From 5e5a08eb37f5513cecb47101a97fdaf09c4be040 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Thu, 19 Mar 2009 08:43:06 +0000 Subject: [PATCH] Template Haskell: support for type family declarations --- compiler/deSugar/DsMeta.hs | 286 ++++++++++++++++++++++++++++++------------ compiler/hsSyn/Convert.lhs | 160 +++++++++++++++++------ compiler/hsSyn/HsDecls.lhs | 4 +- compiler/utils/MonadUtils.hs | 6 + 4 files changed, 340 insertions(+), 116 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 554a945..5fb13df 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -64,6 +64,7 @@ import Outputable import Bag import FastString import ForeignCall +import MonadUtils import Data.Maybe import Control.Monad @@ -138,11 +139,13 @@ repTopDs group groupBinders :: HsGroup Name -> [Located Name] groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) + hs_instds = inst_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group = collectHsValBinders val_decls ++ - [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ + [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++ [n | L _ (ForeignImport n _ _) <- foreign_decls] + where + assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls] {- Note [Binders and occurrences] @@ -171,59 +174,99 @@ in repTyClD and repC. repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyClD tydecl@(L _ (TyFamily {})) + = repTyFamily tydecl addTyVarBinds + repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, - tcdCons = cons, tcdDerivs = mb_derivs })) - = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] - dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repLContext cxt ; - cons1 <- mapM repC cons ; - cons2 <- coreList conQTyConName cons1 ; - derivs1 <- repDerivs mb_derivs ; - bndrs1 <- coreList nameTyConName bndrs ; - repData cxt1 tc1 bndrs1 cons2 derivs1 } ; - return $ Just (loc, dec) } + tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdCons = cons, tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; cons1 <- mapM repC cons + ; cons2 <- coreList conQTyConName cons1 + ; derivs1 <- repDerivs mb_derivs + ; bndrs1 <- coreList nameTyConName bndrs + ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 + } + ; return $ Just (loc, dec) + } repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdLName = tc, tcdTyVars = tvs, - tcdCons = [con], tcdDerivs = mb_derivs })) - = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] - dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repLContext cxt ; - con1 <- repC con ; - derivs1 <- repDerivs mb_derivs ; - bndrs1 <- coreList nameTyConName bndrs ; - repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ; - return $ Just (loc, dec) } - -repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty })) - = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] - dec <- addTyVarBinds tvs $ \bndrs -> do { - ty1 <- repLTy ty ; - bndrs1 <- coreList nameTyConName bndrs ; - repTySyn tc1 bndrs1 ty1 } ; - return (Just (loc, dec)) } + tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdCons = [con], tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; con1 <- repC con + ; derivs1 <- repDerivs mb_derivs + ; bndrs1 <- coreList nameTyConName bndrs + ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 + } + ; return $ Just (loc, dec) + } + +repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys, + tcdSynRhs = ty })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts + ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 + ; ty1 <- repLTy ty + ; bndrs1 <- coreList nameTyConName bndrs + ; repTySyn tc1 bndrs1 opt_tys2 ty1 + } + ; return (Just (loc, dec)) + } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, - tcdTyVars = tvs, - tcdFDs = fds, - tcdSigs = sigs, tcdMeths = meth_binds })) - = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences] - dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repLContext cxt ; - sigs1 <- rep_sigs sigs ; - binds1 <- rep_binds meth_binds ; - fds1 <- repLFunDeps fds; - decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; - bndrs1 <- coreList nameTyConName bndrs ; - repClass cxt1 cls1 bndrs1 fds1 decls1 } ; - return $ Just (loc, dec) } + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, + tcdATs = ats })) + = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> + do { cxt1 <- repLContext cxt + ; sigs1 <- rep_sigs sigs + ; binds1 <- rep_binds meth_binds + ; fds1 <- repLFunDeps fds + ; ats1 <- repLAssocFamilys ats + ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) + ; bndrs1 <- coreList nameTyConName bndrs + ; repClass cxt1 cls1 bndrs1 fds1 decls1 + } + ; return $ Just (loc, dec) + } -- Un-handled cases repTyClD (L loc d) = putSrcSpanDs loc $ do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } +-- The type variables in the head of families are treated differently when the +-- family declaration is associated. In that case, they are usage, not binding +-- occurences. +-- +repTyFamily :: LTyClDecl Name + -> ProcessTyVarBinds TH.Dec + -> DsM (Maybe (SrcSpan, Core TH.DecQ)) +repTyFamily (L loc (TyFamily { tcdFlavour = flavour, + tcdLName = tc, tcdTyVars = tvs, + tcdKind = _kind })) + tyVarBinds + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- tyVarBinds tvs $ \bndrs -> + do { flav <- repFamilyFlavour flavour + ; bndrs1 <- coreList nameTyConName bndrs + ; repFamily flav tc1 bndrs1 + } + ; return $ Just (loc, dec) + } +repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error" + -- represent fundeps -- repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep]) @@ -238,22 +281,49 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs ys_list <- coreList nameTyConName ys' repFunDep xs_list ys_list +-- represent family declaration flavours +-- +repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) +repFamilyFlavour TypeFamily = rep2 typeFamName [] +repFamilyFlavour DataFamily = rep2 dataFamName [] + +-- represent associated family declarations +-- +repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repLAssocFamilys = mapM repLAssocFamily + where + repLAssocFamily tydecl@(L _ (TyFamily {})) + = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds + repLAssocFamily tydecl + = failWithDs msg + where + msg = ptext (sLit "Illegal associated declaration in class:") <+> + ppr tydecl + +-- represent associated family instances +-- +repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ] +repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD + +-- represent instance declarations +-- repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repInstD' (L loc (InstDecl ty binds _ _)) -- Ignore user pragmas for now - = do { i <- addTyVarBinds tvs $ \_ -> - -- We must bring the type variables into scope, so their occurrences - -- don't fail, even though the binders don't appear in the resulting - -- data structure - do { cxt1 <- repContext cxt +repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now + = do { i <- addTyVarBinds tvs $ \_ -> + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't + -- appear in the resulting data structure + do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; ss <- mkGenSyms (collectHsBindBinders binds) ; binds1 <- addBinds ss (rep_binds binds) - ; decls1 <- coreList decQTyConName binds1 + ; ats1 <- repLAssocFamInst ats + ; decls1 <- coreList decQTyConName (ats1 ++ binds1) ; decls2 <- wrapNongenSyms ss decls1 - -- wrapNonGenSyms: do not clone the class op names! + -- wrapNongenSyms: do not clone the class op names! -- They must be called 'op' etc, not 'op34' - ; repInst cxt1 inst_ty1 decls2 } - + ; repInst cxt1 inst_ty1 (decls2) + } ; return (loc, i)} where (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) @@ -370,13 +440,20 @@ rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; -- Types ------------------------------------------------------- +-- We process type variable bindings in two ways, either by generating fresh +-- names or looking up existing names. The difference is crucial for type +-- families, depending on whether they are associated or not. +-- +type ProcessTyVarBinds a = + [LHsTyVarBndr Name] -- the binders to be added + -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env + -> DsM (Core (TH.Q a)) + -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -- -addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added - -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env - -> DsM (Core (TH.Q a)) +addTyVarBinds :: ProcessTyVarBinds a addTyVarBinds tvs m = do let names = map (hsTyVarName.unLoc) tvs @@ -386,6 +463,16 @@ addTyVarBinds tvs m = m bndrs wrapGenSyns freshNames term +-- Look up a list of type variables; the computations passed as the second +-- argument gets the *new* names on Core-level as an argument +-- +lookupTyVarBinds :: ProcessTyVarBinds a +lookupTyVarBinds tvs m = + do + let names = map (hsTyVarName.unLoc) tvs + bndrs <- mapM lookupBinder names + m bndrs + -- represent a type context -- repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) @@ -1185,16 +1272,29 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) -repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, cons, derivs] - -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) -repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) - = rep2 newtypeDName [cxt, nm, tvs, con, derivs] - -repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ) -repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] + -> Maybe (Core [TH.TypeQ]) + -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) +repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, cons, derivs] +repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) + = rep2 dataInstDName [cxt, nm, tys, cons, derivs] + +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] + -> Maybe (Core [TH.TypeQ]) + -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) +repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, con, derivs] +repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) + = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] + +repTySyn :: Core TH.Name -> Core [TH.Name] + -> Maybe (Core [TH.TypeQ]) + -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) + = rep2 tySynDName [nm, tvs, rhs] +repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) + = rep2 tySynInstDName [nm, tys, rhs] repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] @@ -1202,6 +1302,11 @@ repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds] +repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name] + -> DsM (Core TH.DecQ) +repFamily (MkC flav) (MkC nm) (MkC tvs) + = rep2 familyDName [flav, nm, tvs] + repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] @@ -1408,7 +1513,8 @@ templateHaskellNames = [ bindSName, letSName, noBindSName, parSName, -- Dec funDName, valDName, dataDName, newtypeDName, tySynDName, - classDName, instanceDName, sigDName, forImpDName, + classDName, instanceDName, sigDName, forImpDName, familyDName, dataInstDName, + newtypeInstDName, tySynInstDName, -- Cxt cxtName, -- Strict @@ -1430,6 +1536,8 @@ templateHaskellNames = [ threadsafeName, -- FunDep funDepName, + -- FamFlavour + typeFamName, dataFamName, -- And the tycons qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName, @@ -1583,16 +1691,21 @@ parSName = libFun (fsLit "parS") parSIdKey -- data Dec = ... funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, - instanceDName, sigDName, forImpDName :: Name -funDName = libFun (fsLit "funD") funDIdKey -valDName = libFun (fsLit "valD") valDIdKey -dataDName = libFun (fsLit "dataD") dataDIdKey -newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey -tySynDName = libFun (fsLit "tySynD") tySynDIdKey -classDName = libFun (fsLit "classD") classDIdKey -instanceDName = libFun (fsLit "instanceD") instanceDIdKey -sigDName = libFun (fsLit "sigD") sigDIdKey -forImpDName = libFun (fsLit "forImpD") forImpDIdKey + instanceDName, sigDName, forImpDName, familyDName, dataInstDName, + newtypeInstDName, tySynInstDName :: Name +funDName = libFun (fsLit "funD") funDIdKey +valDName = libFun (fsLit "valD") valDIdKey +dataDName = libFun (fsLit "dataD") dataDIdKey +newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +tySynDName = libFun (fsLit "tySynD") tySynDIdKey +classDName = libFun (fsLit "classD") classDIdKey +instanceDName = libFun (fsLit "instanceD") instanceDIdKey +sigDName = libFun (fsLit "sigD") sigDIdKey +forImpDName = libFun (fsLit "forImpD") forImpDIdKey +familyDName = libFun (fsLit "familyD") familyDIdKey +dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey +newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey +tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey -- type Ctxt = ... cxtName :: Name @@ -1644,6 +1757,11 @@ threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey funDepName :: Name funDepName = libFun (fsLit "funDep") funDepIdKey +-- data FamFlavour = ... +typeFamName, dataFamName :: Name +typeFamName = libFun (fsLit "typeFam") typeFamIdKey +dataFamName = libFun (fsLit "dataFam") dataFamIdKey + matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, @@ -1809,7 +1927,8 @@ parSIdKey = mkPreludeMiscIdUnique 271 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, - classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey :: Unique + classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, familyDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 272 valDIdKey = mkPreludeMiscIdUnique 273 dataDIdKey = mkPreludeMiscIdUnique 274 @@ -1819,6 +1938,10 @@ classDIdKey = mkPreludeMiscIdUnique 277 instanceDIdKey = mkPreludeMiscIdUnique 278 sigDIdKey = mkPreludeMiscIdUnique 279 forImpDIdKey = mkPreludeMiscIdUnique 297 +familyDIdKey = mkPreludeMiscIdUnique 340 +dataInstDIdKey = mkPreludeMiscIdUnique 341 +newtypeInstDIdKey = mkPreludeMiscIdUnique 342 +tySynInstDIdKey = mkPreludeMiscIdUnique 343 -- type Cxt = ... cxtIdKey :: Unique @@ -1870,6 +1993,11 @@ threadsafeIdKey = mkPreludeMiscIdUnique 307 funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 320 +-- data FamFlavour = ... +typeFamIdKey, dataFamIdKey :: Unique +typeFamIdKey = mkPreludeMiscIdUnique 344 +dataFamIdKey = mkPreludeMiscIdUnique 345 + -- quasiquoting quoteExpKey, quotePatKey :: Unique quoteExpKey = mkPreludeMiscIdUnique 321 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 09ffafd..b48d361 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -6,13 +6,6 @@ This module converts Template Haskell syntax into HsSyn \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, thRdrNameGuesses ) where @@ -32,6 +25,7 @@ import ForeignCall import Char import List import Unique +import MonadUtils import ErrUtils import Bag import FastString @@ -107,15 +101,21 @@ wrapL (CvtM m) = CvtM (\loc -> case m loc of ------------------------------------------------------------------- cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName) -cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') } -cvtTop d@(TH.FunD _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') } -cvtTop (TH.SigD nm typ) = do { nm' <- vNameL nm - ; ty' <- cvtType typ - ; returnL $ Hs.SigD (TypeSig nm' ty') } +cvtTop d@(TH.ValD _ _ _) + = do { L loc d' <- cvtBind d + ; return (L loc $ Hs.ValD d') } + +cvtTop d@(TH.FunD _ _) + = do { L loc d' <- cvtBind d + ; return (L loc $ Hs.ValD d') } + +cvtTop (TH.SigD nm typ) + = do { nm' <- vNameL nm + ; ty' <- cvtType typ + ; returnL $ Hs.SigD (TypeSig nm' ty') } cvtTop (TySynD tc tvs rhs) - = do { tc' <- tconNameL tc - ; tvs' <- cvtTvs tvs + = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs ; rhs' <- cvtType rhs ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') } @@ -125,7 +125,6 @@ cvtTop (DataD ctxt tc tvs constrs derivs) ; derivs' <- cvtDerivs derivs ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') } - cvtTop (NewtypeD ctxt tc tvs constr derivs) = do { stuff <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr @@ -135,32 +134,109 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs) cvtTop (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs') <- cvtBindsAndSigs decs - ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] [] - -- no ATs or docs in TH ^^ ^^ + ; let (ats, bind_sig_decs) = partition isFamilyD decs + ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs + ; ats' <- mapM cvtTop ats + ; let ats'' = map unTyClD ats' + ; returnL $ + TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' ats'' [] + -- no docs in TH ^^ } + where + isFamilyD (FamilyD _ _ _) = True + isFamilyD _ = False cvtTop (InstanceD tys ty decs) - = do { (binds', sigs') <- cvtBindsAndSigs decs + = do { let (ats, bind_sig_decs) = partition isFamInstD decs + ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs + ; ats' <- mapM cvtTop ats + ; let ats'' = map unTyClD ats' ; ctxt' <- cvtContext tys ; L loc pred' <- cvtPred ty - ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) - ; returnL $ InstD (InstDecl inst_ty' binds' sigs' []) - -- no ATs in TH ^^ + ; inst_ty' <- returnL $ + mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred')) + ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'') } + where + isFamInstD (DataInstD _ _ _ _ _) = True + isFamInstD (NewtypeInstD _ _ _ _ _) = True + isFamInstD (TySynInstD _ _ _) = True + isFamInstD _ = False cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' } +cvtTop (FamilyD flav tc tvs) + = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs + ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' Nothing) + -- FIXME: kinds + } + 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.Name] - -> CvtM (LHsContext RdrName - ,Located RdrName - ,[LHsTyVarBndr RdrName] - ,Maybe [LHsType RdrName]) + -> CvtM ( LHsContext RdrName + , Located RdrName + , [LHsTyVarBndr RdrName] + , Maybe [LHsType RdrName]) cvt_tycl_hdr cxt tc tvs - = do { cxt' <- cvtContext cxt - ; tc' <- tconNameL tc - ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs', Nothing) } + = do { cxt' <- cvtContext cxt + ; tc' <- tconNameL tc + ; tvs' <- cvtTvs tvs + ; return (cxt', tc', tvs', Nothing) + } + +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 [tv] + collect (ConT _) = return [] + collect (TupleT _) = return [] + collect ArrowT = return [] + collect ListT = return [] + collect (AppT t1 t2) + = do { tvs1 <- collect t1 + ; tvs2 <- collect t2 + ; return $ tvs1 ++ tvs2 + } --------------------------------------------------- -- Data types @@ -317,6 +393,7 @@ cvtBindsAndSigs ds cvtSig :: TH.Dec -> CvtM (LSig RdrName) cvtSig (TH.SigD nm ty) = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') } +cvtSig _ = panic "Convert.cvtSig: Signature expected" cvtBind :: TH.Dec -> CvtM (LHsBind RdrName) -- Used only for declarations in a 'let/where' clause, @@ -426,6 +503,7 @@ cvtHsDo do_or_lc stmts = do { stmts' <- cvtStmts stmts ; let body = case last stmts' of L _ (ExprStmt body _ _) -> body + _ -> panic "Malformed body" ; return $ HsDo do_or_lc (init stmts') body void } cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName] @@ -458,10 +536,17 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs ; returnL $ GRHS gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) -cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} -cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType} -cvtOverLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType } --- An Integer is like an an (overloaded) '3' in a Haskell source program +cvtOverLit (IntegerL i) + = do { force i; return $ mkHsIntegral i placeHolderType} +cvtOverLit (RationalL r) + = do { force r; return $ mkHsFractional r placeHolderType} +cvtOverLit (StringL s) + = do { let { s' = mkFastString s } + ; force s' + ; return $ mkHsIsString s' placeHolderType + } +cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" +-- An Integer is like an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals cvtLit :: Lit -> CvtM HsLit @@ -470,7 +555,12 @@ cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } cvtLit (CharL c) = do { force c; return $ HsChar c } -cvtLit (StringL s) = do { let { s' = mkFastString s }; force s'; return $ HsString s' } +cvtLit (StringL s) + = do { let { s' = mkFastString s } + ; force s' + ; return $ HsString s' + } +cvtLit _ = panic "Convert.cvtLit: Unexpected literal" cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] cvtPats pats = mapM cvtPat pats diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 8ef3816..cd04a1a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -406,8 +406,8 @@ data TyClDecl name } - | -- | @type/data/newtype family T :: *->*@ - TyFamily { tcdFlavour:: FamilyFlavour, -- type, new, or data + | -- | @type/data family T :: *->*@ + TyFamily { tcdFlavour:: FamilyFlavour, -- type or data tcdLName :: Located name, -- type constructor tcdTyVars :: [LHsTyVarBndr name], -- type variables tcdKind :: Maybe Kind -- result kind diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 2064657..733eda1 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -19,6 +19,7 @@ module MonadUtils , mapMaybeM , anyM, allM , foldlM, foldrM + , maybeMapM ) where ---------------------------------------------------------------------------------------- @@ -149,3 +150,8 @@ foldlM = foldM foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a foldrM _ z [] = return z foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } + +-- | Monadic version of fmap specialised for Maybe +maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) +maybeMapM _ Nothing = return Nothing +maybeMapM m (Just x) = liftM Just $ m x -- 1.7.10.4