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,
17 decTyConName, typTyConName ) where
19 #include "HsVersions.h"
21 import {-# SOURCE #-} DsExpr ( dsExpr )
23 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup,
24 mkIntExpr, mkCharExpr )
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 )
46 import MkIface ( ifaceTyThing )
47 import Name ( Name, nameOccName, nameModule )
48 import OccName ( isDataOcc, isTvOcc, occNameUserString )
49 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
50 -- we do this by removing varName from the import of OccName above, making
51 -- a qualified instance of OccName and using OccNameAlias.varName where varName
52 -- ws previously used in this file.
53 import qualified OccName( varName, tcName )
55 import Module ( Module, mkThPkgModule, moduleUserString )
56 import Id ( Id, idType )
57 import Name ( mkKnownKeyExternalName )
58 import OccName ( mkOccFS )
61 import Type ( Type, TyThing(..), mkGenTyConApp )
62 import TyCon ( DataConDetails(..) )
63 import TysWiredIn ( stringTy )
65 import CoreUtils ( exprType )
66 import SrcLoc ( noSrcLoc )
67 import Maybe ( catMaybes )
68 import Panic ( panic )
69 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
70 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
73 import FastString ( mkFastString )
75 -----------------------------------------------------------------------------
76 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
77 -- Returns a CoreExpr of type M.Expr
78 -- The quoted thing is parameterised over Name, even though it has
79 -- been type checked. We don't want all those type decorations!
81 dsBracket brack splices
82 = dsExtendMetaEnv new_bit (do_brack brack)
84 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
86 do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
87 do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
88 do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
89 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
91 -----------------------------------------------------------------------------
92 dsReify :: HsReify Id -> DsM CoreExpr
93 -- Returns a CoreExpr of type reifyType --> M.Typ
94 -- reifyDecl --> M.Dec
95 -- reifyFixty --> M.Fix
96 dsReify (ReifyOut ReifyType name)
97 = do { thing <- dsLookupGlobal name ;
98 -- By deferring the lookup until now (rather than doing it
99 -- in the type checker) we ensure that all zonking has
102 AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
104 other -> pprPanic "dsReify: reifyType" (ppr name)
107 dsReify r@(ReifyOut ReifyDecl name)
108 = do { thing <- dsLookupGlobal name ;
109 mb_d <- repTyClD (ifaceTyThing thing) ;
111 Just (MkC d) -> return d
112 Nothing -> pprPanic "dsReify" (ppr r)
115 {- -------------- Examples --------------------
119 gensym (unpackString "x"#) `bindQ` \ x1::String ->
120 lam (pvar x1) (var x1)
123 [| \x -> $(f [| x |]) |]
125 gensym (unpackString "x"#) `bindQ` \ x1::String ->
126 lam (pvar x1) (f (var x1))
130 -------------------------------------------------------
132 -------------------------------------------------------
134 repTopDs :: HsGroup Name -> DsM (Core [M.Decl])
136 = do { let { bndrs = groupBinders group } ;
137 ss <- mkGenSyms bndrs ;
139 decls <- addBinds ss (do {
140 val_ds <- rep_binds (hs_valds group) ;
141 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
142 inst_ds <- mapM repInstD (hs_instds group) ;
144 return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
146 core_list <- coreList declTyConName decls ;
147 wrapNongenSyms ss core_list
148 -- Do *not* gensym top-level binders
151 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
152 hs_fords = foreign_decls })
153 -- Collect the binders of a Group
154 = collectHsBinders val_decls ++
155 [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
156 [n | ForeignImport n _ _ _ _ <- foreign_decls]
159 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
161 repTyClD (TyData { tcdND = DataType, tcdCtxt = [],
162 tcdName = tc, tcdTyVars = tvs,
163 tcdCons = DataCons cons, tcdDerivs = mb_derivs })
164 = do { tc1 <- lookupBinder tc ;
166 cons1 <- mapM repC cons ;
167 cons2 <- coreList consTyConName cons1 ;
168 derivs1 <- repDerivs mb_derivs ;
169 dec <- repData tc1 tvs1 cons2 derivs1 ;
172 repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls,
173 tcdTyVars = tvs, tcdFDs = [],
174 tcdSigs = sigs, tcdMeths = Just binds
176 = do { cls1 <- lookupBinder cls ;
178 cxt1 <- repCtxt cxt ;
179 sigs1 <- rep_sigs sigs ;
180 binds1 <- rep_monobind binds ;
181 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
182 dec <- repClass cxt1 cls1 tvs1 decls1 ;
186 repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
190 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
192 repInstD (InstDecl ty binds _ _ loc)
193 -- Ignore user pragmas for now
194 = do { cxt1 <- repCtxt cxt ;
195 inst_ty1 <- repPred (HsClassP cls tys) ;
196 binds1 <- rep_monobind binds ;
197 decls1 <- coreList declTyConName binds1 ;
198 repInst cxt1 inst_ty1 decls1 }
200 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
203 -------------------------------------------------------
205 -------------------------------------------------------
207 repC :: ConDecl Name -> DsM (Core M.Cons)
208 repC (ConDecl con [] [] details loc)
209 = do { con1 <- lookupBinder con ;
210 arg_tys <- mapM (repBangTy con) (hsConArgs details) ;
211 arg_tys1 <- coreList typeTyConName arg_tys ;
212 repConstr con1 arg_tys1 }
214 repBangTy con (BangType NotMarkedStrict ty) = repTy ty
215 repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
217 msg = ptext SLIT("Ignoring stricness on argument of constructor")
220 -------------------------------------------------------
222 -------------------------------------------------------
224 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
225 repDerivs Nothing = return (coreList' stringTy [])
226 repDerivs (Just ctxt)
227 = do { strs <- mapM rep_deriv ctxt ;
228 return (coreList' stringTy strs) }
230 rep_deriv :: HsPred Name -> DsM (Core String)
231 -- Deriving clauses must have the simple H98 form
232 rep_deriv (HsClassP cls []) = lookupOcc cls
233 rep_deriv other = panic "rep_deriv"
236 -------------------------------------------------------
237 -- Signatures in a class decl, or a group of bindings
238 -------------------------------------------------------
240 rep_sigs :: [Sig Name] -> DsM [Core M.Decl]
241 -- We silently ignore ones we don't recognise
242 rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ;
243 return (concat sigs1) }
245 rep_sig :: Sig Name -> DsM [Core M.Decl]
247 -- Empty => Too hard, signature ignored
248 rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
249 rep_sig (Sig nm ty _) = rep_proto nm ty
250 rep_sig other = return []
252 rep_proto nm ty = do { nm1 <- lookupBinder nm ;
254 sig <- repProto nm1 ty1 ;
258 -------------------------------------------------------
260 -------------------------------------------------------
262 repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
263 repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
264 return (coreList' stringTy tvs1) }
267 repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
268 repCtxt ctxt = do { preds <- mapM repPred ctxt;
269 coreList typeTyConName preds }
272 repPred :: HsPred Name -> DsM (Core M.Type)
273 repPred (HsClassP cls tys)
274 = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
275 tys1 <- repTys tys; repTapps tcon tys1 }
276 repPred (HsIParam _ _) = panic "No implicit parameters yet"
279 repTys :: [HsType Name] -> DsM [Core M.Type]
280 repTys tys = mapM repTy tys
283 repTy :: HsType Name -> DsM (Core M.Type)
286 | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
287 | otherwise = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
288 repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
289 repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ;
290 tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
291 repTy (HsListTy t) = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
292 repTy (HsTupleTy tc tys) = do { tys1 <- repTys tys;
293 tcon <- repTupleTyCon (length tys);
295 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
296 repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
297 repTy (HsParTy t) = repTy t
298 repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
300 repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig
302 -----------------------------------------------------------------------------
304 -----------------------------------------------------------------------------
306 repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
307 repEs es = do { es' <- mapM repE es ;
308 coreList exprTyConName es' }
310 -- FIXME: some of these panics should be converted into proper error messages
311 -- unless we can make sure that constructs, which are plainly not
312 -- supported in TH already lead to error messages at an earlier stage
313 repE :: HsExpr Name -> DsM (Core M.Expr)
315 do { mb_val <- dsLookupMetaEnv x
317 Nothing -> do { str <- globalVar x
318 ; repVarOrCon x str }
319 Just (Bound y) -> repVarOrCon x (coreVar y)
320 Just (Splice e) -> do { e' <- dsExpr e
321 ; return (MkC e') } }
323 panic "DsMeta.repE: Can't represent implicit parameters"
324 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
325 repE (HsLit l) = do { a <- repLiteral l; repLit a }
326 repE (HsLam m) = repLambda m
327 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
328 repE (OpApp e1 op fix e2) =
330 HsVar op -> do { arg1 <- repE e1;
332 the_op <- lookupOcc op ;
333 repInfixApp arg1 the_op arg2 }
334 _ -> panic "DsMeta.repE: Operator is not a variable"
335 repE (NegApp x nm) = repE x >>= repNeg
336 repE (HsPar x) = repE x
337 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
338 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
339 repE (HsCase e ms loc) = do { arg <- repE e
340 ; ms2 <- mapM repMatchTup ms
341 ; repCaseE arg (nonEmptyCoreList ms2) }
342 repE (HsIf x y z loc) = do
347 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
348 ; e2 <- addBinds ss (repE e)
350 ; wrapGenSyns expTyConName ss z }
351 -- FIXME: I haven't got the types here right yet
352 repE (HsDo ctxt sts _ ty loc)
353 | isComprCtxt ctxt = do { (ss,zs) <- repSts sts;
354 e <- repDoE (nonEmptyCoreList zs);
355 wrapGenSyns expTyConName ss e }
357 panic "DsMeta.repE: Can't represent mdo and [: :] yet"
359 isComprCtxt ListComp = True
360 isComprCtxt DoExpr = True
361 isComprCtxt _ = False
362 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
363 repE (ExplicitPArr ty es) =
364 panic "DsMeta.repE: No explicit parallel arrays yet"
365 repE (ExplicitTuple es boxed)
366 | isBoxed boxed = do { xs <- repEs es; repTup xs }
367 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
368 repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
369 repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
370 repE (ExprWithTySig e ty) =
371 panic "DsMeta.repE: No expressions with type signatures yet"
372 repE (ArithSeqOut _ aseq) =
374 From e -> do { ds1 <- repE e; repFrom ds1 }
383 FromThenTo e1 e2 e3 -> do
387 repFromThenTo ds1 ds2 ds3
388 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
389 repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
390 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
391 repE (HsBracketOut _ _) =
392 panic "DsMeta.repE: Can't represent Oxford brackets"
393 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
395 Just (Splice e) -> do { e' <- dsExpr e
397 other -> pprPanic "HsSplice" (ppr n) }
398 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
400 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
402 -----------------------------------------------------------------------------
403 -- Building representations of auxillary structures like Match, Clause, Stmt,
405 repMatchTup :: Match Name -> DsM (Core M.Mtch)
406 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
407 do { ss1 <- mkGenSyms (collectPatBinders p)
408 ; addBinds ss1 $ do {
410 ; (ss2,ds) <- repBinds wheres
411 ; addBinds ss2 $ do {
412 ; gs <- repGuards guards
413 ; match <- repMatch p1 gs ds
414 ; wrapGenSyns matTyConName (ss1++ss2) match }}}
416 repClauseTup :: Match Name -> DsM (Core M.Clse)
417 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
418 do { ss1 <- mkGenSyms (collectPatsBinders ps)
419 ; addBinds ss1 $ do {
421 ; (ss2,ds) <- repBinds wheres
422 ; addBinds ss2 $ do {
423 gs <- repGuards guards
424 ; clause <- repClause ps1 gs ds
425 ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
427 repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
428 repGuards [GRHS [ResultStmt e loc] loc2]
429 = do {a <- repE e; repNormal a }
431 = do { zs <- mapM process other;
432 repGuarded (nonEmptyCoreList (map corePair zs)) }
434 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
435 = do { x <- repE e1; y <- repE e2; return (x, y) }
436 process other = panic "Non Haskell 98 guarded body"
439 -----------------------------------------------------------------------------
440 -- Representing Stmt's is tricky, especially if bound variables
441 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
442 -- First gensym new names for every variable in any of the patterns.
443 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
444 -- if variables didn't shaddow, the static gensym wouldn't be necessary
445 -- and we could reuse the original names (x and x).
447 -- do { x'1 <- gensym "x"
448 -- ; x'2 <- gensym "x"
449 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
450 -- , BindSt (pvar x'2) [| f x |]
451 -- , NoBindSt [| g x |]
455 -- The strategy is to translate a whole list of do-bindings by building a
456 -- bigger environment, and a bigger set of meta bindings
457 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
458 -- of the expressions within the Do
460 -----------------------------------------------------------------------------
461 -- The helper function repSts computes the translation of each sub expression
462 -- and a bunch of prefix bindings denoting the dynamic renaming.
464 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
465 repSts [ResultStmt e loc] =
467 ; e1 <- repNoBindSt a
468 ; return ([], [e1]) }
469 repSts (BindStmt p e loc : ss) =
471 ; ss1 <- mkGenSyms (collectPatBinders p)
472 ; addBinds ss1 $ do {
474 ; (ss2,zs) <- repSts ss
475 ; z <- repBindSt p1 e2
476 ; return (ss1++ss2, z : zs) }}
477 repSts (LetStmt bs : ss) =
478 do { (ss1,ds) <- repBinds bs
480 ; (ss2,zs) <- addBinds ss1 (repSts ss)
481 ; return (ss1++ss2, z : zs) }
482 repSts (ExprStmt e ty loc : ss) =
484 ; z <- repNoBindSt e2
485 ; (ss2,zs) <- repSts ss
486 ; return (ss2, z : zs) }
487 repSts other = panic "Exotic Stmt in meta brackets"
490 -----------------------------------------------------------
492 -----------------------------------------------------------
494 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
496 = do { let { bndrs = collectHsBinders decs } ;
497 ss <- mkGenSyms bndrs ;
498 core <- addBinds ss (rep_binds decs) ;
499 core_list <- coreList declTyConName core ;
500 return (ss, core_list) }
502 rep_binds :: HsBinds Name -> DsM [Core M.Decl]
503 rep_binds EmptyBinds = return []
504 rep_binds (ThenBinds x y)
505 = do { core1 <- rep_binds x
506 ; core2 <- rep_binds y
507 ; return (core1 ++ core2) }
508 rep_binds (MonoBind bs sigs _)
509 = do { core1 <- rep_monobind bs
510 ; core2 <- rep_sigs sigs
511 ; return (core1 ++ core2) }
512 rep_binds (IPBinds _ _)
513 = panic "DsMeta:repBinds: can't do implicit parameters"
515 rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
516 rep_monobind EmptyMonoBinds = return []
517 rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
518 y1 <- rep_monobind y;
521 -- Note GHC treats declarations of a variable (not a pattern)
522 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
523 -- with an empty list of patterns
524 rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
525 = do { (ss,wherecore) <- repBinds wheres
526 ; guardcore <- addBinds ss (repGuards guards)
527 ; fn' <- lookupBinder fn
529 ; ans <- repVal p guardcore wherecore
532 rep_monobind (FunMonoBind fn infx ms loc)
533 = do { ms1 <- mapM repClauseTup ms
534 ; fn' <- lookupBinder fn
535 ; ans <- repFun fn' (nonEmptyCoreList ms1)
538 rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
539 = do { patcore <- repP pat
540 ; (ss,wherecore) <- repBinds wheres
541 ; guardcore <- addBinds ss (repGuards guards)
542 ; ans <- repVal patcore guardcore wherecore
545 rep_monobind (VarMonoBind v e)
546 = do { v' <- lookupBinder v
549 ; patcore <- repPvar v'
550 ; empty_decls <- coreList declTyConName []
551 ; ans <- repVal patcore x empty_decls
554 -----------------------------------------------------------------------------
555 -- Since everything in a MonoBind is mutually recursive we need rename all
556 -- all the variables simultaneously. For example:
557 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
558 -- do { f'1 <- gensym "f"
559 -- ; g'2 <- gensym "g"
560 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
561 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
563 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
564 -- environment ( f |-> f'1 ) from each binding, and then unioning them
565 -- together. As we do this we collect GenSymBinds's which represent the renamed
566 -- variables bound by the Bindings. In order not to lose track of these
567 -- representations we build a shadow datatype MB with the same structure as
568 -- MonoBinds, but which has slots for the representations
571 -----------------------------------------------------------------------------
572 -- GHC allows a more general form of lambda abstraction than specified
573 -- by Haskell 98. In particular it allows guarded lambda's like :
574 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
575 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
576 -- (\ p1 .. pn -> exp) by causing an error.
578 repLambda :: Match Name -> DsM (Core M.Expr)
579 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
581 = do { let bndrs = collectPatsBinders ps ;
582 ; ss <- mkGenSyms bndrs
583 ; lam <- addBinds ss (
584 do { xs <- repPs ps; body <- repE e; repLam xs body })
585 ; wrapGenSyns expTyConName ss lam }
587 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
590 -----------------------------------------------------------------------------
592 -- repP deals with patterns. It assumes that we have already
593 -- walked over the pattern(s) once to collect the binders, and
594 -- have extended the environment. So every pattern-bound
595 -- variable should already appear in the environment.
597 -- Process a list of patterns
598 repPs :: [Pat Name] -> DsM (Core [M.Patt])
599 repPs ps = do { ps' <- mapM repP ps ;
600 coreList pattTyConName ps' }
602 repP :: Pat Name -> DsM (Core M.Patt)
603 repP (WildPat _) = repPwild
604 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
605 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
606 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
607 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
608 repP (ParPat p) = repP p
609 repP (ListPat ps _) = repListPat ps
610 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
611 repP (ConPatIn dc details)
612 = do { con_str <- lookupOcc dc
614 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
615 RecCon pairs -> error "No records in template haskell yet"
616 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
618 repP other = panic "Exotic pattern inside meta brackets"
620 repListPat :: [Pat Name] -> DsM (Core M.Patt)
621 repListPat [] = do { nil_con <- coreStringLit "[]"
622 ; nil_args <- coreList pattTyConName []
623 ; repPcon nil_con nil_args }
624 repListPat (p:ps) = do { p2 <- repP p
625 ; ps2 <- repListPat ps
626 ; cons_con <- coreStringLit ":"
627 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
630 ----------------------------------------------------------
631 -- The meta-environment
633 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
634 -- I.e. (x, x_id) means
635 -- let x_id = gensym "x" in ...
637 addBinds :: [GenSymBind] -> DsM a -> DsM a
638 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
640 lookupBinder :: Name -> DsM (Core String)
642 = do { mb_val <- dsLookupMetaEnv n;
644 Just (Bound id) -> return (MkC (Var id))
645 other -> pprPanic "Failed binder lookup:" (ppr n) }
647 mkGenSym :: Name -> DsM GenSymBind
648 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
650 mkGenSyms :: [Name] -> DsM [GenSymBind]
651 mkGenSyms ns = mapM mkGenSym ns
653 lookupType :: Name -- Name of type constructor (e.g. M.Expr)
654 -> DsM Type -- The type
655 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
656 return (mkGenTyConApp tc []) }
658 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
659 -- --> bindQ (gensym nm1) (\ id1 ->
660 -- bindQ (gensym nm2 (\ id2 ->
663 wrapGenSyns :: Name -- Name of the type (consructor) for 'a'
665 -> Core (M.Q a) -> DsM (Core (M.Q a))
666 wrapGenSyns tc_name binds body@(MkC b)
667 = do { elt_ty <- lookupType tc_name
670 go elt_ty [] = return body
671 go elt_ty ((name,id) : binds)
672 = do { MkC body' <- go elt_ty binds
673 ; lit_str <- localVar name
674 ; gensym_app <- repGensym lit_str
675 ; repBindQ stringTy elt_ty
676 gensym_app (MkC (Lam id body')) }
678 -- Just like wrapGenSym, but don't actually do the gensym
679 -- Instead use the existing name
680 -- Only used for [Decl]
681 wrapNongenSyms :: [GenSymBind]
682 -> Core [M.Decl] -> DsM (Core [M.Decl])
683 wrapNongenSyms binds body@(MkC b)
687 go ((name,id) : binds)
688 = do { MkC body' <- go binds
689 ; MkC lit_str <- localVar name -- No gensym
690 ; return (MkC (Let (NonRec id lit_str) body'))
693 void = placeHolderType
695 string :: String -> HsExpr Id
696 string s = HsLit (HsString (mkFastString s))
699 -- %*********************************************************************
703 -- %*********************************************************************
705 -----------------------------------------------------------------------------
706 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
707 -- we invent a new datatype which uses phantom types.
709 newtype Core a = MkC CoreExpr
712 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
713 rep2 n xs = do { id <- dsLookupGlobalId n
714 ; return (MkC (foldl App (Var id) xs)) }
716 -- Then we make "repConstructors" which use the phantom types for each of the
717 -- smart constructors of the Meta.Meta datatypes.
720 -- %*********************************************************************
722 -- The 'smart constructors'
724 -- %*********************************************************************
726 --------------- Patterns -----------------
727 repPlit :: Core M.Lit -> DsM (Core M.Patt)
728 repPlit (MkC l) = rep2 plitName [l]
730 repPvar :: Core String -> DsM (Core M.Patt)
731 repPvar (MkC s) = rep2 pvarName [s]
733 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
734 repPtup (MkC ps) = rep2 ptupName [ps]
736 repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
737 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
739 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
740 repPtilde (MkC p) = rep2 ptildeName [p]
742 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
743 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
745 repPwild :: DsM (Core M.Patt)
746 repPwild = rep2 pwildName []
748 --------------- Expressions -----------------
749 repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
750 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
751 | otherwise = repVar str
753 repVar :: Core String -> DsM (Core M.Expr)
754 repVar (MkC s) = rep2 varName [s]
756 repCon :: Core String -> DsM (Core M.Expr)
757 repCon (MkC s) = rep2 conName [s]
759 repLit :: Core M.Lit -> DsM (Core M.Expr)
760 repLit (MkC c) = rep2 litName [c]
762 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
763 repApp (MkC x) (MkC y) = rep2 appName [x,y]
765 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
766 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
768 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
769 repTup (MkC es) = rep2 tupName [es]
771 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
772 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
774 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
775 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
777 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
778 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
780 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
781 repDoE (MkC ss) = rep2 doEName [ss]
783 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
784 repComp (MkC ss) = rep2 compName [ss]
786 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
787 repListExp (MkC es) = rep2 listExpName [es]
789 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
790 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
792 repNeg :: Core M.Expr -> DsM (Core M.Expr)
793 repNeg (MkC x) = rep2 negName [x]
795 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
796 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
798 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
799 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
801 ------------ Right hand sides (guarded expressions) ----
802 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
803 repGuarded (MkC pairs) = rep2 guardedName [pairs]
805 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
806 repNormal (MkC e) = rep2 normalName [e]
808 ------------- Statements -------------------
809 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
810 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
812 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
813 repLetSt (MkC ds) = rep2 letStName [ds]
815 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
816 repNoBindSt (MkC e) = rep2 noBindStName [e]
818 -------------- DotDot (Arithmetic sequences) -----------
819 repFrom :: Core M.Expr -> DsM (Core M.Expr)
820 repFrom (MkC x) = rep2 fromName [x]
822 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
823 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
825 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
826 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
828 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
829 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
831 ------------ Match and Clause Tuples -----------
832 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
833 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
835 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
836 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
838 -------------- Dec -----------------------------
839 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
840 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
842 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
843 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
845 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
846 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
848 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
849 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
851 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
852 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
854 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
855 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
857 repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
858 repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
860 ------------ Types -------------------
862 repTvar :: Core String -> DsM (Core M.Type)
863 repTvar (MkC s) = rep2 tvarName [s]
865 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
866 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
868 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
869 repTapps f [] = return f
870 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
872 --------- Type constructors --------------
874 repNamedTyCon :: Core String -> DsM (Core M.Type)
875 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
877 repTupleTyCon :: Int -> DsM (Core M.Type)
878 -- Note: not Core Int; it's easier to be direct here
879 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
881 repArrowTyCon :: DsM (Core M.Type)
882 repArrowTyCon = rep2 arrowTyConName []
884 repListTyCon :: DsM (Core M.Type)
885 repListTyCon = rep2 listTyConName []
888 ----------------------------------------------------------
891 repLiteral :: HsLit -> DsM (Core M.Lit)
892 repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
893 repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
894 repLiteral x = panic "trying to represent exotic literal"
896 repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
897 repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
898 repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
901 --------------- Miscellaneous -------------------
903 repLift :: Core e -> DsM (Core M.Expr)
904 repLift (MkC x) = rep2 liftName [x]
906 repGensym :: Core String -> DsM (Core (M.Q String))
907 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
909 repBindQ :: Type -> Type -- a and b
910 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
911 repBindQ ty_a ty_b (MkC x) (MkC y)
912 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
914 ------------ Lists and Tuples -------------------
915 -- turn a list of patterns into a single pattern matching a list
917 coreList :: Name -- Of the TyCon of the element type
918 -> [Core a] -> DsM (Core [a])
920 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
922 coreList' :: Type -- The element type
923 -> [Core a] -> Core [a]
924 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
926 nonEmptyCoreList :: [Core a] -> Core [a]
927 -- The list must be non-empty so we can get the element type
928 -- Otherwise use coreList
929 nonEmptyCoreList [] = panic "coreList: empty argument"
930 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
932 corePair :: (Core a, Core b) -> Core (a,b)
933 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
935 lookupOcc :: Name -> DsM (Core String)
936 -- Lookup an occurrence; it can't be a splice.
937 -- Use the in-scope bindings if they exist
939 = do { mb_val <- dsLookupMetaEnv n ;
941 Nothing -> globalVar n
942 Just (Bound x) -> return (coreVar x)
943 other -> pprPanic "repE:lookupOcc" (ppr n)
946 globalVar :: Name -> DsM (Core String)
947 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
949 name_mod = moduleUserString (nameModule n)
950 name_occ = occNameUserString (nameOccName n)
952 localVar :: Name -> DsM (Core String)
953 localVar n = coreStringLit (occNameUserString (nameOccName n))
955 coreStringLit :: String -> DsM (Core String)
956 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
958 coreVar :: Id -> Core String -- The Id has type String
959 coreVar id = MkC (Var id)
963 -- %************************************************************************
965 -- The known-key names for Template Haskell
967 -- %************************************************************************
969 -- To add a name, do three things
973 -- 3) Add the name to knownKeyNames
975 templateHaskellNames :: NameSet
976 -- The names that are implicitly mentioned by ``bracket''
977 -- Should stay in sync with the import list of DsMeta
979 = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
980 pconName, ptildeName, paspatName, pwildName,
981 varName, conName, litName, appName, infixEName, lamName,
982 tupName, doEName, compName,
983 listExpName, condName, letEName, caseEName,
984 infixAppName, negName, sectionLName, sectionRName,
985 guardedName, normalName,
986 bindStName, letStName, noBindStName, parStName,
987 fromName, fromThenName, fromToName, fromThenToName,
988 funName, valName, liftName,
989 gensymName, returnQName, bindQName,
990 matchName, clauseName, funName, valName, dataDName, classDName,
991 instName, protoName, tvarName, tconName, tappName,
992 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
994 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
995 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
996 qTyConName, expTyConName, matTyConName, clsTyConName,
997 decTyConName, typTyConName ]
1000 varQual = mk_known_key_name OccName.varName
1001 tcQual = mk_known_key_name OccName.tcName
1004 -- NB: the THSyntax module comes from the "haskell-src" package
1005 thModule = mkThPkgModule mETA_META_Name
1007 mk_known_key_name space str uniq
1008 = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1010 intLName = varQual FSLIT("intL") intLIdKey
1011 charLName = varQual FSLIT("charL") charLIdKey
1012 plitName = varQual FSLIT("plit") plitIdKey
1013 pvarName = varQual FSLIT("pvar") pvarIdKey
1014 ptupName = varQual FSLIT("ptup") ptupIdKey
1015 pconName = varQual FSLIT("pcon") pconIdKey
1016 ptildeName = varQual FSLIT("ptilde") ptildeIdKey
1017 paspatName = varQual FSLIT("paspat") paspatIdKey
1018 pwildName = varQual FSLIT("pwild") pwildIdKey
1019 varName = varQual FSLIT("var") varIdKey
1020 conName = varQual FSLIT("con") conIdKey
1021 litName = varQual FSLIT("lit") litIdKey
1022 appName = varQual FSLIT("app") appIdKey
1023 infixEName = varQual FSLIT("infixE") infixEIdKey
1024 lamName = varQual FSLIT("lam") lamIdKey
1025 tupName = varQual FSLIT("tup") tupIdKey
1026 doEName = varQual FSLIT("doE") doEIdKey
1027 compName = varQual FSLIT("comp") compIdKey
1028 listExpName = varQual FSLIT("listExp") listExpIdKey
1029 condName = varQual FSLIT("cond") condIdKey
1030 letEName = varQual FSLIT("letE") letEIdKey
1031 caseEName = varQual FSLIT("caseE") caseEIdKey
1032 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1033 negName = varQual FSLIT("neg") negIdKey
1034 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1035 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1036 guardedName = varQual FSLIT("guarded") guardedIdKey
1037 normalName = varQual FSLIT("normal") normalIdKey
1038 bindStName = varQual FSLIT("bindSt") bindStIdKey
1039 letStName = varQual FSLIT("letSt") letStIdKey
1040 noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
1041 parStName = varQual FSLIT("parSt") parStIdKey
1042 fromName = varQual FSLIT("from") fromIdKey
1043 fromThenName = varQual FSLIT("fromThen") fromThenIdKey
1044 fromToName = varQual FSLIT("fromTo") fromToIdKey
1045 fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
1046 liftName = varQual FSLIT("lift") liftIdKey
1047 gensymName = varQual FSLIT("gensym") gensymIdKey
1048 returnQName = varQual FSLIT("returnQ") returnQIdKey
1049 bindQName = varQual FSLIT("bindQ") bindQIdKey
1052 matchName = varQual FSLIT("match") matchIdKey
1055 clauseName = varQual FSLIT("clause") clauseIdKey
1058 funName = varQual FSLIT("fun") funIdKey
1059 valName = varQual FSLIT("val") valIdKey
1060 dataDName = varQual FSLIT("dataD") dataDIdKey
1061 classDName = varQual FSLIT("classD") classDIdKey
1062 instName = varQual FSLIT("inst") instIdKey
1063 protoName = varQual FSLIT("proto") protoIdKey
1066 tvarName = varQual FSLIT("tvar") tvarIdKey
1067 tconName = varQual FSLIT("tcon") tconIdKey
1068 tappName = varQual FSLIT("tapp") tappIdKey
1071 arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
1072 tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
1073 listTyConName = varQual FSLIT("listTyCon") listIdKey
1074 namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
1077 constrName = varQual FSLIT("constr") constrIdKey
1079 exprTyConName = tcQual FSLIT("Expr") exprTyConKey
1080 declTyConName = tcQual FSLIT("Decl") declTyConKey
1081 pattTyConName = tcQual FSLIT("Patt") pattTyConKey
1082 mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey
1083 clseTyConName = tcQual FSLIT("Clse") clseTyConKey
1084 stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
1085 consTyConName = tcQual FSLIT("Cons") consTyConKey
1086 typeTyConName = tcQual FSLIT("Type") typeTyConKey
1088 qTyConName = tcQual FSLIT("Q") qTyConKey
1089 expTyConName = tcQual FSLIT("Exp") expTyConKey
1090 decTyConName = tcQual FSLIT("Dec") decTyConKey
1091 typTyConName = tcQual FSLIT("Typ") typTyConKey
1092 matTyConName = tcQual FSLIT("Mat") matTyConKey
1093 clsTyConName = tcQual FSLIT("Cls") clsTyConKey
1095 -- TyConUniques available: 100-119
1096 -- Check in PrelNames if you want to change this
1098 expTyConKey = mkPreludeTyConUnique 100
1099 matTyConKey = mkPreludeTyConUnique 101
1100 clsTyConKey = mkPreludeTyConUnique 102
1101 qTyConKey = mkPreludeTyConUnique 103
1102 exprTyConKey = mkPreludeTyConUnique 104
1103 declTyConKey = mkPreludeTyConUnique 105
1104 pattTyConKey = mkPreludeTyConUnique 106
1105 mtchTyConKey = mkPreludeTyConUnique 107
1106 clseTyConKey = mkPreludeTyConUnique 108
1107 stmtTyConKey = mkPreludeTyConUnique 109
1108 consTyConKey = mkPreludeTyConUnique 110
1109 typeTyConKey = mkPreludeTyConUnique 111
1110 typTyConKey = mkPreludeTyConUnique 112
1111 decTyConKey = mkPreludeTyConUnique 113
1115 -- IdUniques available: 200-299
1116 -- If you want to change this, make sure you check in PrelNames
1117 fromIdKey = mkPreludeMiscIdUnique 200
1118 fromThenIdKey = mkPreludeMiscIdUnique 201
1119 fromToIdKey = mkPreludeMiscIdUnique 202
1120 fromThenToIdKey = mkPreludeMiscIdUnique 203
1121 liftIdKey = mkPreludeMiscIdUnique 204
1122 gensymIdKey = mkPreludeMiscIdUnique 205
1123 returnQIdKey = mkPreludeMiscIdUnique 206
1124 bindQIdKey = mkPreludeMiscIdUnique 207
1125 funIdKey = mkPreludeMiscIdUnique 208
1126 valIdKey = mkPreludeMiscIdUnique 209
1127 protoIdKey = mkPreludeMiscIdUnique 210
1128 matchIdKey = mkPreludeMiscIdUnique 211
1129 clauseIdKey = mkPreludeMiscIdUnique 212
1130 intLIdKey = mkPreludeMiscIdUnique 213
1131 charLIdKey = mkPreludeMiscIdUnique 214
1133 classDIdKey = mkPreludeMiscIdUnique 215
1134 instIdKey = mkPreludeMiscIdUnique 216
1135 dataDIdKey = mkPreludeMiscIdUnique 217
1138 plitIdKey = mkPreludeMiscIdUnique 220
1139 pvarIdKey = mkPreludeMiscIdUnique 221
1140 ptupIdKey = mkPreludeMiscIdUnique 222
1141 pconIdKey = mkPreludeMiscIdUnique 223
1142 ptildeIdKey = mkPreludeMiscIdUnique 224
1143 paspatIdKey = mkPreludeMiscIdUnique 225
1144 pwildIdKey = mkPreludeMiscIdUnique 226
1145 varIdKey = mkPreludeMiscIdUnique 227
1146 conIdKey = mkPreludeMiscIdUnique 228
1147 litIdKey = mkPreludeMiscIdUnique 229
1148 appIdKey = mkPreludeMiscIdUnique 230
1149 infixEIdKey = mkPreludeMiscIdUnique 231
1150 lamIdKey = mkPreludeMiscIdUnique 232
1151 tupIdKey = mkPreludeMiscIdUnique 233
1152 doEIdKey = mkPreludeMiscIdUnique 234
1153 compIdKey = mkPreludeMiscIdUnique 235
1154 listExpIdKey = mkPreludeMiscIdUnique 237
1155 condIdKey = mkPreludeMiscIdUnique 238
1156 letEIdKey = mkPreludeMiscIdUnique 239
1157 caseEIdKey = mkPreludeMiscIdUnique 240
1158 infixAppIdKey = mkPreludeMiscIdUnique 241
1159 negIdKey = mkPreludeMiscIdUnique 242
1160 sectionLIdKey = mkPreludeMiscIdUnique 243
1161 sectionRIdKey = mkPreludeMiscIdUnique 244
1162 guardedIdKey = mkPreludeMiscIdUnique 245
1163 normalIdKey = mkPreludeMiscIdUnique 246
1164 bindStIdKey = mkPreludeMiscIdUnique 247
1165 letStIdKey = mkPreludeMiscIdUnique 248
1166 noBindStIdKey = mkPreludeMiscIdUnique 249
1167 parStIdKey = mkPreludeMiscIdUnique 250
1169 tvarIdKey = mkPreludeMiscIdUnique 251
1170 tconIdKey = mkPreludeMiscIdUnique 252
1171 tappIdKey = mkPreludeMiscIdUnique 253
1173 arrowIdKey = mkPreludeMiscIdUnique 254
1174 tupleIdKey = mkPreludeMiscIdUnique 255
1175 listIdKey = mkPreludeMiscIdUnique 256
1176 namedTyConIdKey = mkPreludeMiscIdUnique 257
1178 constrIdKey = mkPreludeMiscIdUnique 258
1180 -- %************************************************************************
1184 -- %************************************************************************
1186 -- It is rather usatisfactory that we don't have a SrcLoc
1187 addDsWarn :: SDoc -> DsM ()
1188 addDsWarn msg = dsWarn (noSrcLoc, msg)