-
-cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
-
-cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.Name]
- -> CvtM (LHsContext RdrName
- ,Located RdrName
- ,[LHsTyVarBndr RdrName]
- ,Maybe [LHsType RdrName])
+ 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 { stuff <- cvt_tyinst_hdr ctxt tc tys
+ ; cons' <- mapM cvtConstr constrs
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs')
+ }
+
+cvtTop (NewtypeInstD ctxt tc tys constr derivs)
+ = do { stuff <- cvt_tyinst_hdr ctxt tc tys
+ ; con' <- cvtConstr constr
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] 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]
+ , Maybe [LHsType RdrName])