repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
repTopDs 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.
-- Thus we get
repInstD' (InstDecl ty binds _ loc)
-- Ignore user pragmas for now
- = do { cxt1 <- repContext cxt ;
- inst_ty1 <- repPred (HsClassP cls tys) ;
- binds1 <- rep_monobind binds ;
- decls1 <- coreList decQTyConName binds1 ;
- i <- repInst cxt1 inst_ty1 decls1;
- return (loc, i)}
+ = do { cxt1 <- repContext cxt
+ ; inst_ty1 <- repPred (HsClassP cls tys)
+ ; let ss = mkGenSyms (collectMonoBinders binds)
+ ; binds1 <- addBinds ss (rep_monobind binds)
+ ; decls1 <- coreList decQTyConName binds1
+ ; 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
(tvs, cxt, cls, tys) = splitHsInstDeclTy ty
addTyVarBinds tvs m =
do
let names = map hsTyVarName tvs
- freshNames <- mkGenSyms names
+ let freshNames = mkGenSyms names
term <- addBinds freshNames $ do
bndrs <- mapM lookupBinder names
m bndrs
repMatchTup :: Match Name -> DsM (Core M.MatchQ)
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
- do { ss1 <- mkGenSyms (collectPatBinders p)
+ do { let ss1 = mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repP p
; (ss2,ds) <- repBinds wheres
repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
- do { ss1 <- mkGenSyms (collectPatsBinders ps)
+ do { let ss1 = mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repPs ps
; (ss2,ds) <- repBinds wheres
-----------------------------------------------------------------------------
-- 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.
-- 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
; return ([], [e1]) }
repSts (BindStmt p e loc : ss) =
do { e2 <- repE e
- ; ss1 <- mkGenSyms (collectPatBinders p)
+ ; let ss1 = mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repP p;
; (ss2,zs) <- repSts ss
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
repBinds decs
- = do { let { bndrs = collectHsBinders decs } ;
- ss <- mkGenSyms bndrs ;
- core <- addBinds ss (rep_binds decs) ;
- core_list <- coreList decQTyConName core ;
- return (ss, core_list) }
+ = do { let { bndrs = collectHsBinders 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
+ -- 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]
+-- Assumes: all the binders of the binding are alrady in the meta-env
rep_binds binds = do locs_cores <- rep_binds' binds
return $ de_loc $ sort_by_loc locs_cores
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' (ThenBinds x y)
= do { core1 <- rep_binds' x
= panic "DsMeta:repBinds: can't do implicit parameters"
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
return $ de_loc $ sort_by_loc locs_cores
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' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
y1 <- rep_monobind' y;
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
EmptyBinds _))
= do { let bndrs = collectPatsBinders ps ;
- ; ss <- mkGenSyms bndrs
+ ; let ss = mkGenSyms bndrs
; lam <- addBinds ss (
do { xs <- repPs ps; body <- repE e; repLam xs body })
; wrapGenSyns ss lam }
-- The meta-environment
-- A name/identifier association for fresh names of locally bound entities
---
type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
-- I.e. (x, x_id) means
-- let x_id = gensym "x" in ...
-- Generate a fresh name for a locally bound entity
---
-mkGenSym :: Name -> DsM GenSymBind
-mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
+
+mkGenSym :: Name -> GenSymBind
+mkGenSym nm = (nm, mkLocalId nm stringTy)
-- Ditto for a list of names
--
-mkGenSyms :: [Name] -> DsM [GenSymBind]
-mkGenSyms ns = mapM mkGenSym ns
+mkGenSyms :: [Name] -> [GenSymBind]
+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
+-- 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
-- Look up a locally bound name
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
return (mkGenTyConApp tc []) }
+wrapGenSyns :: [GenSymBind]
+ -> Core (M.Q a) -> DsM (Core (M.Q a))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y
-- --> bindQ (gensym nm1) (\ id1 ->
-- bindQ (gensym nm2 (\ id2 ->
-- y))
-wrapGenSyns :: [GenSymBind]
- -> Core (M.Q a) -> DsM (Core (M.Q a))
wrapGenSyns binds body@(MkC b)
= go binds
where
gensym_app (MkC (Lam id body')) }
-- Just like wrapGenSym, but don't actually do the gensym
--- Instead use the existing name
--- Only used for [Decl]
+-- Instead use the existing name:
+-- 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 binds (MkC body)
= do { binds' <- mapM do_one binds ;
projects / ghc-hetmet.git / commitdiff