1 -----------------------------------------------------------------------------
2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
4 -- input HsExpr. We do this in the DsM monad, which supplies access to
5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
7 -- It also defines a bunch of knownKeyNames, in the same way as is done
8 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
9 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
10 -- a Royal Pain (triggers other recompilation).
11 -----------------------------------------------------------------------------
14 module DsMeta( dsBracket,
15 templateHaskellNames, qTyConName, nameTyConName,
16 liftName, expQTyConName, decQTyConName, typeQTyConName,
17 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
20 #include "HsVersions.h"
22 import {-# SOURCE #-} DsExpr ( dsExpr )
24 import MatchLit ( dsLit )
25 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
28 import qualified Language.Haskell.TH as TH
31 import PrelNames ( rationalTyConName, integerTyConName, negateName )
32 import OccName ( isDataOcc, isTvOcc, occNameUserString )
33 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
34 -- we do this by removing varName from the import of OccName above, making
35 -- a qualified instance of OccName and using OccNameAlias.varName where varName
36 -- ws previously used in this file.
37 import qualified OccName
39 import Module ( Module, mkModule, mkModuleName, moduleUserString )
40 import Id ( Id, mkLocalId )
41 import OccName ( mkOccFS )
42 import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
43 isExternalName, getSrcLoc )
45 import Type ( Type, mkGenTyConApp )
46 import TcType ( tcTyConAppArgs )
47 import TyCon ( tyConName )
48 import TysWiredIn ( parrTyCon )
50 import CoreUtils ( exprType )
51 import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
52 import Maybe ( catMaybes )
53 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
54 import BasicTypes ( NewOrData(..), isBoxed )
55 import Packages ( thPackage )
57 import Bag ( bagToList )
59 import Monad ( zipWithM )
60 import List ( sortBy )
62 -----------------------------------------------------------------------------
63 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
64 -- Returns a CoreExpr of type TH.ExpQ
65 -- The quoted thing is parameterised over Name, even though it has
66 -- been type checked. We don't want all those type decorations!
68 dsBracket brack splices
69 = dsExtendMetaEnv new_bit (do_brack brack)
71 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
73 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
74 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
75 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
76 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
77 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
79 {- -------------- Examples --------------------
83 gensym (unpackString "x"#) `bindQ` \ x1::String ->
84 lam (pvar x1) (var x1)
87 [| \x -> $(f [| x |]) |]
89 gensym (unpackString "x"#) `bindQ` \ x1::String ->
90 lam (pvar x1) (f (var x1))
94 -------------------------------------------------------
96 -------------------------------------------------------
98 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
100 = do { let { bndrs = map unLoc (groupBinders group) } ;
101 ss <- mkGenSyms bndrs ;
103 -- Bind all the names mainly to avoid repeated use of explicit strings.
105 -- do { t :: String <- genSym "T" ;
106 -- return (Data t [] ...more t's... }
107 -- The other important reason is that the output must mention
108 -- only "T", not "Foo:T" where Foo is the current module
111 decls <- addBinds ss (do {
112 val_ds <- mapM rep_bind_group (hs_valds group) ;
113 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
114 inst_ds <- mapM repInstD' (hs_instds group) ;
116 return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
118 decl_ty <- lookupType decQTyConName ;
119 let { core_list = coreList' decl_ty decls } ;
121 dec_ty <- lookupType decTyConName ;
122 q_decs <- repSequenceQ dec_ty core_list ;
124 wrapNongenSyms ss q_decs
125 -- Do *not* gensym top-level binders
128 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
129 hs_fords = foreign_decls })
130 -- Collect the binders of a Group
131 = collectGroupBinders val_decls ++
132 [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
133 [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
136 {- Note [Binders and occurrences]
137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
138 When we desugar [d| data T = MkT |]
140 Data "T" [] [Con "MkT" []] []
142 Data "Foo:T" [] [Con "Foo:MkT" []] []
143 That is, the new data decl should fit into whatever new module it is
144 asked to fit in. We do *not* clone, though; no need for this:
151 then we must desugar to
152 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
154 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
155 And we use lookupOcc, rather than lookupBinder
156 in repTyClD and repC.
160 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
162 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
163 tcdLName = tc, tcdTyVars = tvs,
164 tcdCons = cons, tcdDerivs = mb_derivs }))
165 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
166 dec <- addTyVarBinds tvs $ \bndrs -> do {
167 cxt1 <- repLContext cxt ;
168 cons1 <- mapM repC cons ;
169 cons2 <- coreList conQTyConName cons1 ;
170 derivs1 <- repDerivs mb_derivs ;
171 bndrs1 <- coreList nameTyConName bndrs ;
172 repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
173 return $ Just (loc, dec) }
175 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
176 tcdLName = tc, tcdTyVars = tvs,
177 tcdCons = [con], tcdDerivs = mb_derivs }))
178 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
179 dec <- addTyVarBinds tvs $ \bndrs -> do {
180 cxt1 <- repLContext cxt ;
182 derivs1 <- repDerivs mb_derivs ;
183 bndrs1 <- coreList nameTyConName bndrs ;
184 repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
185 return $ Just (loc, dec) }
187 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
188 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
189 dec <- addTyVarBinds tvs $ \bndrs -> do {
191 bndrs1 <- coreList nameTyConName bndrs ;
192 repTySyn tc1 bndrs1 ty1 } ;
193 return (Just (loc, dec)) }
195 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
197 tcdFDs = [], -- We don't understand functional dependencies
198 tcdSigs = sigs, tcdMeths = meth_binds }))
199 = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
200 dec <- addTyVarBinds tvs $ \bndrs -> do {
201 cxt1 <- repLContext cxt ;
202 sigs1 <- rep_sigs sigs ;
203 binds1 <- rep_binds meth_binds ;
204 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
205 bndrs1 <- coreList nameTyConName bndrs ;
206 repClass cxt1 cls1 bndrs1 decls1 } ;
207 return $ Just (loc, dec) }
210 repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ;
214 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
216 repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
217 = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
218 -- We must bring the type variables into scope, so their occurrences
219 -- don't fail, even though the binders don't appear in the resulting
221 do { cxt1 <- repContext cxt
222 ; inst_ty1 <- repPred (HsClassP cls tys)
223 ; ss <- mkGenSyms (collectHsBindBinders binds)
224 ; binds1 <- addBinds ss (rep_binds binds)
225 ; decls1 <- coreList decQTyConName binds1
226 ; decls2 <- wrapNongenSyms ss decls1
227 -- wrapNonGenSyms: do not clone the class op names!
228 -- They must be called 'op' etc, not 'op34'
229 ; repInst cxt1 inst_ty1 decls2 }
233 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
235 -------------------------------------------------------
237 -------------------------------------------------------
239 repC :: LConDecl Name -> DsM (Core TH.ConQ)
240 repC (L loc (ConDecl con [] (L _ []) details))
241 = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
242 repConstr con1 details }
244 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
245 repBangTy (L _ (BangType str ty)) = do
246 MkC s <- rep2 strName []
248 rep2 strictTypeName [s, t]
249 where strName = case str of
250 HsNoBang -> notStrictName
251 other -> isStrictName
253 -------------------------------------------------------
255 -------------------------------------------------------
257 repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name])
258 repDerivs Nothing = coreList nameTyConName []
259 repDerivs (Just (L _ ctxt))
260 = do { strs <- mapM rep_deriv ctxt ;
261 coreList nameTyConName strs }
263 rep_deriv :: LHsPred Name -> DsM (Core TH.Name)
264 -- Deriving clauses must have the simple H98 form
265 rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls
266 rep_deriv other = panic "rep_deriv"
269 -------------------------------------------------------
270 -- Signatures in a class decl, or a group of bindings
271 -------------------------------------------------------
273 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
274 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
275 return $ de_loc $ sort_by_loc locs_cores
277 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
278 -- We silently ignore ones we don't recognise
279 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
280 return (concat sigs1) }
282 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
284 -- Empty => Too hard, signature ignored
285 rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
286 rep_sig other = return []
288 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
289 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
291 sig <- repProto nm1 ty1 ;
292 return [(loc, sig)] }
295 -------------------------------------------------------
297 -------------------------------------------------------
299 -- gensym a list of type variables and enter them into the meta environment;
300 -- the computations passed as the second argument is executed in that extended
301 -- meta environment and gets the *new* names on Core-level as an argument
303 addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
304 -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
305 -> DsM (Core (TH.Q a))
306 addTyVarBinds tvs m =
308 let names = map (hsTyVarName.unLoc) tvs
309 freshNames <- mkGenSyms names
310 term <- addBinds freshNames $ do
311 bndrs <- mapM lookupBinder names
313 wrapGenSyns freshNames term
315 -- represent a type context
317 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
318 repLContext (L _ ctxt) = repContext ctxt
320 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
322 preds <- mapM repLPred ctxt
323 predList <- coreList typeQTyConName preds
326 -- represent a type predicate
328 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
329 repLPred (L _ p) = repPred p
331 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
332 repPred (HsClassP cls tys) = do
333 tcon <- repTy (HsTyVar cls)
336 repPred (HsIParam _ _) =
337 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
339 -- yield the representation of a list of types
341 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
342 repLTys tys = mapM repLTy tys
346 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
347 repLTy (L _ ty) = repTy ty
349 repTy :: HsType Name -> DsM (Core TH.TypeQ)
350 repTy (HsForAllTy _ tvs ctxt ty) =
351 addTyVarBinds tvs $ \bndrs -> do
352 ctxt1 <- repLContext ctxt
354 bndrs1 <- coreList nameTyConName bndrs
355 repTForall bndrs1 ctxt1 ty1
358 | isTvOcc (nameOccName n) = do
359 tv1 <- lookupBinder n
364 repTy (HsAppTy f a) = do
368 repTy (HsFunTy f a) = do
371 tcon <- repArrowTyCon
372 repTapps tcon [f1, a1]
373 repTy (HsListTy t) = do
377 repTy (HsPArrTy t) = do
379 tcon <- repTy (HsTyVar (tyConName parrTyCon))
381 repTy (HsTupleTy tc tys) = do
383 tcon <- repTupleTyCon (length tys)
385 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
387 repTy (HsParTy t) = repLTy t
389 panic "DsMeta.repTy: Can't represent number types (for generics)"
390 repTy (HsPredTy pred) = repLPred pred
391 repTy (HsKindSig ty kind) =
392 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
395 -----------------------------------------------------------------------------
397 -----------------------------------------------------------------------------
399 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
400 repLEs es = do { es' <- mapM repLE es ;
401 coreList expQTyConName es' }
403 -- FIXME: some of these panics should be converted into proper error messages
404 -- unless we can make sure that constructs, which are plainly not
405 -- supported in TH already lead to error messages at an earlier stage
406 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
407 repLE (L _ e) = repE e
409 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
411 do { mb_val <- dsLookupMetaEnv x
413 Nothing -> do { str <- globalVar x
414 ; repVarOrCon x str }
415 Just (Bound y) -> repVarOrCon x (coreVar y)
416 Just (Splice e) -> do { e' <- dsExpr e
417 ; return (MkC e') } }
418 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
420 -- Remember, we're desugaring renamer output here, so
421 -- HsOverlit can definitely occur
422 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
423 repE (HsLit l) = do { a <- repLiteral l; repLit a }
424 repE (HsLam m) = repLambda m
425 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
427 repE (OpApp e1 op fix e2) =
428 do { arg1 <- repLE e1;
431 repInfixApp arg1 the_op arg2 }
432 repE (NegApp x nm) = do
434 negateVar <- lookupOcc negateName >>= repVar
436 repE (HsPar x) = repLE x
437 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
438 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
439 repE (HsCase e ms) = do { arg <- repLE e
440 ; ms2 <- mapM repMatchTup ms
441 ; repCaseE arg (nonEmptyCoreList ms2) }
442 repE (HsIf x y z) = do
447 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
448 ; e2 <- addBinds ss (repLE e)
451 -- FIXME: I haven't got the types here right yet
452 repE (HsDo DoExpr sts _ ty)
453 = do { (ss,zs) <- repLSts sts;
454 e <- repDoE (nonEmptyCoreList zs);
456 repE (HsDo ListComp sts _ ty)
457 = do { (ss,zs) <- repLSts sts;
458 e <- repComp (nonEmptyCoreList zs);
460 repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
461 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
462 repE (ExplicitPArr ty es) =
463 panic "DsMeta.repE: No explicit parallel arrays yet"
464 repE (ExplicitTuple es boxed)
465 | isBoxed boxed = do { xs <- repLEs es; repTup xs }
466 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
467 repE (RecordCon c flds)
468 = do { x <- lookupLOcc c;
469 fs <- repFields flds;
471 repE (RecordUpd e flds)
473 fs <- repFields flds;
476 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
477 repE (ArithSeqIn aseq) =
479 From e -> do { ds1 <- repLE e; repFrom ds1 }
488 FromThenTo e1 e2 e3 -> do
492 repFromThenTo ds1 ds2 ds3
493 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
494 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
495 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
496 repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
497 repE (HsSpliceE (HsSplice n _))
498 = do { mb_val <- dsLookupMetaEnv n
500 Just (Splice e) -> do { e' <- dsExpr e
502 other -> pprPanic "HsSplice" (ppr n) }
504 repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
506 -----------------------------------------------------------------------------
507 -- Building representations of auxillary structures like Match, Clause, Stmt,
509 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
510 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) =
511 do { ss1 <- mkGenSyms (collectPatBinders p)
512 ; addBinds ss1 $ do {
514 ; (ss2,ds) <- repBinds wheres
515 ; addBinds ss2 $ do {
516 ; gs <- repGuards guards
517 ; match <- repMatch p1 gs ds
518 ; wrapGenSyns (ss1++ss2) match }}}
520 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
521 repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) =
522 do { ss1 <- mkGenSyms (collectPatsBinders ps)
523 ; addBinds ss1 $ do {
525 ; (ss2,ds) <- repBinds wheres
526 ; addBinds ss2 $ do {
527 gs <- repGuards guards
528 ; clause <- repClause ps1 gs ds
529 ; wrapGenSyns (ss1++ss2) clause }}}
531 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
532 repGuards [L _ (GRHS [L _ (ResultStmt e)])]
533 = do {a <- repLE e; repNormal a }
535 = do { zs <- mapM process other;
536 repGuarded (nonEmptyCoreList (map corePair zs)) }
538 process (L _ (GRHS [L _ (ExprStmt e1 ty),
539 L _ (ResultStmt e2)]))
540 = do { x <- repLE e1; y <- repLE e2; return (x, y) }
541 process other = panic "Non Haskell 98 guarded body"
543 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp])
545 fnames <- mapM lookupLOcc (map fst flds)
546 es <- mapM repLE (map snd flds)
547 fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
548 coreList fieldExpTyConName fs
551 -----------------------------------------------------------------------------
552 -- Representing Stmt's is tricky, especially if bound variables
553 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
554 -- First gensym new names for every variable in any of the patterns.
555 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
556 -- if variables didn't shaddow, the static gensym wouldn't be necessary
557 -- and we could reuse the original names (x and x).
559 -- do { x'1 <- gensym "x"
560 -- ; x'2 <- gensym "x"
561 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
562 -- , BindSt (pvar x'2) [| f x |]
563 -- , NoBindSt [| g x |]
567 -- The strategy is to translate a whole list of do-bindings by building a
568 -- bigger environment, and a bigger set of meta bindings
569 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
570 -- of the expressions within the Do
572 -----------------------------------------------------------------------------
573 -- The helper function repSts computes the translation of each sub expression
574 -- and a bunch of prefix bindings denoting the dynamic renaming.
576 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
577 repLSts stmts = repSts (map unLoc stmts)
579 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
580 repSts [ResultStmt e] =
582 ; e1 <- repNoBindSt a
583 ; return ([], [e1]) }
584 repSts (BindStmt p e : ss) =
586 ; ss1 <- mkGenSyms (collectPatBinders p)
587 ; addBinds ss1 $ do {
589 ; (ss2,zs) <- repSts ss
590 ; z <- repBindSt p1 e2
591 ; return (ss1++ss2, z : zs) }}
592 repSts (LetStmt bs : ss) =
593 do { (ss1,ds) <- repBinds bs
595 ; (ss2,zs) <- addBinds ss1 (repSts ss)
596 ; return (ss1++ss2, z : zs) }
597 repSts (ExprStmt e ty : ss) =
599 ; z <- repNoBindSt e2
600 ; (ss2,zs) <- repSts ss
601 ; return (ss2, z : zs) }
602 repSts other = panic "Exotic Stmt in meta brackets"
605 -----------------------------------------------------------
607 -----------------------------------------------------------
609 repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ])
611 = do { let { bndrs = map unLoc (collectGroupBinders decs) }
612 -- No need to worrry about detailed scopes within
613 -- the binding group, because we are talking Names
614 -- here, so we can safely treat it as a mutually
616 ; ss <- mkGenSyms bndrs
617 ; core <- addBinds ss (rep_bind_groups decs)
618 ; core_list <- coreList decQTyConName core
619 ; return (ss, core_list) }
621 rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ]
622 -- Assumes: all the binders of the binding are alrady in the meta-env
623 rep_bind_groups binds = do
624 locs_cores_s <- mapM rep_bind_group binds
625 return $ de_loc $ sort_by_loc (concat locs_cores_s)
627 rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)]
628 -- Assumes: all the binders of the binding are alrady in the meta-env
629 rep_bind_group (HsBindGroup bs sigs _)
630 = do { core1 <- mapM rep_bind (bagToList bs)
631 ; core2 <- rep_sigs' sigs
632 ; return (core1 ++ core2) }
633 rep_bind_group (HsIPBinds _)
634 = panic "DsMeta:repBinds: can't do implicit parameters"
636 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
637 -- Assumes: all the binders of the binding are alrady in the meta-env
639 locs_cores <- mapM rep_bind (bagToList binds)
640 return $ de_loc $ sort_by_loc locs_cores
642 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
643 -- Assumes: all the binders of the binding are alrady in the meta-env
645 -- Note GHC treats declarations of a variable (not a pattern)
646 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
647 -- with an empty list of patterns
648 rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))]))
649 = do { (ss,wherecore) <- repBinds wheres
650 ; guardcore <- addBinds ss (repGuards guards)
651 ; fn' <- lookupLBinder fn
653 ; ans <- repVal p guardcore wherecore
654 ; return (loc, ans) }
656 rep_bind (L loc (FunBind fn infx ms))
657 = do { ms1 <- mapM repClauseTup ms
658 ; fn' <- lookupLBinder fn
659 ; ans <- repFun fn' (nonEmptyCoreList ms1)
660 ; return (loc, ans) }
662 rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2)))
663 = do { patcore <- repLP pat
664 ; (ss,wherecore) <- repBinds wheres
665 ; guardcore <- addBinds ss (repGuards guards)
666 ; ans <- repVal patcore guardcore wherecore
667 ; return (loc, ans) }
669 rep_bind (L loc (VarBind v e))
670 = do { v' <- lookupBinder v
673 ; patcore <- repPvar v'
674 ; empty_decls <- coreList decQTyConName []
675 ; ans <- repVal patcore x empty_decls
676 ; return (srcLocSpan (getSrcLoc v), ans) }
678 -----------------------------------------------------------------------------
679 -- Since everything in a Bind is mutually recursive we need rename all
680 -- all the variables simultaneously. For example:
681 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
682 -- do { f'1 <- gensym "f"
683 -- ; g'2 <- gensym "g"
684 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
685 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
687 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
688 -- environment ( f |-> f'1 ) from each binding, and then unioning them
689 -- together. As we do this we collect GenSymBinds's which represent the renamed
690 -- variables bound by the Bindings. In order not to lose track of these
691 -- representations we build a shadow datatype MB with the same structure as
692 -- MonoBinds, but which has slots for the representations
695 -----------------------------------------------------------------------------
696 -- GHC allows a more general form of lambda abstraction than specified
697 -- by Haskell 98. In particular it allows guarded lambda's like :
698 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
699 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
700 -- (\ p1 .. pn -> exp) by causing an error.
702 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
703 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _)))
704 = do { let bndrs = collectPatsBinders ps ;
705 ; ss <- mkGenSyms bndrs
706 ; lam <- addBinds ss (
707 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
708 ; wrapGenSyns ss lam }
710 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
713 -----------------------------------------------------------------------------
715 -- repP deals with patterns. It assumes that we have already
716 -- walked over the pattern(s) once to collect the binders, and
717 -- have extended the environment. So every pattern-bound
718 -- variable should already appear in the environment.
720 -- Process a list of patterns
721 repLPs :: [LPat Name] -> DsM (Core [TH.Pat])
722 repLPs ps = do { ps' <- mapM repLP ps ;
723 coreList patTyConName ps' }
725 repLP :: LPat Name -> DsM (Core TH.Pat)
726 repLP (L _ p) = repP p
728 repP :: Pat Name -> DsM (Core TH.Pat)
729 repP (WildPat _) = repPwild
730 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
731 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
732 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
733 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
734 repP (ParPat p) = repLP p
735 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
736 repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
737 repP (ConPatIn dc details)
738 = do { con_str <- lookupLOcc dc
740 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
741 RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
742 ; ps <- sequence $ map repLP (map snd pairs)
743 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
744 ; fps' <- coreList fieldPatTyConName fps
745 ; repPrec con_str fps' }
746 InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs }
748 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
749 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
750 repP other = panic "Exotic pattern inside meta brackets"
752 ----------------------------------------------------------
753 -- Declaration ordering helpers
755 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
756 sort_by_loc xs = sortBy comp xs
757 where comp x y = compare (fst x) (fst y)
759 de_loc :: [(a, b)] -> [b]
762 ----------------------------------------------------------
763 -- The meta-environment
765 -- A name/identifier association for fresh names of locally bound entities
766 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
767 -- I.e. (x, x_id) means
768 -- let x_id = gensym "x" in ...
770 -- Generate a fresh name for a locally bound entity
772 mkGenSyms :: [Name] -> DsM [GenSymBind]
773 -- We can use the existing name. For example:
774 -- [| \x_77 -> x_77 + x_77 |]
776 -- do { x_77 <- genSym "x"; .... }
777 -- We use the same x_77 in the desugared program, but with the type Bndr
780 -- We do make it an Internal name, though (hence localiseName)
782 -- Nevertheless, it's monadic because we have to generate nameTy
783 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
784 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
787 addBinds :: [GenSymBind] -> DsM a -> DsM a
788 -- Add a list of fresh names for locally bound entities to the
789 -- meta environment (which is part of the state carried around
790 -- by the desugarer monad)
791 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
793 -- Look up a locally bound name
795 lookupLBinder :: Located Name -> DsM (Core TH.Name)
796 lookupLBinder (L _ n) = lookupBinder n
798 lookupBinder :: Name -> DsM (Core TH.Name)
800 = do { mb_val <- dsLookupMetaEnv n;
802 Just (Bound x) -> return (coreVar x)
803 other -> pprPanic "Failed binder lookup:" (ppr n) }
805 -- Look up a name that is either locally bound or a global name
807 -- * If it is a global name, generate the "original name" representation (ie,
808 -- the <module>:<name> form) for the associated entity
810 lookupLOcc :: Located Name -> DsM (Core TH.Name)
811 -- Lookup an occurrence; it can't be a splice.
812 -- Use the in-scope bindings if they exist
813 lookupLOcc (L _ n) = lookupOcc n
815 lookupOcc :: Name -> DsM (Core TH.Name)
817 = do { mb_val <- dsLookupMetaEnv n ;
819 Nothing -> globalVar n
820 Just (Bound x) -> return (coreVar x)
821 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
824 globalVar :: Name -> DsM (Core TH.Name)
825 -- Not bound by the meta-env
826 -- Could be top-level; or could be local
827 -- f x = $(g [| x |])
828 -- Here the x will be local
830 | isExternalName name
831 = do { MkC mod <- coreStringLit name_mod
832 ; MkC occ <- occNameLit name
833 ; rep2 mk_varg [mod,occ] }
835 = do { MkC occ <- occNameLit name
836 ; MkC uni <- coreIntLit (getKey (getUnique name))
837 ; rep2 mkNameUName [occ,uni] }
839 name_mod = moduleUserString (nameModule name)
840 name_occ = nameOccName name
841 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
842 | OccName.isVarOcc name_occ = mkNameG_vName
843 | OccName.isTcOcc name_occ = mkNameG_tcName
844 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
846 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
847 -> DsM Type -- The type
848 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
849 return (mkGenTyConApp tc []) }
851 wrapGenSyns :: [GenSymBind]
852 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
853 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
854 -- --> bindQ (gensym nm1) (\ id1 ->
855 -- bindQ (gensym nm2 (\ id2 ->
858 wrapGenSyns binds body@(MkC b)
859 = do { var_ty <- lookupType nameTyConName
862 [elt_ty] = tcTyConAppArgs (exprType b)
863 -- b :: Q a, so we can get the type 'a' by looking at the
864 -- argument type. NB: this relies on Q being a data/newtype,
865 -- not a type synonym
867 go var_ty [] = return body
868 go var_ty ((name,id) : binds)
869 = do { MkC body' <- go var_ty binds
870 ; lit_str <- occNameLit name
871 ; gensym_app <- repGensym lit_str
872 ; repBindQ var_ty elt_ty
873 gensym_app (MkC (Lam id body')) }
875 -- Just like wrapGenSym, but don't actually do the gensym
876 -- Instead use the existing name:
877 -- let x = "x" in ...
878 -- Only used for [Decl], and for the class ops in class
879 -- and instance decls
880 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
881 wrapNongenSyms binds (MkC body)
882 = do { binds' <- mapM do_one binds ;
883 return (MkC (mkLets binds' body)) }
886 = do { MkC lit_str <- occNameLit name
887 ; MkC var <- rep2 mkNameName [lit_str]
888 ; return (NonRec id var) }
890 occNameLit :: Name -> DsM (Core String)
891 occNameLit n = coreStringLit (occNameUserString (nameOccName n))
894 -- %*********************************************************************
898 -- %*********************************************************************
900 -----------------------------------------------------------------------------
901 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
902 -- we invent a new datatype which uses phantom types.
904 newtype Core a = MkC CoreExpr
907 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
908 rep2 n xs = do { id <- dsLookupGlobalId n
909 ; return (MkC (foldl App (Var id) xs)) }
911 -- Then we make "repConstructors" which use the phantom types for each of the
912 -- smart constructors of the Meta.Meta datatypes.
915 -- %*********************************************************************
917 -- The 'smart constructors'
919 -- %*********************************************************************
921 --------------- Patterns -----------------
922 repPlit :: Core TH.Lit -> DsM (Core TH.Pat)
923 repPlit (MkC l) = rep2 litPName [l]
925 repPvar :: Core TH.Name -> DsM (Core TH.Pat)
926 repPvar (MkC s) = rep2 varPName [s]
928 repPtup :: Core [TH.Pat] -> DsM (Core TH.Pat)
929 repPtup (MkC ps) = rep2 tupPName [ps]
931 repPcon :: Core TH.Name -> Core [TH.Pat] -> DsM (Core TH.Pat)
932 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
934 repPrec :: Core TH.Name -> Core [(TH.Name,TH.Pat)] -> DsM (Core TH.Pat)
935 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
937 repPtilde :: Core TH.Pat -> DsM (Core TH.Pat)
938 repPtilde (MkC p) = rep2 tildePName [p]
940 repPaspat :: Core TH.Name -> Core TH.Pat -> DsM (Core TH.Pat)
941 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
943 repPwild :: DsM (Core TH.Pat)
944 repPwild = rep2 wildPName []
946 repPlist :: Core [TH.Pat] -> DsM (Core TH.Pat)
947 repPlist (MkC ps) = rep2 listPName [ps]
949 --------------- Expressions -----------------
950 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
951 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
952 | otherwise = repVar str
954 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
955 repVar (MkC s) = rep2 varEName [s]
957 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
958 repCon (MkC s) = rep2 conEName [s]
960 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
961 repLit (MkC c) = rep2 litEName [c]
963 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
964 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
966 repLam :: Core [TH.Pat] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
967 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
969 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
970 repTup (MkC es) = rep2 tupEName [es]
972 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
973 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
975 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
976 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
978 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
979 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
981 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
982 repDoE (MkC ss) = rep2 doEName [ss]
984 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
985 repComp (MkC ss) = rep2 compEName [ss]
987 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
988 repListExp (MkC es) = rep2 listEName [es]
990 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
991 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
993 repRecCon :: Core TH.Name -> Core [TH.FieldExp]-> DsM (Core TH.ExpQ)
994 repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
996 repRecUpd :: Core TH.ExpQ -> Core [TH.FieldExp] -> DsM (Core TH.ExpQ)
997 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
999 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1000 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1002 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1003 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1005 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1006 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1008 ------------ Right hand sides (guarded expressions) ----
1009 repGuarded :: Core [(TH.ExpQ, TH.ExpQ)] -> DsM (Core TH.BodyQ)
1010 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1012 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1013 repNormal (MkC e) = rep2 normalBName [e]
1015 ------------- Stmts -------------------
1016 repBindSt :: Core TH.Pat -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1017 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1019 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1020 repLetSt (MkC ds) = rep2 letSName [ds]
1022 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1023 repNoBindSt (MkC e) = rep2 noBindSName [e]
1025 -------------- Range (Arithmetic sequences) -----------
1026 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1027 repFrom (MkC x) = rep2 fromEName [x]
1029 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1030 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1032 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1033 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1035 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1036 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1038 ------------ Match and Clause Tuples -----------
1039 repMatch :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1040 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1042 repClause :: Core [TH.Pat] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1043 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1045 -------------- Dec -----------------------------
1046 repVal :: Core TH.Pat -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1047 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1049 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1050 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1052 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1053 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1054 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1056 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1057 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1058 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1060 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1061 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1063 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1064 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1066 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1067 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1069 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1070 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1072 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1073 repCtxt (MkC tys) = rep2 cxtName [tys]
1075 repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
1076 -> DsM (Core TH.ConQ)
1077 repConstr con (PrefixCon ps)
1078 = do arg_tys <- mapM repBangTy ps
1079 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1080 rep2 normalCName [unC con, unC arg_tys1]
1081 repConstr con (RecCon ips)
1082 = do arg_vs <- mapM lookupLOcc (map fst ips)
1083 arg_tys <- mapM repBangTy (map snd ips)
1084 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1086 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1087 rep2 recCName [unC con, unC arg_vtys']
1088 repConstr con (InfixCon st1 st2)
1089 = do arg1 <- repBangTy st1
1090 arg2 <- repBangTy st2
1091 rep2 infixCName [unC arg1, unC con, unC arg2]
1093 ------------ Types -------------------
1095 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1096 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1097 = rep2 forallTName [tvars, ctxt, ty]
1099 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1100 repTvar (MkC s) = rep2 varTName [s]
1102 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1103 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1105 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1106 repTapps f [] = return f
1107 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1109 --------- Type constructors --------------
1111 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1112 repNamedTyCon (MkC s) = rep2 conTName [s]
1114 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1115 -- Note: not Core Int; it's easier to be direct here
1116 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1118 repArrowTyCon :: DsM (Core TH.TypeQ)
1119 repArrowTyCon = rep2 arrowTName []
1121 repListTyCon :: DsM (Core TH.TypeQ)
1122 repListTyCon = rep2 listTName []
1125 ----------------------------------------------------------
1128 repLiteral :: HsLit -> DsM (Core TH.Lit)
1130 = do lit' <- case lit of
1131 HsIntPrim i -> mk_integer i
1132 HsInt i -> mk_integer i
1133 HsFloatPrim r -> mk_rational r
1134 HsDoublePrim r -> mk_rational r
1136 lit_expr <- dsLit lit'
1137 rep2 lit_name [lit_expr]
1139 lit_name = case lit of
1140 HsInteger _ _ -> integerLName
1141 HsInt _ -> integerLName
1142 HsIntPrim _ -> intPrimLName
1143 HsFloatPrim _ -> floatPrimLName
1144 HsDoublePrim _ -> doublePrimLName
1145 HsChar _ -> charLName
1146 HsString _ -> stringLName
1147 HsRat _ _ -> rationalLName
1149 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1152 mk_integer i = do integer_ty <- lookupType integerTyConName
1153 return $ HsInteger i integer_ty
1154 mk_rational r = do rat_ty <- lookupType rationalTyConName
1155 return $ HsRat r rat_ty
1157 repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
1158 repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
1159 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1160 -- The type Rational will be in the environment, becuase
1161 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1162 -- and rationalL is sucked in when any TH stuff is used
1164 --------------- Miscellaneous -------------------
1166 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1167 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1169 repBindQ :: Type -> Type -- a and b
1170 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1171 repBindQ ty_a ty_b (MkC x) (MkC y)
1172 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1174 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1175 repSequenceQ ty_a (MkC list)
1176 = rep2 sequenceQName [Type ty_a, list]
1178 ------------ Lists and Tuples -------------------
1179 -- turn a list of patterns into a single pattern matching a list
1181 coreList :: Name -- Of the TyCon of the element type
1182 -> [Core a] -> DsM (Core [a])
1184 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1186 coreList' :: Type -- The element type
1187 -> [Core a] -> Core [a]
1188 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1190 nonEmptyCoreList :: [Core a] -> Core [a]
1191 -- The list must be non-empty so we can get the element type
1192 -- Otherwise use coreList
1193 nonEmptyCoreList [] = panic "coreList: empty argument"
1194 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1196 corePair :: (Core a, Core b) -> Core (a,b)
1197 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1199 coreStringLit :: String -> DsM (Core String)
1200 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1202 coreIntLit :: Int -> DsM (Core Int)
1203 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1205 coreVar :: Id -> Core TH.Name -- The Id has type Name
1206 coreVar id = MkC (Var id)
1210 -- %************************************************************************
1212 -- The known-key names for Template Haskell
1214 -- %************************************************************************
1216 -- To add a name, do three things
1218 -- 1) Allocate a key
1220 -- 3) Add the name to knownKeyNames
1222 templateHaskellNames :: [Name]
1223 -- The names that are implicitly mentioned by ``bracket''
1224 -- Should stay in sync with the import list of DsMeta
1226 templateHaskellNames = [
1227 returnQName, bindQName, sequenceQName, newNameName, liftName,
1228 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName,
1231 charLName, stringLName, integerLName, intPrimLName,
1232 floatPrimLName, doublePrimLName, rationalLName,
1234 litPName, varPName, tupPName, conPName, tildePName,
1235 asPName, wildPName, recPName, listPName,
1243 varEName, conEName, litEName, appEName, infixEName,
1244 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1245 condEName, letEName, caseEName, doEName, compEName,
1246 fromEName, fromThenEName, fromToEName, fromThenToEName,
1247 listEName, sigEName, recConEName, recUpdEName,
1251 guardedBName, normalBName,
1253 bindSName, letSName, noBindSName, parSName,
1255 funDName, valDName, dataDName, newtypeDName, tySynDName,
1256 classDName, instanceDName, sigDName,
1260 isStrictName, notStrictName,
1262 normalCName, recCName, infixCName,
1268 forallTName, varTName, conTName, appTName,
1269 tupleTName, arrowTName, listTName,
1272 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1273 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1274 decQTyConName, conQTyConName, strictTypeQTyConName,
1275 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1276 typeTyConName, matchTyConName, clauseTyConName]
1278 tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
1279 tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
1282 -- NB: the TH.Syntax module comes from the "haskell-src" package
1283 thSyn = mkModule thPackage tH_SYN_Name
1284 thLib = mkModule thPackage tH_LIB_Name
1286 mk_known_key_name mod space str uniq
1287 = mkExternalName uniq mod (mkOccFS space str)
1290 libFun = mk_known_key_name thLib OccName.varName
1291 libTc = mk_known_key_name thLib OccName.tcName
1292 thFun = mk_known_key_name thSyn OccName.varName
1293 thTc = mk_known_key_name thSyn OccName.tcName
1295 -------------------- TH.Syntax -----------------------
1296 qTyConName = thTc FSLIT("Q") qTyConKey
1297 nameTyConName = thTc FSLIT("Name") nameTyConKey
1298 fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
1299 patTyConName = thTc FSLIT("Pat") patTyConKey
1300 fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
1301 expTyConName = thTc FSLIT("Exp") expTyConKey
1302 decTyConName = thTc FSLIT("Dec") decTyConKey
1303 typeTyConName = thTc FSLIT("Type") typeTyConKey
1304 matchTyConName = thTc FSLIT("Match") matchTyConKey
1305 clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
1307 returnQName = thFun FSLIT("returnQ") returnQIdKey
1308 bindQName = thFun FSLIT("bindQ") bindQIdKey
1309 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1310 newNameName = thFun FSLIT("newName") newNameIdKey
1311 liftName = thFun FSLIT("lift") liftIdKey
1312 mkNameName = thFun FSLIT("mkName") mkNameIdKey
1313 mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
1314 mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
1315 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1316 mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey
1319 -------------------- TH.Lib -----------------------
1321 charLName = libFun FSLIT("charL") charLIdKey
1322 stringLName = libFun FSLIT("stringL") stringLIdKey
1323 integerLName = libFun FSLIT("integerL") integerLIdKey
1324 intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
1325 floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
1326 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1327 rationalLName = libFun FSLIT("rationalL") rationalLIdKey
1330 litPName = libFun FSLIT("litP") litPIdKey
1331 varPName = libFun FSLIT("varP") varPIdKey
1332 tupPName = libFun FSLIT("tupP") tupPIdKey
1333 conPName = libFun FSLIT("conP") conPIdKey
1334 tildePName = libFun FSLIT("tildeP") tildePIdKey
1335 asPName = libFun FSLIT("asP") asPIdKey
1336 wildPName = libFun FSLIT("wildP") wildPIdKey
1337 recPName = libFun FSLIT("recP") recPIdKey
1338 listPName = libFun FSLIT("listP") listPIdKey
1340 -- type FieldPat = ...
1341 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1344 matchName = libFun FSLIT("match") matchIdKey
1346 -- data Clause = ...
1347 clauseName = libFun FSLIT("clause") clauseIdKey
1350 varEName = libFun FSLIT("varE") varEIdKey
1351 conEName = libFun FSLIT("conE") conEIdKey
1352 litEName = libFun FSLIT("litE") litEIdKey
1353 appEName = libFun FSLIT("appE") appEIdKey
1354 infixEName = libFun FSLIT("infixE") infixEIdKey
1355 infixAppName = libFun FSLIT("infixApp") infixAppIdKey
1356 sectionLName = libFun FSLIT("sectionL") sectionLIdKey
1357 sectionRName = libFun FSLIT("sectionR") sectionRIdKey
1358 lamEName = libFun FSLIT("lamE") lamEIdKey
1359 tupEName = libFun FSLIT("tupE") tupEIdKey
1360 condEName = libFun FSLIT("condE") condEIdKey
1361 letEName = libFun FSLIT("letE") letEIdKey
1362 caseEName = libFun FSLIT("caseE") caseEIdKey
1363 doEName = libFun FSLIT("doE") doEIdKey
1364 compEName = libFun FSLIT("compE") compEIdKey
1365 -- ArithSeq skips a level
1366 fromEName = libFun FSLIT("fromE") fromEIdKey
1367 fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
1368 fromToEName = libFun FSLIT("fromToE") fromToEIdKey
1369 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1371 listEName = libFun FSLIT("listE") listEIdKey
1372 sigEName = libFun FSLIT("sigE") sigEIdKey
1373 recConEName = libFun FSLIT("recConE") recConEIdKey
1374 recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
1376 -- type FieldExp = ...
1377 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1380 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1381 normalBName = libFun FSLIT("normalB") normalBIdKey
1384 bindSName = libFun FSLIT("bindS") bindSIdKey
1385 letSName = libFun FSLIT("letS") letSIdKey
1386 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1387 parSName = libFun FSLIT("parS") parSIdKey
1390 funDName = libFun FSLIT("funD") funDIdKey
1391 valDName = libFun FSLIT("valD") valDIdKey
1392 dataDName = libFun FSLIT("dataD") dataDIdKey
1393 newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
1394 tySynDName = libFun FSLIT("tySynD") tySynDIdKey
1395 classDName = libFun FSLIT("classD") classDIdKey
1396 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1397 sigDName = libFun FSLIT("sigD") sigDIdKey
1400 cxtName = libFun FSLIT("cxt") cxtIdKey
1402 -- data Strict = ...
1403 isStrictName = libFun FSLIT("isStrict") isStrictKey
1404 notStrictName = libFun FSLIT("notStrict") notStrictKey
1407 normalCName = libFun FSLIT("normalC") normalCIdKey
1408 recCName = libFun FSLIT("recC") recCIdKey
1409 infixCName = libFun FSLIT("infixC") infixCIdKey
1411 -- type StrictType = ...
1412 strictTypeName = libFun FSLIT("strictType") strictTKey
1414 -- type VarStrictType = ...
1415 varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
1418 forallTName = libFun FSLIT("forallT") forallTIdKey
1419 varTName = libFun FSLIT("varT") varTIdKey
1420 conTName = libFun FSLIT("conT") conTIdKey
1421 tupleTName = libFun FSLIT("tupleT") tupleTIdKey
1422 arrowTName = libFun FSLIT("arrowT") arrowTIdKey
1423 listTName = libFun FSLIT("listT") listTIdKey
1424 appTName = libFun FSLIT("appT") appTIdKey
1426 matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
1427 clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
1428 expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
1429 stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
1430 decQTyConName = libTc FSLIT("DecQ") decQTyConKey
1431 conQTyConName = libTc FSLIT("ConQ") conQTyConKey
1432 strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
1433 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1434 typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
1436 -- TyConUniques available: 100-119
1437 -- Check in PrelNames if you want to change this
1439 expTyConKey = mkPreludeTyConUnique 100
1440 matchTyConKey = mkPreludeTyConUnique 101
1441 clauseTyConKey = mkPreludeTyConUnique 102
1442 qTyConKey = mkPreludeTyConUnique 103
1443 expQTyConKey = mkPreludeTyConUnique 104
1444 decQTyConKey = mkPreludeTyConUnique 105
1445 patTyConKey = mkPreludeTyConUnique 106
1446 matchQTyConKey = mkPreludeTyConUnique 107
1447 clauseQTyConKey = mkPreludeTyConUnique 108
1448 stmtQTyConKey = mkPreludeTyConUnique 109
1449 conQTyConKey = mkPreludeTyConUnique 110
1450 typeQTyConKey = mkPreludeTyConUnique 111
1451 typeTyConKey = mkPreludeTyConUnique 112
1452 decTyConKey = mkPreludeTyConUnique 113
1453 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1454 strictTypeQTyConKey = mkPreludeTyConUnique 115
1455 fieldExpTyConKey = mkPreludeTyConUnique 116
1456 fieldPatTyConKey = mkPreludeTyConUnique 117
1457 nameTyConKey = mkPreludeTyConUnique 118
1459 -- IdUniques available: 200-299
1460 -- If you want to change this, make sure you check in PrelNames
1462 returnQIdKey = mkPreludeMiscIdUnique 200
1463 bindQIdKey = mkPreludeMiscIdUnique 201
1464 sequenceQIdKey = mkPreludeMiscIdUnique 202
1465 liftIdKey = mkPreludeMiscIdUnique 203
1466 newNameIdKey = mkPreludeMiscIdUnique 204
1467 mkNameIdKey = mkPreludeMiscIdUnique 205
1468 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
1469 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
1470 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
1471 mkNameUIdKey = mkPreludeMiscIdUnique 209
1475 charLIdKey = mkPreludeMiscIdUnique 210
1476 stringLIdKey = mkPreludeMiscIdUnique 211
1477 integerLIdKey = mkPreludeMiscIdUnique 212
1478 intPrimLIdKey = mkPreludeMiscIdUnique 213
1479 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1480 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1481 rationalLIdKey = mkPreludeMiscIdUnique 216
1484 litPIdKey = mkPreludeMiscIdUnique 220
1485 varPIdKey = mkPreludeMiscIdUnique 221
1486 tupPIdKey = mkPreludeMiscIdUnique 222
1487 conPIdKey = mkPreludeMiscIdUnique 223
1488 tildePIdKey = mkPreludeMiscIdUnique 224
1489 asPIdKey = mkPreludeMiscIdUnique 225
1490 wildPIdKey = mkPreludeMiscIdUnique 226
1491 recPIdKey = mkPreludeMiscIdUnique 227
1492 listPIdKey = mkPreludeMiscIdUnique 228
1494 -- type FieldPat = ...
1495 fieldPatIdKey = mkPreludeMiscIdUnique 230
1498 matchIdKey = mkPreludeMiscIdUnique 231
1500 -- data Clause = ...
1501 clauseIdKey = mkPreludeMiscIdUnique 232
1504 varEIdKey = mkPreludeMiscIdUnique 240
1505 conEIdKey = mkPreludeMiscIdUnique 241
1506 litEIdKey = mkPreludeMiscIdUnique 242
1507 appEIdKey = mkPreludeMiscIdUnique 243
1508 infixEIdKey = mkPreludeMiscIdUnique 244
1509 infixAppIdKey = mkPreludeMiscIdUnique 245
1510 sectionLIdKey = mkPreludeMiscIdUnique 246
1511 sectionRIdKey = mkPreludeMiscIdUnique 247
1512 lamEIdKey = mkPreludeMiscIdUnique 248
1513 tupEIdKey = mkPreludeMiscIdUnique 249
1514 condEIdKey = mkPreludeMiscIdUnique 250
1515 letEIdKey = mkPreludeMiscIdUnique 251
1516 caseEIdKey = mkPreludeMiscIdUnique 252
1517 doEIdKey = mkPreludeMiscIdUnique 253
1518 compEIdKey = mkPreludeMiscIdUnique 254
1519 fromEIdKey = mkPreludeMiscIdUnique 255
1520 fromThenEIdKey = mkPreludeMiscIdUnique 256
1521 fromToEIdKey = mkPreludeMiscIdUnique 257
1522 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1523 listEIdKey = mkPreludeMiscIdUnique 259
1524 sigEIdKey = mkPreludeMiscIdUnique 260
1525 recConEIdKey = mkPreludeMiscIdUnique 261
1526 recUpdEIdKey = mkPreludeMiscIdUnique 262
1528 -- type FieldExp = ...
1529 fieldExpIdKey = mkPreludeMiscIdUnique 265
1532 guardedBIdKey = mkPreludeMiscIdUnique 266
1533 normalBIdKey = mkPreludeMiscIdUnique 267
1536 bindSIdKey = mkPreludeMiscIdUnique 268
1537 letSIdKey = mkPreludeMiscIdUnique 269
1538 noBindSIdKey = mkPreludeMiscIdUnique 270
1539 parSIdKey = mkPreludeMiscIdUnique 271
1542 funDIdKey = mkPreludeMiscIdUnique 272
1543 valDIdKey = mkPreludeMiscIdUnique 273
1544 dataDIdKey = mkPreludeMiscIdUnique 274
1545 newtypeDIdKey = mkPreludeMiscIdUnique 275
1546 tySynDIdKey = mkPreludeMiscIdUnique 276
1547 classDIdKey = mkPreludeMiscIdUnique 277
1548 instanceDIdKey = mkPreludeMiscIdUnique 278
1549 sigDIdKey = mkPreludeMiscIdUnique 279
1552 cxtIdKey = mkPreludeMiscIdUnique 280
1554 -- data Strict = ...
1555 isStrictKey = mkPreludeMiscIdUnique 281
1556 notStrictKey = mkPreludeMiscIdUnique 282
1559 normalCIdKey = mkPreludeMiscIdUnique 283
1560 recCIdKey = mkPreludeMiscIdUnique 284
1561 infixCIdKey = mkPreludeMiscIdUnique 285
1563 -- type StrictType = ...
1564 strictTKey = mkPreludeMiscIdUnique 2286
1566 -- type VarStrictType = ...
1567 varStrictTKey = mkPreludeMiscIdUnique 287
1570 forallTIdKey = mkPreludeMiscIdUnique 290
1571 varTIdKey = mkPreludeMiscIdUnique 291
1572 conTIdKey = mkPreludeMiscIdUnique 292
1573 tupleTIdKey = mkPreludeMiscIdUnique 294
1574 arrowTIdKey = mkPreludeMiscIdUnique 295
1575 listTIdKey = mkPreludeMiscIdUnique 296
1576 appTIdKey = mkPreludeMiscIdUnique 293