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 let { 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 ; let ss = mkGenSyms (collectMonoBinders binds)
268 ; binds1 <- addBinds ss (rep_monobind binds)
269 ; decls1 <- coreList decQTyConName binds1
270 ; i <- repInst cxt1 inst_ty1
271 (wrapNonGenSyms ss decls1)
272 -- wrapNonGenSyms: do not clone the class op names!
273 -- They must be called 'op' etc, not 'op34'
276 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
279 -------------------------------------------------------
281 -------------------------------------------------------
283 repC :: ConDecl Name -> DsM (Core M.ConQ)
284 repC (ConDecl con [] [] details loc)
285 = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
286 repConstr con1 details }
288 repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ))
289 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
291 rep2 strictTypeName [s, t]
292 where strName = case str of
293 HsNoBang -> notStrictName
294 other -> isStrictName
296 -------------------------------------------------------
298 -------------------------------------------------------
300 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
301 repDerivs Nothing = return (coreList' stringTy [])
302 repDerivs (Just ctxt)
303 = do { strs <- mapM rep_deriv ctxt ;
304 return (coreList' stringTy strs) }
306 rep_deriv :: HsPred Name -> DsM (Core String)
307 -- Deriving clauses must have the simple H98 form
308 rep_deriv (HsClassP cls []) = lookupOcc cls
309 rep_deriv other = panic "rep_deriv"
312 -------------------------------------------------------
313 -- Signatures in a class decl, or a group of bindings
314 -------------------------------------------------------
316 rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
317 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
318 return $ de_loc $ sort_by_loc locs_cores
320 rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
321 -- We silently ignore ones we don't recognise
322 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
323 return (concat sigs1) }
325 rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
327 -- Empty => Too hard, signature ignored
328 rep_sig (Sig nm ty loc) = rep_proto nm ty loc
329 rep_sig other = return []
331 rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
332 rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
334 sig <- repProto nm1 ty1 ;
335 return [(loc, sig)] }
338 -------------------------------------------------------
340 -------------------------------------------------------
342 -- gensym a list of type variables and enter them into the meta environment;
343 -- the computations passed as the second argument is executed in that extended
344 -- meta environment and gets the *new* names on Core-level as an argument
346 addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
347 -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
348 -> DsM (Core (M.Q a))
349 addTyVarBinds tvs m =
351 let names = map hsTyVarName tvs
352 let freshNames = mkGenSyms names
353 term <- addBinds freshNames $ do
354 bndrs <- mapM lookupBinder names
356 wrapGenSyns freshNames term
358 -- represent a type context
360 repContext :: HsContext Name -> DsM (Core M.CxtQ)
362 preds <- mapM repPred ctxt
363 predList <- coreList typeQTyConName preds
366 -- represent a type predicate
368 repPred :: HsPred Name -> DsM (Core M.TypeQ)
369 repPred (HsClassP cls tys) = do
370 tcon <- repTy (HsTyVar cls)
373 repPred (HsIParam _ _) =
374 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
376 -- yield the representation of a list of types
378 repTys :: [HsType Name] -> DsM [Core M.TypeQ]
379 repTys tys = mapM repTy tys
383 repTy :: HsType Name -> DsM (Core M.TypeQ)
384 repTy (HsForAllTy _ bndrs ctxt ty) =
385 addTyVarBinds bndrs $ \bndrs' -> do
386 ctxt' <- repContext ctxt
388 repTForall (coreList' stringTy bndrs') ctxt' ty'
391 | isTvOcc (nameOccName n) = do
392 tv1 <- lookupBinder n
397 repTy (HsAppTy f a) = do
401 repTy (HsFunTy f a) = do
404 tcon <- repArrowTyCon
405 repTapps tcon [f1, a1]
406 repTy (HsListTy t) = do
410 repTy (HsPArrTy t) = do
412 tcon <- repTy (HsTyVar (tyConName parrTyCon))
414 repTy (HsTupleTy tc tys) = do
416 tcon <- repTupleTyCon (length tys)
418 repTy (HsOpTy ty1 n ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
420 repTy (HsParTy t) = repTy t
422 panic "DsMeta.repTy: Can't represent number types (for generics)"
423 repTy (HsPredTy pred) = repPred pred
424 repTy (HsKindSig ty kind) =
425 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
428 -----------------------------------------------------------------------------
430 -----------------------------------------------------------------------------
432 repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
433 repEs es = do { es' <- mapM repE es ;
434 coreList expQTyConName es' }
436 -- FIXME: some of these panics should be converted into proper error messages
437 -- unless we can make sure that constructs, which are plainly not
438 -- supported in TH already lead to error messages at an earlier stage
439 repE :: HsExpr Name -> DsM (Core M.ExpQ)
441 do { mb_val <- dsLookupMetaEnv x
443 Nothing -> do { str <- globalVar x
444 ; repVarOrCon x str }
445 Just (Bound y) -> repVarOrCon x (coreVar y)
446 Just (Splice e) -> do { e' <- dsExpr e
447 ; return (MkC e') } }
448 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
450 -- Remember, we're desugaring renamer output here, so
451 -- HsOverlit can definitely occur
452 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
453 repE (HsLit l) = do { a <- repLiteral l; repLit a }
454 repE (HsLam m) = repLambda m
455 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
457 repE (OpApp e1 op fix e2) =
458 do { arg1 <- repE e1;
461 repInfixApp arg1 the_op arg2 }
462 repE (NegApp x nm) = do
464 negateVar <- lookupOcc negateName >>= repVar
466 repE (HsPar x) = repE x
467 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
468 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
469 repE (HsCase e ms loc) = do { arg <- repE e
470 ; ms2 <- mapM repMatchTup ms
471 ; repCaseE arg (nonEmptyCoreList ms2) }
472 repE (HsIf x y z loc) = do
477 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
478 ; e2 <- addBinds ss (repE e)
481 -- FIXME: I haven't got the types here right yet
482 repE (HsDo DoExpr sts _ ty loc)
483 = do { (ss,zs) <- repSts sts;
484 e <- repDoE (nonEmptyCoreList zs);
486 repE (HsDo ListComp sts _ ty loc)
487 = do { (ss,zs) <- repSts sts;
488 e <- repComp (nonEmptyCoreList zs);
490 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
491 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
492 repE (ExplicitPArr ty es) =
493 panic "DsMeta.repE: No explicit parallel arrays yet"
494 repE (ExplicitTuple es boxed)
495 | isBoxed boxed = do { xs <- repEs es; repTup xs }
496 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
497 repE (RecordCon c flds)
498 = do { x <- lookupOcc c;
499 fs <- repFields flds;
501 repE (RecordUpd e flds)
503 fs <- repFields flds;
506 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
507 repE (ArithSeqIn aseq) =
509 From e -> do { ds1 <- repE e; repFrom ds1 }
518 FromThenTo e1 e2 e3 -> do
522 repFromThenTo ds1 ds2 ds3
523 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
524 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
525 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
526 repE (HsBracketOut _ _) =
527 panic "DsMeta.repE: Can't represent Oxford brackets"
528 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
530 Just (Splice e) -> do { e' <- dsExpr e
532 other -> pprPanic "HsSplice" (ppr n) }
533 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
535 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
537 -----------------------------------------------------------------------------
538 -- Building representations of auxillary structures like Match, Clause, Stmt,
540 repMatchTup :: Match Name -> DsM (Core M.MatchQ)
541 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
542 do { let ss1 = mkGenSyms (collectPatBinders p)
543 ; addBinds ss1 $ do {
545 ; (ss2,ds) <- repBinds wheres
546 ; addBinds ss2 $ do {
547 ; gs <- repGuards guards
548 ; match <- repMatch p1 gs ds
549 ; wrapGenSyns (ss1++ss2) match }}}
551 repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
552 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
553 do { let ss1 = mkGenSyms (collectPatsBinders ps)
554 ; addBinds ss1 $ do {
556 ; (ss2,ds) <- repBinds wheres
557 ; addBinds ss2 $ do {
558 gs <- repGuards guards
559 ; clause <- repClause ps1 gs ds
560 ; wrapGenSyns (ss1++ss2) clause }}}
562 repGuards :: [GRHS Name] -> DsM (Core M.BodyQ)
563 repGuards [GRHS [ResultStmt e loc] loc2]
564 = do {a <- repE e; repNormal a }
566 = do { zs <- mapM process other;
567 repGuarded (nonEmptyCoreList (map corePair zs)) }
569 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
570 = do { x <- repE e1; y <- repE e2; return (x, y) }
571 process other = panic "Non Haskell 98 guarded body"
573 repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
575 fnames <- mapM lookupOcc (map fst flds)
576 es <- mapM repE (map snd flds)
577 fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
578 coreList fieldExpTyConName fs
581 -----------------------------------------------------------------------------
582 -- Representing Stmt's is tricky, especially if bound variables
583 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
584 -- First gensym new names for every variable in any of the patterns.
585 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
586 -- if variables didn't shaddow, the static gensym wouldn't be necessary
587 -- and we could reuse the original names (x and x).
589 -- do { x'1 <- gensym "x"
590 -- ; x'2 <- gensym "x"
591 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
592 -- , BindSt (pvar x'2) [| f x |]
593 -- , NoBindSt [| g x |]
597 -- The strategy is to translate a whole list of do-bindings by building a
598 -- bigger environment, and a bigger set of meta bindings
599 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
600 -- of the expressions within the Do
602 -----------------------------------------------------------------------------
603 -- The helper function repSts computes the translation of each sub expression
604 -- and a bunch of prefix bindings denoting the dynamic renaming.
606 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
607 repSts [ResultStmt e loc] =
609 ; e1 <- repNoBindSt a
610 ; return ([], [e1]) }
611 repSts (BindStmt p e loc : ss) =
613 ; let ss1 = mkGenSyms (collectPatBinders p)
614 ; addBinds ss1 $ do {
616 ; (ss2,zs) <- repSts ss
617 ; z <- repBindSt p1 e2
618 ; return (ss1++ss2, z : zs) }}
619 repSts (LetStmt bs : ss) =
620 do { (ss1,ds) <- repBinds bs
622 ; (ss2,zs) <- addBinds ss1 (repSts ss)
623 ; return (ss1++ss2, z : zs) }
624 repSts (ExprStmt e ty loc : ss) =
626 ; z <- repNoBindSt e2
627 ; (ss2,zs) <- repSts ss
628 ; return (ss2, z : zs) }
629 repSts other = panic "Exotic Stmt in meta brackets"
632 -----------------------------------------------------------
634 -----------------------------------------------------------
636 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
638 = do { let { bndrs = collectHsBinders decs }
639 -- No need to worrry about detailed scopes within
640 -- the binding group, because we are talking Names
641 -- here, so we can safely treat it as a mutually
643 ; let ss = mkGenSyms bndrs
644 ; core <- addBinds ss (rep_binds decs)
645 ; core_list <- coreList decQTyConName core
646 ; return (ss, core_list) }
648 rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
649 -- Assumes: all the binders of the binding are alrady in the meta-env
650 rep_binds binds = do locs_cores <- rep_binds' binds
651 return $ de_loc $ sort_by_loc locs_cores
653 rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
654 -- Assumes: all the binders of the binding are alrady in the meta-env
655 rep_binds' EmptyBinds = return []
656 rep_binds' (ThenBinds x y)
657 = do { core1 <- rep_binds' x
658 ; core2 <- rep_binds' y
659 ; return (core1 ++ core2) }
660 rep_binds' (MonoBind bs sigs _)
661 = do { core1 <- rep_monobind' bs
662 ; core2 <- rep_sigs' sigs
663 ; return (core1 ++ core2) }
664 rep_binds' (IPBinds _)
665 = panic "DsMeta:repBinds: can't do implicit parameters"
667 rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
668 -- Assumes: all the binders of the binding are alrady in the meta-env
669 rep_monobind binds = do locs_cores <- rep_monobind' binds
670 return $ de_loc $ sort_by_loc locs_cores
672 rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
673 -- Assumes: all the binders of the binding are alrady in the meta-env
674 rep_monobind' EmptyMonoBinds = return []
675 rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
676 y1 <- rep_monobind' y;
679 -- Note GHC treats declarations of a variable (not a pattern)
680 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
681 -- with an empty list of patterns
682 rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
683 = do { (ss,wherecore) <- repBinds wheres
684 ; guardcore <- addBinds ss (repGuards guards)
685 ; fn' <- lookupBinder fn
687 ; ans <- repVal p guardcore wherecore
688 ; return [(loc, ans)] }
690 rep_monobind' (FunMonoBind fn infx ms loc)
691 = do { ms1 <- mapM repClauseTup ms
692 ; fn' <- lookupBinder fn
693 ; ans <- repFun fn' (nonEmptyCoreList ms1)
694 ; return [(loc, ans)] }
696 rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
697 = do { patcore <- repP pat
698 ; (ss,wherecore) <- repBinds wheres
699 ; guardcore <- addBinds ss (repGuards guards)
700 ; ans <- repVal patcore guardcore wherecore
701 ; return [(loc, ans)] }
703 rep_monobind' (VarMonoBind v e)
704 = do { v' <- lookupBinder v
707 ; patcore <- repPvar v'
708 ; empty_decls <- coreList decQTyConName []
709 ; ans <- repVal patcore x empty_decls
710 ; return [(getSrcLoc v, ans)] }
712 -----------------------------------------------------------------------------
713 -- Since everything in a MonoBind is mutually recursive we need rename all
714 -- all the variables simultaneously. For example:
715 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
716 -- do { f'1 <- gensym "f"
717 -- ; g'2 <- gensym "g"
718 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
719 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
721 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
722 -- environment ( f |-> f'1 ) from each binding, and then unioning them
723 -- together. As we do this we collect GenSymBinds's which represent the renamed
724 -- variables bound by the Bindings. In order not to lose track of these
725 -- representations we build a shadow datatype MB with the same structure as
726 -- MonoBinds, but which has slots for the representations
729 -----------------------------------------------------------------------------
730 -- GHC allows a more general form of lambda abstraction than specified
731 -- by Haskell 98. In particular it allows guarded lambda's like :
732 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
733 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
734 -- (\ p1 .. pn -> exp) by causing an error.
736 repLambda :: Match Name -> DsM (Core M.ExpQ)
737 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
739 = do { let bndrs = collectPatsBinders ps ;
740 ; let ss = mkGenSyms bndrs
741 ; lam <- addBinds ss (
742 do { xs <- repPs ps; body <- repE e; repLam xs body })
743 ; wrapGenSyns ss lam }
745 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
748 -----------------------------------------------------------------------------
750 -- repP deals with patterns. It assumes that we have already
751 -- walked over the pattern(s) once to collect the binders, and
752 -- have extended the environment. So every pattern-bound
753 -- variable should already appear in the environment.
755 -- Process a list of patterns
756 repPs :: [Pat Name] -> DsM (Core [M.Pat])
757 repPs ps = do { ps' <- mapM repP ps ;
758 coreList patTyConName ps' }
760 repP :: Pat Name -> DsM (Core M.Pat)
761 repP (WildPat _) = repPwild
762 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
763 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
764 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
765 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
766 repP (ParPat p) = repP p
767 repP (ListPat ps _) = do { qs <- repPs ps; repPlist qs }
768 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
769 repP (ConPatIn dc details)
770 = do { con_str <- lookupOcc dc
772 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
773 RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
774 ; ps <- sequence $ map repP (map snd pairs)
775 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
776 ; fps' <- coreList fieldPatTyConName fps
777 ; repPrec con_str fps' }
778 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
780 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
781 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
782 repP other = panic "Exotic pattern inside meta brackets"
784 ----------------------------------------------------------
785 -- Declaration ordering helpers
787 sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
788 sort_by_loc xs = sortBy comp xs
789 where comp x y = compare (fst x) (fst y)
791 de_loc :: [(SrcLoc, a)] -> [a]
794 ----------------------------------------------------------
795 -- The meta-environment
797 -- A name/identifier association for fresh names of locally bound entities
798 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
799 -- I.e. (x, x_id) means
800 -- let x_id = gensym "x" in ...
802 -- Generate a fresh name for a locally bound entity
804 mkGenSym :: Name -> GenSymBind
805 mkGenSym nm = (nm, mkLocalId nm stringTy)
807 -- Ditto for a list of names
809 mkGenSyms :: [Name] -> [GenSymBind]
810 mkGenSyms ns = map mkGenSym ns
812 addBinds :: [GenSymBind] -> DsM a -> DsM a
813 -- Add a list of fresh names for locally bound entities to the
814 -- meta environment (which is part of the state carried around
815 -- by the desugarer monad)
816 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
818 -- Look up a locally bound name
820 lookupBinder :: Name -> DsM (Core String)
822 = do { mb_val <- dsLookupMetaEnv n;
824 Just (Bound x) -> return (coreVar x)
825 other -> pprPanic "Failed binder lookup:" (ppr n) }
827 -- Look up a name that is either locally bound or a global name
829 -- * If it is a global name, generate the "original name" representation (ie,
830 -- the <module>:<name> form) for the associated entity
832 lookupOcc :: Name -> DsM (Core String)
833 -- Lookup an occurrence; it can't be a splice.
834 -- Use the in-scope bindings if they exist
836 = do { mb_val <- dsLookupMetaEnv n ;
838 Nothing -> globalVar n
839 Just (Bound x) -> return (coreVar x)
840 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
843 globalVar :: Name -> DsM (Core String)
844 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
846 name_mod = moduleUserString (nameModule n)
847 name_occ = occNameUserString (nameOccName n)
849 localVar :: Name -> DsM (Core String)
850 localVar n = coreStringLit (occNameUserString (nameOccName n))
852 lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
853 -> DsM Type -- The type
854 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
855 return (mkGenTyConApp tc []) }
857 wrapGenSyns :: [GenSymBind]
858 -> Core (M.Q a) -> DsM (Core (M.Q a))
859 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
860 -- --> bindQ (gensym nm1) (\ id1 ->
861 -- bindQ (gensym nm2 (\ id2 ->
864 wrapGenSyns binds body@(MkC b)
867 [elt_ty] = tcTyConAppArgs (exprType b)
868 -- b :: Q a, so we can get the type 'a' by looking at the
869 -- argument type. NB: this relies on Q being a data/newtype,
870 -- not a type synonym
873 go ((name,id) : binds)
874 = do { MkC body' <- go binds
875 ; lit_str <- localVar name
876 ; gensym_app <- repGensym lit_str
877 ; repBindQ stringTy elt_ty
878 gensym_app (MkC (Lam id body')) }
880 -- Just like wrapGenSym, but don't actually do the gensym
881 -- Instead use the existing name:
882 -- let x = "x" in ...
883 -- Only used for [Decl], and for the class ops in class
884 -- and instance decls
885 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
886 wrapNongenSyms binds (MkC body)
887 = do { binds' <- mapM do_one binds ;
888 return (MkC (mkLets binds' body)) }
891 = do { MkC lit_str <- localVar name -- No gensym
892 ; return (NonRec id lit_str) }
894 void = placeHolderType
896 string :: String -> HsExpr Id
897 string s = HsLit (HsString (mkFastString s))
900 -- %*********************************************************************
904 -- %*********************************************************************
906 -----------------------------------------------------------------------------
907 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
908 -- we invent a new datatype which uses phantom types.
910 newtype Core a = MkC CoreExpr
913 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
914 rep2 n xs = do { id <- dsLookupGlobalId n
915 ; return (MkC (foldl App (Var id) xs)) }
917 -- Then we make "repConstructors" which use the phantom types for each of the
918 -- smart constructors of the Meta.Meta datatypes.
921 -- %*********************************************************************
923 -- The 'smart constructors'
925 -- %*********************************************************************
927 --------------- Patterns -----------------
928 repPlit :: Core M.Lit -> DsM (Core M.Pat)
929 repPlit (MkC l) = rep2 litPName [l]
931 repPvar :: Core String -> DsM (Core M.Pat)
932 repPvar (MkC s) = rep2 varPName [s]
934 repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
935 repPtup (MkC ps) = rep2 tupPName [ps]
937 repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
938 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
940 repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
941 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
943 repPtilde :: Core M.Pat -> DsM (Core M.Pat)
944 repPtilde (MkC p) = rep2 tildePName [p]
946 repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
947 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
949 repPwild :: DsM (Core M.Pat)
950 repPwild = rep2 wildPName []
952 repPlist :: Core [M.Pat] -> DsM (Core M.Pat)
953 repPlist (MkC ps) = rep2 listPName [ps]
955 --------------- Expressions -----------------
956 repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
957 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
958 | otherwise = repVar str
960 repVar :: Core String -> DsM (Core M.ExpQ)
961 repVar (MkC s) = rep2 varEName [s]
963 repCon :: Core String -> DsM (Core M.ExpQ)
964 repCon (MkC s) = rep2 conEName [s]
966 repLit :: Core M.Lit -> DsM (Core M.ExpQ)
967 repLit (MkC c) = rep2 litEName [c]
969 repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
970 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
972 repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
973 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
975 repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
976 repTup (MkC es) = rep2 tupEName [es]
978 repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
979 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
981 repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
982 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
984 repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
985 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
987 repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
988 repDoE (MkC ss) = rep2 doEName [ss]
990 repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
991 repComp (MkC ss) = rep2 compEName [ss]
993 repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
994 repListExp (MkC es) = rep2 listEName [es]
996 repSigExp :: Core M.ExpQ -> Core M.TypeQ -> DsM (Core M.ExpQ)
997 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
999 repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
1000 repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs]
1002 repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
1003 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1005 repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1006 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1008 repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1009 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1011 repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1012 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1014 ------------ Right hand sides (guarded expressions) ----
1015 repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.BodyQ)
1016 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1018 repNormal :: Core M.ExpQ -> DsM (Core M.BodyQ)
1019 repNormal (MkC e) = rep2 normalBName [e]
1021 ------------- Stmts -------------------
1022 repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
1023 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1025 repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
1026 repLetSt (MkC ds) = rep2 letSName [ds]
1028 repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
1029 repNoBindSt (MkC e) = rep2 noBindSName [e]
1031 -------------- Range (Arithmetic sequences) -----------
1032 repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
1033 repFrom (MkC x) = rep2 fromEName [x]
1035 repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1036 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1038 repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1039 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1041 repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1042 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1044 ------------ Match and Clause Tuples -----------
1045 repMatch :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
1046 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1048 repClause :: Core [M.Pat] -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
1049 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1051 -------------- Dec -----------------------------
1052 repVal :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1053 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1055 repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
1056 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1058 repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
1059 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1060 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1062 repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
1063 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1064 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1066 repTySyn :: Core String -> Core [String] -> Core M.TypeQ -> DsM (Core M.DecQ)
1067 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1069 repInst :: Core M.CxtQ -> Core M.TypeQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1070 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1072 repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
1073 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1075 repProto :: Core String -> Core M.TypeQ -> DsM (Core M.DecQ)
1076 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1078 repCtxt :: Core [M.TypeQ] -> DsM (Core M.CxtQ)
1079 repCtxt (MkC tys) = rep2 cxtName [tys]
1081 repConstr :: Core String -> HsConDetails Name (BangType Name)
1082 -> DsM (Core M.ConQ)
1083 repConstr con (PrefixCon ps)
1084 = do arg_tys <- mapM repBangTy ps
1085 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1086 rep2 normalCName [unC con, unC arg_tys1]
1087 repConstr con (RecCon ips)
1088 = do arg_vs <- mapM lookupOcc (map fst ips)
1089 arg_tys <- mapM repBangTy (map snd ips)
1090 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1092 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1093 rep2 recCName [unC con, unC arg_vtys']
1094 repConstr con (InfixCon st1 st2)
1095 = do arg1 <- repBangTy st1
1096 arg2 <- repBangTy st2
1097 rep2 infixCName [unC arg1, unC con, unC arg2]
1099 ------------ Types -------------------
1101 repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
1102 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1103 = rep2 forallTName [tvars, ctxt, ty]
1105 repTvar :: Core String -> DsM (Core M.TypeQ)
1106 repTvar (MkC s) = rep2 varTName [s]
1108 repTapp :: Core M.TypeQ -> Core M.TypeQ -> DsM (Core M.TypeQ)
1109 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1111 repTapps :: Core M.TypeQ -> [Core M.TypeQ] -> DsM (Core M.TypeQ)
1112 repTapps f [] = return f
1113 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1115 --------- Type constructors --------------
1117 repNamedTyCon :: Core String -> DsM (Core M.TypeQ)
1118 repNamedTyCon (MkC s) = rep2 conTName [s]
1120 repTupleTyCon :: Int -> DsM (Core M.TypeQ)
1121 -- Note: not Core Int; it's easier to be direct here
1122 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1124 repArrowTyCon :: DsM (Core M.TypeQ)
1125 repArrowTyCon = rep2 arrowTName []
1127 repListTyCon :: DsM (Core M.TypeQ)
1128 repListTyCon = rep2 listTName []
1131 ----------------------------------------------------------
1134 repLiteral :: HsLit -> DsM (Core M.Lit)
1136 = do lit' <- case lit of
1137 HsIntPrim i -> mk_integer i
1138 HsInt i -> mk_integer i
1139 HsFloatPrim r -> mk_rational r
1140 HsDoublePrim r -> mk_rational r
1142 lit_expr <- dsLit lit'
1143 rep2 lit_name [lit_expr]
1145 lit_name = case lit of
1146 HsInteger _ _ -> integerLName
1147 HsInt _ -> integerLName
1148 HsIntPrim _ -> intPrimLName
1149 HsFloatPrim _ -> floatPrimLName
1150 HsDoublePrim _ -> doublePrimLName
1151 HsChar _ -> charLName
1152 HsString _ -> stringLName
1153 HsRat _ _ -> rationalLName
1155 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1158 mk_integer i = do integer_ty <- lookupType integerTyConName
1159 return $ HsInteger i integer_ty
1160 mk_rational r = do rat_ty <- lookupType rationalTyConName
1161 return $ HsRat r rat_ty
1163 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1164 repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
1165 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1166 -- The type Rational will be in the environment, becuase
1167 -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1168 -- and rationalL is sucked in when any TH stuff is used
1170 --------------- Miscellaneous -------------------
1172 repLift :: Core e -> DsM (Core M.ExpQ)
1173 repLift (MkC x) = rep2 liftName [x]
1175 repGensym :: Core String -> DsM (Core (M.Q String))
1176 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1178 repBindQ :: Type -> Type -- a and b
1179 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1180 repBindQ ty_a ty_b (MkC x) (MkC y)
1181 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1183 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1184 repSequenceQ ty_a (MkC list)
1185 = rep2 sequenceQName [Type ty_a, list]
1187 ------------ Lists and Tuples -------------------
1188 -- turn a list of patterns into a single pattern matching a list
1190 coreList :: Name -- Of the TyCon of the element type
1191 -> [Core a] -> DsM (Core [a])
1193 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1195 coreList' :: Type -- The element type
1196 -> [Core a] -> Core [a]
1197 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1199 nonEmptyCoreList :: [Core a] -> Core [a]
1200 -- The list must be non-empty so we can get the element type
1201 -- Otherwise use coreList
1202 nonEmptyCoreList [] = panic "coreList: empty argument"
1203 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1205 corePair :: (Core a, Core b) -> Core (a,b)
1206 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1208 coreStringLit :: String -> DsM (Core String)
1209 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1211 coreVar :: Id -> Core String -- The Id has type String
1212 coreVar id = MkC (Var id)
1216 -- %************************************************************************
1218 -- The known-key names for Template Haskell
1220 -- %************************************************************************
1222 -- To add a name, do three things
1224 -- 1) Allocate a key
1226 -- 3) Add the name to knownKeyNames
1228 templateHaskellNames :: [Name]
1229 -- The names that are implicitly mentioned by ``bracket''
1230 -- Should stay in sync with the import list of DsMeta
1232 templateHaskellNames = [
1233 returnQName, bindQName, sequenceQName, gensymName, liftName,
1235 charLName, stringLName, integerLName, intPrimLName,
1236 floatPrimLName, doublePrimLName, rationalLName,
1238 litPName, varPName, tupPName, conPName, tildePName,
1239 asPName, wildPName, recPName, listPName,
1247 varEName, conEName, litEName, appEName, infixEName,
1248 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1249 condEName, letEName, caseEName, doEName, compEName,
1250 fromEName, fromThenEName, fromToEName, fromThenToEName,
1251 listEName, sigEName, recConEName, recUpdEName,
1255 guardedBName, normalBName,
1257 bindSName, letSName, noBindSName, parSName,
1259 funDName, valDName, dataDName, newtypeDName, tySynDName,
1260 classDName, instanceDName, sigDName,
1264 isStrictName, notStrictName,
1266 normalCName, recCName, infixCName,
1272 forallTName, varTName, conTName, appTName,
1273 tupleTName, arrowTName, listTName,
1276 qTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1277 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1278 decQTyConName, conQTyConName, strictTypeQTyConName,
1279 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1280 typeTyConName, matchTyConName, clauseTyConName]
1282 varQual = mk_known_key_name OccName.varName
1283 tcQual = mk_known_key_name OccName.tcName
1286 -- NB: the THSyntax module comes from the "haskell-src" package
1287 thModule = mkModule thPackage mETA_META_Name
1289 mk_known_key_name space str uniq
1290 = mkExternalName uniq thModule (mkOccFS space str)
1293 returnQName = varQual FSLIT("returnQ") returnQIdKey
1294 bindQName = varQual FSLIT("bindQ") bindQIdKey
1295 sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
1296 gensymName = varQual FSLIT("gensym") gensymIdKey
1297 liftName = varQual FSLIT("lift") liftIdKey
1300 charLName = varQual FSLIT("charL") charLIdKey
1301 stringLName = varQual FSLIT("stringL") stringLIdKey
1302 integerLName = varQual FSLIT("integerL") integerLIdKey
1303 intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey
1304 floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey
1305 doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey
1306 rationalLName = varQual FSLIT("rationalL") rationalLIdKey
1309 litPName = varQual FSLIT("litP") litPIdKey
1310 varPName = varQual FSLIT("varP") varPIdKey
1311 tupPName = varQual FSLIT("tupP") tupPIdKey
1312 conPName = varQual FSLIT("conP") conPIdKey
1313 tildePName = varQual FSLIT("tildeP") tildePIdKey
1314 asPName = varQual FSLIT("asP") asPIdKey
1315 wildPName = varQual FSLIT("wildP") wildPIdKey
1316 recPName = varQual FSLIT("recP") recPIdKey
1317 listPName = varQual FSLIT("listP") listPIdKey
1319 -- type FieldPat = ...
1320 fieldPatName = varQual FSLIT("fieldPat") fieldPatIdKey
1323 matchName = varQual FSLIT("match") matchIdKey
1325 -- data Clause = ...
1326 clauseName = varQual FSLIT("clause") clauseIdKey
1329 varEName = varQual FSLIT("varE") varEIdKey
1330 conEName = varQual FSLIT("conE") conEIdKey
1331 litEName = varQual FSLIT("litE") litEIdKey
1332 appEName = varQual FSLIT("appE") appEIdKey
1333 infixEName = varQual FSLIT("infixE") infixEIdKey
1334 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1335 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1336 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1337 lamEName = varQual FSLIT("lamE") lamEIdKey
1338 tupEName = varQual FSLIT("tupE") tupEIdKey
1339 condEName = varQual FSLIT("condE") condEIdKey
1340 letEName = varQual FSLIT("letE") letEIdKey
1341 caseEName = varQual FSLIT("caseE") caseEIdKey
1342 doEName = varQual FSLIT("doE") doEIdKey
1343 compEName = varQual FSLIT("compE") compEIdKey
1344 -- ArithSeq skips a level
1345 fromEName = varQual FSLIT("fromE") fromEIdKey
1346 fromThenEName = varQual FSLIT("fromThenE") fromThenEIdKey
1347 fromToEName = varQual FSLIT("fromToE") fromToEIdKey
1348 fromThenToEName = varQual FSLIT("fromThenToE") fromThenToEIdKey
1350 listEName = varQual FSLIT("listE") listEIdKey
1351 sigEName = varQual FSLIT("sigE") sigEIdKey
1352 recConEName = varQual FSLIT("recConE") recConEIdKey
1353 recUpdEName = varQual FSLIT("recUpdE") recUpdEIdKey
1355 -- type FieldExp = ...
1356 fieldExpName = varQual FSLIT("fieldExp") fieldExpIdKey
1359 guardedBName = varQual FSLIT("guardedB") guardedBIdKey
1360 normalBName = varQual FSLIT("normalB") normalBIdKey
1363 bindSName = varQual FSLIT("bindS") bindSIdKey
1364 letSName = varQual FSLIT("letS") letSIdKey
1365 noBindSName = varQual FSLIT("noBindS") noBindSIdKey
1366 parSName = varQual FSLIT("parS") parSIdKey
1369 funDName = varQual FSLIT("funD") funDIdKey
1370 valDName = varQual FSLIT("valD") valDIdKey
1371 dataDName = varQual FSLIT("dataD") dataDIdKey
1372 newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey
1373 tySynDName = varQual FSLIT("tySynD") tySynDIdKey
1374 classDName = varQual FSLIT("classD") classDIdKey
1375 instanceDName = varQual FSLIT("instanceD") instanceDIdKey
1376 sigDName = varQual FSLIT("sigD") sigDIdKey
1379 cxtName = varQual FSLIT("cxt") cxtIdKey
1381 -- data Strict = ...
1382 isStrictName = varQual FSLIT("isStrict") isStrictKey
1383 notStrictName = varQual FSLIT("notStrict") notStrictKey
1386 normalCName = varQual FSLIT("normalC") normalCIdKey
1387 recCName = varQual FSLIT("recC") recCIdKey
1388 infixCName = varQual FSLIT("infixC") infixCIdKey
1390 -- type StrictType = ...
1391 strictTypeName = varQual FSLIT("strictType") strictTKey
1393 -- type VarStrictType = ...
1394 varStrictTypeName = varQual FSLIT("varStrictType") varStrictTKey
1397 forallTName = varQual FSLIT("forallT") forallTIdKey
1398 varTName = varQual FSLIT("varT") varTIdKey
1399 conTName = varQual FSLIT("conT") conTIdKey
1400 tupleTName = varQual FSLIT("tupleT") tupleTIdKey
1401 arrowTName = varQual FSLIT("arrowT") arrowTIdKey
1402 listTName = varQual FSLIT("listT") listTIdKey
1403 appTName = varQual FSLIT("appT") appTIdKey
1405 qTyConName = tcQual FSLIT("Q") qTyConKey
1406 patTyConName = tcQual FSLIT("Pat") patTyConKey
1407 fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey
1408 matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey
1409 clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey
1410 expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey
1411 fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey
1412 stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey
1413 decQTyConName = tcQual FSLIT("DecQ") decQTyConKey
1414 conQTyConName = tcQual FSLIT("ConQ") conQTyConKey
1415 strictTypeQTyConName = tcQual FSLIT("StrictTypeQ") strictTypeQTyConKey
1416 varStrictTypeQTyConName = tcQual FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1417 typeQTyConName = tcQual FSLIT("TypeQ") typeQTyConKey
1419 expTyConName = tcQual FSLIT("Exp") expTyConKey
1420 decTyConName = tcQual FSLIT("Dec") decTyConKey
1421 typeTyConName = tcQual FSLIT("Type") typeTyConKey
1422 matchTyConName = tcQual FSLIT("Match") matchTyConKey
1423 clauseTyConName = tcQual FSLIT("Clause") clauseTyConKey
1425 -- TyConUniques available: 100-119
1426 -- Check in PrelNames if you want to change this
1428 expTyConKey = mkPreludeTyConUnique 100
1429 matchTyConKey = mkPreludeTyConUnique 101
1430 clauseTyConKey = mkPreludeTyConUnique 102
1431 qTyConKey = mkPreludeTyConUnique 103
1432 expQTyConKey = mkPreludeTyConUnique 104
1433 decQTyConKey = mkPreludeTyConUnique 105
1434 patTyConKey = mkPreludeTyConUnique 106
1435 matchQTyConKey = mkPreludeTyConUnique 107
1436 clauseQTyConKey = mkPreludeTyConUnique 108
1437 stmtQTyConKey = mkPreludeTyConUnique 109
1438 conQTyConKey = mkPreludeTyConUnique 110
1439 typeQTyConKey = mkPreludeTyConUnique 111
1440 typeTyConKey = mkPreludeTyConUnique 112
1441 decTyConKey = mkPreludeTyConUnique 113
1442 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1443 strictTypeQTyConKey = mkPreludeTyConUnique 115
1444 fieldExpTyConKey = mkPreludeTyConUnique 116
1445 fieldPatTyConKey = mkPreludeTyConUnique 117
1447 -- IdUniques available: 200-299
1448 -- If you want to change this, make sure you check in PrelNames
1450 returnQIdKey = mkPreludeMiscIdUnique 200
1451 bindQIdKey = mkPreludeMiscIdUnique 201
1452 sequenceQIdKey = mkPreludeMiscIdUnique 202
1453 gensymIdKey = mkPreludeMiscIdUnique 203
1454 liftIdKey = mkPreludeMiscIdUnique 204
1457 charLIdKey = mkPreludeMiscIdUnique 210
1458 stringLIdKey = mkPreludeMiscIdUnique 211
1459 integerLIdKey = mkPreludeMiscIdUnique 212
1460 intPrimLIdKey = mkPreludeMiscIdUnique 213
1461 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1462 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1463 rationalLIdKey = mkPreludeMiscIdUnique 216
1466 litPIdKey = mkPreludeMiscIdUnique 220
1467 varPIdKey = mkPreludeMiscIdUnique 221
1468 tupPIdKey = mkPreludeMiscIdUnique 222
1469 conPIdKey = mkPreludeMiscIdUnique 223
1470 tildePIdKey = mkPreludeMiscIdUnique 224
1471 asPIdKey = mkPreludeMiscIdUnique 225
1472 wildPIdKey = mkPreludeMiscIdUnique 226
1473 recPIdKey = mkPreludeMiscIdUnique 227
1474 listPIdKey = mkPreludeMiscIdUnique 228
1476 -- type FieldPat = ...
1477 fieldPatIdKey = mkPreludeMiscIdUnique 230
1480 matchIdKey = mkPreludeMiscIdUnique 231
1482 -- data Clause = ...
1483 clauseIdKey = mkPreludeMiscIdUnique 232
1486 varEIdKey = mkPreludeMiscIdUnique 240
1487 conEIdKey = mkPreludeMiscIdUnique 241
1488 litEIdKey = mkPreludeMiscIdUnique 242
1489 appEIdKey = mkPreludeMiscIdUnique 243
1490 infixEIdKey = mkPreludeMiscIdUnique 244
1491 infixAppIdKey = mkPreludeMiscIdUnique 245
1492 sectionLIdKey = mkPreludeMiscIdUnique 246
1493 sectionRIdKey = mkPreludeMiscIdUnique 247
1494 lamEIdKey = mkPreludeMiscIdUnique 248
1495 tupEIdKey = mkPreludeMiscIdUnique 249
1496 condEIdKey = mkPreludeMiscIdUnique 250
1497 letEIdKey = mkPreludeMiscIdUnique 251
1498 caseEIdKey = mkPreludeMiscIdUnique 252
1499 doEIdKey = mkPreludeMiscIdUnique 253
1500 compEIdKey = mkPreludeMiscIdUnique 254
1501 fromEIdKey = mkPreludeMiscIdUnique 255
1502 fromThenEIdKey = mkPreludeMiscIdUnique 256
1503 fromToEIdKey = mkPreludeMiscIdUnique 257
1504 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1505 listEIdKey = mkPreludeMiscIdUnique 259
1506 sigEIdKey = mkPreludeMiscIdUnique 260
1507 recConEIdKey = mkPreludeMiscIdUnique 261
1508 recUpdEIdKey = mkPreludeMiscIdUnique 262
1510 -- type FieldExp = ...
1511 fieldExpIdKey = mkPreludeMiscIdUnique 265
1514 guardedBIdKey = mkPreludeMiscIdUnique 266
1515 normalBIdKey = mkPreludeMiscIdUnique 267
1518 bindSIdKey = mkPreludeMiscIdUnique 268
1519 letSIdKey = mkPreludeMiscIdUnique 269
1520 noBindSIdKey = mkPreludeMiscIdUnique 270
1521 parSIdKey = mkPreludeMiscIdUnique 271
1524 funDIdKey = mkPreludeMiscIdUnique 272
1525 valDIdKey = mkPreludeMiscIdUnique 273
1526 dataDIdKey = mkPreludeMiscIdUnique 274
1527 newtypeDIdKey = mkPreludeMiscIdUnique 275
1528 tySynDIdKey = mkPreludeMiscIdUnique 276
1529 classDIdKey = mkPreludeMiscIdUnique 277
1530 instanceDIdKey = mkPreludeMiscIdUnique 278
1531 sigDIdKey = mkPreludeMiscIdUnique 279
1534 cxtIdKey = mkPreludeMiscIdUnique 280
1536 -- data Strict = ...
1537 isStrictKey = mkPreludeMiscIdUnique 281
1538 notStrictKey = mkPreludeMiscIdUnique 282
1541 normalCIdKey = mkPreludeMiscIdUnique 283
1542 recCIdKey = mkPreludeMiscIdUnique 284
1543 infixCIdKey = mkPreludeMiscIdUnique 285
1545 -- type StrictType = ...
1546 strictTKey = mkPreludeMiscIdUnique 2286
1548 -- type VarStrictType = ...
1549 varStrictTKey = mkPreludeMiscIdUnique 287
1552 forallTIdKey = mkPreludeMiscIdUnique 290
1553 varTIdKey = mkPreludeMiscIdUnique 291
1554 conTIdKey = mkPreludeMiscIdUnique 292
1555 tupleTIdKey = mkPreludeMiscIdUnique 294
1556 arrowTIdKey = mkPreludeMiscIdUnique 295
1557 listTIdKey = mkPreludeMiscIdUnique 296
1558 appTIdKey = mkPreludeMiscIdUnique 293
1560 -- %************************************************************************
1564 -- %************************************************************************
1566 -- It is rather usatisfactory that we don't have a SrcLoc
1567 addDsWarn :: SDoc -> DsM ()
1568 addDsWarn msg = dsWarn (noSrcLoc, msg)