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, dsReify,
15 templateHaskellNames, qTyConName,
16 liftName, expQTyConName, decQTyConName, typeQTyConName,
17 decTyConName, typeTyConName ) where
19 #include "HsVersions.h"
21 import {-# SOURCE #-} DsExpr ( dsExpr )
23 import MatchLit ( dsLit )
24 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
27 import qualified Language.Haskell.THSyntax as M
29 import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
30 Match(..), GRHSs(..), GRHS(..), HsBracket(..),
31 HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
32 HsBinds(..), MonoBinds(..), HsConDetails(..),
33 TyClDecl(..), HsGroup(..), HsBang(..),
34 HsReify(..), ReifyFlavour(..),
35 HsType(..), HsContext(..), HsPred(..),
36 HsTyVarBndr(..), Sig(..), ForeignDecl(..),
37 InstDecl(..), ConDecl(..), BangType(..),
38 PendingSplice, splitHsInstDeclTy,
39 placeHolderType, tyClDeclNames,
40 collectHsBinders, collectPatBinders, collectPatsBinders,
41 hsTyVarName, hsConArgs
44 import PrelNames ( mETA_META_Name, rationalTyConName, integerTyConName, negateName )
45 import Name ( Name, nameOccName, nameModule, getSrcLoc )
46 import OccName ( isDataOcc, isTvOcc, occNameUserString )
47 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
48 -- we do this by removing varName from the import of OccName above, making
49 -- a qualified instance of OccName and using OccNameAlias.varName where varName
50 -- ws previously used in this file.
51 import qualified OccName( varName, tcName )
53 import Module ( Module, mkModule, moduleUserString )
54 import Id ( Id, idType )
55 import Name ( mkExternalName )
56 import OccName ( mkOccFS )
59 import Type ( Type, mkGenTyConApp )
60 import TcType ( tcTyConAppArgs )
61 import TyCon ( DataConDetails(..), tyConName )
62 import TysWiredIn ( stringTy, parrTyCon )
64 import CoreUtils ( exprType )
65 import SrcLoc ( noSrcLoc )
66 import Maybes ( orElse )
67 import Maybe ( catMaybes, fromMaybe )
68 import Panic ( panic )
69 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
70 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
71 import SrcLoc ( SrcLoc )
72 import Packages ( thPackage )
74 import FastString ( mkFastString )
76 import Monad ( zipWithM )
77 import List ( sortBy )
79 -----------------------------------------------------------------------------
80 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
81 -- Returns a CoreExpr of type M.ExpQ
82 -- The quoted thing is parameterised over Name, even though it has
83 -- been type checked. We don't want all those type decorations!
85 dsBracket brack splices
86 = dsExtendMetaEnv new_bit (do_brack brack)
88 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
90 do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
91 do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
92 do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
93 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
95 -----------------------------------------------------------------------------
96 dsReify :: HsReify Id -> DsM CoreExpr
97 dsReify r = panic "dsReify" -- To be re-done
99 -- Returns a CoreExpr of type reifyType --> M.TypeQ
100 -- reifyDecl --> M.DecQ
101 -- reifyFixty --> Q M.Fix
103 dsReify (ReifyOut ReifyType name)
104 = do { thing <- dsLookupGlobal name ;
105 -- By deferring the lookup until now (rather than doing it
106 -- in the type checker) we ensure that all zonking has
109 AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
111 other -> pprPanic "dsReify: reifyType" (ppr name)
114 dsReify r@(ReifyOut ReifyDecl name)
115 = do { thing <- dsLookupGlobal name ;
116 mb_d <- repTyClD (ifaceTyThing True{-omit pragmas-} thing) ;
118 Just (MkC d) -> return d
119 Nothing -> pprPanic "dsReify" (ppr r)
122 {- -------------- Examples --------------------
126 gensym (unpackString "x"#) `bindQ` \ x1::String ->
127 lam (pvar x1) (var x1)
130 [| \x -> $(f [| x |]) |]
132 gensym (unpackString "x"#) `bindQ` \ x1::String ->
133 lam (pvar x1) (f (var x1))
137 -------------------------------------------------------
139 -------------------------------------------------------
141 repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
143 = do { let { bndrs = groupBinders group } ;
144 ss <- mkGenSyms bndrs ;
146 -- Bind all the names mainly to avoid repeated use of explicit strings.
148 -- do { t :: String <- genSym "T" ;
149 -- return (Data t [] ...more t's... }
150 -- The other important reason is that the output must mention
151 -- only "T", not "Foo:T" where Foo is the current module
154 decls <- addBinds ss (do {
155 val_ds <- rep_binds' (hs_valds group) ;
156 tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
157 inst_ds <- mapM repInstD' (hs_instds group) ;
159 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
161 decl_ty <- lookupType decQTyConName ;
162 let { core_list = coreList' decl_ty decls } ;
164 dec_ty <- lookupType decTyConName ;
165 q_decs <- repSequenceQ dec_ty core_list ;
167 wrapNongenSyms ss q_decs
168 -- Do *not* gensym top-level binders
171 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
172 hs_fords = foreign_decls })
173 -- Collect the binders of a Group
174 = collectHsBinders val_decls ++
175 [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
176 [n | ForeignImport n _ _ _ _ <- foreign_decls]
179 {- Note [Binders and occurrences]
180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 When we desugar [d| data T = MkT |]
183 Data "T" [] [Con "MkT" []] []
185 Data "Foo:T" [] [Con "Foo:MkT" []] []
186 That is, the new data decl should fit into whatever new module it is
187 asked to fit in. We do *not* clone, though; no need for this:
194 then we must desugar to
195 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
197 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
198 but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
199 in repTyClD and repC.
203 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
204 repTyClD decl = do x <- repTyClD' decl
207 repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))
209 repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
210 tcdName = tc, tcdTyVars = tvs,
211 tcdCons = cons, tcdDerivs = mb_derivs,
213 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
214 dec <- addTyVarBinds tvs $ \bndrs -> do {
215 cxt1 <- repContext cxt ;
216 cons1 <- mapM repC cons ;
217 cons2 <- coreList conQTyConName cons1 ;
218 derivs1 <- repDerivs mb_derivs ;
219 repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
220 return $ Just (loc, dec) }
222 repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt,
223 tcdName = tc, tcdTyVars = tvs,
224 tcdCons = [con], tcdDerivs = mb_derivs,
226 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
227 dec <- addTyVarBinds tvs $ \bndrs -> do {
228 cxt1 <- repContext cxt ;
230 derivs1 <- repDerivs mb_derivs ;
231 repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
232 return $ Just (loc, dec) }
234 repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
236 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
237 dec <- addTyVarBinds tvs $ \bndrs -> do {
239 repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
240 return (Just (loc, dec)) }
242 repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
244 tcdFDs = [], -- We don't understand functional dependencies
245 tcdSigs = sigs, tcdMeths = meth_binds,
247 = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
248 dec <- addTyVarBinds tvs $ \bndrs -> do {
249 cxt1 <- repContext cxt ;
250 sigs1 <- rep_sigs sigs ;
251 binds1 <- rep_monobind meth_binds ;
252 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
253 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
254 return $ Just (loc, dec) }
257 repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
261 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
263 repInstD' (InstDecl ty binds _ loc)
264 -- Ignore user pragmas for now
265 = do { cxt1 <- repContext cxt ;
266 inst_ty1 <- repPred (HsClassP cls tys) ;
267 binds1 <- rep_monobind binds ;
268 decls1 <- coreList decQTyConName binds1 ;
269 i <- repInst cxt1 inst_ty1 decls1;
272 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
275 -------------------------------------------------------
277 -------------------------------------------------------
279 repC :: ConDecl Name -> DsM (Core M.ConQ)
280 repC (ConDecl con [] [] details loc)
281 = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
282 repConstr con1 details }
284 repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ))
285 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
287 rep2 strictTypeName [s, t]
288 where strName = case str of
289 HsNoBang -> notStrictName
290 other -> isStrictName
292 -------------------------------------------------------
294 -------------------------------------------------------
296 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
297 repDerivs Nothing = return (coreList' stringTy [])
298 repDerivs (Just ctxt)
299 = do { strs <- mapM rep_deriv ctxt ;
300 return (coreList' stringTy strs) }
302 rep_deriv :: HsPred Name -> DsM (Core String)
303 -- Deriving clauses must have the simple H98 form
304 rep_deriv (HsClassP cls []) = lookupOcc cls
305 rep_deriv other = panic "rep_deriv"
308 -------------------------------------------------------
309 -- Signatures in a class decl, or a group of bindings
310 -------------------------------------------------------
312 rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
313 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
314 return $ de_loc $ sort_by_loc locs_cores
316 rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
317 -- We silently ignore ones we don't recognise
318 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
319 return (concat sigs1) }
321 rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
323 -- Empty => Too hard, signature ignored
324 rep_sig (Sig nm ty loc) = rep_proto nm ty loc
325 rep_sig other = return []
327 rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
328 rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
330 sig <- repProto nm1 ty1 ;
331 return [(loc, sig)] }
334 -------------------------------------------------------
336 -------------------------------------------------------
338 -- gensym a list of type variables and enter them into the meta environment;
339 -- the computations passed as the second argument is executed in that extended
340 -- meta environment and gets the *new* names on Core-level as an argument
342 addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
343 -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
344 -> DsM (Core (M.Q a))
345 addTyVarBinds tvs m =
347 let names = map hsTyVarName tvs
348 freshNames <- mkGenSyms names
349 term <- addBinds freshNames $ do
350 bndrs <- mapM lookupBinder names
352 wrapGenSyns freshNames term
354 -- represent a type context
356 repContext :: HsContext Name -> DsM (Core M.CxtQ)
358 preds <- mapM repPred ctxt
359 predList <- coreList typeQTyConName preds
362 -- represent a type predicate
364 repPred :: HsPred Name -> DsM (Core M.TypeQ)
365 repPred (HsClassP cls tys) = do
366 tcon <- repTy (HsTyVar cls)
369 repPred (HsIParam _ _) =
370 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
372 -- yield the representation of a list of types
374 repTys :: [HsType Name] -> DsM [Core M.TypeQ]
375 repTys tys = mapM repTy tys
379 repTy :: HsType Name -> DsM (Core M.TypeQ)
380 repTy (HsForAllTy _ bndrs ctxt ty) =
381 addTyVarBinds bndrs $ \bndrs' -> do
382 ctxt' <- repContext ctxt
384 repTForall (coreList' stringTy bndrs') ctxt' ty'
387 | isTvOcc (nameOccName n) = do
388 tv1 <- lookupBinder n
393 repTy (HsAppTy f a) = do
397 repTy (HsFunTy f a) = do
400 tcon <- repArrowTyCon
401 repTapps tcon [f1, a1]
402 repTy (HsListTy t) = do
406 repTy (HsPArrTy t) = do
408 tcon <- repTy (HsTyVar (tyConName parrTyCon))
410 repTy (HsTupleTy tc tys) = do
412 tcon <- repTupleTyCon (length tys)
414 repTy (HsOpTy ty1 n ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
416 repTy (HsParTy t) = repTy t
418 panic "DsMeta.repTy: Can't represent number types (for generics)"
419 repTy (HsPredTy pred) = repPred pred
420 repTy (HsKindSig ty kind) =
421 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
424 -----------------------------------------------------------------------------
426 -----------------------------------------------------------------------------
428 repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
429 repEs es = do { es' <- mapM repE es ;
430 coreList expQTyConName es' }
432 -- FIXME: some of these panics should be converted into proper error messages
433 -- unless we can make sure that constructs, which are plainly not
434 -- supported in TH already lead to error messages at an earlier stage
435 repE :: HsExpr Name -> DsM (Core M.ExpQ)
437 do { mb_val <- dsLookupMetaEnv x
439 Nothing -> do { str <- globalVar x
440 ; repVarOrCon x str }
441 Just (Bound y) -> repVarOrCon x (coreVar y)
442 Just (Splice e) -> do { e' <- dsExpr e
443 ; return (MkC e') } }
444 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
446 -- Remember, we're desugaring renamer output here, so
447 -- HsOverlit can definitely occur
448 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
449 repE (HsLit l) = do { a <- repLiteral l; repLit a }
450 repE (HsLam m) = repLambda m
451 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
453 repE (OpApp e1 op fix e2) =
454 do { arg1 <- repE e1;
457 repInfixApp arg1 the_op arg2 }
458 repE (NegApp x nm) = do
460 negateVar <- lookupOcc negateName >>= repVar
462 repE (HsPar x) = repE x
463 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
464 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
465 repE (HsCase e ms loc) = do { arg <- repE e
466 ; ms2 <- mapM repMatchTup ms
467 ; repCaseE arg (nonEmptyCoreList ms2) }
468 repE (HsIf x y z loc) = do
473 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
474 ; e2 <- addBinds ss (repE e)
477 -- FIXME: I haven't got the types here right yet
478 repE (HsDo DoExpr sts _ ty loc)
479 = do { (ss,zs) <- repSts sts;
480 e <- repDoE (nonEmptyCoreList zs);
482 repE (HsDo ListComp sts _ ty loc)
483 = do { (ss,zs) <- repSts sts;
484 e <- repComp (nonEmptyCoreList zs);
486 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
487 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
488 repE (ExplicitPArr ty es) =
489 panic "DsMeta.repE: No explicit parallel arrays yet"
490 repE (ExplicitTuple es boxed)
491 | isBoxed boxed = do { xs <- repEs es; repTup xs }
492 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
493 repE (RecordCon c flds)
494 = do { x <- lookupOcc c;
495 fs <- repFields flds;
497 repE (RecordUpd e flds)
499 fs <- repFields flds;
502 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
503 repE (ArithSeqIn aseq) =
505 From e -> do { ds1 <- repE e; repFrom ds1 }
514 FromThenTo e1 e2 e3 -> do
518 repFromThenTo ds1 ds2 ds3
519 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
520 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
521 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
522 repE (HsBracketOut _ _) =
523 panic "DsMeta.repE: Can't represent Oxford brackets"
524 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
526 Just (Splice e) -> do { e' <- dsExpr e
528 other -> pprPanic "HsSplice" (ppr n) }
529 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
531 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
533 -----------------------------------------------------------------------------
534 -- Building representations of auxillary structures like Match, Clause, Stmt,
536 repMatchTup :: Match Name -> DsM (Core M.MatchQ)
537 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
538 do { ss1 <- mkGenSyms (collectPatBinders p)
539 ; addBinds ss1 $ do {
541 ; (ss2,ds) <- repBinds wheres
542 ; addBinds ss2 $ do {
543 ; gs <- repGuards guards
544 ; match <- repMatch p1 gs ds
545 ; wrapGenSyns (ss1++ss2) match }}}
547 repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
548 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
549 do { ss1 <- mkGenSyms (collectPatsBinders ps)
550 ; addBinds ss1 $ do {
552 ; (ss2,ds) <- repBinds wheres
553 ; addBinds ss2 $ do {
554 gs <- repGuards guards
555 ; clause <- repClause ps1 gs ds
556 ; wrapGenSyns (ss1++ss2) clause }}}
558 repGuards :: [GRHS Name] -> DsM (Core M.BodyQ)
559 repGuards [GRHS [ResultStmt e loc] loc2]
560 = do {a <- repE e; repNormal a }
562 = do { zs <- mapM process other;
563 repGuarded (nonEmptyCoreList (map corePair zs)) }
565 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
566 = do { x <- repE e1; y <- repE e2; return (x, y) }
567 process other = panic "Non Haskell 98 guarded body"
569 repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
571 fnames <- mapM lookupOcc (map fst flds)
572 es <- mapM repE (map snd flds)
573 fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
574 coreList fieldExpTyConName fs
577 -----------------------------------------------------------------------------
578 -- Representing Stmt's is tricky, especially if bound variables
579 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
580 -- First gensym new names for every variable in any of the patterns.
581 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
582 -- if variables didn't shaddow, the static gensym wouldn't be necessary
583 -- and we could reuse the original names (x and x).
585 -- do { x'1 <- gensym "x"
586 -- ; x'2 <- gensym "x"
587 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
588 -- , BindSt (pvar x'2) [| f x |]
589 -- , NoBindSt [| g x |]
593 -- The strategy is to translate a whole list of do-bindings by building a
594 -- bigger environment, and a bigger set of meta bindings
595 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
596 -- of the expressions within the Do
598 -----------------------------------------------------------------------------
599 -- The helper function repSts computes the translation of each sub expression
600 -- and a bunch of prefix bindings denoting the dynamic renaming.
602 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
603 repSts [ResultStmt e loc] =
605 ; e1 <- repNoBindSt a
606 ; return ([], [e1]) }
607 repSts (BindStmt p e loc : ss) =
609 ; ss1 <- mkGenSyms (collectPatBinders p)
610 ; addBinds ss1 $ do {
612 ; (ss2,zs) <- repSts ss
613 ; z <- repBindSt p1 e2
614 ; return (ss1++ss2, z : zs) }}
615 repSts (LetStmt bs : ss) =
616 do { (ss1,ds) <- repBinds bs
618 ; (ss2,zs) <- addBinds ss1 (repSts ss)
619 ; return (ss1++ss2, z : zs) }
620 repSts (ExprStmt e ty loc : ss) =
622 ; z <- repNoBindSt e2
623 ; (ss2,zs) <- repSts ss
624 ; return (ss2, z : zs) }
625 repSts other = panic "Exotic Stmt in meta brackets"
628 -----------------------------------------------------------
630 -----------------------------------------------------------
632 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
634 = do { let { bndrs = collectHsBinders decs } ;
635 ss <- mkGenSyms bndrs ;
636 core <- addBinds ss (rep_binds decs) ;
637 core_list <- coreList decQTyConName core ;
638 return (ss, core_list) }
640 rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
641 rep_binds binds = do locs_cores <- rep_binds' binds
642 return $ de_loc $ sort_by_loc locs_cores
644 rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
645 rep_binds' EmptyBinds = return []
646 rep_binds' (ThenBinds x y)
647 = do { core1 <- rep_binds' x
648 ; core2 <- rep_binds' y
649 ; return (core1 ++ core2) }
650 rep_binds' (MonoBind bs sigs _)
651 = do { core1 <- rep_monobind' bs
652 ; core2 <- rep_sigs' sigs
653 ; return (core1 ++ core2) }
654 rep_binds' (IPBinds _)
655 = panic "DsMeta:repBinds: can't do implicit parameters"
657 rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
658 rep_monobind binds = do locs_cores <- rep_monobind' binds
659 return $ de_loc $ sort_by_loc locs_cores
661 rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
662 rep_monobind' EmptyMonoBinds = return []
663 rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
664 y1 <- rep_monobind' y;
667 -- Note GHC treats declarations of a variable (not a pattern)
668 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
669 -- with an empty list of patterns
670 rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
671 = do { (ss,wherecore) <- repBinds wheres
672 ; guardcore <- addBinds ss (repGuards guards)
673 ; fn' <- lookupBinder fn
675 ; ans <- repVal p guardcore wherecore
676 ; return [(loc, ans)] }
678 rep_monobind' (FunMonoBind fn infx ms loc)
679 = do { ms1 <- mapM repClauseTup ms
680 ; fn' <- lookupBinder fn
681 ; ans <- repFun fn' (nonEmptyCoreList ms1)
682 ; return [(loc, ans)] }
684 rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
685 = do { patcore <- repP pat
686 ; (ss,wherecore) <- repBinds wheres
687 ; guardcore <- addBinds ss (repGuards guards)
688 ; ans <- repVal patcore guardcore wherecore
689 ; return [(loc, ans)] }
691 rep_monobind' (VarMonoBind v e)
692 = do { v' <- lookupBinder v
695 ; patcore <- repPvar v'
696 ; empty_decls <- coreList decQTyConName []
697 ; ans <- repVal patcore x empty_decls
698 ; return [(getSrcLoc v, ans)] }
700 -----------------------------------------------------------------------------
701 -- Since everything in a MonoBind is mutually recursive we need rename all
702 -- all the variables simultaneously. For example:
703 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
704 -- do { f'1 <- gensym "f"
705 -- ; g'2 <- gensym "g"
706 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
707 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
709 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
710 -- environment ( f |-> f'1 ) from each binding, and then unioning them
711 -- together. As we do this we collect GenSymBinds's which represent the renamed
712 -- variables bound by the Bindings. In order not to lose track of these
713 -- representations we build a shadow datatype MB with the same structure as
714 -- MonoBinds, but which has slots for the representations
717 -----------------------------------------------------------------------------
718 -- GHC allows a more general form of lambda abstraction than specified
719 -- by Haskell 98. In particular it allows guarded lambda's like :
720 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
721 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
722 -- (\ p1 .. pn -> exp) by causing an error.
724 repLambda :: Match Name -> DsM (Core M.ExpQ)
725 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
727 = do { let bndrs = collectPatsBinders ps ;
728 ; ss <- mkGenSyms bndrs
729 ; lam <- addBinds ss (
730 do { xs <- repPs ps; body <- repE e; repLam xs body })
731 ; wrapGenSyns ss lam }
733 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
736 -----------------------------------------------------------------------------
738 -- repP deals with patterns. It assumes that we have already
739 -- walked over the pattern(s) once to collect the binders, and
740 -- have extended the environment. So every pattern-bound
741 -- variable should already appear in the environment.
743 -- Process a list of patterns
744 repPs :: [Pat Name] -> DsM (Core [M.Pat])
745 repPs ps = do { ps' <- mapM repP ps ;
746 coreList patTyConName ps' }
748 repP :: Pat Name -> DsM (Core M.Pat)
749 repP (WildPat _) = repPwild
750 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
751 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
752 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
753 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
754 repP (ParPat p) = repP p
755 repP (ListPat ps _) = do { qs <- repPs ps; repPlist qs }
756 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
757 repP (ConPatIn dc details)
758 = do { con_str <- lookupOcc dc
760 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
761 RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
762 ; ps <- sequence $ map repP (map snd pairs)
763 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
764 ; fps' <- coreList fieldPatTyConName fps
765 ; repPrec con_str fps' }
766 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
768 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
769 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
770 repP other = panic "Exotic pattern inside meta brackets"
772 ----------------------------------------------------------
773 -- Declaration ordering helpers
775 sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
776 sort_by_loc xs = sortBy comp xs
777 where comp x y = compare (fst x) (fst y)
779 de_loc :: [(SrcLoc, a)] -> [a]
782 ----------------------------------------------------------
783 -- The meta-environment
785 -- A name/identifier association for fresh names of locally bound entities
787 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
788 -- I.e. (x, x_id) means
789 -- let x_id = gensym "x" in ...
791 -- Generate a fresh name for a locally bound entity
793 mkGenSym :: Name -> DsM GenSymBind
794 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
796 -- Ditto for a list of names
798 mkGenSyms :: [Name] -> DsM [GenSymBind]
799 mkGenSyms ns = mapM mkGenSym ns
801 -- Add a list of fresh names for locally bound entities to the meta
802 -- environment (which is part of the state carried around by the desugarer
805 addBinds :: [GenSymBind] -> DsM a -> DsM a
806 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
808 -- Look up a locally bound name
810 lookupBinder :: Name -> DsM (Core String)
812 = do { mb_val <- dsLookupMetaEnv n;
814 Just (Bound x) -> return (coreVar x)
815 other -> pprPanic "Failed binder lookup:" (ppr n) }
817 -- Look up a name that is either locally bound or a global name
819 -- * If it is a global name, generate the "original name" representation (ie,
820 -- the <module>:<name> form) for the associated entity
822 lookupOcc :: Name -> DsM (Core String)
823 -- Lookup an occurrence; it can't be a splice.
824 -- Use the in-scope bindings if they exist
826 = do { mb_val <- dsLookupMetaEnv n ;
828 Nothing -> globalVar n
829 Just (Bound x) -> return (coreVar x)
830 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
833 globalVar :: Name -> DsM (Core String)
834 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
836 name_mod = moduleUserString (nameModule n)
837 name_occ = occNameUserString (nameOccName n)
839 localVar :: Name -> DsM (Core String)
840 localVar n = coreStringLit (occNameUserString (nameOccName n))
842 lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
843 -> DsM Type -- The type
844 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
845 return (mkGenTyConApp tc []) }
847 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
848 -- --> bindQ (gensym nm1) (\ id1 ->
849 -- bindQ (gensym nm2 (\ id2 ->
852 wrapGenSyns :: [GenSymBind]
853 -> Core (M.Q a) -> DsM (Core (M.Q a))
854 wrapGenSyns binds body@(MkC b)
857 [elt_ty] = tcTyConAppArgs (exprType b)
858 -- b :: Q a, so we can get the type 'a' by looking at the
859 -- argument type. NB: this relies on Q being a data/newtype,
860 -- not a type synonym
863 go ((name,id) : binds)
864 = do { MkC body' <- go binds
865 ; lit_str <- localVar name
866 ; gensym_app <- repGensym lit_str
867 ; repBindQ stringTy elt_ty
868 gensym_app (MkC (Lam id body')) }
870 -- Just like wrapGenSym, but don't actually do the gensym
871 -- Instead use the existing name
872 -- Only used for [Decl]
873 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
874 wrapNongenSyms binds (MkC body)
875 = do { binds' <- mapM do_one binds ;
876 return (MkC (mkLets binds' body)) }
879 = do { MkC lit_str <- localVar name -- No gensym
880 ; return (NonRec id lit_str) }
882 void = placeHolderType
884 string :: String -> HsExpr Id
885 string s = HsLit (HsString (mkFastString s))
888 -- %*********************************************************************
892 -- %*********************************************************************
894 -----------------------------------------------------------------------------
895 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
896 -- we invent a new datatype which uses phantom types.
898 newtype Core a = MkC CoreExpr
901 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
902 rep2 n xs = do { id <- dsLookupGlobalId n
903 ; return (MkC (foldl App (Var id) xs)) }
905 -- Then we make "repConstructors" which use the phantom types for each of the
906 -- smart constructors of the Meta.Meta datatypes.
909 -- %*********************************************************************
911 -- The 'smart constructors'
913 -- %*********************************************************************
915 --------------- Patterns -----------------
916 repPlit :: Core M.Lit -> DsM (Core M.Pat)
917 repPlit (MkC l) = rep2 litPName [l]
919 repPvar :: Core String -> DsM (Core M.Pat)
920 repPvar (MkC s) = rep2 varPName [s]
922 repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
923 repPtup (MkC ps) = rep2 tupPName [ps]
925 repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
926 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
928 repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
929 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
931 repPtilde :: Core M.Pat -> DsM (Core M.Pat)
932 repPtilde (MkC p) = rep2 tildePName [p]
934 repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
935 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
937 repPwild :: DsM (Core M.Pat)
938 repPwild = rep2 wildPName []
940 repPlist :: Core [M.Pat] -> DsM (Core M.Pat)
941 repPlist (MkC ps) = rep2 listPName [ps]
943 --------------- Expressions -----------------
944 repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
945 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
946 | otherwise = repVar str
948 repVar :: Core String -> DsM (Core M.ExpQ)
949 repVar (MkC s) = rep2 varEName [s]
951 repCon :: Core String -> DsM (Core M.ExpQ)
952 repCon (MkC s) = rep2 conEName [s]
954 repLit :: Core M.Lit -> DsM (Core M.ExpQ)
955 repLit (MkC c) = rep2 litEName [c]
957 repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
958 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
960 repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
961 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
963 repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
964 repTup (MkC es) = rep2 tupEName [es]
966 repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
967 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
969 repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
970 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
972 repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
973 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
975 repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
976 repDoE (MkC ss) = rep2 doEName [ss]
978 repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
979 repComp (MkC ss) = rep2 compEName [ss]
981 repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
982 repListExp (MkC es) = rep2 listEName [es]
984 repSigExp :: Core M.ExpQ -> Core M.TypeQ -> DsM (Core M.ExpQ)
985 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
987 repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
988 repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
990 repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
991 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
993 repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
994 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
996 repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
997 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
999 repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1000 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1002 ------------ Right hand sides (guarded expressions) ----
1003 repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.BodyQ)
1004 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1006 repNormal :: Core M.ExpQ -> DsM (Core M.BodyQ)
1007 repNormal (MkC e) = rep2 normalBName [e]
1009 ------------- Stmts -------------------
1010 repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
1011 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1013 repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
1014 repLetSt (MkC ds) = rep2 letSName [ds]
1016 repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
1017 repNoBindSt (MkC e) = rep2 noBindSName [e]
1019 -------------- Range (Arithmetic sequences) -----------
1020 repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
1021 repFrom (MkC x) = rep2 fromEName [x]
1023 repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1024 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1026 repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1027 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1029 repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1030 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1032 ------------ Match and Clause Tuples -----------
1033 repMatch :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
1034 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1036 repClause :: Core [M.Pat] -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
1037 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1039 -------------- Dec -----------------------------
1040 repVal :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1041 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1043 repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
1044 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1046 repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
1047 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1048 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1050 repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
1051 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1052 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1054 repTySyn :: Core String -> Core [String] -> Core M.TypeQ -> DsM (Core M.DecQ)
1055 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1057 repInst :: Core M.CxtQ -> Core M.TypeQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1058 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1060 repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
1061 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1063 repProto :: Core String -> Core M.TypeQ -> DsM (Core M.DecQ)
1064 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1066 repCtxt :: Core [M.TypeQ] -> DsM (Core M.CxtQ)
1067 repCtxt (MkC tys) = rep2 cxtName [tys]
1069 repConstr :: Core String -> HsConDetails Name (BangType Name)
1070 -> DsM (Core M.ConQ)
1071 repConstr con (PrefixCon ps)
1072 = do arg_tys <- mapM repBangTy ps
1073 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1074 rep2 normalCName [unC con, unC arg_tys1]
1075 repConstr con (RecCon ips)
1076 = do arg_vs <- mapM lookupOcc (map fst ips)
1077 arg_tys <- mapM repBangTy (map snd ips)
1078 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1080 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1081 rep2 recCName [unC con, unC arg_vtys']
1082 repConstr con (InfixCon st1 st2)
1083 = do arg1 <- repBangTy st1
1084 arg2 <- repBangTy st2
1085 rep2 infixCName [unC arg1, unC con, unC arg2]
1087 ------------ Types -------------------
1089 repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
1090 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1091 = rep2 forallTName [tvars, ctxt, ty]
1093 repTvar :: Core String -> DsM (Core M.TypeQ)
1094 repTvar (MkC s) = rep2 varTName [s]
1096 repTapp :: Core M.TypeQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
1097 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1099 repTapps :: Core M.TypeQ -> [Core M.TypeQ] -> DsM (Core M.TypeQ)
1100 repTapps f [] = return f
1101 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1103 --------- Type constructors --------------
1105 repNamedTyCon :: Core String -> DsM (Core M.TypeQ)
1106 repNamedTyCon (MkC s) = rep2 conTName [s]
1108 repTupleTyCon :: Int -> DsM (Core M.TypeQ)
1109 -- Note: not Core Int; it's easier to be direct here
1110 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1112 repArrowTyCon :: DsM (Core M.TypeQ)
1113 repArrowTyCon = rep2 arrowTName []
1115 repListTyCon :: DsM (Core M.TypeQ)
1116 repListTyCon = rep2 listTName []
1119 ----------------------------------------------------------
1122 repLiteral :: HsLit -> DsM (Core M.Lit)
1124 = do lit' <- case lit of
1125 HsIntPrim i -> mk_integer i
1126 HsInt i -> mk_integer i
1127 HsFloatPrim r -> mk_rational r
1128 HsDoublePrim r -> mk_rational r
1130 lit_expr <- dsLit lit'
1131 rep2 lit_name [lit_expr]
1133 lit_name = case lit of
1134 HsInteger _ _ -> integerLName
1135 HsInt _ -> integerLName
1136 HsIntPrim _ -> intPrimLName
1137 HsFloatPrim _ -> floatPrimLName
1138 HsDoublePrim _ -> doublePrimLName
1139 HsChar _ -> charLName
1140 HsString _ -> stringLName
1141 HsRat _ _ -> rationalLName
1143 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1146 mk_integer i = do integer_ty <- lookupType integerTyConName
1147 return $ HsInteger i integer_ty
1148 mk_rational r = do rat_ty <- lookupType rationalTyConName
1149 return $ HsRat r rat_ty
1151 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1152 repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
1153 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1154 -- The type Rational will be in the environment, becuase
1155 -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1156 -- and rationalL is sucked in when any TH stuff is used
1158 --------------- Miscellaneous -------------------
1160 repLift :: Core e -> DsM (Core M.ExpQ)
1161 repLift (MkC x) = rep2 liftName [x]
1163 repGensym :: Core String -> DsM (Core (M.Q String))
1164 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1166 repBindQ :: Type -> Type -- a and b
1167 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1168 repBindQ ty_a ty_b (MkC x) (MkC y)
1169 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1171 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1172 repSequenceQ ty_a (MkC list)
1173 = rep2 sequenceQName [Type ty_a, list]
1175 ------------ Lists and Tuples -------------------
1176 -- turn a list of patterns into a single pattern matching a list
1178 coreList :: Name -- Of the TyCon of the element type
1179 -> [Core a] -> DsM (Core [a])
1181 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1183 coreList' :: Type -- The element type
1184 -> [Core a] -> Core [a]
1185 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1187 nonEmptyCoreList :: [Core a] -> Core [a]
1188 -- The list must be non-empty so we can get the element type
1189 -- Otherwise use coreList
1190 nonEmptyCoreList [] = panic "coreList: empty argument"
1191 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1193 corePair :: (Core a, Core b) -> Core (a,b)
1194 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1196 coreStringLit :: String -> DsM (Core String)
1197 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1199 coreVar :: Id -> Core String -- The Id has type String
1200 coreVar id = MkC (Var id)
1204 -- %************************************************************************
1206 -- The known-key names for Template Haskell
1208 -- %************************************************************************
1210 -- To add a name, do three things
1212 -- 1) Allocate a key
1214 -- 3) Add the name to knownKeyNames
1216 templateHaskellNames :: [Name]
1217 -- The names that are implicitly mentioned by ``bracket''
1218 -- Should stay in sync with the import list of DsMeta
1220 templateHaskellNames = [
1221 returnQName, bindQName, sequenceQName, gensymName, liftName,
1223 charLName, stringLName, integerLName, intPrimLName,
1224 floatPrimLName, doublePrimLName, rationalLName,
1226 litPName, varPName, tupPName, conPName, tildePName,
1227 asPName, wildPName, recPName, listPName,
1235 varEName, conEName, litEName, appEName, infixEName,
1236 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1237 condEName, letEName, caseEName, doEName, compEName,
1238 fromEName, fromThenEName, fromToEName, fromThenToEName,
1239 listEName, sigEName, recConEName, recUpdEName,
1243 guardedBName, normalBName,
1245 bindSName, letSName, noBindSName, parSName,
1247 funDName, valDName, dataDName, newtypeDName, tySynDName,
1248 classDName, instanceDName, sigDName,
1252 isStrictName, notStrictName,
1254 normalCName, recCName, infixCName,
1260 forallTName, varTName, conTName, appTName,
1261 tupleTName, arrowTName, listTName,
1264 qTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1265 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1266 decQTyConName, conQTyConName, strictTypeQTyConName,
1267 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1268 typeTyConName, matchTyConName, clauseTyConName]
1270 varQual = mk_known_key_name OccName.varName
1271 tcQual = mk_known_key_name OccName.tcName
1274 -- NB: the THSyntax module comes from the "haskell-src" package
1275 thModule = mkModule thPackage mETA_META_Name
1277 mk_known_key_name space str uniq
1278 = mkExternalName uniq thModule (mkOccFS space str)
1281 returnQName = varQual FSLIT("returnQ") returnQIdKey
1282 bindQName = varQual FSLIT("bindQ") bindQIdKey
1283 sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
1284 gensymName = varQual FSLIT("gensym") gensymIdKey
1285 liftName = varQual FSLIT("lift") liftIdKey
1288 charLName = varQual FSLIT("charL") charLIdKey
1289 stringLName = varQual FSLIT("stringL") stringLIdKey
1290 integerLName = varQual FSLIT("integerL") integerLIdKey
1291 intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey
1292 floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey
1293 doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey
1294 rationalLName = varQual FSLIT("rationalL") rationalLIdKey
1297 litPName = varQual FSLIT("litP") litPIdKey
1298 varPName = varQual FSLIT("varP") varPIdKey
1299 tupPName = varQual FSLIT("tupP") tupPIdKey
1300 conPName = varQual FSLIT("conP") conPIdKey
1301 tildePName = varQual FSLIT("tildeP") tildePIdKey
1302 asPName = varQual FSLIT("asP") asPIdKey
1303 wildPName = varQual FSLIT("wildP") wildPIdKey
1304 recPName = varQual FSLIT("recP") recPIdKey
1305 listPName = varQual FSLIT("listP") listPIdKey
1307 -- type FieldPat = ...
1308 fieldPatName = varQual FSLIT("fieldPat") fieldPatIdKey
1311 matchName = varQual FSLIT("match") matchIdKey
1313 -- data Clause = ...
1314 clauseName = varQual FSLIT("clause") clauseIdKey
1317 varEName = varQual FSLIT("varE") varEIdKey
1318 conEName = varQual FSLIT("conE") conEIdKey
1319 litEName = varQual FSLIT("litE") litEIdKey
1320 appEName = varQual FSLIT("appE") appEIdKey
1321 infixEName = varQual FSLIT("infixE") infixEIdKey
1322 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1323 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1324 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1325 lamEName = varQual FSLIT("lamE") lamEIdKey
1326 tupEName = varQual FSLIT("tupE") tupEIdKey
1327 condEName = varQual FSLIT("condE") condEIdKey
1328 letEName = varQual FSLIT("letE") letEIdKey
1329 caseEName = varQual FSLIT("caseE") caseEIdKey
1330 doEName = varQual FSLIT("doE") doEIdKey
1331 compEName = varQual FSLIT("compE") compEIdKey
1332 -- ArithSeq skips a level
1333 fromEName = varQual FSLIT("fromE") fromEIdKey
1334 fromThenEName = varQual FSLIT("fromThenE") fromThenEIdKey
1335 fromToEName = varQual FSLIT("fromToE") fromToEIdKey
1336 fromThenToEName = varQual FSLIT("fromThenToE") fromThenToEIdKey
1338 listEName = varQual FSLIT("listE") listEIdKey
1339 sigEName = varQual FSLIT("sigE") sigEIdKey
1340 recConEName = varQual FSLIT("recConE") recConEIdKey
1341 recUpdEName = varQual FSLIT("recUpdE") recUpdEIdKey
1343 -- type FieldExp = ...
1344 fieldExpName = varQual FSLIT("fieldExp") fieldExpIdKey
1347 guardedBName = varQual FSLIT("guardedB") guardedBIdKey
1348 normalBName = varQual FSLIT("normalB") normalBIdKey
1351 bindSName = varQual FSLIT("bindS") bindSIdKey
1352 letSName = varQual FSLIT("letS") letSIdKey
1353 noBindSName = varQual FSLIT("noBindS") noBindSIdKey
1354 parSName = varQual FSLIT("parS") parSIdKey
1357 funDName = varQual FSLIT("funD") funDIdKey
1358 valDName = varQual FSLIT("valD") valDIdKey
1359 dataDName = varQual FSLIT("dataD") dataDIdKey
1360 newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey
1361 tySynDName = varQual FSLIT("tySynD") tySynDIdKey
1362 classDName = varQual FSLIT("classD") classDIdKey
1363 instanceDName = varQual FSLIT("instanceD") instanceDIdKey
1364 sigDName = varQual FSLIT("sigD") sigDIdKey
1367 cxtName = varQual FSLIT("cxt") cxtIdKey
1369 -- data Strict = ...
1370 isStrictName = varQual FSLIT("isStrict") isStrictKey
1371 notStrictName = varQual FSLIT("notStrict") notStrictKey
1374 normalCName = varQual FSLIT("normalC") normalCIdKey
1375 recCName = varQual FSLIT("recC") recCIdKey
1376 infixCName = varQual FSLIT("infixC") infixCIdKey
1378 -- type StrictType = ...
1379 strictTypeName = varQual FSLIT("strictType") strictTKey
1381 -- type VarStrictType = ...
1382 varStrictTypeName = varQual FSLIT("varStrictType") varStrictTKey
1385 forallTName = varQual FSLIT("forallT") forallTIdKey
1386 varTName = varQual FSLIT("varT") varTIdKey
1387 conTName = varQual FSLIT("conT") conTIdKey
1388 tupleTName = varQual FSLIT("tupleT") tupleTIdKey
1389 arrowTName = varQual FSLIT("arrowT") arrowTIdKey
1390 listTName = varQual FSLIT("listT") listTIdKey
1391 appTName = varQual FSLIT("appT") appTIdKey
1393 qTyConName = tcQual FSLIT("Q") qTyConKey
1394 patTyConName = tcQual FSLIT("Pat") patTyConKey
1395 fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey
1396 matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey
1397 clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey
1398 expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey
1399 fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey
1400 stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey
1401 decQTyConName = tcQual FSLIT("DecQ") decQTyConKey
1402 conQTyConName = tcQual FSLIT("ConQ") conQTyConKey
1403 strictTypeQTyConName = tcQual FSLIT("StrictTypeQ") strictTypeQTyConKey
1404 varStrictTypeQTyConName = tcQual FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1405 typeQTyConName = tcQual FSLIT("TypeQ") typeQTyConKey
1407 expTyConName = tcQual FSLIT("Exp") expTyConKey
1408 decTyConName = tcQual FSLIT("Dec") decTyConKey
1409 typeTyConName = tcQual FSLIT("Type") typeTyConKey
1410 matchTyConName = tcQual FSLIT("Match") matchTyConKey
1411 clauseTyConName = tcQual FSLIT("Clause") clauseTyConKey
1413 -- TyConUniques available: 100-119
1414 -- Check in PrelNames if you want to change this
1416 expTyConKey = mkPreludeTyConUnique 100
1417 matchTyConKey = mkPreludeTyConUnique 101
1418 clauseTyConKey = mkPreludeTyConUnique 102
1419 qTyConKey = mkPreludeTyConUnique 103
1420 expQTyConKey = mkPreludeTyConUnique 104
1421 decQTyConKey = mkPreludeTyConUnique 105
1422 patTyConKey = mkPreludeTyConUnique 106
1423 matchQTyConKey = mkPreludeTyConUnique 107
1424 clauseQTyConKey = mkPreludeTyConUnique 108
1425 stmtQTyConKey = mkPreludeTyConUnique 109
1426 conQTyConKey = mkPreludeTyConUnique 110
1427 typeQTyConKey = mkPreludeTyConUnique 111
1428 typeTyConKey = mkPreludeTyConUnique 112
1429 decTyConKey = mkPreludeTyConUnique 113
1430 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1431 strictTypeQTyConKey = mkPreludeTyConUnique 115
1432 fieldExpTyConKey = mkPreludeTyConUnique 116
1433 fieldPatTyConKey = mkPreludeTyConUnique 117
1435 -- IdUniques available: 200-299
1436 -- If you want to change this, make sure you check in PrelNames
1438 returnQIdKey = mkPreludeMiscIdUnique 200
1439 bindQIdKey = mkPreludeMiscIdUnique 201
1440 sequenceQIdKey = mkPreludeMiscIdUnique 202
1441 gensymIdKey = mkPreludeMiscIdUnique 203
1442 liftIdKey = mkPreludeMiscIdUnique 204
1445 charLIdKey = mkPreludeMiscIdUnique 210
1446 stringLIdKey = mkPreludeMiscIdUnique 211
1447 integerLIdKey = mkPreludeMiscIdUnique 212
1448 intPrimLIdKey = mkPreludeMiscIdUnique 213
1449 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1450 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1451 rationalLIdKey = mkPreludeMiscIdUnique 216
1454 litPIdKey = mkPreludeMiscIdUnique 220
1455 varPIdKey = mkPreludeMiscIdUnique 221
1456 tupPIdKey = mkPreludeMiscIdUnique 222
1457 conPIdKey = mkPreludeMiscIdUnique 223
1458 tildePIdKey = mkPreludeMiscIdUnique 224
1459 asPIdKey = mkPreludeMiscIdUnique 225
1460 wildPIdKey = mkPreludeMiscIdUnique 226
1461 recPIdKey = mkPreludeMiscIdUnique 227
1462 listPIdKey = mkPreludeMiscIdUnique 228
1464 -- type FieldPat = ...
1465 fieldPatIdKey = mkPreludeMiscIdUnique 230
1468 matchIdKey = mkPreludeMiscIdUnique 231
1470 -- data Clause = ...
1471 clauseIdKey = mkPreludeMiscIdUnique 232
1474 varEIdKey = mkPreludeMiscIdUnique 240
1475 conEIdKey = mkPreludeMiscIdUnique 241
1476 litEIdKey = mkPreludeMiscIdUnique 242
1477 appEIdKey = mkPreludeMiscIdUnique 243
1478 infixEIdKey = mkPreludeMiscIdUnique 244
1479 infixAppIdKey = mkPreludeMiscIdUnique 245
1480 sectionLIdKey = mkPreludeMiscIdUnique 246
1481 sectionRIdKey = mkPreludeMiscIdUnique 247
1482 lamEIdKey = mkPreludeMiscIdUnique 248
1483 tupEIdKey = mkPreludeMiscIdUnique 249
1484 condEIdKey = mkPreludeMiscIdUnique 250
1485 letEIdKey = mkPreludeMiscIdUnique 251
1486 caseEIdKey = mkPreludeMiscIdUnique 252
1487 doEIdKey = mkPreludeMiscIdUnique 253
1488 compEIdKey = mkPreludeMiscIdUnique 254
1489 fromEIdKey = mkPreludeMiscIdUnique 255
1490 fromThenEIdKey = mkPreludeMiscIdUnique 256
1491 fromToEIdKey = mkPreludeMiscIdUnique 257
1492 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1493 listEIdKey = mkPreludeMiscIdUnique 259
1494 sigEIdKey = mkPreludeMiscIdUnique 260
1495 recConEIdKey = mkPreludeMiscIdUnique 261
1496 recUpdEIdKey = mkPreludeMiscIdUnique 262
1498 -- type FieldExp = ...
1499 fieldExpIdKey = mkPreludeMiscIdUnique 265
1502 guardedBIdKey = mkPreludeMiscIdUnique 266
1503 normalBIdKey = mkPreludeMiscIdUnique 267
1506 bindSIdKey = mkPreludeMiscIdUnique 268
1507 letSIdKey = mkPreludeMiscIdUnique 269
1508 noBindSIdKey = mkPreludeMiscIdUnique 270
1509 parSIdKey = mkPreludeMiscIdUnique 271
1512 funDIdKey = mkPreludeMiscIdUnique 272
1513 valDIdKey = mkPreludeMiscIdUnique 273
1514 dataDIdKey = mkPreludeMiscIdUnique 274
1515 newtypeDIdKey = mkPreludeMiscIdUnique 275
1516 tySynDIdKey = mkPreludeMiscIdUnique 276
1517 classDIdKey = mkPreludeMiscIdUnique 277
1518 instanceDIdKey = mkPreludeMiscIdUnique 278
1519 sigDIdKey = mkPreludeMiscIdUnique 279
1522 cxtIdKey = mkPreludeMiscIdUnique 280
1524 -- data Strict = ...
1525 isStrictKey = mkPreludeMiscIdUnique 281
1526 notStrictKey = mkPreludeMiscIdUnique 282
1529 normalCIdKey = mkPreludeMiscIdUnique 283
1530 recCIdKey = mkPreludeMiscIdUnique 284
1531 infixCIdKey = mkPreludeMiscIdUnique 285
1533 -- type StrictType = ...
1534 strictTKey = mkPreludeMiscIdUnique 2286
1536 -- type VarStrictType = ...
1537 varStrictTKey = mkPreludeMiscIdUnique 287
1540 forallTIdKey = mkPreludeMiscIdUnique 290
1541 varTIdKey = mkPreludeMiscIdUnique 291
1542 conTIdKey = mkPreludeMiscIdUnique 292
1543 tupleTIdKey = mkPreludeMiscIdUnique 294
1544 arrowTIdKey = mkPreludeMiscIdUnique 295
1545 listTIdKey = mkPreludeMiscIdUnique 296
1546 appTIdKey = mkPreludeMiscIdUnique 293
1548 -- %************************************************************************
1552 -- %************************************************************************
1554 -- It is rather usatisfactory that we don't have a SrcLoc
1555 addDsWarn :: SDoc -> DsM ()
1556 addDsWarn msg = dsWarn (noSrcLoc, msg)