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, exprTyConName, declTyConName, typeTyConName,
17 decTyConName, typTyConName ) 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(..),
34 HsReify(..), ReifyFlavour(..),
35 HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
36 HsTyVarBndr(..), Sig(..), ForeignDecl(..),
37 InstDecl(..), ConDecl(..), BangType(..),
38 PendingSplice, splitHsInstDeclTy,
39 placeHolderType, tyClDeclNames,
40 collectHsBinders, collectPatBinders, collectPatsBinders,
41 hsTyVarName, hsConArgs, getBangType,
45 import PrelNames ( mETA_META_Name, rationalTyConName, negateName,
47 import MkIface ( ifaceTyThing )
48 import Name ( Name, nameOccName, nameModule )
49 import OccName ( isDataOcc, isTvOcc, occNameUserString )
50 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
51 -- we do this by removing varName from the import of OccName above, making
52 -- a qualified instance of OccName and using OccNameAlias.varName where varName
53 -- ws previously used in this file.
54 import qualified OccName( varName, tcName )
56 import Module ( Module, mkThPkgModule, moduleUserString )
57 import Id ( Id, idType )
58 import Name ( mkKnownKeyExternalName )
59 import OccName ( mkOccFS )
62 import Type ( Type, mkGenTyConApp )
63 import TcType ( TyThing(..), tcTyConAppArgs )
64 import TyCon ( DataConDetails(..) )
65 import TysWiredIn ( stringTy )
67 import CoreUtils ( exprType )
68 import SrcLoc ( noSrcLoc )
69 import Maybes ( orElse )
70 import Maybe ( catMaybes, fromMaybe )
71 import Panic ( panic )
72 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
73 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
76 import FastString ( mkFastString )
78 import Monad ( zipWithM )
80 -----------------------------------------------------------------------------
81 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
82 -- Returns a CoreExpr of type M.Expr
83 -- The quoted thing is parameterised over Name, even though it has
84 -- been type checked. We don't want all those type decorations!
86 dsBracket brack splices
87 = dsExtendMetaEnv new_bit (do_brack brack)
89 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
91 do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
92 do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
93 do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
94 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
96 -----------------------------------------------------------------------------
97 dsReify :: HsReify Id -> DsM CoreExpr
98 -- Returns a CoreExpr of type reifyType --> M.Type
99 -- reifyDecl --> M.Decl
100 -- reifyFixty --> Q M.Fix
101 dsReify (ReifyOut ReifyType name)
102 = do { thing <- dsLookupGlobal name ;
103 -- By deferring the lookup until now (rather than doing it
104 -- in the type checker) we ensure that all zonking has
107 AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
109 other -> pprPanic "dsReify: reifyType" (ppr name)
112 dsReify r@(ReifyOut ReifyDecl name)
113 = do { thing <- dsLookupGlobal name ;
114 mb_d <- repTyClD (ifaceTyThing thing) ;
116 Just (MkC d) -> return d
117 Nothing -> pprPanic "dsReify" (ppr r)
120 {- -------------- Examples --------------------
124 gensym (unpackString "x"#) `bindQ` \ x1::String ->
125 lam (pvar x1) (var x1)
128 [| \x -> $(f [| x |]) |]
130 gensym (unpackString "x"#) `bindQ` \ x1::String ->
131 lam (pvar x1) (f (var x1))
135 -------------------------------------------------------
137 -------------------------------------------------------
139 repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
141 = do { let { bndrs = groupBinders group } ;
142 ss <- mkGenSyms bndrs ;
144 -- Bind all the names mainly to avoid repeated use of explicit strings.
146 -- do { t :: String <- genSym "T" ;
147 -- return (Data t [] ...more t's... }
148 -- The other important reason is that the output must mention
149 -- only "T", not "Foo:T" where Foo is the current module
152 decls <- addBinds ss (do {
153 val_ds <- rep_binds (hs_valds group) ;
154 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
155 inst_ds <- mapM repInstD (hs_instds group) ;
157 return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
159 decl_ty <- lookupType declTyConName ;
160 let { core_list = coreList' decl_ty decls } ;
162 dec_ty <- lookupType decTyConName ;
163 q_decs <- repSequenceQ dec_ty core_list ;
165 wrapNongenSyms ss q_decs
166 -- Do *not* gensym top-level binders
169 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
170 hs_fords = foreign_decls })
171 -- Collect the binders of a Group
172 = collectHsBinders val_decls ++
173 [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
174 [n | ForeignImport n _ _ _ _ <- foreign_decls]
177 {- Note [Binders and occurrences]
178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
179 When we desugar [d| data T = MkT |]
181 Data "T" [] [Con "MkT" []] []
183 Data "Foo:T" [] [Con "Foo:MkT" []] []
184 That is, the new data decl should fit into whatever new module it is
185 asked to fit in. We do *not* clone, though; no need for this:
192 then we must desugar to
193 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
195 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
196 but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
197 in repTyClD and repC.
201 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
203 repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt,
204 tcdName = tc, tcdTyVars = tvs,
205 tcdCons = DataCons cons, tcdDerivs = mb_derivs })
206 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
207 dec <- addTyVarBinds tvs $ \bndrs -> do {
208 cxt1 <- repContext cxt ;
209 cons1 <- mapM repC cons ;
210 cons2 <- coreList consTyConName cons1 ;
211 derivs1 <- repDerivs mb_derivs ;
212 repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
215 repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
216 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
217 dec <- addTyVarBinds tvs $ \bndrs -> do {
219 repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
222 repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
224 tcdFDs = [], -- We don't understand functional dependencies
225 tcdSigs = sigs, tcdMeths = mb_meth_binds })
226 = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
227 dec <- addTyVarBinds tvs $ \bndrs -> do {
228 cxt1 <- repContext cxt ;
229 sigs1 <- rep_sigs sigs ;
230 binds1 <- rep_monobind meth_binds ;
231 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
232 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
235 -- If the user quotes a class decl, it'll have default-method
236 -- bindings; but if we (reifyDecl C) where C is a class, we
237 -- won't be given the default methods (a definite infelicity).
238 meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
241 repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
245 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
247 repInstD (InstDecl ty binds _ _ loc)
248 -- Ignore user pragmas for now
249 = do { cxt1 <- repContext cxt ;
250 inst_ty1 <- repPred (HsClassP cls tys) ;
251 binds1 <- rep_monobind binds ;
252 decls1 <- coreList declTyConName binds1 ;
253 repInst cxt1 inst_ty1 decls1 }
255 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
258 -------------------------------------------------------
260 -------------------------------------------------------
262 repC :: ConDecl Name -> DsM (Core M.Cons)
263 repC (ConDecl con [] [] details loc)
264 = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
265 repConstr con1 details }
267 repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ)))
268 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
270 rep2 strictTypeName [s, t]
271 where strName = case str of
272 NotMarkedStrict -> nonstrictName
275 -------------------------------------------------------
277 -------------------------------------------------------
279 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
280 repDerivs Nothing = return (coreList' stringTy [])
281 repDerivs (Just ctxt)
282 = do { strs <- mapM rep_deriv ctxt ;
283 return (coreList' stringTy strs) }
285 rep_deriv :: HsPred Name -> DsM (Core String)
286 -- Deriving clauses must have the simple H98 form
287 rep_deriv (HsClassP cls []) = lookupOcc cls
288 rep_deriv other = panic "rep_deriv"
291 -------------------------------------------------------
292 -- Signatures in a class decl, or a group of bindings
293 -------------------------------------------------------
295 rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
296 -- We silently ignore ones we don't recognise
297 rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
298 return (concat sigs1) }
300 rep_sig :: Sig Name -> DsM [Core M.Decl]
302 -- Empty => Too hard, signature ignored
303 rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
304 rep_sig (Sig nm ty _) = rep_proto nm ty
305 rep_sig other = return []
307 rep_proto nm ty = do { nm1 <- lookupOcc nm ;
309 sig <- repProto nm1 ty1 ;
313 -------------------------------------------------------
315 -------------------------------------------------------
317 -- gensym a list of type variables and enter them into the meta environment;
318 -- the computations passed as the second argument is executed in that extended
319 -- meta environment and gets the *new* names on Core-level as an argument
321 addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
322 -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
323 -> DsM (Core (M.Q a))
324 addTyVarBinds tvs m =
326 let names = map hsTyVarName tvs
327 freshNames <- mkGenSyms names
328 term <- addBinds freshNames $ do
329 bndrs <- mapM lookupBinder names
331 wrapGenSyns freshNames term
333 -- represent a type context
335 repContext :: HsContext Name -> DsM (Core M.Ctxt)
337 preds <- mapM repPred ctxt
338 predList <- coreList typeTyConName preds
341 -- represent a type predicate
343 repPred :: HsPred Name -> DsM (Core M.Type)
344 repPred (HsClassP cls tys) = do
345 tcon <- repTy (HsTyVar cls)
348 repPred (HsIParam _ _) =
349 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
351 -- yield the representation of a list of types
353 repTys :: [HsType Name] -> DsM [Core M.Type]
354 repTys tys = mapM repTy tys
358 repTy :: HsType Name -> DsM (Core M.Type)
359 repTy (HsForAllTy bndrs ctxt ty) =
360 addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
361 ctxt' <- repContext ctxt
363 repTForall (coreList' stringTy bndrs') ctxt' ty'
366 | isTvOcc (nameOccName n) = do
367 tv1 <- lookupBinder n
372 repTy (HsAppTy f a) = do
376 repTy (HsFunTy f a) = do
379 tcon <- repArrowTyCon
380 repTapps tcon [f1, a1]
381 repTy (HsListTy t) = do
385 repTy (HsPArrTy t) = do
387 tcon <- repTy (HsTyVar parrTyConName)
389 repTy (HsTupleTy tc tys) = do
391 tcon <- repTupleTyCon (length tys)
393 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
394 repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
396 repTy (HsParTy t) = repTy t
398 panic "DsMeta.repTy: Can't represent number types (for generics)"
399 repTy (HsPredTy pred) = repPred pred
400 repTy (HsKindSig ty kind) =
401 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
404 -----------------------------------------------------------------------------
406 -----------------------------------------------------------------------------
408 repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
409 repEs es = do { es' <- mapM repE es ;
410 coreList exprTyConName es' }
412 -- FIXME: some of these panics should be converted into proper error messages
413 -- unless we can make sure that constructs, which are plainly not
414 -- supported in TH already lead to error messages at an earlier stage
415 repE :: HsExpr Name -> DsM (Core M.Expr)
417 do { mb_val <- dsLookupMetaEnv x
419 Nothing -> do { str <- globalVar x
420 ; repVarOrCon x str }
421 Just (Bound y) -> repVarOrCon x (coreVar y)
422 Just (Splice e) -> do { e' <- dsExpr e
423 ; return (MkC e') } }
424 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
426 -- Remember, we're desugaring renamer output here, so
427 -- HsOverlit can definitely occur
428 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
429 repE (HsLit l) = do { a <- repLiteral l; repLit a }
430 repE (HsLam m) = repLambda m
431 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
433 repE (OpApp e1 op fix e2) =
434 do { arg1 <- repE e1;
437 repInfixApp arg1 the_op arg2 }
438 repE (NegApp x nm) = do
440 negateVar <- lookupOcc negateName >>= repVar
442 repE (HsPar x) = repE x
443 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
444 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
445 repE (HsCase e ms loc) = do { arg <- repE e
446 ; ms2 <- mapM repMatchTup ms
447 ; repCaseE arg (nonEmptyCoreList ms2) }
448 repE (HsIf x y z loc) = do
453 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
454 ; e2 <- addBinds ss (repE e)
457 -- FIXME: I haven't got the types here right yet
458 repE (HsDo DoExpr sts _ ty loc)
459 = do { (ss,zs) <- repSts sts;
460 e <- repDoE (nonEmptyCoreList zs);
462 repE (HsDo ListComp sts _ ty loc)
463 = do { (ss,zs) <- repSts sts;
464 e <- repComp (nonEmptyCoreList zs);
466 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
467 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
468 repE (ExplicitPArr ty es) =
469 panic "DsMeta.repE: No explicit parallel arrays yet"
470 repE (ExplicitTuple es boxed)
471 | isBoxed boxed = do { xs <- repEs es; repTup xs }
472 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
473 repE (RecordCon c flds)
474 = do { x <- lookupOcc c;
475 fs <- repFields flds;
477 repE (RecordUpd e flds)
479 fs <- repFields flds;
482 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
483 repE (ArithSeqIn aseq) =
485 From e -> do { ds1 <- repE e; repFrom ds1 }
494 FromThenTo e1 e2 e3 -> do
498 repFromThenTo ds1 ds2 ds3
499 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
500 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
501 repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
502 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
503 repE (HsBracketOut _ _) =
504 panic "DsMeta.repE: Can't represent Oxford brackets"
505 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
507 Just (Splice e) -> do { e' <- dsExpr e
509 other -> pprPanic "HsSplice" (ppr n) }
510 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
512 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
514 -----------------------------------------------------------------------------
515 -- Building representations of auxillary structures like Match, Clause, Stmt,
517 repMatchTup :: Match Name -> DsM (Core M.Mtch)
518 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
519 do { ss1 <- mkGenSyms (collectPatBinders p)
520 ; addBinds ss1 $ do {
522 ; (ss2,ds) <- repBinds wheres
523 ; addBinds ss2 $ do {
524 ; gs <- repGuards guards
525 ; match <- repMatch p1 gs ds
526 ; wrapGenSyns (ss1++ss2) match }}}
528 repClauseTup :: Match Name -> DsM (Core M.Clse)
529 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
530 do { ss1 <- mkGenSyms (collectPatsBinders ps)
531 ; addBinds ss1 $ do {
533 ; (ss2,ds) <- repBinds wheres
534 ; addBinds ss2 $ do {
535 gs <- repGuards guards
536 ; clause <- repClause ps1 gs ds
537 ; wrapGenSyns (ss1++ss2) clause }}}
539 repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
540 repGuards [GRHS [ResultStmt e loc] loc2]
541 = do {a <- repE e; repNormal a }
543 = do { zs <- mapM process other;
544 repGuarded (nonEmptyCoreList (map corePair zs)) }
546 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
547 = do { x <- repE e1; y <- repE e2; return (x, y) }
548 process other = panic "Non Haskell 98 guarded body"
550 repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FldE])
552 fnames <- mapM lookupOcc (map fst flds)
553 es <- mapM repE (map snd flds)
554 fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
555 coreList fieldTyConName fs
558 -----------------------------------------------------------------------------
559 -- Representing Stmt's is tricky, especially if bound variables
560 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
561 -- First gensym new names for every variable in any of the patterns.
562 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
563 -- if variables didn't shaddow, the static gensym wouldn't be necessary
564 -- and we could reuse the original names (x and x).
566 -- do { x'1 <- gensym "x"
567 -- ; x'2 <- gensym "x"
568 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
569 -- , BindSt (pvar x'2) [| f x |]
570 -- , NoBindSt [| g x |]
574 -- The strategy is to translate a whole list of do-bindings by building a
575 -- bigger environment, and a bigger set of meta bindings
576 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
577 -- of the expressions within the Do
579 -----------------------------------------------------------------------------
580 -- The helper function repSts computes the translation of each sub expression
581 -- and a bunch of prefix bindings denoting the dynamic renaming.
583 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
584 repSts [ResultStmt e loc] =
586 ; e1 <- repNoBindSt a
587 ; return ([], [e1]) }
588 repSts (BindStmt p e loc : ss) =
590 ; ss1 <- mkGenSyms (collectPatBinders p)
591 ; addBinds ss1 $ do {
593 ; (ss2,zs) <- repSts ss
594 ; z <- repBindSt p1 e2
595 ; return (ss1++ss2, z : zs) }}
596 repSts (LetStmt bs : ss) =
597 do { (ss1,ds) <- repBinds bs
599 ; (ss2,zs) <- addBinds ss1 (repSts ss)
600 ; return (ss1++ss2, z : zs) }
601 repSts (ExprStmt e ty loc : ss) =
603 ; z <- repNoBindSt e2
604 ; (ss2,zs) <- repSts ss
605 ; return (ss2, z : zs) }
606 repSts other = panic "Exotic Stmt in meta brackets"
609 -----------------------------------------------------------
611 -----------------------------------------------------------
613 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
615 = do { let { bndrs = collectHsBinders decs } ;
616 ss <- mkGenSyms bndrs ;
617 core <- addBinds ss (rep_binds decs) ;
618 core_list <- coreList declTyConName core ;
619 return (ss, core_list) }
621 rep_binds :: HsBinds Name -> DsM [Core M.Decl]
622 rep_binds EmptyBinds = return []
623 rep_binds (ThenBinds x y)
624 = do { core1 <- rep_binds x
625 ; core2 <- rep_binds y
626 ; return (core1 ++ core2) }
627 rep_binds (MonoBind bs sigs _)
628 = do { core1 <- rep_monobind bs
629 ; core2 <- rep_sigs sigs
630 ; return (core1 ++ core2) }
631 rep_binds (IPBinds _ _)
632 = panic "DsMeta:repBinds: can't do implicit parameters"
634 rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
635 rep_monobind EmptyMonoBinds = return []
636 rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
637 y1 <- rep_monobind y;
640 -- Note GHC treats declarations of a variable (not a pattern)
641 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
642 -- with an empty list of patterns
643 rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
644 = do { (ss,wherecore) <- repBinds wheres
645 ; guardcore <- addBinds ss (repGuards guards)
646 ; fn' <- lookupBinder fn
648 ; ans <- repVal p guardcore wherecore
651 rep_monobind (FunMonoBind fn infx ms loc)
652 = do { ms1 <- mapM repClauseTup ms
653 ; fn' <- lookupBinder fn
654 ; ans <- repFun fn' (nonEmptyCoreList ms1)
657 rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
658 = do { patcore <- repP pat
659 ; (ss,wherecore) <- repBinds wheres
660 ; guardcore <- addBinds ss (repGuards guards)
661 ; ans <- repVal patcore guardcore wherecore
664 rep_monobind (VarMonoBind v e)
665 = do { v' <- lookupBinder v
668 ; patcore <- repPvar v'
669 ; empty_decls <- coreList declTyConName []
670 ; ans <- repVal patcore x empty_decls
673 -----------------------------------------------------------------------------
674 -- Since everything in a MonoBind is mutually recursive we need rename all
675 -- all the variables simultaneously. For example:
676 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
677 -- do { f'1 <- gensym "f"
678 -- ; g'2 <- gensym "g"
679 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
680 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
682 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
683 -- environment ( f |-> f'1 ) from each binding, and then unioning them
684 -- together. As we do this we collect GenSymBinds's which represent the renamed
685 -- variables bound by the Bindings. In order not to lose track of these
686 -- representations we build a shadow datatype MB with the same structure as
687 -- MonoBinds, but which has slots for the representations
690 -----------------------------------------------------------------------------
691 -- GHC allows a more general form of lambda abstraction than specified
692 -- by Haskell 98. In particular it allows guarded lambda's like :
693 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
694 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
695 -- (\ p1 .. pn -> exp) by causing an error.
697 repLambda :: Match Name -> DsM (Core M.Expr)
698 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
700 = do { let bndrs = collectPatsBinders ps ;
701 ; ss <- mkGenSyms bndrs
702 ; lam <- addBinds ss (
703 do { xs <- repPs ps; body <- repE e; repLam xs body })
704 ; wrapGenSyns ss lam }
706 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
709 -----------------------------------------------------------------------------
711 -- repP deals with patterns. It assumes that we have already
712 -- walked over the pattern(s) once to collect the binders, and
713 -- have extended the environment. So every pattern-bound
714 -- variable should already appear in the environment.
716 -- Process a list of patterns
717 repPs :: [Pat Name] -> DsM (Core [M.Patt])
718 repPs ps = do { ps' <- mapM repP ps ;
719 coreList pattTyConName ps' }
721 repP :: Pat Name -> DsM (Core M.Patt)
722 repP (WildPat _) = repPwild
723 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
724 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
725 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
726 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
727 repP (ParPat p) = repP p
728 repP (ListPat ps _) = repListPat ps
729 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
730 repP (ConPatIn dc details)
731 = do { con_str <- lookupOcc dc
733 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
734 RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
735 ; ps <- sequence $ map repP (map snd pairs)
736 ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
737 ; fps' <- coreList fieldPTyConName fps
738 ; repPrec con_str fps' }
739 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
741 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
742 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
743 repP other = panic "Exotic pattern inside meta brackets"
745 repListPat :: [Pat Name] -> DsM (Core M.Patt)
746 repListPat [] = do { nil_con <- coreStringLit "[]"
747 ; nil_args <- coreList pattTyConName []
748 ; repPcon nil_con nil_args }
749 repListPat (p:ps) = do { p2 <- repP p
750 ; ps2 <- repListPat ps
751 ; cons_con <- coreStringLit ":"
752 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
755 ----------------------------------------------------------
756 -- The meta-environment
758 -- A name/identifier association for fresh names of locally bound entities
760 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
761 -- I.e. (x, x_id) means
762 -- let x_id = gensym "x" in ...
764 -- Generate a fresh name for a locally bound entity
766 mkGenSym :: Name -> DsM GenSymBind
767 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
769 -- Ditto for a list of names
771 mkGenSyms :: [Name] -> DsM [GenSymBind]
772 mkGenSyms ns = mapM mkGenSym ns
774 -- Add a list of fresh names for locally bound entities to the meta
775 -- environment (which is part of the state carried around by the desugarer
778 addBinds :: [GenSymBind] -> DsM a -> DsM a
779 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
781 -- Look up a locally bound name
783 lookupBinder :: Name -> DsM (Core String)
785 = do { mb_val <- dsLookupMetaEnv n;
787 Just (Bound x) -> return (coreVar x)
788 other -> pprPanic "Failed binder lookup:" (ppr n) }
790 -- Look up a name that is either locally bound or a global name
792 -- * If it is a global name, generate the "original name" representation (ie,
793 -- the <module>:<name> form) for the associated entity
795 lookupOcc :: Name -> DsM (Core String)
796 -- Lookup an occurrence; it can't be a splice.
797 -- Use the in-scope bindings if they exist
799 = do { mb_val <- dsLookupMetaEnv n ;
801 Nothing -> globalVar n
802 Just (Bound x) -> return (coreVar x)
803 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
806 globalVar :: Name -> DsM (Core String)
807 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
809 name_mod = moduleUserString (nameModule n)
810 name_occ = occNameUserString (nameOccName n)
812 localVar :: Name -> DsM (Core String)
813 localVar n = coreStringLit (occNameUserString (nameOccName n))
815 lookupType :: Name -- Name of type constructor (e.g. M.Expr)
816 -> DsM Type -- The type
817 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
818 return (mkGenTyConApp tc []) }
820 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
821 -- --> bindQ (gensym nm1) (\ id1 ->
822 -- bindQ (gensym nm2 (\ id2 ->
825 wrapGenSyns :: [GenSymBind]
826 -> Core (M.Q a) -> DsM (Core (M.Q a))
827 wrapGenSyns binds body@(MkC b)
830 [elt_ty] = tcTyConAppArgs (exprType b)
831 -- b :: Q a, so we can get the type 'a' by looking at the
832 -- argument type. NB: this relies on Q being a data/newtype,
833 -- not a type synonym
836 go ((name,id) : binds)
837 = do { MkC body' <- go binds
838 ; lit_str <- localVar name
839 ; gensym_app <- repGensym lit_str
840 ; repBindQ stringTy elt_ty
841 gensym_app (MkC (Lam id body')) }
843 -- Just like wrapGenSym, but don't actually do the gensym
844 -- Instead use the existing name
845 -- Only used for [Decl]
846 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
847 wrapNongenSyms binds (MkC body)
848 = do { binds' <- mapM do_one binds ;
849 return (MkC (mkLets binds' body)) }
852 = do { MkC lit_str <- localVar name -- No gensym
853 ; return (NonRec id lit_str) }
855 void = placeHolderType
857 string :: String -> HsExpr Id
858 string s = HsLit (HsString (mkFastString s))
861 -- %*********************************************************************
865 -- %*********************************************************************
867 -----------------------------------------------------------------------------
868 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
869 -- we invent a new datatype which uses phantom types.
871 newtype Core a = MkC CoreExpr
874 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
875 rep2 n xs = do { id <- dsLookupGlobalId n
876 ; return (MkC (foldl App (Var id) xs)) }
878 -- Then we make "repConstructors" which use the phantom types for each of the
879 -- smart constructors of the Meta.Meta datatypes.
882 -- %*********************************************************************
884 -- The 'smart constructors'
886 -- %*********************************************************************
888 --------------- Patterns -----------------
889 repPlit :: Core M.Lit -> DsM (Core M.Patt)
890 repPlit (MkC l) = rep2 plitName [l]
892 repPvar :: Core String -> DsM (Core M.Patt)
893 repPvar (MkC s) = rep2 pvarName [s]
895 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
896 repPtup (MkC ps) = rep2 ptupName [ps]
898 repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
899 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
901 repPrec :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt)
902 repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
904 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
905 repPtilde (MkC p) = rep2 ptildeName [p]
907 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
908 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
910 repPwild :: DsM (Core M.Patt)
911 repPwild = rep2 pwildName []
913 --------------- Expressions -----------------
914 repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
915 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
916 | otherwise = repVar str
918 repVar :: Core String -> DsM (Core M.Expr)
919 repVar (MkC s) = rep2 varName [s]
921 repCon :: Core String -> DsM (Core M.Expr)
922 repCon (MkC s) = rep2 conName [s]
924 repLit :: Core M.Lit -> DsM (Core M.Expr)
925 repLit (MkC c) = rep2 litName [c]
927 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
928 repApp (MkC x) (MkC y) = rep2 appName [x,y]
930 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
931 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
933 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
934 repTup (MkC es) = rep2 tupName [es]
936 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
937 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
939 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
940 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
942 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
943 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
945 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
946 repDoE (MkC ss) = rep2 doEName [ss]
948 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
949 repComp (MkC ss) = rep2 compName [ss]
951 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
952 repListExp (MkC es) = rep2 listExpName [es]
954 repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
955 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
957 repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr)
958 repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
960 repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr)
961 repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
963 repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
964 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
966 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
967 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
969 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
970 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
972 ------------ Right hand sides (guarded expressions) ----
973 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
974 repGuarded (MkC pairs) = rep2 guardedName [pairs]
976 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
977 repNormal (MkC e) = rep2 normalName [e]
979 ------------- Statements -------------------
980 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
981 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
983 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
984 repLetSt (MkC ds) = rep2 letStName [ds]
986 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
987 repNoBindSt (MkC e) = rep2 noBindStName [e]
989 -------------- DotDot (Arithmetic sequences) -----------
990 repFrom :: Core M.Expr -> DsM (Core M.Expr)
991 repFrom (MkC x) = rep2 fromName [x]
993 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
994 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
996 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
997 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
999 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
1000 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
1002 ------------ Match and Clause Tuples -----------
1003 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
1004 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1006 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
1007 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1009 -------------- Dec -----------------------------
1010 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
1011 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
1013 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
1014 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
1016 repData :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
1017 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1019 repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl)
1020 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1022 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
1023 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
1025 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
1026 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1028 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
1029 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
1031 repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt)
1032 repCtxt (MkC tys) = rep2 ctxtName [tys]
1034 repConstr :: Core String -> HsConDetails Name (BangType Name)
1035 -> DsM (Core M.Cons)
1036 repConstr con (PrefixCon ps)
1037 = do arg_tys <- mapM repBangTy ps
1038 arg_tys1 <- coreList strTypeTyConName arg_tys
1039 rep2 constrName [unC con, unC arg_tys1]
1040 repConstr con (RecCon ips)
1041 = do arg_vs <- mapM lookupOcc (map fst ips)
1042 arg_tys <- mapM repBangTy (map snd ips)
1043 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1045 arg_vtys' <- coreList varStrTypeTyConName arg_vtys
1046 rep2 recConstrName [unC con, unC arg_vtys']
1047 repConstr con (InfixCon st1 st2)
1048 = do arg1 <- repBangTy st1
1049 arg2 <- repBangTy st2
1050 rep2 infixConstrName [unC arg1, unC con, unC arg2]
1052 ------------ Types -------------------
1054 repTForall :: Core [String] -> Core M.Ctxt -> Core M.Type -> DsM (Core M.Type)
1055 repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty]
1057 repTvar :: Core String -> DsM (Core M.Type)
1058 repTvar (MkC s) = rep2 tvarName [s]
1060 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
1061 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
1063 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
1064 repTapps f [] = return f
1065 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1067 --------- Type constructors --------------
1069 repNamedTyCon :: Core String -> DsM (Core M.Type)
1070 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
1072 repTupleTyCon :: Int -> DsM (Core M.Type)
1073 -- Note: not Core Int; it's easier to be direct here
1074 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
1076 repArrowTyCon :: DsM (Core M.Type)
1077 repArrowTyCon = rep2 arrowTyConName []
1079 repListTyCon :: DsM (Core M.Type)
1080 repListTyCon = rep2 listTyConName []
1083 ----------------------------------------------------------
1086 repLiteral :: HsLit -> DsM (Core M.Lit)
1088 = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
1090 lit_name = case lit of
1091 HsInteger _ -> integerLName
1092 HsInt _ -> integerLName
1093 HsChar _ -> charLName
1094 HsString _ -> stringLName
1095 HsRat _ _ -> rationalLName
1097 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1100 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1101 repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i)
1102 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
1103 repLiteral (HsRat f rat_ty) }
1104 -- The type Rational will be in the environment, becuase
1105 -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1106 -- and rationalL is sucked in when any TH stuff is used
1108 --------------- Miscellaneous -------------------
1110 repLift :: Core e -> DsM (Core M.Expr)
1111 repLift (MkC x) = rep2 liftName [x]
1113 repGensym :: Core String -> DsM (Core (M.Q String))
1114 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1116 repBindQ :: Type -> Type -- a and b
1117 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1118 repBindQ ty_a ty_b (MkC x) (MkC y)
1119 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1121 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1122 repSequenceQ ty_a (MkC list)
1123 = rep2 sequenceQName [Type ty_a, list]
1125 ------------ Lists and Tuples -------------------
1126 -- turn a list of patterns into a single pattern matching a list
1128 coreList :: Name -- Of the TyCon of the element type
1129 -> [Core a] -> DsM (Core [a])
1131 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1133 coreList' :: Type -- The element type
1134 -> [Core a] -> Core [a]
1135 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1137 nonEmptyCoreList :: [Core a] -> Core [a]
1138 -- The list must be non-empty so we can get the element type
1139 -- Otherwise use coreList
1140 nonEmptyCoreList [] = panic "coreList: empty argument"
1141 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1143 corePair :: (Core a, Core b) -> Core (a,b)
1144 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1146 coreStringLit :: String -> DsM (Core String)
1147 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1149 coreVar :: Id -> Core String -- The Id has type String
1150 coreVar id = MkC (Var id)
1154 -- %************************************************************************
1156 -- The known-key names for Template Haskell
1158 -- %************************************************************************
1160 -- To add a name, do three things
1162 -- 1) Allocate a key
1164 -- 3) Add the name to knownKeyNames
1166 templateHaskellNames :: NameSet
1167 -- The names that are implicitly mentioned by ``bracket''
1168 -- Should stay in sync with the import list of DsMeta
1169 templateHaskellNames
1170 = mkNameSet [ integerLName, charLName, stringLName, rationalLName,
1171 plitName, pvarName, ptupName,
1172 pconName, ptildeName, paspatName, pwildName,
1173 varName, conName, litName, appName, infixEName, lamName,
1174 tupName, doEName, compName,
1175 listExpName, sigExpName, condName, letEName, caseEName,
1176 infixAppName, sectionLName, sectionRName,
1177 guardedName, normalName,
1178 bindStName, letStName, noBindStName, parStName,
1179 fromName, fromThenName, fromToName, fromThenToName,
1180 funName, valName, liftName,
1181 gensymName, returnQName, bindQName, sequenceQName,
1182 matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
1183 instName, protoName, tforallName, tvarName, tconName, tappName,
1184 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
1185 ctxtName, constrName, recConstrName, infixConstrName,
1186 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
1187 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1188 strTypeTyConName, varStrTypeTyConName,
1189 qTyConName, expTyConName, matTyConName, clsTyConName,
1190 decTyConName, typTyConName, strictTypeName, varStrictTypeName,
1191 recConName, recUpdName, precName,
1192 fieldName, fieldTyConName, fieldPName, fieldPTyConName,
1193 strictName, nonstrictName ]
1196 varQual = mk_known_key_name OccName.varName
1197 tcQual = mk_known_key_name OccName.tcName
1200 -- NB: the THSyntax module comes from the "haskell-src" package
1201 thModule = mkThPkgModule mETA_META_Name
1203 mk_known_key_name space str uniq
1204 = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1206 integerLName = varQual FSLIT("integerL") integerLIdKey
1207 charLName = varQual FSLIT("charL") charLIdKey
1208 stringLName = varQual FSLIT("stringL") stringLIdKey
1209 rationalLName = varQual FSLIT("rationalL") rationalLIdKey
1210 plitName = varQual FSLIT("plit") plitIdKey
1211 pvarName = varQual FSLIT("pvar") pvarIdKey
1212 ptupName = varQual FSLIT("ptup") ptupIdKey
1213 pconName = varQual FSLIT("pcon") pconIdKey
1214 ptildeName = varQual FSLIT("ptilde") ptildeIdKey
1215 paspatName = varQual FSLIT("paspat") paspatIdKey
1216 pwildName = varQual FSLIT("pwild") pwildIdKey
1217 precName = varQual FSLIT("prec") precIdKey
1218 varName = varQual FSLIT("var") varIdKey
1219 conName = varQual FSLIT("con") conIdKey
1220 litName = varQual FSLIT("lit") litIdKey
1221 appName = varQual FSLIT("app") appIdKey
1222 infixEName = varQual FSLIT("infixE") infixEIdKey
1223 lamName = varQual FSLIT("lam") lamIdKey
1224 tupName = varQual FSLIT("tup") tupIdKey
1225 doEName = varQual FSLIT("doE") doEIdKey
1226 compName = varQual FSLIT("comp") compIdKey
1227 listExpName = varQual FSLIT("listExp") listExpIdKey
1228 sigExpName = varQual FSLIT("sigExp") sigExpIdKey
1229 condName = varQual FSLIT("cond") condIdKey
1230 letEName = varQual FSLIT("letE") letEIdKey
1231 caseEName = varQual FSLIT("caseE") caseEIdKey
1232 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1233 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1234 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1235 recConName = varQual FSLIT("recCon") recConIdKey
1236 recUpdName = varQual FSLIT("recUpd") recUpdIdKey
1237 guardedName = varQual FSLIT("guarded") guardedIdKey
1238 normalName = varQual FSLIT("normal") normalIdKey
1239 bindStName = varQual FSLIT("bindSt") bindStIdKey
1240 letStName = varQual FSLIT("letSt") letStIdKey
1241 noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
1242 parStName = varQual FSLIT("parSt") parStIdKey
1243 fromName = varQual FSLIT("from") fromIdKey
1244 fromThenName = varQual FSLIT("fromThen") fromThenIdKey
1245 fromToName = varQual FSLIT("fromTo") fromToIdKey
1246 fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
1247 liftName = varQual FSLIT("lift") liftIdKey
1248 gensymName = varQual FSLIT("gensym") gensymIdKey
1249 returnQName = varQual FSLIT("returnQ") returnQIdKey
1250 bindQName = varQual FSLIT("bindQ") bindQIdKey
1251 sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
1254 matchName = varQual FSLIT("match") matchIdKey
1257 clauseName = varQual FSLIT("clause") clauseIdKey
1260 funName = varQual FSLIT("fun") funIdKey
1261 valName = varQual FSLIT("val") valIdKey
1262 dataDName = varQual FSLIT("dataD") dataDIdKey
1263 tySynDName = varQual FSLIT("tySynD") tySynDIdKey
1264 classDName = varQual FSLIT("classD") classDIdKey
1265 instName = varQual FSLIT("inst") instIdKey
1266 protoName = varQual FSLIT("proto") protoIdKey
1269 tforallName = varQual FSLIT("tforall") tforallIdKey
1270 tvarName = varQual FSLIT("tvar") tvarIdKey
1271 tconName = varQual FSLIT("tcon") tconIdKey
1272 tappName = varQual FSLIT("tapp") tappIdKey
1275 arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
1276 tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
1277 listTyConName = varQual FSLIT("listTyCon") listIdKey
1278 namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
1281 ctxtName = varQual FSLIT("ctxt") ctxtIdKey
1284 constrName = varQual FSLIT("constr") constrIdKey
1285 recConstrName = varQual FSLIT("recConstr") recConstrIdKey
1286 infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey
1288 exprTyConName = tcQual FSLIT("Expr") exprTyConKey
1289 declTyConName = tcQual FSLIT("Decl") declTyConKey
1290 pattTyConName = tcQual FSLIT("Patt") pattTyConKey
1291 mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey
1292 clseTyConName = tcQual FSLIT("Clse") clseTyConKey
1293 stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
1294 consTyConName = tcQual FSLIT("Cons") consTyConKey
1295 typeTyConName = tcQual FSLIT("Type") typeTyConKey
1296 strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey
1297 varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey
1299 fieldTyConName = tcQual FSLIT("FldE") fieldTyConKey
1300 fieldPTyConName = tcQual FSLIT("FldP") fieldPTyConKey
1302 qTyConName = tcQual FSLIT("Q") qTyConKey
1303 expTyConName = tcQual FSLIT("Exp") expTyConKey
1304 decTyConName = tcQual FSLIT("Dec") decTyConKey
1305 typTyConName = tcQual FSLIT("Typ") typTyConKey
1306 matTyConName = tcQual FSLIT("Mat") matTyConKey
1307 clsTyConName = tcQual FSLIT("Cls") clsTyConKey
1309 strictTypeName = varQual FSLIT("strictType") strictTypeKey
1310 varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey
1311 strictName = varQual FSLIT("strict") strictKey
1312 nonstrictName = varQual FSLIT("nonstrict") nonstrictKey
1314 fieldName = varQual FSLIT("field") fieldKey
1315 fieldPName = varQual FSLIT("fieldP") fieldPKey
1317 -- TyConUniques available: 100-119
1318 -- Check in PrelNames if you want to change this
1320 expTyConKey = mkPreludeTyConUnique 100
1321 matTyConKey = mkPreludeTyConUnique 101
1322 clsTyConKey = mkPreludeTyConUnique 102
1323 qTyConKey = mkPreludeTyConUnique 103
1324 exprTyConKey = mkPreludeTyConUnique 104
1325 declTyConKey = mkPreludeTyConUnique 105
1326 pattTyConKey = mkPreludeTyConUnique 106
1327 mtchTyConKey = mkPreludeTyConUnique 107
1328 clseTyConKey = mkPreludeTyConUnique 108
1329 stmtTyConKey = mkPreludeTyConUnique 109
1330 consTyConKey = mkPreludeTyConUnique 110
1331 typeTyConKey = mkPreludeTyConUnique 111
1332 typTyConKey = mkPreludeTyConUnique 112
1333 decTyConKey = mkPreludeTyConUnique 113
1334 varStrTypeTyConKey = mkPreludeTyConUnique 114
1335 strTypeTyConKey = mkPreludeTyConUnique 115
1336 fieldTyConKey = mkPreludeTyConUnique 116
1337 fieldPTyConKey = mkPreludeTyConUnique 117
1341 -- IdUniques available: 200-299
1342 -- If you want to change this, make sure you check in PrelNames
1343 fromIdKey = mkPreludeMiscIdUnique 200
1344 fromThenIdKey = mkPreludeMiscIdUnique 201
1345 fromToIdKey = mkPreludeMiscIdUnique 202
1346 fromThenToIdKey = mkPreludeMiscIdUnique 203
1347 liftIdKey = mkPreludeMiscIdUnique 204
1348 gensymIdKey = mkPreludeMiscIdUnique 205
1349 returnQIdKey = mkPreludeMiscIdUnique 206
1350 bindQIdKey = mkPreludeMiscIdUnique 207
1351 funIdKey = mkPreludeMiscIdUnique 208
1352 valIdKey = mkPreludeMiscIdUnique 209
1353 protoIdKey = mkPreludeMiscIdUnique 210
1354 matchIdKey = mkPreludeMiscIdUnique 211
1355 clauseIdKey = mkPreludeMiscIdUnique 212
1356 integerLIdKey = mkPreludeMiscIdUnique 213
1357 charLIdKey = mkPreludeMiscIdUnique 214
1359 classDIdKey = mkPreludeMiscIdUnique 215
1360 instIdKey = mkPreludeMiscIdUnique 216
1361 dataDIdKey = mkPreludeMiscIdUnique 217
1363 sequenceQIdKey = mkPreludeMiscIdUnique 218
1364 tySynDIdKey = mkPreludeMiscIdUnique 219
1366 plitIdKey = mkPreludeMiscIdUnique 220
1367 pvarIdKey = mkPreludeMiscIdUnique 221
1368 ptupIdKey = mkPreludeMiscIdUnique 222
1369 pconIdKey = mkPreludeMiscIdUnique 223
1370 ptildeIdKey = mkPreludeMiscIdUnique 224
1371 paspatIdKey = mkPreludeMiscIdUnique 225
1372 pwildIdKey = mkPreludeMiscIdUnique 226
1373 varIdKey = mkPreludeMiscIdUnique 227
1374 conIdKey = mkPreludeMiscIdUnique 228
1375 litIdKey = mkPreludeMiscIdUnique 229
1376 appIdKey = mkPreludeMiscIdUnique 230
1377 infixEIdKey = mkPreludeMiscIdUnique 231
1378 lamIdKey = mkPreludeMiscIdUnique 232
1379 tupIdKey = mkPreludeMiscIdUnique 233
1380 doEIdKey = mkPreludeMiscIdUnique 234
1381 compIdKey = mkPreludeMiscIdUnique 235
1382 listExpIdKey = mkPreludeMiscIdUnique 237
1383 condIdKey = mkPreludeMiscIdUnique 238
1384 letEIdKey = mkPreludeMiscIdUnique 239
1385 caseEIdKey = mkPreludeMiscIdUnique 240
1386 infixAppIdKey = mkPreludeMiscIdUnique 241
1388 sectionLIdKey = mkPreludeMiscIdUnique 243
1389 sectionRIdKey = mkPreludeMiscIdUnique 244
1390 guardedIdKey = mkPreludeMiscIdUnique 245
1391 normalIdKey = mkPreludeMiscIdUnique 246
1392 bindStIdKey = mkPreludeMiscIdUnique 247
1393 letStIdKey = mkPreludeMiscIdUnique 248
1394 noBindStIdKey = mkPreludeMiscIdUnique 249
1395 parStIdKey = mkPreludeMiscIdUnique 250
1397 tforallIdKey = mkPreludeMiscIdUnique 251
1398 tvarIdKey = mkPreludeMiscIdUnique 252
1399 tconIdKey = mkPreludeMiscIdUnique 253
1400 tappIdKey = mkPreludeMiscIdUnique 254
1402 arrowIdKey = mkPreludeMiscIdUnique 255
1403 tupleIdKey = mkPreludeMiscIdUnique 256
1404 listIdKey = mkPreludeMiscIdUnique 257
1405 namedTyConIdKey = mkPreludeMiscIdUnique 258
1407 ctxtIdKey = mkPreludeMiscIdUnique 259
1409 constrIdKey = mkPreludeMiscIdUnique 260
1411 stringLIdKey = mkPreludeMiscIdUnique 261
1412 rationalLIdKey = mkPreludeMiscIdUnique 262
1414 sigExpIdKey = mkPreludeMiscIdUnique 263
1416 strictTypeKey = mkPreludeMiscIdUnique 264
1417 strictKey = mkPreludeMiscIdUnique 265
1418 nonstrictKey = mkPreludeMiscIdUnique 266
1419 varStrictTypeKey = mkPreludeMiscIdUnique 267
1421 recConstrIdKey = mkPreludeMiscIdUnique 268
1422 infixConstrIdKey = mkPreludeMiscIdUnique 269
1424 recConIdKey = mkPreludeMiscIdUnique 270
1425 recUpdIdKey = mkPreludeMiscIdUnique 271
1426 precIdKey = mkPreludeMiscIdUnique 272
1427 fieldKey = mkPreludeMiscIdUnique 273
1428 fieldPKey = mkPreludeMiscIdUnique 274
1431 -- %************************************************************************
1435 -- %************************************************************************
1437 -- It is rather usatisfactory that we don't have a SrcLoc
1438 addDsWarn :: SDoc -> DsM ()
1439 addDsWarn msg = dsWarn (noSrcLoc, msg)