X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=7718e4f9dbc4517abce4f6b63094f63ae1f95e2a;hp=902eeb8f3f59a73135f7110f206d4d18ca658531;hb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;hpb=4b357e2a7e7eff16cb51b01830636d451664b202 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 902eeb8..7718e4f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -15,9 +15,10 @@ 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" @@ -72,11 +73,12 @@ dsBracket brack splices 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 -------------------- @@ -97,6 +99,11 @@ dsBracket brack splices -- 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) } ; @@ -511,7 +518,7 @@ addTyVarBinds tvs m = 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 @@ -713,7 +720,7 @@ repE (HsIf x y z) = do 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 e@(HsDo ctxt sts body _) @@ -722,14 +729,14 @@ repE e@(HsDo ctxt sts body _) body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e' } + 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' } + wrapGenSyms ss e' } | otherwise = notHandled "mdo and [: :]" (ppr e) @@ -788,7 +795,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = ; 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) @@ -800,7 +807,7 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = ; 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)] @@ -809,7 +816,7 @@ repGuards other = 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)) @@ -932,7 +939,7 @@ rep_bind (L loc (FunBind { fun_id = fn, ; 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 _ })) @@ -946,7 +953,7 @@ rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) ; (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})) @@ -990,7 +997,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) ; 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) @@ -1164,14 +1171,14 @@ lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) 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 @@ -1729,10 +1736,10 @@ templateHaskellNames = [ 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") @@ -1980,13 +1987,14 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey 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 @@ -1996,9 +2004,11 @@ fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey 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 @@ -2009,7 +2019,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, 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 @@ -2023,7 +2033,6 @@ stmtQTyConKey = mkPreludeTyConUnique 109 conQTyConKey = mkPreludeTyConUnique 110 typeQTyConKey = mkPreludeTyConUnique 111 typeTyConKey = mkPreludeTyConUnique 112 -tyVarBndrTyConKey = mkPreludeTyConUnique 125 decTyConKey = mkPreludeTyConUnique 113 varStrictTypeQTyConKey = mkPreludeTyConUnique 114 strictTypeQTyConKey = mkPreludeTyConUnique 115 @@ -2036,6 +2045,8 @@ fieldExpQTyConKey = mkPreludeTyConUnique 121 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 @@ -2250,6 +2261,8 @@ typeFamIdKey = mkPreludeMiscIdUnique 344 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