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(..) )
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 repE :: HsExpr Name -> DsM (Core M.Expr)
312 = do { mb_val <- dsLookupMetaEnv x
314 Nothing -> do { str <- globalVar x
315 ; repVarOrCon x str }
316 Just (Bound y) -> repVarOrCon x (coreVar y)
317 Just (Splice e) -> do { e' <- dsExpr e
318 ; return (MkC e') } }
320 repE (HsIPVar x) = panic "Can't represent implicit parameters"
321 repE (HsLit l) = do { a <- repLiteral l; repLit a }
322 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
324 repE (HsSplice n e loc)
325 = do { mb_val <- dsLookupMetaEnv n
327 Just (Splice e) -> do { e' <- dsExpr e
329 other -> pprPanic "HsSplice" (ppr n) }
332 repE (HsLam m) = repLambda m
333 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
334 repE (NegApp x nm) = panic "No negate yet"
335 repE (HsPar x) = repE x
336 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
337 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
339 repE (OpApp e1 (HsVar op) fix e2)
340 = do { arg1 <- repE e1;
342 the_op <- lookupOcc op ;
343 repInfixApp arg1 the_op arg2 }
345 repE (HsCase e ms loc)
347 ; ms2 <- mapM repMatchTup ms
348 ; repCaseE arg (nonEmptyCoreList ms2) }
350 -- I havn't got the types here right yet
351 repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts;
352 e <- repDoE (nonEmptyCoreList zs);
353 wrapGenSyns expTyConName ss e }
354 repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
355 e <- repComp (nonEmptyCoreList zs);
356 wrapGenSyns expTyConName ss e }
358 repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 }
359 repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
360 repFromThen ds1 ds2 }
361 repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2;
363 repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
364 ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
366 repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
368 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
369 ; e2 <- addBinds ss (repE e)
371 ; wrapGenSyns expTyConName ss z }
372 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
373 repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs }
375 repE (ExplicitPArr ty es) = panic "repE: No parallel arrays yet"
376 repE (RecordConOut _ _ _) = panic "repE: No record construction yet"
377 repE (RecordUpdOut _ _ _ _) = panic "repE: No record update yet"
378 repE (ExprWithTySig e ty) =
379 panic "repE: No expressions with type signatures yet"
380 repE (HsCCall _ _ _ _ _) = panic "repE: Can't represent __ccall__"
381 repE (HsSCC _ _) = panic "repE: Can't represent SCC"
382 repE (HsBracketOut _ _) = panic "repE: No Oxford brackets yet"
383 repE (HsReify _) = panic "repE: No reification yet"
385 -----------------------------------------------------------------------------
386 -- Building representations of auxillary structures like Match, Clause, Stmt,
388 repMatchTup :: Match Name -> DsM (Core M.Mtch)
389 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
390 do { ss1 <- mkGenSyms (collectPatBinders p)
391 ; addBinds ss1 $ do {
393 ; (ss2,ds) <- repBinds wheres
394 ; addBinds ss2 $ do {
395 ; gs <- repGuards guards
396 ; match <- repMatch p1 gs ds
397 ; wrapGenSyns matTyConName (ss1++ss2) match }}}
399 repClauseTup :: Match Name -> DsM (Core M.Clse)
400 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
401 do { ss1 <- mkGenSyms (collectPatsBinders ps)
402 ; addBinds ss1 $ do {
404 ; (ss2,ds) <- repBinds wheres
405 ; addBinds ss2 $ do {
406 gs <- repGuards guards
407 ; clause <- repClause ps1 gs ds
408 ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
410 repGuards :: [GRHS Name] -> DsM (Core M.Rihs)
411 repGuards [GRHS [ResultStmt e loc] loc2]
412 = do {a <- repE e; repNormal a }
414 = do { zs <- mapM process other;
415 repGuarded (nonEmptyCoreList (map corePair zs)) }
417 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
418 = do { x <- repE e1; y <- repE e2; return (x, y) }
419 process other = panic "Non Haskell 98 guarded body"
422 -----------------------------------------------------------------------------
423 -- Representing Stmt's is tricky, especially if bound variables
424 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
425 -- First gensym new names for every variable in any of the patterns.
426 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
427 -- if variables didn't shaddow, the static gensym wouldn't be necessary
428 -- and we could reuse the original names (x and x).
430 -- do { x'1 <- gensym "x"
431 -- ; x'2 <- gensym "x"
432 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
433 -- , BindSt (pvar x'2) [| f x |]
434 -- , NoBindSt [| g x |]
438 -- The strategy is to translate a whole list of do-bindings by building a
439 -- bigger environment, and a bigger set of meta bindings
440 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
441 -- of the expressions within the Do
443 -----------------------------------------------------------------------------
444 -- The helper function repSts computes the translation of each sub expression
445 -- and a bunch of prefix bindings denoting the dynamic renaming.
447 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
448 repSts [ResultStmt e loc] =
450 ; e1 <- repNoBindSt a
451 ; return ([], [e1]) }
452 repSts (BindStmt p e loc : ss) =
454 ; ss1 <- mkGenSyms (collectPatBinders p)
455 ; addBinds ss1 $ do {
457 ; (ss2,zs) <- repSts ss
458 ; z <- repBindSt p1 e2
459 ; return (ss1++ss2, z : zs) }}
460 repSts (LetStmt bs : ss) =
461 do { (ss1,ds) <- repBinds bs
463 ; (ss2,zs) <- addBinds ss1 (repSts ss)
464 ; return (ss1++ss2, z : zs) }
465 repSts (ExprStmt e ty loc : ss) =
467 ; z <- repNoBindSt e2
468 ; (ss2,zs) <- repSts ss
469 ; return (ss2, z : zs) }
470 repSts other = panic "Exotic Stmt in meta brackets"
473 -----------------------------------------------------------
475 -----------------------------------------------------------
477 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
479 = do { let { bndrs = collectHsBinders decs } ;
480 ss <- mkGenSyms bndrs ;
481 core <- addBinds ss (rep_binds decs) ;
482 core_list <- coreList declTyConName core ;
483 return (ss, core_list) }
485 rep_binds :: HsBinds Name -> DsM [Core M.Decl]
486 rep_binds EmptyBinds = return []
487 rep_binds (ThenBinds x y)
488 = do { core1 <- rep_binds x
489 ; core2 <- rep_binds y
490 ; return (core1 ++ core2) }
491 rep_binds (MonoBind bs sigs _)
492 = do { core1 <- rep_monobind bs
493 ; core2 <- rep_sigs sigs
494 ; return (core1 ++ core2) }
495 rep_binds (IPBinds _ _)
496 = panic "DsMeta:repBinds: can't do implicit parameters"
498 rep_monobind :: MonoBinds Name -> DsM [Core M.Decl]
499 rep_monobind EmptyMonoBinds = return []
500 rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x;
501 y1 <- rep_monobind y;
504 -- Note GHC treats declarations of a variable (not a pattern)
505 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
506 -- with an empty list of patterns
507 rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
508 = do { (ss,wherecore) <- repBinds wheres
509 ; guardcore <- addBinds ss (repGuards guards)
510 ; fn' <- lookupBinder fn
512 ; ans <- repVal p guardcore wherecore
515 rep_monobind (FunMonoBind fn infx ms loc)
516 = do { ms1 <- mapM repClauseTup ms
517 ; fn' <- lookupBinder fn
518 ; ans <- repFun fn' (nonEmptyCoreList ms1)
521 rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
522 = do { patcore <- repP pat
523 ; (ss,wherecore) <- repBinds wheres
524 ; guardcore <- addBinds ss (repGuards guards)
525 ; ans <- repVal patcore guardcore wherecore
528 rep_monobind (VarMonoBind v e)
529 = do { v' <- lookupBinder v
532 ; patcore <- repPvar v'
533 ; empty_decls <- coreList declTyConName []
534 ; ans <- repVal patcore x empty_decls
537 -----------------------------------------------------------------------------
538 -- Since everything in a MonoBind is mutually recursive we need rename all
539 -- all the variables simultaneously. For example:
540 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
541 -- do { f'1 <- gensym "f"
542 -- ; g'2 <- gensym "g"
543 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
544 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
546 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
547 -- environment ( f |-> f'1 ) from each binding, and then unioning them
548 -- together. As we do this we collect GenSymBinds's which represent the renamed
549 -- variables bound by the Bindings. In order not to lose track of these
550 -- representations we build a shadow datatype MB with the same structure as
551 -- MonoBinds, but which has slots for the representations
554 -----------------------------------------------------------------------------
555 -- GHC allows a more general form of lambda abstraction than specified
556 -- by Haskell 98. In particular it allows guarded lambda's like :
557 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
558 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
559 -- (\ p1 .. pn -> exp) by causing an error.
561 repLambda :: Match Name -> DsM (Core M.Expr)
562 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
564 = do { let bndrs = collectPatsBinders ps ;
565 ; ss <- mkGenSyms bndrs
566 ; lam <- addBinds ss (
567 do { xs <- repPs ps; body <- repE e; repLam xs body })
568 ; wrapGenSyns expTyConName ss lam }
570 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
573 -----------------------------------------------------------------------------
575 -- repP deals with patterns. It assumes that we have already
576 -- walked over the pattern(s) once to collect the binders, and
577 -- have extended the environment. So every pattern-bound
578 -- variable should already appear in the environment.
580 -- Process a list of patterns
581 repPs :: [Pat Name] -> DsM (Core [M.Patt])
582 repPs ps = do { ps' <- mapM repP ps ;
583 coreList pattTyConName ps' }
585 repP :: Pat Name -> DsM (Core M.Patt)
586 repP (WildPat _) = repPwild
587 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
588 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
589 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
590 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
591 repP (ParPat p) = repP p
592 repP (ListPat ps _) = repListPat ps
593 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
594 repP (ConPatIn dc details)
595 = do { con_str <- lookupOcc dc
597 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
598 RecCon pairs -> error "No records in template haskell yet"
599 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
601 repP other = panic "Exotic pattern inside meta brackets"
603 repListPat :: [Pat Name] -> DsM (Core M.Patt)
604 repListPat [] = do { nil_con <- coreStringLit "[]"
605 ; nil_args <- coreList pattTyConName []
606 ; repPcon nil_con nil_args }
607 repListPat (p:ps) = do { p2 <- repP p
608 ; ps2 <- repListPat ps
609 ; cons_con <- coreStringLit ":"
610 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
613 ----------------------------------------------------------
614 -- The meta-environment
616 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
617 -- I.e. (x, x_id) means
618 -- let x_id = gensym "x" in ...
620 addBinds :: [GenSymBind] -> DsM a -> DsM a
621 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
623 lookupBinder :: Name -> DsM (Core String)
625 = do { mb_val <- dsLookupMetaEnv n;
627 Just (Bound id) -> return (MkC (Var id))
628 other -> pprPanic "Failed binder lookup:" (ppr n) }
630 mkGenSym :: Name -> DsM GenSymBind
631 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
633 mkGenSyms :: [Name] -> DsM [GenSymBind]
634 mkGenSyms ns = mapM mkGenSym ns
636 lookupType :: Name -- Name of type constructor (e.g. M.Expr)
637 -> DsM Type -- The type
638 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
639 return (mkGenTyConApp tc []) }
641 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
642 -- --> bindQ (gensym nm1) (\ id1 ->
643 -- bindQ (gensym nm2 (\ id2 ->
646 wrapGenSyns :: Name -- Name of the type (consructor) for 'a'
648 -> Core (M.Q a) -> DsM (Core (M.Q a))
649 wrapGenSyns tc_name binds body@(MkC b)
650 = do { elt_ty <- lookupType tc_name
653 go elt_ty [] = return body
654 go elt_ty ((name,id) : binds)
655 = do { MkC body' <- go elt_ty binds
656 ; lit_str <- localVar name
657 ; gensym_app <- repGensym lit_str
658 ; repBindQ stringTy elt_ty
659 gensym_app (MkC (Lam id body')) }
661 -- Just like wrapGenSym, but don't actually do the gensym
662 -- Instead use the existing name
663 -- Only used for [Decl]
664 wrapNongenSyms :: [GenSymBind]
665 -> Core [M.Decl] -> DsM (Core [M.Decl])
666 wrapNongenSyms binds body@(MkC b)
670 go ((name,id) : binds)
671 = do { MkC body' <- go binds
672 ; MkC lit_str <- localVar name -- No gensym
673 ; return (MkC (Let (NonRec id lit_str) body'))
676 void = placeHolderType
678 string :: String -> HsExpr Id
679 string s = HsLit (HsString (mkFastString s))
682 -- %*********************************************************************
686 -- %*********************************************************************
688 -----------------------------------------------------------------------------
689 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
690 -- we invent a new datatype which uses phantom types.
692 newtype Core a = MkC CoreExpr
695 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
696 rep2 n xs = do { id <- dsLookupGlobalId n
697 ; return (MkC (foldl App (Var id) xs)) }
699 -- Then we make "repConstructors" which use the phantom types for each of the
700 -- smart constructors of the Meta.Meta datatypes.
703 -- %*********************************************************************
705 -- The 'smart constructors'
707 -- %*********************************************************************
709 --------------- Patterns -----------------
710 repPlit :: Core M.Lit -> DsM (Core M.Patt)
711 repPlit (MkC l) = rep2 plitName [l]
713 repPvar :: Core String -> DsM (Core M.Patt)
714 repPvar (MkC s) = rep2 pvarName [s]
716 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
717 repPtup (MkC ps) = rep2 ptupName [ps]
719 repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
720 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
722 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
723 repPtilde (MkC p) = rep2 ptildeName [p]
725 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
726 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
728 repPwild :: DsM (Core M.Patt)
729 repPwild = rep2 pwildName []
731 --------------- Expressions -----------------
732 repVarOrCon :: Name -> Core String -> DsM (Core M.Expr)
733 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
734 | otherwise = repVar str
736 repVar :: Core String -> DsM (Core M.Expr)
737 repVar (MkC s) = rep2 varName [s]
739 repCon :: Core String -> DsM (Core M.Expr)
740 repCon (MkC s) = rep2 conName [s]
742 repLit :: Core M.Lit -> DsM (Core M.Expr)
743 repLit (MkC c) = rep2 litName [c]
745 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
746 repApp (MkC x) (MkC y) = rep2 appName [x,y]
748 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
749 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
751 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
752 repTup (MkC es) = rep2 tupName [es]
754 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
755 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
757 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
758 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
760 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
761 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
763 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
764 repDoE (MkC ss) = rep2 doEName [ss]
766 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
767 repComp (MkC ss) = rep2 compName [ss]
769 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
770 repListExp (MkC es) = rep2 listExpName [es]
772 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
773 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
775 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
776 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
778 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
779 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
781 ------------ Right hand sides (guarded expressions) ----
782 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
783 repGuarded (MkC pairs) = rep2 guardedName [pairs]
785 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
786 repNormal (MkC e) = rep2 normalName [e]
788 ------------- Statements -------------------
789 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
790 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
792 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
793 repLetSt (MkC ds) = rep2 letStName [ds]
795 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
796 repNoBindSt (MkC e) = rep2 noBindStName [e]
798 -------------- DotDot (Arithmetic sequences) -----------
799 repFrom :: Core M.Expr -> DsM (Core M.Expr)
800 repFrom (MkC x) = rep2 fromName [x]
802 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
803 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
805 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
806 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
808 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
809 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
811 ------------ Match and Clause Tuples -----------
812 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
813 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
815 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
816 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
818 -------------- Dec -----------------------------
819 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
820 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
822 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
823 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
825 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
826 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
828 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
829 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
831 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
832 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
834 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
835 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
837 repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
838 repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
840 ------------ Types -------------------
842 repTvar :: Core String -> DsM (Core M.Type)
843 repTvar (MkC s) = rep2 tvarName [s]
845 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
846 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
848 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
849 repTapps f [] = return f
850 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
852 --------- Type constructors --------------
854 repNamedTyCon :: Core String -> DsM (Core M.Type)
855 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
857 repTupleTyCon :: Int -> DsM (Core M.Type)
858 -- Note: not Core Int; it's easier to be direct here
859 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
861 repArrowTyCon :: DsM (Core M.Type)
862 repArrowTyCon = rep2 arrowTyConName []
864 repListTyCon :: DsM (Core M.Type)
865 repListTyCon = rep2 listTyConName []
868 ----------------------------------------------------------
871 repLiteral :: HsLit -> DsM (Core M.Lit)
872 repLiteral (HsInt i) = rep2 intLName [mkIntExpr i]
873 repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
874 repLiteral x = panic "trying to represent exotic literal"
876 repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
877 repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i]
878 repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
881 --------------- Miscellaneous -------------------
883 repLift :: Core e -> DsM (Core M.Expr)
884 repLift (MkC x) = rep2 liftName [x]
886 repGensym :: Core String -> DsM (Core (M.Q String))
887 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
889 repBindQ :: Type -> Type -- a and b
890 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
891 repBindQ ty_a ty_b (MkC x) (MkC y)
892 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
894 ------------ Lists and Tuples -------------------
895 -- turn a list of patterns into a single pattern matching a list
897 coreList :: Name -- Of the TyCon of the element type
898 -> [Core a] -> DsM (Core [a])
900 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
902 coreList' :: Type -- The element type
903 -> [Core a] -> Core [a]
904 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
906 nonEmptyCoreList :: [Core a] -> Core [a]
907 -- The list must be non-empty so we can get the element type
908 -- Otherwise use coreList
909 nonEmptyCoreList [] = panic "coreList: empty argument"
910 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
912 corePair :: (Core a, Core b) -> Core (a,b)
913 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
915 lookupOcc :: Name -> DsM (Core String)
916 -- Lookup an occurrence; it can't be a splice.
917 -- Use the in-scope bindings if they exist
919 = do { mb_val <- dsLookupMetaEnv n ;
921 Nothing -> globalVar n
922 Just (Bound x) -> return (coreVar x)
923 other -> pprPanic "repE:lookupOcc" (ppr n)
926 globalVar :: Name -> DsM (Core String)
927 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
929 name_mod = moduleUserString (nameModule n)
930 name_occ = occNameUserString (nameOccName n)
932 localVar :: Name -> DsM (Core String)
933 localVar n = coreStringLit (occNameUserString (nameOccName n))
935 coreStringLit :: String -> DsM (Core String)
936 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
938 coreVar :: Id -> Core String -- The Id has type String
939 coreVar id = MkC (Var id)
943 -- %************************************************************************
945 -- The known-key names for Template Haskell
947 -- %************************************************************************
949 -- To add a name, do three things
953 -- 3) Add the name to knownKeyNames
955 templateHaskellNames :: NameSet
956 -- The names that are implicitly mentioned by ``bracket''
957 -- Should stay in sync with the import list of DsMeta
959 = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName,
960 pconName, ptildeName, paspatName, pwildName,
961 varName, conName, litName, appName, infixEName, lamName,
962 tupName, doEName, compName,
963 listExpName, condName, letEName, caseEName,
964 infixAppName, sectionLName, sectionRName, guardedName, normalName,
965 bindStName, letStName, noBindStName, parStName,
966 fromName, fromThenName, fromToName, fromThenToName,
967 funName, valName, liftName,
968 gensymName, returnQName, bindQName,
969 matchName, clauseName, funName, valName, dataDName, classDName,
970 instName, protoName, tvarName, tconName, tappName,
971 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
973 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
974 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
975 qTyConName, expTyConName, matTyConName, clsTyConName,
976 decTyConName, typTyConName ]
979 varQual = mk_known_key_name OccName.varName
980 tcQual = mk_known_key_name OccName.tcName
983 -- NB: the THSyntax module comes from the "haskell-src" package
984 thModule = mkThPkgModule mETA_META_Name
986 mk_known_key_name space str uniq
987 = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
989 intLName = varQual FSLIT("intL") intLIdKey
990 charLName = varQual FSLIT("charL") charLIdKey
991 plitName = varQual FSLIT("plit") plitIdKey
992 pvarName = varQual FSLIT("pvar") pvarIdKey
993 ptupName = varQual FSLIT("ptup") ptupIdKey
994 pconName = varQual FSLIT("pcon") pconIdKey
995 ptildeName = varQual FSLIT("ptilde") ptildeIdKey
996 paspatName = varQual FSLIT("paspat") paspatIdKey
997 pwildName = varQual FSLIT("pwild") pwildIdKey
998 varName = varQual FSLIT("var") varIdKey
999 conName = varQual FSLIT("con") conIdKey
1000 litName = varQual FSLIT("lit") litIdKey
1001 appName = varQual FSLIT("app") appIdKey
1002 infixEName = varQual FSLIT("infixE") infixEIdKey
1003 lamName = varQual FSLIT("lam") lamIdKey
1004 tupName = varQual FSLIT("tup") tupIdKey
1005 doEName = varQual FSLIT("doE") doEIdKey
1006 compName = varQual FSLIT("comp") compIdKey
1007 listExpName = varQual FSLIT("listExp") listExpIdKey
1008 condName = varQual FSLIT("cond") condIdKey
1009 letEName = varQual FSLIT("letE") letEIdKey
1010 caseEName = varQual FSLIT("caseE") caseEIdKey
1011 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1012 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1013 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1014 guardedName = varQual FSLIT("guarded") guardedIdKey
1015 normalName = varQual FSLIT("normal") normalIdKey
1016 bindStName = varQual FSLIT("bindSt") bindStIdKey
1017 letStName = varQual FSLIT("letSt") letStIdKey
1018 noBindStName = varQual FSLIT("noBindSt") noBindStIdKey
1019 parStName = varQual FSLIT("parSt") parStIdKey
1020 fromName = varQual FSLIT("from") fromIdKey
1021 fromThenName = varQual FSLIT("fromThen") fromThenIdKey
1022 fromToName = varQual FSLIT("fromTo") fromToIdKey
1023 fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey
1024 liftName = varQual FSLIT("lift") liftIdKey
1025 gensymName = varQual FSLIT("gensym") gensymIdKey
1026 returnQName = varQual FSLIT("returnQ") returnQIdKey
1027 bindQName = varQual FSLIT("bindQ") bindQIdKey
1030 matchName = varQual FSLIT("match") matchIdKey
1033 clauseName = varQual FSLIT("clause") clauseIdKey
1036 funName = varQual FSLIT("fun") funIdKey
1037 valName = varQual FSLIT("val") valIdKey
1038 dataDName = varQual FSLIT("dataD") dataDIdKey
1039 classDName = varQual FSLIT("classD") classDIdKey
1040 instName = varQual FSLIT("inst") instIdKey
1041 protoName = varQual FSLIT("proto") protoIdKey
1044 tvarName = varQual FSLIT("tvar") tvarIdKey
1045 tconName = varQual FSLIT("tcon") tconIdKey
1046 tappName = varQual FSLIT("tapp") tappIdKey
1049 arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
1050 tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
1051 listTyConName = varQual FSLIT("listTyCon") listIdKey
1052 namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
1055 constrName = varQual FSLIT("constr") constrIdKey
1057 exprTyConName = tcQual FSLIT("Expr") exprTyConKey
1058 declTyConName = tcQual FSLIT("Decl") declTyConKey
1059 pattTyConName = tcQual FSLIT("Patt") pattTyConKey
1060 mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey
1061 clseTyConName = tcQual FSLIT("Clse") clseTyConKey
1062 stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey
1063 consTyConName = tcQual FSLIT("Cons") consTyConKey
1064 typeTyConName = tcQual FSLIT("Type") typeTyConKey
1066 qTyConName = tcQual FSLIT("Q") qTyConKey
1067 expTyConName = tcQual FSLIT("Exp") expTyConKey
1068 decTyConName = tcQual FSLIT("Dec") decTyConKey
1069 typTyConName = tcQual FSLIT("Typ") typTyConKey
1070 matTyConName = tcQual FSLIT("Mat") matTyConKey
1071 clsTyConName = tcQual FSLIT("Cls") clsTyConKey
1073 -- TyConUniques available: 100-119
1074 -- Check in PrelNames if you want to change this
1076 expTyConKey = mkPreludeTyConUnique 100
1077 matTyConKey = mkPreludeTyConUnique 101
1078 clsTyConKey = mkPreludeTyConUnique 102
1079 qTyConKey = mkPreludeTyConUnique 103
1080 exprTyConKey = mkPreludeTyConUnique 104
1081 declTyConKey = mkPreludeTyConUnique 105
1082 pattTyConKey = mkPreludeTyConUnique 106
1083 mtchTyConKey = mkPreludeTyConUnique 107
1084 clseTyConKey = mkPreludeTyConUnique 108
1085 stmtTyConKey = mkPreludeTyConUnique 109
1086 consTyConKey = mkPreludeTyConUnique 110
1087 typeTyConKey = mkPreludeTyConUnique 111
1088 typTyConKey = mkPreludeTyConUnique 112
1089 decTyConKey = mkPreludeTyConUnique 113
1093 -- IdUniques available: 200-299
1094 -- If you want to change this, make sure you check in PrelNames
1095 fromIdKey = mkPreludeMiscIdUnique 200
1096 fromThenIdKey = mkPreludeMiscIdUnique 201
1097 fromToIdKey = mkPreludeMiscIdUnique 202
1098 fromThenToIdKey = mkPreludeMiscIdUnique 203
1099 liftIdKey = mkPreludeMiscIdUnique 204
1100 gensymIdKey = mkPreludeMiscIdUnique 205
1101 returnQIdKey = mkPreludeMiscIdUnique 206
1102 bindQIdKey = mkPreludeMiscIdUnique 207
1103 funIdKey = mkPreludeMiscIdUnique 208
1104 valIdKey = mkPreludeMiscIdUnique 209
1105 protoIdKey = mkPreludeMiscIdUnique 210
1106 matchIdKey = mkPreludeMiscIdUnique 211
1107 clauseIdKey = mkPreludeMiscIdUnique 212
1108 intLIdKey = mkPreludeMiscIdUnique 213
1109 charLIdKey = mkPreludeMiscIdUnique 214
1111 classDIdKey = mkPreludeMiscIdUnique 215
1112 instIdKey = mkPreludeMiscIdUnique 216
1113 dataDIdKey = mkPreludeMiscIdUnique 217
1116 plitIdKey = mkPreludeMiscIdUnique 220
1117 pvarIdKey = mkPreludeMiscIdUnique 221
1118 ptupIdKey = mkPreludeMiscIdUnique 222
1119 pconIdKey = mkPreludeMiscIdUnique 223
1120 ptildeIdKey = mkPreludeMiscIdUnique 224
1121 paspatIdKey = mkPreludeMiscIdUnique 225
1122 pwildIdKey = mkPreludeMiscIdUnique 226
1123 varIdKey = mkPreludeMiscIdUnique 227
1124 conIdKey = mkPreludeMiscIdUnique 228
1125 litIdKey = mkPreludeMiscIdUnique 229
1126 appIdKey = mkPreludeMiscIdUnique 230
1127 infixEIdKey = mkPreludeMiscIdUnique 231
1128 lamIdKey = mkPreludeMiscIdUnique 232
1129 tupIdKey = mkPreludeMiscIdUnique 233
1130 doEIdKey = mkPreludeMiscIdUnique 234
1131 compIdKey = mkPreludeMiscIdUnique 235
1132 listExpIdKey = mkPreludeMiscIdUnique 237
1133 condIdKey = mkPreludeMiscIdUnique 238
1134 letEIdKey = mkPreludeMiscIdUnique 239
1135 caseEIdKey = mkPreludeMiscIdUnique 240
1136 infixAppIdKey = mkPreludeMiscIdUnique 241
1137 sectionLIdKey = mkPreludeMiscIdUnique 242
1138 sectionRIdKey = mkPreludeMiscIdUnique 243
1139 guardedIdKey = mkPreludeMiscIdUnique 244
1140 normalIdKey = mkPreludeMiscIdUnique 245
1141 bindStIdKey = mkPreludeMiscIdUnique 246
1142 letStIdKey = mkPreludeMiscIdUnique 247
1143 noBindStIdKey = mkPreludeMiscIdUnique 248
1144 parStIdKey = mkPreludeMiscIdUnique 249
1146 tvarIdKey = mkPreludeMiscIdUnique 250
1147 tconIdKey = mkPreludeMiscIdUnique 251
1148 tappIdKey = mkPreludeMiscIdUnique 252
1150 arrowIdKey = mkPreludeMiscIdUnique 253
1151 tupleIdKey = mkPreludeMiscIdUnique 254
1152 listIdKey = mkPreludeMiscIdUnique 255
1153 namedTyConIdKey = mkPreludeMiscIdUnique 256
1155 constrIdKey = mkPreludeMiscIdUnique 257
1157 -- %************************************************************************
1161 -- %************************************************************************
1163 -- It is rather usatisfactory that we don't have a SrcLoc
1164 addDsWarn :: SDoc -> DsM ()
1165 addDsWarn msg = dsWarn (noSrcLoc, msg)