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"
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
-import qualified OccName
+import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
import Module
import Id
-import Name
+import Name hiding( isVarOcc, isTcOcc, varName, tcName )
import NameEnv
import TcType
import TyCon
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) } ;
where
conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
- conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+ conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
conv_cimportspec CWrapper = return "wrapper"
static = case cis of
- CFunction (StaticTarget _) -> "static "
+ CFunction (StaticTarget _ _) -> "static "
_ -> ""
repForD decl = notHandled "Foreign declaration" (ppr decl)
; return [(loc, sig)]
}
-rep_inline :: Located Name -> InlineSpec -> SrcSpan
+rep_inline :: Located Name
+ -> InlinePragma -- Never defaultInlinePragma
+ -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
= do { nm1 <- lookupLOcc nm
- ; (_, ispec1) <- rep_InlineSpec ispec
+ ; ispec1 <- rep_InlinePrag ispec
; pragma <- repPragInl nm1 ispec1
; return [(loc, pragma)]
}
-rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan
+rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty
- ; (hasSpec, ispec1) <- rep_InlineSpec ispec
- ; pragma <- if hasSpec
- then repPragSpecInl nm1 ty1 ispec1
- else repPragSpec nm1 ty1
+ ; pragma <- if isDefaultInlinePragma ispec
+ then repPragSpec nm1 ty1 -- SPECIALISE
+ else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
+ ; repPragSpecInl nm1 ty1 ispec1 }
; return [(loc, pragma)]
}
--- extract all the information needed to build a TH.InlineSpec
+-- Extract all the information needed to build a TH.InlinePrag
--
-rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
-rep_InlineSpec (Inline (InlinePragma activation match) inline)
+rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
+ -> DsM (Core TH.InlineSpecQ)
+rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
| Nothing <- activation1
- = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
+ = repInlineSpecNoPhase inline1 match1
| Just (flag, phase) <- activation1
- = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase
+ = repInlineSpecPhase inline1 match1 flag phase
| otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
where
match1 = coreBool (rep_RuleMatchInfo match)
rep_RuleMatchInfo FunLike = False
rep_RuleMatchInfo ConLike = True
- rep_Activation NeverActive = Nothing
- rep_Activation AlwaysActive = Nothing
+ rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
+ rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
rep_Activation (ActiveBefore phase) = Just (coreBool False,
MkC $ mkIntExprInt phase)
rep_Activation (ActiveAfter phase) = Just (coreBool True,
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
--
repTForall bndrs1 ctxt1 ty1
repTy (HsTyVar n)
- | isTvOcc (nameOccName n) = do
- tv1 <- lookupTvOcc n
- repTvar tv1
- | otherwise = do
- tc1 <- lookupOcc n
- repNamedTyCon tc1
-repTy (HsAppTy f a) = do
- f1 <- repLTy f
- a1 <- repLTy a
- repTapp f1 a1
-repTy (HsFunTy f a) = do
- f1 <- repLTy f
- a1 <- repLTy a
- tcon <- repArrowTyCon
- repTapps tcon [f1, a1]
-repTy (HsListTy t) = do
- t1 <- repLTy t
- tcon <- repListTyCon
- repTapp tcon t1
-repTy (HsPArrTy t) = do
- t1 <- repLTy t
- tcon <- repTy (HsTyVar (tyConName parrTyCon))
- repTapp tcon t1
-repTy (HsTupleTy _ tys) = do
- tys1 <- repLTys tys
- tcon <- repTupleTyCon (length tys)
- repTapps tcon tys1
-repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
- `nlHsAppTy` ty2)
-repTy (HsParTy t) = repLTy t
-repTy (HsPredTy pred) = repPredTy pred
-repTy (HsKindSig t k) = do
- t1 <- repLTy t
- k1 <- repKind k
- repTSig t1 k1
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
-repTy ty = notHandled "Exotic form of type" (ppr ty)
+ | isTvOcc (nameOccName n) = do
+ tv1 <- lookupTvOcc n
+ repTvar tv1
+ | otherwise = do
+ tc1 <- lookupOcc n
+ repNamedTyCon tc1
+repTy (HsAppTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ repTapp f1 a1
+repTy (HsFunTy f a) = do
+ f1 <- repLTy f
+ a1 <- repLTy a
+ tcon <- repArrowTyCon
+ repTapps tcon [f1, a1]
+repTy (HsListTy t) = do
+ t1 <- repLTy t
+ tcon <- repListTyCon
+ repTapp tcon t1
+repTy (HsPArrTy t) = do
+ t1 <- repLTy t
+ tcon <- repTy (HsTyVar (tyConName parrTyCon))
+ repTapp tcon t1
+repTy (HsTupleTy _ tys) = do
+ tys1 <- repLTys tys
+ tcon <- repTupleTyCon (length tys)
+ repTapps tcon tys1
+repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+ `nlHsAppTy` ty2)
+repTy (HsParTy t) = repLTy t
+repTy (HsPredTy pred) = repPredTy pred
+repTy (HsKindSig t k) = do
+ 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)
-- represent a kind
--
(ppr k)
-----------------------------------------------------------------------------
+-- Splices
+-----------------------------------------------------------------------------
+
+repSplice :: HsSplice Name -> DsM (Core a)
+-- See Note [How brackets and nested splices are handled] in TcSplice
+-- We return a CoreExpr of any old type; the context should know
+repSplice (HsSplice n _)
+ = do { mb_val <- dsLookupMetaEnv n
+ ; case mb_val of
+ Just (Splice e) -> do { e' <- dsExpr e
+ ; return (MkC e') }
+ _ -> pprPanic "HsSplice" (ppr n) }
+ -- Should not happen; statically checked
+
+-----------------------------------------------------------------------------
-- Expressions
-----------------------------------------------------------------------------
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)
- | isBoxed boxed = do { xs <- repLEs es; repTup xs }
- | otherwise = notHandled "Unboxed tuples" (ppr e)
+ | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
+ | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
+ | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
+
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
ds2 <- repLE e2
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
-repE (HsSpliceE (HsSplice n _))
- = do { mb_val <- dsLookupMetaEnv n
- ; case mb_val of
- Just (Splice e) -> do { e' <- dsExpr e
- ; return (MkC e') }
- _ -> pprPanic "HsSplice" (ppr n) }
- -- Should not happen; statically checked
+repE (HsSpliceE splice) = repSplice splice
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
; 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))
; 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)
repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p) = repLP p
repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
+repP p@(TuplePat ps boxed _)
+ | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
+ | otherwise = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
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