Commit 5a0fa261 authored by simonpj's avatar simonpj

[project @ 2003-10-30 09:33:30 by simonpj]

Updating TH; not finished
parent 8fc898cb
...@@ -141,7 +141,7 @@ dsReify r@(ReifyOut ReifyDecl name) ...@@ -141,7 +141,7 @@ dsReify r@(ReifyOut ReifyDecl name)
repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec])) repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
repTopDs group repTopDs group
= do { let { bndrs = groupBinders group } ; = do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ; let { ss = mkGenSyms bndrs } ;
-- Bind all the names mainly to avoid repeated use of explicit strings. -- Bind all the names mainly to avoid repeated use of explicit strings.
-- Thus we get -- Thus we get
...@@ -262,12 +262,16 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; ...@@ -262,12 +262,16 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
repInstD' (InstDecl ty binds _ loc) repInstD' (InstDecl ty binds _ loc)
-- Ignore user pragmas for now -- Ignore user pragmas for now
= do { cxt1 <- repContext cxt ; = do { cxt1 <- repContext cxt
inst_ty1 <- repPred (HsClassP cls tys) ; ; inst_ty1 <- repPred (HsClassP cls tys)
binds1 <- rep_monobind binds ; ; let ss = mkGenSyms (collectMonoBinders binds)
decls1 <- coreList decQTyConName binds1 ; ; binds1 <- addBinds ss (rep_monobind binds)
i <- repInst cxt1 inst_ty1 decls1; ; decls1 <- coreList decQTyConName binds1
return (loc, i)} ; i <- repInst cxt1 inst_ty1
(wrapNonGenSyms ss decls1)
-- wrapNonGenSyms: do not clone the class op names!
-- They must be called 'op' etc, not 'op34'
; return (loc, i)}
where where
(tvs, cxt, cls, tys) = splitHsInstDeclTy ty (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
...@@ -345,7 +349,7 @@ addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added ...@@ -345,7 +349,7 @@ addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
addTyVarBinds tvs m = addTyVarBinds tvs m =
do do
let names = map hsTyVarName tvs let names = map hsTyVarName tvs
freshNames <- mkGenSyms names let freshNames = mkGenSyms names
term <- addBinds freshNames $ do term <- addBinds freshNames $ do
bndrs <- mapM lookupBinder names bndrs <- mapM lookupBinder names
m bndrs m bndrs
...@@ -535,7 +539,7 @@ repE e = ...@@ -535,7 +539,7 @@ repE e =
repMatchTup :: Match Name -> DsM (Core M.MatchQ) repMatchTup :: Match Name -> DsM (Core M.MatchQ)
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
do { ss1 <- mkGenSyms (collectPatBinders p) do { let ss1 = mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do { ; addBinds ss1 $ do {
; p1 <- repP p ; p1 <- repP p
; (ss2,ds) <- repBinds wheres ; (ss2,ds) <- repBinds wheres
...@@ -546,7 +550,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = ...@@ -546,7 +550,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
repClauseTup :: Match Name -> DsM (Core M.ClauseQ) repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
do { ss1 <- mkGenSyms (collectPatsBinders ps) do { let ss1 = mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do { ; addBinds ss1 $ do {
ps1 <- repPs ps ps1 <- repPs ps
; (ss2,ds) <- repBinds wheres ; (ss2,ds) <- repBinds wheres
...@@ -576,7 +580,7 @@ repFields flds = do ...@@ -576,7 +580,7 @@ repFields flds = do
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables -- Representing Stmt's is tricky, especially if bound variables
-- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
-- First gensym new names for every variable in any of the patterns. -- First gensym new names for every variable in any of the patterns.
-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
-- if variables didn't shaddow, the static gensym wouldn't be necessary -- if variables didn't shaddow, the static gensym wouldn't be necessary
...@@ -606,7 +610,7 @@ repSts [ResultStmt e loc] = ...@@ -606,7 +610,7 @@ repSts [ResultStmt e loc] =
; return ([], [e1]) } ; return ([], [e1]) }
repSts (BindStmt p e loc : ss) = repSts (BindStmt p e loc : ss) =
do { e2 <- repE e do { e2 <- repE e
; ss1 <- mkGenSyms (collectPatBinders p) ; let ss1 = mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do { ; addBinds ss1 $ do {
; p1 <- repP p; ; p1 <- repP p;
; (ss2,zs) <- repSts ss ; (ss2,zs) <- repSts ss
...@@ -631,17 +635,23 @@ repSts other = panic "Exotic Stmt in meta brackets" ...@@ -631,17 +635,23 @@ repSts other = panic "Exotic Stmt in meta brackets"
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ]) repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
repBinds decs repBinds decs
= do { let { bndrs = collectHsBinders decs } ; = do { let { bndrs = collectHsBinders decs }
ss <- mkGenSyms bndrs ; -- No need to worrry about detailed scopes within
core <- addBinds ss (rep_binds decs) ; -- the binding group, because we are talking Names
core_list <- coreList decQTyConName core ; -- here, so we can safely treat it as a mutually
return (ss, core_list) } -- recursive group
; let ss = mkGenSyms bndrs
; core <- addBinds ss (rep_binds decs)
; core_list <- coreList decQTyConName core
; return (ss, core_list) }
rep_binds :: HsBinds Name -> DsM [Core M.DecQ] rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds binds = do locs_cores <- rep_binds' binds rep_binds binds = do locs_cores <- rep_binds' binds
return $ de_loc $ sort_by_loc locs_cores return $ de_loc $ sort_by_loc locs_cores
rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)] rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds' EmptyBinds = return [] rep_binds' EmptyBinds = return []
rep_binds' (ThenBinds x y) rep_binds' (ThenBinds x y)
= do { core1 <- rep_binds' x = do { core1 <- rep_binds' x
...@@ -655,10 +665,12 @@ rep_binds' (IPBinds _) ...@@ -655,10 +665,12 @@ rep_binds' (IPBinds _)
= panic "DsMeta:repBinds: can't do implicit parameters" = panic "DsMeta:repBinds: can't do implicit parameters"
rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ] rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind binds = do locs_cores <- rep_monobind' binds rep_monobind binds = do locs_cores <- rep_monobind' binds
return $ de_loc $ sort_by_loc locs_cores return $ de_loc $ sort_by_loc locs_cores
rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)] rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_monobind' EmptyMonoBinds = return [] rep_monobind' EmptyMonoBinds = return []
rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x; rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
y1 <- rep_monobind' y; y1 <- rep_monobind' y;
...@@ -725,7 +737,7 @@ repLambda :: Match Name -> DsM (Core M.ExpQ) ...@@ -725,7 +737,7 @@ repLambda :: Match Name -> DsM (Core M.ExpQ)
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
EmptyBinds _)) EmptyBinds _))
= do { let bndrs = collectPatsBinders ps ; = do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs ; let ss = mkGenSyms bndrs
; lam <- addBinds ss ( ; lam <- addBinds ss (
do { xs <- repPs ps; body <- repE e; repLam xs body }) do { xs <- repPs ps; body <- repE e; repLam xs body })
; wrapGenSyns ss lam } ; wrapGenSyns ss lam }
...@@ -783,26 +795,24 @@ de_loc = map snd ...@@ -783,26 +795,24 @@ de_loc = map snd
-- The meta-environment -- The meta-environment
-- A name/identifier association for fresh names of locally bound entities -- A name/identifier association for fresh names of locally bound entities
--
type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
-- I.e. (x, x_id) means -- I.e. (x, x_id) means
-- let x_id = gensym "x" in ... -- let x_id = gensym "x" in ...
-- Generate a fresh name for a locally bound entity -- Generate a fresh name for a locally bound entity
--
mkGenSym :: Name -> DsM GenSymBind mkGenSym :: Name -> GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) } mkGenSym nm = (nm, mkLocalId nm stringTy)
-- Ditto for a list of names -- Ditto for a list of names
-- --
mkGenSyms :: [Name] -> DsM [GenSymBind] mkGenSyms :: [Name] -> [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns mkGenSyms ns = map mkGenSym ns
-- Add a list of fresh names for locally bound entities to the meta
-- environment (which is part of the state carried around by the desugarer
-- monad)
--
addBinds :: [GenSymBind] -> DsM a -> DsM a addBinds :: [GenSymBind] -> DsM a -> DsM a
-- Add a list of fresh names for locally bound entities to the
-- meta environment (which is part of the state carried around
-- by the desugarer monad)
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
-- Look up a locally bound name -- Look up a locally bound name
...@@ -844,13 +854,13 @@ lookupType :: Name -- Name of type constructor (e.g. M.ExpQ) ...@@ -844,13 +854,13 @@ lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkGenTyConApp tc []) } return (mkGenTyConApp tc []) }
wrapGenSyns :: [GenSymBind]
-> Core (M.Q a) -> DsM (Core (M.Q a))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 -> -- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 -> -- bindQ (gensym nm2 (\ id2 ->
-- y)) -- y))
wrapGenSyns :: [GenSymBind]
-> Core (M.Q a) -> DsM (Core (M.Q a))
wrapGenSyns binds body@(MkC b) wrapGenSyns binds body@(MkC b)
= go binds = go binds
where where
...@@ -868,8 +878,10 @@ wrapGenSyns binds body@(MkC b) ...@@ -868,8 +878,10 @@ wrapGenSyns binds body@(MkC b)
gensym_app (MkC (Lam id body')) } gensym_app (MkC (Lam id body')) }
-- Just like wrapGenSym, but don't actually do the gensym -- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name -- Instead use the existing name:
-- Only used for [Decl] -- let x = "x" in ...
-- Only used for [Decl], and for the class ops in class
-- and instance decls
wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a) wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
wrapNongenSyms binds (MkC body) wrapNongenSyms binds (MkC body)
= do { binds' <- mapM do_one binds ; = do { binds' <- mapM do_one binds ;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment