+ ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
+ ; returnL $
+ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+ , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
+ , tcdATs = ats', tcdDocs = [] }
+ -- no docs in TH ^^
+ }
+
+cvtDec (InstanceD ctxt ty decs)
+ = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
+ ; ctxt' <- cvtContext ctxt
+ ; L loc pred' <- cvtPredTy ty
+ ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred'
+ ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
+
+cvtDec (ForeignD ford)
+ = do { ford' <- cvtForD ford
+ ; returnL $ ForD ford' }
+
+cvtDec (FamilyD flav tc tvs kind)
+ = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
+ ; let kind' = fmap cvtKind kind
+ ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
+ where
+ cvtFamFlavour TypeFam = TypeFamily
+ cvtFamFlavour DataFam = DataFamily
+
+cvtDec (DataInstD ctxt tc tys constrs derivs)
+ = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
+ ; cons' <- mapM cvtConstr constrs
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
+ , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+ , tcdCons = cons', tcdDerivs = derivs' }) }
+
+cvtDec (NewtypeInstD ctxt tc tys constr derivs)
+ = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
+ ; con' <- cvtConstr constr
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
+ , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
+ , tcdCons = [con'], tcdDerivs = derivs' })
+ }
+
+cvtDec (TySynInstD tc tys rhs)
+ = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
+ ; rhs' <- cvtType rhs
+ ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
+
+----------------
+cvt_ci_decs :: Message -> [TH.Dec]
+ -> CvtM (LHsBinds RdrName,
+ [LSig RdrName],
+ [LTyClDecl RdrName])
+-- Convert the declarations inside a class or instance decl
+-- ie signatures, bindings, and associated types
+cvt_ci_decs doc decs
+ = do { decs' <- mapM cvtDec decs
+ ; let (ats', bind_sig_decs') = partitionWith is_tycl decs'
+ ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
+ ; let (binds', bads) = partitionWith is_bind prob_binds'
+ ; unless (null bads) (failWith (mkBadDecMsg doc bads))
+ ; return (listToBag binds', sigs', ats') }
+
+----------------
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
+ -> CvtM ( LHsContext RdrName
+ , Located RdrName
+ , [LHsTyVarBndr RdrName])
+cvt_tycl_hdr cxt tc tvs
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; tvs' <- cvtTvs tvs
+ ; return (cxt', tc', tvs')
+ }
+
+cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
+ -> CvtM ( LHsContext RdrName
+ , Located RdrName
+ , [LHsTyVarBndr RdrName]
+ , Maybe [LHsType RdrName])
+cvt_tyinst_hdr cxt tc tys
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; tvs <- concatMapM collect tys
+ ; tvs' <- cvtTvs tvs
+ ; tys' <- mapM cvtType tys
+ ; return (cxt', tc', tvs', Just tys')
+ }
+ where
+ collect (ForallT _ _ _)
+ = failWith $ text "Forall type not allowed as type parameter"
+ collect (VarT tv) = return [PlainTV tv]
+ collect (ConT _) = return []
+ collect (TupleT _) = return []
+ collect (UnboxedTupleT _) = return []
+ collect ArrowT = return []
+ collect ListT = return []
+ collect (AppT t1 t2)
+ = do { tvs1 <- collect t1
+ ; tvs2 <- collect t2
+ ; return $ tvs1 ++ tvs2
+ }
+ collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
+ collect (SigT ty _) = collect ty