+ where
+ isFamInstD (DataInstD _ _ _ _ _) = True
+ isFamInstD (NewtypeInstD _ _ _ _ _) = True
+ isFamInstD (TySynInstD _ _ _) = True
+ isFamInstD _ = False
+
+cvtTop (ForeignD ford)
+ = do { ford' <- cvtForD ford
+ ; returnL $ ForD ford'
+ }
+
+cvtTop (PragmaD prag)
+ = do { prag' <- cvtPragmaD prag
+ ; returnL $ Hs.SigD prag'
+ }
+
+cvtTop (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
+
+cvtTop (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' })
+ }
+
+cvtTop (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' })
+ }
+
+cvtTop (TySynInstD tc tys rhs)
+ = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
+ ; rhs' <- cvtType rhs
+ ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
+
+-- FIXME: This projection is not nice, but to remove it, cvtTop should be
+-- refactored.
+unTyClD :: LHsDecl a -> LTyClDecl a
+unTyClD (L l (TyClD d)) = L l d
+unTyClD _ = panic "Convert.unTyClD: internal error"
+
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
+ -> CvtM ( LHsContext RdrName
+ , Located RdrName
+ , [LHsTyVarBndr RdrName])