Skip to content

GitLab

Commit 5e5a08eb authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Template Haskell: support for type family declarations

parent 2c8d42f3
Hide whitespace changes
Inline Side-by-side
compiler/deSugar/DsMeta.hs
View file @ 5e5a08eb
......@@ -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
......
compiler/hsSyn/Convert.lhs
View file @ 5e5a08eb
......@@ -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)