module DsMeta( dsBracket,
templateHaskellNames, qTyConName, nameTyConName,
- liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
+ liftName, liftStringName, expQTyConName, patQTyConName,
+ decQTyConName, decsQTyConName, typeQTyConName,
decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
- quoteExpName, quotePatName
+ quoteExpName, quotePatName, quoteDecName, quoteTypeName
) where
#include "HsVersions.h"
where
new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
- do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
- do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
- do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
- do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
- do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
+ do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
+ do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
+ do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
+ do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
+ do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+ do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
{- -------------- Examples --------------------
-- Declarations
-------------------------------------------------------
+repTopP :: LPat Name -> DsM (Core TH.PatQ)
+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
+ ; pat' <- addBinds ss (repLP pat)
+ ; wrapNongenSyms ss pat' }
+
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
- = do { let { bndrs = map unLoc (groupBinders group) } ;
+ = do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ;
-- Bind all the names mainly to avoid repeated use of explicit strings.
-- Do *not* gensym top-level binders
}
-groupBinders :: HsGroup Name -> [Located Name]
+groupBinders :: HsGroup Name -> [Name]
groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_instds = inst_decls, hs_fords = foreign_decls })
-- Collect the binders of a Group
= collectHsValBinders val_decls ++
- [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
- [n | L _ (ForeignImport n _ _) <- foreign_decls]
+ [n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
+ [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
where
assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
-- appear in the resulting data structure
do { cxt1 <- repContext cxt
; inst_ty1 <- repPredTy (HsClassP cls tys)
- ; ss <- mkGenSyms (collectHsBindBinders binds)
+ ; ss <- mkGenSyms (collectHsBindsBinders binds)
; binds1 <- addBinds ss (rep_binds binds)
; ats1 <- repLAssocFamInst ats
; decls1 <- coreList decQTyConName (ats1 ++ binds1)
bndrs <- mapM lookupBinder names
kindedBndrs <- zipWithM ($) mkWithKinds bndrs
m kindedBndrs
- wrapGenSyns freshNames term
+ wrapGenSyms 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
--
repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
- \nm -> repKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+ = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+ = repKind ki >>= repKindedTV nm
-- represent a type context
--
t1 <- repLTy t
k1 <- repKind k
repTSig t1 k1
-repTy (HsSpliceTy splice) = repSplice splice
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
-repTy ty = notHandled "Exotic form of type" (ppr ty)
+repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
+repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
--
= do { let (kis, ki') = splitKindFunTys ki
; kis_rep <- mapM repKind kis
; ki'_rep <- repNonArrowKind ki'
- ; foldlM repArrowK ki'_rep kis_rep
+ ; foldrM repArrowK ki'_rep kis_rep
}
where
repNonArrowKind k | isLiftedTypeKind k = repStarK
repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
- ; wrapGenSyns ss z }
+ ; wrapGenSyms ss z }
+
-- FIXME: I haven't got the types here right yet
-repE (HsDo DoExpr sts body _)
+repE e@(HsDo ctxt sts body _)
+ | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
- e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
- wrapGenSyns ss e }
-repE (HsDo ListComp sts body _)
+ e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyms ss e' }
+
+ | ListComp <- ctxt
= do { (ss,zs) <- repLSts sts;
body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
- e <- repComp (nonEmptyCoreList (zs ++ [ret]));
- wrapGenSyns ss e }
-repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
+ e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ wrapGenSyms ss e' }
+
+ | otherwise
+ = notHandled "mdo and [: :]" (ppr e)
+
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed)
; addBinds ss2 $ do {
; gs <- repGuards guards
; match <- repMatch p1 gs ds
- ; wrapGenSyns (ss1++ss2) match }}}
+ ; wrapGenSyms (ss1++ss2) match }}}
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
; addBinds ss2 $ do {
gs <- repGuards guards
; clause <- repClause ps1 gs ds
- ; wrapGenSyns (ss1++ss2) clause }}}
+ ; wrapGenSyms (ss1++ss2) clause }}}
repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
repGuards [L _ (GRHS [] e)]
= do { zs <- mapM process other;
let {(xs, ys) = unzip zs};
gd <- repGuarded (nonEmptyCoreList ys);
- wrapGenSyns (concat xs) gd }
+ wrapGenSyms (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
repBinds (HsValBinds decs)
- = do { let { bndrs = map unLoc (collectHsValBinders decs) }
+ = do { let { bndrs = collectHsValBinders decs }
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
; fn' <- lookupLBinder fn
; p <- repPvar fn'
; ans <- repVal p guardcore wherecore
- ; ans' <- wrapGenSyns ss ans
+ ; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; ans <- repVal patcore guardcore wherecore
- ; ans' <- wrapGenSyns ss ans
+ ; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repLPs ps; body <- repLE e; repLam xs body })
- ; wrapGenSyns ss lam }
+ ; wrapGenSyms ss lam }
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkTyConApp tc []) }
-wrapGenSyns :: [GenSymBind]
+wrapGenSyms :: [GenSymBind]
-> Core (TH.Q a) -> DsM (Core (TH.Q a))
--- wrapGenSyns [(nm1,id1), (nm2,id2)] y
+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
-- y))
-wrapGenSyns binds body@(MkC b)
+wrapGenSyms binds body@(MkC b)
= do { var_ty <- lookupType nameTyConName
; go var_ty binds }
where
varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
- predQTyConName,
+ predQTyConName, decsQTyConName,
-- Quasiquoting
- quoteExpName, quotePatName]
+ quoteDecName, quoteTypeName, quoteExpName, quotePatName]
thSyn, thLib, qqLib :: Module
thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
decQTyConName, conQTyConName, strictTypeQTyConName,
varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
- patQTyConName, fieldPatQTyConName, predQTyConName :: Name
+ patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
decQTyConName = libTc (fsLit "DecQ") decQTyConKey
-conQTyConName = libTc (fsLit "ConQ") conQTyConKey
+decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
+conQTyConName = libTc (fsLit "ConQ") conQTyConKey
strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
predQTyConName = libTc (fsLit "PredQ") predQTyConKey
-- quasiquoting
-quoteExpName, quotePatName :: Name
-quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
-quotePatName = qqFun (fsLit "quotePat") quotePatKey
+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
+quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
+quotePatName = qqFun (fsLit "quotePat") quotePatKey
+quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
+quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
-- TyConUniques available: 100-129
-- Check in PrelNames if you want to change this
decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
- predQTyConKey :: Unique
+ predQTyConKey, decsQTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 100
matchTyConKey = mkPreludeTyConUnique 101
clauseTyConKey = mkPreludeTyConUnique 102
conQTyConKey = mkPreludeTyConUnique 110
typeQTyConKey = mkPreludeTyConUnique 111
typeTyConKey = mkPreludeTyConUnique 112
-tyVarBndrTyConKey = mkPreludeTyConUnique 125
decTyConKey = mkPreludeTyConUnique 113
varStrictTypeQTyConKey = mkPreludeTyConUnique 114
strictTypeQTyConKey = mkPreludeTyConUnique 115
funDepTyConKey = mkPreludeTyConUnique 122
predTyConKey = mkPreludeTyConUnique 123
predQTyConKey = mkPreludeTyConUnique 124
+tyVarBndrTyConKey = mkPreludeTyConUnique 125
+decsQTyConKey = mkPreludeTyConUnique 126
-- IdUniques available: 200-399
-- If you want to change this, make sure you check in PrelNames
dataFamIdKey = mkPreludeMiscIdUnique 345
-- quasiquoting
-quoteExpKey, quotePatKey :: Unique
-quoteExpKey = mkPreludeMiscIdUnique 321
-quotePatKey = mkPreludeMiscIdUnique 322
+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
+quoteExpKey = mkPreludeMiscIdUnique 321
+quotePatKey = mkPreludeMiscIdUnique 322
+quoteDecKey = mkPreludeMiscIdUnique 323
+quoteTypeKey = mkPreludeMiscIdUnique 324