module DsMeta( dsBracket, dsReify,
templateHaskellNames, qTyConName,
- liftName, exprTyConName, declTyConName,
+ liftName, exprTyConName, declTyConName, typeTyConName,
decTyConName, typTyConName ) where
#include "HsVersions.h"
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
--- Returns a CoreExpr of type reifyType --> M.Typ
--- reifyDecl --> M.Dec
--- reifyFixty --> M.Fix
+-- Returns a CoreExpr of type reifyType --> M.Type
+-- reifyDecl --> M.Decl
+-- reifyFixty --> Q M.Fix
dsReify (ReifyOut ReifyType name)
= do { thing <- dsLookupGlobal name ;
-- By deferring the lookup until now (rather than doing it
-- Declarations
-------------------------------------------------------
-repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
+repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
repTopDs group
= do { let { bndrs = groupBinders group } ;
ss <- mkGenSyms bndrs ;
+ -- Bind all the names mainly to avoid repeated use of explicit strings.
+ -- Thus we get
+ -- do { t :: String <- genSym "T" ;
+ -- return (Data t [] ...more t's... }
+ -- The other important reason is that the output must mention
+ -- only "T", not "Foo.T" where Foo is the current module
+
+
decls <- addBinds ss (do {
val_ds <- rep_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (hs_tyclds group) ;
-- more needed
return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
- core_list <- coreList declTyConName decls ;
- wrapNongenSyms ss core_list
+ decl_ty <- lookupType declTyConName ;
+ let { core_list = coreList' decl_ty decls } ;
+ q_decs <- repSequenceQ decl_ty core_list ;
+
+ wrapNongenSyms ss q_decs
-- Do *not* gensym top-level binders
}
[n | ForeignImport n _ _ _ _ <- foreign_decls]
+{- Note [Binders and occurrences]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+ Data "T" [] [Con "MkT" []] []
+and *not*
+ Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in. We do *not* clone, though; no need for this:
+ Data "T79" ....
+
+But if we see this:
+ data T = MkT
+ foo = reifyDecl T
+
+then we must desugar to
+ foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
+but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+-}
+
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
tcdName = tc, tcdTyVars = tvs,
tcdCons = DataCons cons, tcdDerivs = mb_derivs })
- = do { tc1 <- lookupBinder tc ;
+ = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
tvs1 <- repTvs tvs ;
cons1 <- mapM repC cons ;
cons2 <- coreList consTyConName cons1 ;
tcdTyVars = tvs, tcdFDs = [],
tcdSigs = sigs, tcdMeths = Just binds
})
- = do { cls1 <- lookupBinder cls ;
+ = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
tvs1 <- repTvs tvs ;
cxt1 <- repCtxt cxt ;
sigs1 <- rep_sigs sigs ;
repC :: ConDecl Name -> DsM (Core M.Cons)
repC (ConDecl con [] [] details loc)
- = do { con1 <- lookupBinder con ;
+ = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
arg_tys <- mapM (repBangTy con) (hsConArgs details) ;
arg_tys1 <- coreList typeTyConName arg_tys ;
repConstr con1 arg_tys1 }
; z <- repLetE ds e2
; wrapGenSyns expTyConName ss z }
-- FIXME: I haven't got the types here right yet
-repE (HsDo ctxt sts _ ty loc)
- | isComprCtxt ctxt = do { (ss,zs) <- repSts sts;
- e <- repDoE (nonEmptyCoreList zs);
- wrapGenSyns expTyConName ss e }
- | otherwise =
- panic "DsMeta.repE: Can't represent mdo and [: :] yet"
- where
- isComprCtxt ListComp = True
- isComprCtxt DoExpr = True
- isComprCtxt _ = False
+repE (HsDo DoExpr sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repDoE (nonEmptyCoreList zs);
+ wrapGenSyns expTyConName ss e }
+repE (HsDo ListComp sts _ ty loc)
+ = do { (ss,zs) <- repSts sts;
+ e <- repComp (nonEmptyCoreList zs);
+ wrapGenSyns expTyConName ss e }
+repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
repE (ExplicitPArr ty es) =
panic "DsMeta.repE: No explicit parallel arrays yet"
repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
-repE (ArithSeqOut _ aseq) =
+repE (ArithSeqIn aseq) =
case aseq of
From e -> do { ds1 <- repE e; repFrom ds1 }
FromThen e1 e2 -> do
RecCon pairs -> error "No records in template haskell yet"
InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
}
+repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
+repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
repP other = panic "Exotic pattern inside meta brackets"
repListPat :: [Pat Name] -> DsM (Core M.Patt)
addBinds :: [GenSymBind] -> DsM a -> DsM a
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
-lookupBinder :: Name -> DsM (Core String)
-lookupBinder n
- = do { mb_val <- dsLookupMetaEnv n;
- case mb_val of
- Just (Bound id) -> return (MkC (Var id))
- other -> pprPanic "Failed binder lookup:" (ppr n) }
-
mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
+lookupBinder :: Name -> DsM (Core String)
+lookupBinder n
+ = do { mb_val <- dsLookupMetaEnv n;
+ case mb_val of
+ Just (Bound x) -> return (coreVar x)
+ other -> pprPanic "Failed binder lookup:" (ppr n) }
+
+lookupOcc :: Name -> DsM (Core String)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupOcc n
+ = do { mb_val <- dsLookupMetaEnv n ;
+ case mb_val of
+ Nothing -> globalVar n
+ Just (Bound x) -> return (coreVar x)
+ Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
+ }
+
+globalVar :: Name -> DsM (Core String)
+globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
+ where
+ name_mod = moduleUserString (nameModule n)
+ name_occ = occNameUserString (nameOccName n)
+
+localVar :: Name -> DsM (Core String)
+localVar n = coreStringLit (occNameUserString (nameOccName n))
+
lookupType :: Name -- Name of type constructor (e.g. M.Expr)
-> DsM Type -- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
-wrapNongenSyms :: [GenSymBind]
- -> Core [M.Decl] -> DsM (Core [M.Decl])
-wrapNongenSyms binds body@(MkC b)
- = go binds
+wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
+wrapNongenSyms binds (MkC body)
+ = do { binds' <- mapM do_one binds ;
+ return (MkC (mkLets binds' body)) }
where
- go [] = return body
- go ((name,id) : binds)
- = do { MkC body' <- go binds
- ; MkC lit_str <- localVar name -- No gensym
- ; return (MkC (Let (NonRec id lit_str) body'))
- }
+ do_one (name,id)
+ = do { MkC lit_str <- localVar name -- No gensym
+ ; return (NonRec id lit_str) }
void = placeHolderType
= do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
where
lit_name = case lit of
- HsInt _ -> intLName
- HsChar _ -> charLName
- HsString _ -> stringLName
- HsRat _ _ -> rationalLName
- other -> uh_oh
+ HsInteger _ -> integerLName
+ HsChar _ -> charLName
+ HsString _ -> stringLName
+ HsRat _ _ -> rationalLName
+ other -> uh_oh
uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
(ppr lit)
repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
-repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInt i)
+repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i)
repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
repLiteral (HsRat f rat_ty) }
-- The type Rational will be in the environment, becuase
repBindQ ty_a ty_b (MkC x) (MkC y)
= rep2 bindQName [Type ty_a, Type ty_b, x, y]
+repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
+repSequenceQ ty_a (MkC list)
+ = rep2 sequenceQName [Type ty_a, list]
+
------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list
corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
-lookupOcc :: Name -> DsM (Core String)
--- Lookup an occurrence; it can't be a splice.
--- Use the in-scope bindings if they exist
-lookupOcc n
- = do { mb_val <- dsLookupMetaEnv n ;
- case mb_val of
- Nothing -> globalVar n
- Just (Bound x) -> return (coreVar x)
- other -> pprPanic "repE:lookupOcc" (ppr n)
- }
-
-globalVar :: Name -> DsM (Core String)
-globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
- where
- name_mod = moduleUserString (nameModule n)
- name_occ = occNameUserString (nameOccName n)
-
-localVar :: Name -> DsM (Core String)
-localVar n = coreStringLit (occNameUserString (nameOccName n))
-
coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta
templateHaskellNames
- = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+ = mkNameSet [ integerLName,charLName, stringLName, rationalLName,
plitName, pvarName, ptupName,
pconName, ptildeName, paspatName, pwildName,
varName, conName, litName, appName, infixEName, lamName,
bindStName, letStName, noBindStName, parStName,
fromName, fromThenName, fromToName, fromThenToName,
funName, valName, liftName,
- gensymName, returnQName, bindQName,
+ gensymName, returnQName, bindQName, sequenceQName,
matchName, clauseName, funName, valName, dataDName, classDName,
instName, protoName, tvarName, tconName, tappName,
arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
mk_known_key_name space str uniq
= mkKnownKeyExternalName thModule (mkOccFS space str) uniq
-intLName = varQual FSLIT("intL") intLIdKey
+integerLName = varQual FSLIT("integerL") integerLIdKey
charLName = varQual FSLIT("charL") charLIdKey
stringLName = varQual FSLIT("stringL") stringLIdKey
rationalLName = varQual FSLIT("rationalL") rationalLIdKey
gensymName = varQual FSLIT("gensym") gensymIdKey
returnQName = varQual FSLIT("returnQ") returnQIdKey
bindQName = varQual FSLIT("bindQ") bindQIdKey
+sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
-- type Mat = ...
matchName = varQual FSLIT("match") matchIdKey
protoIdKey = mkPreludeMiscIdUnique 210
matchIdKey = mkPreludeMiscIdUnique 211
clauseIdKey = mkPreludeMiscIdUnique 212
-intLIdKey = mkPreludeMiscIdUnique 213
+integerLIdKey = mkPreludeMiscIdUnique 213
charLIdKey = mkPreludeMiscIdUnique 214
classDIdKey = mkPreludeMiscIdUnique 215
instIdKey = mkPreludeMiscIdUnique 216
dataDIdKey = mkPreludeMiscIdUnique 217
+sequenceQIdKey = mkPreludeMiscIdUnique 218
plitIdKey = mkPreludeMiscIdUnique 220
pvarIdKey = mkPreludeMiscIdUnique 221
projects / ghc-hetmet.git / blobdiff