1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2006
5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
7 -- input HsExpr. We do this in the DsM monad, which supplies access to
8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
10 -- It also defines a bunch of knownKeyNames, in the same way as is done
11 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
17 -- The above warning supression flag is a temporary kludge.
18 -- While working on this module you are encouraged to remove it and fix
19 -- any warnings in the module. See
20 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
23 module DsMeta( dsBracket,
24 templateHaskellNames, qTyConName, nameTyConName,
25 liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
26 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
27 quoteExpName, quotePatName
30 #include "HsVersions.h"
32 import {-# SOURCE #-} DsExpr ( dsExpr )
38 import qualified Language.Haskell.TH as TH
43 -- To avoid clashes with DsMeta.varName we must make a local alias for
44 -- OccName.varName we do this by removing varName from the import of
45 -- OccName above, making a qualified instance of OccName and using
46 -- OccNameAlias.varName where varName ws previously used in this file.
47 import qualified OccName
71 -----------------------------------------------------------------------------
72 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
73 -- Returns a CoreExpr of type TH.ExpQ
74 -- The quoted thing is parameterised over Name, even though it has
75 -- been type checked. We don't want all those type decorations!
77 dsBracket brack splices
78 = dsExtendMetaEnv new_bit (do_brack brack)
80 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
82 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
83 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
84 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
85 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
86 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
88 {- -------------- Examples --------------------
92 gensym (unpackString "x"#) `bindQ` \ x1::String ->
93 lam (pvar x1) (var x1)
96 [| \x -> $(f [| x |]) |]
98 gensym (unpackString "x"#) `bindQ` \ x1::String ->
99 lam (pvar x1) (f (var x1))
103 -------------------------------------------------------
105 -------------------------------------------------------
107 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
109 = do { let { bndrs = map unLoc (groupBinders group) } ;
110 ss <- mkGenSyms bndrs ;
112 -- Bind all the names mainly to avoid repeated use of explicit strings.
114 -- do { t :: String <- genSym "T" ;
115 -- return (Data t [] ...more t's... }
116 -- The other important reason is that the output must mention
117 -- only "T", not "Foo:T" where Foo is the current module
120 decls <- addBinds ss (do {
121 val_ds <- rep_val_binds (hs_valds group) ;
122 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
123 inst_ds <- mapM repInstD' (hs_instds group) ;
124 for_ds <- mapM repForD (hs_fords group) ;
126 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
128 decl_ty <- lookupType decQTyConName ;
129 let { core_list = coreList' decl_ty decls } ;
131 dec_ty <- lookupType decTyConName ;
132 q_decs <- repSequenceQ dec_ty core_list ;
134 wrapNongenSyms ss q_decs
135 -- Do *not* gensym top-level binders
138 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
139 hs_fords = foreign_decls })
140 -- Collect the binders of a Group
141 = collectHsValBinders val_decls ++
142 [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
143 [n | L _ (ForeignImport n _ _) <- foreign_decls]
146 {- Note [Binders and occurrences]
147 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
148 When we desugar [d| data T = MkT |]
150 Data "T" [] [Con "MkT" []] []
152 Data "Foo:T" [] [Con "Foo:MkT" []] []
153 That is, the new data decl should fit into whatever new module it is
154 asked to fit in. We do *not* clone, though; no need for this:
161 then we must desugar to
162 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
164 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
165 And we use lookupOcc, rather than lookupBinder
166 in repTyClD and repC.
170 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
172 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
173 tcdLName = tc, tcdTyVars = tvs,
174 tcdCons = cons, tcdDerivs = mb_derivs }))
175 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
176 dec <- addTyVarBinds tvs $ \bndrs -> do {
177 cxt1 <- repLContext cxt ;
178 cons1 <- mapM repC cons ;
179 cons2 <- coreList conQTyConName cons1 ;
180 derivs1 <- repDerivs mb_derivs ;
181 bndrs1 <- coreList nameTyConName bndrs ;
182 repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
183 return $ Just (loc, dec) }
185 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
186 tcdLName = tc, tcdTyVars = tvs,
187 tcdCons = [con], tcdDerivs = mb_derivs }))
188 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
189 dec <- addTyVarBinds tvs $ \bndrs -> do {
190 cxt1 <- repLContext cxt ;
192 derivs1 <- repDerivs mb_derivs ;
193 bndrs1 <- coreList nameTyConName bndrs ;
194 repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
195 return $ Just (loc, dec) }
197 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
198 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
199 dec <- addTyVarBinds tvs $ \bndrs -> do {
201 bndrs1 <- coreList nameTyConName bndrs ;
202 repTySyn tc1 bndrs1 ty1 } ;
203 return (Just (loc, dec)) }
205 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
208 tcdSigs = sigs, tcdMeths = meth_binds }))
209 = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
210 dec <- addTyVarBinds tvs $ \bndrs -> do {
211 cxt1 <- repLContext cxt ;
212 sigs1 <- rep_sigs sigs ;
213 binds1 <- rep_binds meth_binds ;
214 fds1 <- repLFunDeps fds;
215 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
216 bndrs1 <- coreList nameTyConName bndrs ;
217 repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
218 return $ Just (loc, dec) }
221 repTyClD (L loc d) = putSrcSpanDs loc $
222 do { warnDs (hang ds_msg 4 (ppr d))
227 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
228 repLFunDeps fds = do fds' <- mapM repLFunDep fds
229 fdList <- coreList funDepTyConName fds'
232 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
233 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
234 ys' <- mapM lookupBinder ys
235 xs_list <- coreList nameTyConName xs'
236 ys_list <- coreList nameTyConName ys'
237 repFunDep xs_list ys_list
239 repInstD' (L loc (InstDecl ty binds _ _)) -- Ignore user pragmas for now
240 = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
241 -- We must bring the type variables into scope, so their occurrences
242 -- don't fail, even though the binders don't appear in the resulting
244 do { cxt1 <- repContext cxt
245 ; inst_ty1 <- repPred (HsClassP cls tys)
246 ; ss <- mkGenSyms (collectHsBindBinders binds)
247 ; binds1 <- addBinds ss (rep_binds binds)
248 ; decls1 <- coreList decQTyConName binds1
249 ; decls2 <- wrapNongenSyms ss decls1
250 -- wrapNonGenSyms: do not clone the class op names!
251 -- They must be called 'op' etc, not 'op34'
252 ; repInst cxt1 inst_ty1 decls2 }
256 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
258 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
259 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
260 = do MkC name' <- lookupLOcc name
261 MkC typ' <- repLTy typ
262 MkC cc' <- repCCallConv cc
263 MkC s' <- repSafety s
264 cis' <- conv_cimportspec cis
265 MkC str <- coreStringLit $ static
266 ++ unpackFS ch ++ " "
267 ++ unpackFS cn ++ " "
269 dec <- rep2 forImpDName [cc', s', str, name', typ']
272 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
273 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
274 conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
275 conv_cimportspec CWrapper = return "wrapper"
277 CFunction (StaticTarget _) -> "static "
279 repForD decl = notHandled "Foreign declaration" (ppr decl)
281 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
282 repCCallConv CCallConv = rep2 cCallName []
283 repCCallConv StdCallConv = rep2 stdCallName []
285 repSafety :: Safety -> DsM (Core TH.Safety)
286 repSafety PlayRisky = rep2 unsafeName []
287 repSafety (PlaySafe False) = rep2 safeName []
288 repSafety (PlaySafe True) = rep2 threadsafeName []
290 ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
292 -------------------------------------------------------
294 -------------------------------------------------------
296 repC :: LConDecl Name -> DsM (Core TH.ConQ)
297 repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _))
298 = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
299 repConstr con1 details }
300 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
301 = do { addTyVarBinds tvs $ \bndrs -> do {
302 c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
303 ctxt' <- repContext ctxt;
304 bndrs' <- coreList nameTyConName bndrs;
305 rep2 forallCName [unC bndrs', unC ctxt', unC c']
308 repC (L loc con_decl) -- GADTs
310 notHandled "GADT declaration" (ppr con_decl)
312 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
316 rep2 strictTypeName [s, t]
318 (str, ty') = case ty of
319 L _ (HsBangTy _ ty) -> (isStrictName, ty)
320 other -> (notStrictName, ty)
322 -------------------------------------------------------
324 -------------------------------------------------------
326 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
327 repDerivs Nothing = coreList nameTyConName []
328 repDerivs (Just ctxt)
329 = do { strs <- mapM rep_deriv ctxt ;
330 coreList nameTyConName strs }
332 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
333 -- Deriving clauses must have the simple H98 form
334 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
335 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
338 -------------------------------------------------------
339 -- Signatures in a class decl, or a group of bindings
340 -------------------------------------------------------
342 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
343 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
344 return $ de_loc $ sort_by_loc locs_cores
346 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
347 -- We silently ignore ones we don't recognise
348 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
349 return (concat sigs1) }
351 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
353 -- Empty => Too hard, signature ignored
354 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
355 rep_sig other = return []
357 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
358 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
360 sig <- repProto nm1 ty1 ;
361 return [(loc, sig)] }
364 -------------------------------------------------------
366 -------------------------------------------------------
368 -- gensym a list of type variables and enter them into the meta environment;
369 -- the computations passed as the second argument is executed in that extended
370 -- meta environment and gets the *new* names on Core-level as an argument
372 addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
373 -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
374 -> DsM (Core (TH.Q a))
375 addTyVarBinds tvs m =
377 let names = map (hsTyVarName.unLoc) tvs
378 freshNames <- mkGenSyms names
379 term <- addBinds freshNames $ do
380 bndrs <- mapM lookupBinder names
382 wrapGenSyns freshNames term
384 -- represent a type context
386 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
387 repLContext (L _ ctxt) = repContext ctxt
389 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
391 preds <- mapM repLPred ctxt
392 predList <- coreList typeQTyConName preds
395 -- represent a type predicate
397 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
398 repLPred (L _ p) = repPred p
400 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
401 repPred (HsClassP cls tys) = do
402 tcon <- repTy (HsTyVar cls)
405 repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)
406 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
408 -- yield the representation of a list of types
410 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
411 repLTys tys = mapM repLTy tys
415 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
416 repLTy (L _ ty) = repTy ty
418 repTy :: HsType Name -> DsM (Core TH.TypeQ)
419 repTy (HsForAllTy _ tvs ctxt ty) =
420 addTyVarBinds tvs $ \bndrs -> do
421 ctxt1 <- repLContext ctxt
423 bndrs1 <- coreList nameTyConName bndrs
424 repTForall bndrs1 ctxt1 ty1
427 | isTvOcc (nameOccName n) = do
433 repTy (HsAppTy f a) = do
437 repTy (HsFunTy f a) = do
440 tcon <- repArrowTyCon
441 repTapps tcon [f1, a1]
442 repTy (HsListTy t) = do
446 repTy (HsPArrTy t) = do
448 tcon <- repTy (HsTyVar (tyConName parrTyCon))
450 repTy (HsTupleTy tc tys) = do
452 tcon <- repTupleTyCon (length tys)
454 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
456 repTy (HsParTy t) = repLTy t
457 repTy (HsPredTy pred) = repPred pred
458 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
459 repTy ty = notHandled "Exotic form of type" (ppr ty)
462 -----------------------------------------------------------------------------
464 -----------------------------------------------------------------------------
466 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
467 repLEs es = do { es' <- mapM repLE es ;
468 coreList expQTyConName es' }
470 -- FIXME: some of these panics should be converted into proper error messages
471 -- unless we can make sure that constructs, which are plainly not
472 -- supported in TH already lead to error messages at an earlier stage
473 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
474 repLE (L loc e) = putSrcSpanDs loc (repE e)
476 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
478 do { mb_val <- dsLookupMetaEnv x
480 Nothing -> do { str <- globalVar x
481 ; repVarOrCon x str }
482 Just (Bound y) -> repVarOrCon x (coreVar y)
483 Just (Splice e) -> do { e' <- dsExpr e
484 ; return (MkC e') } }
485 repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e)
487 -- Remember, we're desugaring renamer output here, so
488 -- HsOverlit can definitely occur
489 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
490 repE (HsLit l) = do { a <- repLiteral l; repLit a }
491 repE (HsLam (MatchGroup [m] _)) = repLambda m
492 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
494 repE (OpApp e1 op fix e2) =
495 do { arg1 <- repLE e1;
498 repInfixApp arg1 the_op arg2 }
499 repE (NegApp x nm) = do
501 negateVar <- lookupOcc negateName >>= repVar
503 repE (HsPar x) = repLE x
504 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
505 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
506 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
507 ; ms2 <- mapM repMatchTup ms
508 ; repCaseE arg (nonEmptyCoreList ms2) }
509 repE (HsIf x y z) = do
514 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
515 ; e2 <- addBinds ss (repLE e)
518 -- FIXME: I haven't got the types here right yet
519 repE (HsDo DoExpr sts body ty)
520 = do { (ss,zs) <- repLSts sts;
521 body' <- addBinds ss $ repLE body;
522 ret <- repNoBindSt body';
523 e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
525 repE (HsDo ListComp sts body ty)
526 = do { (ss,zs) <- repLSts sts;
527 body' <- addBinds ss $ repLE body;
528 ret <- repNoBindSt body';
529 e <- repComp (nonEmptyCoreList (zs ++ [ret]));
531 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
532 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
533 repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
534 repE e@(ExplicitTuple es boxed)
535 | isBoxed boxed = do { xs <- repLEs es; repTup xs }
536 | otherwise = notHandled "Unboxed tuples" (ppr e)
537 repE (RecordCon c _ flds)
538 = do { x <- lookupLOcc c;
539 fs <- repFields flds;
541 repE (RecordUpd e flds _ _ _)
543 fs <- repFields flds;
546 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
547 repE (ArithSeq _ aseq) =
549 From e -> do { ds1 <- repLE e; repFrom ds1 }
558 FromThenTo e1 e2 e3 -> do
562 repFromThenTo ds1 ds2 ds3
563 repE (HsSpliceE (HsSplice n _))
564 = do { mb_val <- dsLookupMetaEnv n
566 Just (Splice e) -> do { e' <- dsExpr e
568 other -> pprPanic "HsSplice" (ppr n) }
569 -- Should not happen; statically checked
571 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
572 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
573 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
574 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
575 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
576 repE e = notHandled "Expression form" (ppr e)
578 -----------------------------------------------------------------------------
579 -- Building representations of auxillary structures like Match, Clause, Stmt,
581 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
582 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
583 do { ss1 <- mkGenSyms (collectPatBinders p)
584 ; addBinds ss1 $ do {
586 ; (ss2,ds) <- repBinds wheres
587 ; addBinds ss2 $ do {
588 ; gs <- repGuards guards
589 ; match <- repMatch p1 gs ds
590 ; wrapGenSyns (ss1++ss2) match }}}
591 repMatchTup other = panic "repMatchTup: case alt with more than one arg"
593 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
594 repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
595 do { ss1 <- mkGenSyms (collectPatsBinders ps)
596 ; addBinds ss1 $ do {
598 ; (ss2,ds) <- repBinds wheres
599 ; addBinds ss2 $ do {
600 gs <- repGuards guards
601 ; clause <- repClause ps1 gs ds
602 ; wrapGenSyns (ss1++ss2) clause }}}
604 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
605 repGuards [L _ (GRHS [] e)]
606 = do {a <- repLE e; repNormal a }
608 = do { zs <- mapM process other;
609 let {(xs, ys) = unzip zs};
610 gd <- repGuarded (nonEmptyCoreList ys);
611 wrapGenSyns (concat xs) gd }
613 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
614 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
615 = do { x <- repLNormalGE e1 e2;
617 process (L _ (GRHS ss rhs))
618 = do (gs, ss') <- repLSts ss
619 rhs' <- addBinds gs $ repLE rhs
620 g <- repPatGE (nonEmptyCoreList ss') rhs'
623 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
624 repFields (HsRecFields { rec_flds = flds })
625 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
626 ; es <- mapM repLE (map hsRecFieldArg flds)
627 ; fs <- zipWithM repFieldExp fnames es
628 ; coreList fieldExpQTyConName fs }
631 -----------------------------------------------------------------------------
632 -- Representing Stmt's is tricky, especially if bound variables
633 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
634 -- First gensym new names for every variable in any of the patterns.
635 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
636 -- if variables didn't shaddow, the static gensym wouldn't be necessary
637 -- and we could reuse the original names (x and x).
639 -- do { x'1 <- gensym "x"
640 -- ; x'2 <- gensym "x"
641 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
642 -- , BindSt (pvar x'2) [| f x |]
643 -- , NoBindSt [| g x |]
647 -- The strategy is to translate a whole list of do-bindings by building a
648 -- bigger environment, and a bigger set of meta bindings
649 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
650 -- of the expressions within the Do
652 -----------------------------------------------------------------------------
653 -- The helper function repSts computes the translation of each sub expression
654 -- and a bunch of prefix bindings denoting the dynamic renaming.
656 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
657 repLSts stmts = repSts (map unLoc stmts)
659 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
660 repSts (BindStmt p e _ _ : ss) =
662 ; ss1 <- mkGenSyms (collectPatBinders p)
663 ; addBinds ss1 $ do {
665 ; (ss2,zs) <- repSts ss
666 ; z <- repBindSt p1 e2
667 ; return (ss1++ss2, z : zs) }}
668 repSts (LetStmt bs : ss) =
669 do { (ss1,ds) <- repBinds bs
671 ; (ss2,zs) <- addBinds ss1 (repSts ss)
672 ; return (ss1++ss2, z : zs) }
673 repSts (ExprStmt e _ _ : ss) =
675 ; z <- repNoBindSt e2
676 ; (ss2,zs) <- repSts ss
677 ; return (ss2, z : zs) }
678 repSts [] = return ([],[])
679 repSts other = notHandled "Exotic statement" (ppr other)
682 -----------------------------------------------------------
684 -----------------------------------------------------------
686 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
687 repBinds EmptyLocalBinds
688 = do { core_list <- coreList decQTyConName []
689 ; return ([], core_list) }
691 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
693 repBinds (HsValBinds decs)
694 = do { let { bndrs = map unLoc (collectHsValBinders decs) }
695 -- No need to worrry about detailed scopes within
696 -- the binding group, because we are talking Names
697 -- here, so we can safely treat it as a mutually
699 ; ss <- mkGenSyms bndrs
700 ; prs <- addBinds ss (rep_val_binds decs)
701 ; core_list <- coreList decQTyConName
702 (de_loc (sort_by_loc prs))
703 ; return (ss, core_list) }
705 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
706 -- Assumes: all the binders of the binding are alrady in the meta-env
707 rep_val_binds (ValBindsOut binds sigs)
708 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
709 ; core2 <- rep_sigs' sigs
710 ; return (core1 ++ core2) }
711 rep_val_binds (ValBindsIn binds sigs)
712 = panic "rep_val_binds: ValBindsIn"
714 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
715 rep_binds binds = do { binds_w_locs <- rep_binds' binds
716 ; return (de_loc (sort_by_loc binds_w_locs)) }
718 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
719 rep_binds' binds = mapM rep_bind (bagToList binds)
721 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
722 -- Assumes: all the binders of the binding are alrady in the meta-env
724 -- Note GHC treats declarations of a variable (not a pattern)
725 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
726 -- with an empty list of patterns
727 rep_bind (L loc (FunBind { fun_id = fn,
728 fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
729 = do { (ss,wherecore) <- repBinds wheres
730 ; guardcore <- addBinds ss (repGuards guards)
731 ; fn' <- lookupLBinder fn
733 ; ans <- repVal p guardcore wherecore
734 ; ans' <- wrapGenSyns ss ans
735 ; return (loc, ans') }
737 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
738 = do { ms1 <- mapM repClauseTup ms
739 ; fn' <- lookupLBinder fn
740 ; ans <- repFun fn' (nonEmptyCoreList ms1)
741 ; return (loc, ans) }
743 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
744 = do { patcore <- repLP pat
745 ; (ss,wherecore) <- repBinds wheres
746 ; guardcore <- addBinds ss (repGuards guards)
747 ; ans <- repVal patcore guardcore wherecore
748 ; ans' <- wrapGenSyns ss ans
749 ; return (loc, ans') }
751 rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
752 = do { v' <- lookupBinder v
755 ; patcore <- repPvar v'
756 ; empty_decls <- coreList decQTyConName []
757 ; ans <- repVal patcore x empty_decls
758 ; return (srcLocSpan (getSrcLoc v), ans) }
760 rep_bind other = panic "rep_bind: AbsBinds"
762 -----------------------------------------------------------------------------
763 -- Since everything in a Bind is mutually recursive we need rename all
764 -- all the variables simultaneously. For example:
765 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
766 -- do { f'1 <- gensym "f"
767 -- ; g'2 <- gensym "g"
768 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
769 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
771 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
772 -- environment ( f |-> f'1 ) from each binding, and then unioning them
773 -- together. As we do this we collect GenSymBinds's which represent the renamed
774 -- variables bound by the Bindings. In order not to lose track of these
775 -- representations we build a shadow datatype MB with the same structure as
776 -- MonoBinds, but which has slots for the representations
779 -----------------------------------------------------------------------------
780 -- GHC allows a more general form of lambda abstraction than specified
781 -- by Haskell 98. In particular it allows guarded lambda's like :
782 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
783 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
784 -- (\ p1 .. pn -> exp) by causing an error.
786 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
787 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
788 = do { let bndrs = collectPatsBinders ps ;
789 ; ss <- mkGenSyms bndrs
790 ; lam <- addBinds ss (
791 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
792 ; wrapGenSyns ss lam }
794 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
797 -----------------------------------------------------------------------------
799 -- repP deals with patterns. It assumes that we have already
800 -- walked over the pattern(s) once to collect the binders, and
801 -- have extended the environment. So every pattern-bound
802 -- variable should already appear in the environment.
804 -- Process a list of patterns
805 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
806 repLPs ps = do { ps' <- mapM repLP ps ;
807 coreList patQTyConName ps' }
809 repLP :: LPat Name -> DsM (Core TH.PatQ)
810 repLP (L _ p) = repP p
812 repP :: Pat Name -> DsM (Core TH.PatQ)
813 repP (WildPat _) = repPwild
814 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
815 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
816 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
817 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
818 repP (ParPat p) = repLP p
819 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
820 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
821 repP (ConPatIn dc details)
822 = do { con_str <- lookupLOcc dc
824 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
825 RecCon rec -> do { let flds = rec_flds rec
826 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
827 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
828 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
829 ; fps' <- coreList fieldPatQTyConName fps
830 ; repPrec con_str fps' }
831 InfixCon p1 p2 -> do { p1' <- repLP p1;
833 repPinfix p1' con_str p2' }
835 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
836 repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
837 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
838 -- The problem is to do with scoped type variables.
839 -- To implement them, we have to implement the scoping rules
840 -- here in DsMeta, and I don't want to do that today!
841 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
842 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
843 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
845 repP other = notHandled "Exotic pattern" (ppr other)
847 ----------------------------------------------------------
848 -- Declaration ordering helpers
850 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
851 sort_by_loc xs = sortBy comp xs
852 where comp x y = compare (fst x) (fst y)
854 de_loc :: [(a, b)] -> [b]
857 ----------------------------------------------------------
858 -- The meta-environment
860 -- A name/identifier association for fresh names of locally bound entities
861 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
862 -- I.e. (x, x_id) means
863 -- let x_id = gensym "x" in ...
865 -- Generate a fresh name for a locally bound entity
867 mkGenSyms :: [Name] -> DsM [GenSymBind]
868 -- We can use the existing name. For example:
869 -- [| \x_77 -> x_77 + x_77 |]
871 -- do { x_77 <- genSym "x"; .... }
872 -- We use the same x_77 in the desugared program, but with the type Bndr
875 -- We do make it an Internal name, though (hence localiseName)
877 -- Nevertheless, it's monadic because we have to generate nameTy
878 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
879 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
882 addBinds :: [GenSymBind] -> DsM a -> DsM a
883 -- Add a list of fresh names for locally bound entities to the
884 -- meta environment (which is part of the state carried around
885 -- by the desugarer monad)
886 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
888 -- Look up a locally bound name
890 lookupLBinder :: Located Name -> DsM (Core TH.Name)
891 lookupLBinder (L _ n) = lookupBinder n
893 lookupBinder :: Name -> DsM (Core TH.Name)
895 = do { mb_val <- dsLookupMetaEnv n;
897 Just (Bound x) -> return (coreVar x)
898 other -> failWithDs msg }
900 msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
902 -- Look up a name that is either locally bound or a global name
904 -- * If it is a global name, generate the "original name" representation (ie,
905 -- the <module>:<name> form) for the associated entity
907 lookupLOcc :: Located Name -> DsM (Core TH.Name)
908 -- Lookup an occurrence; it can't be a splice.
909 -- Use the in-scope bindings if they exist
910 lookupLOcc (L _ n) = lookupOcc n
912 lookupOcc :: Name -> DsM (Core TH.Name)
914 = do { mb_val <- dsLookupMetaEnv n ;
916 Nothing -> globalVar n
917 Just (Bound x) -> return (coreVar x)
918 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
921 lookupTvOcc :: Name -> DsM (Core TH.Name)
922 -- Type variables can't be staged and are not lexically scoped in TH
924 = do { mb_val <- dsLookupMetaEnv n ;
926 Just (Bound x) -> return (coreVar x)
927 other -> failWithDs msg
930 msg = vcat [ ptext SLIT("Illegal lexically-scoped type variable") <+> quotes (ppr n)
931 , ptext SLIT("Lexically scoped type variables are not supported by Template Haskell") ]
933 globalVar :: Name -> DsM (Core TH.Name)
934 -- Not bound by the meta-env
935 -- Could be top-level; or could be local
936 -- f x = $(g [| x |])
937 -- Here the x will be local
939 | isExternalName name
940 = do { MkC mod <- coreStringLit name_mod
941 ; MkC pkg <- coreStringLit name_pkg
942 ; MkC occ <- occNameLit name
943 ; rep2 mk_varg [pkg,mod,occ] }
945 = do { MkC occ <- occNameLit name
946 ; MkC uni <- coreIntLit (getKey (getUnique name))
947 ; rep2 mkNameLName [occ,uni] }
949 mod = nameModule name
950 name_mod = moduleNameString (moduleName mod)
951 name_pkg = packageIdString (modulePackageId mod)
952 name_occ = nameOccName name
953 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
954 | OccName.isVarOcc name_occ = mkNameG_vName
955 | OccName.isTcOcc name_occ = mkNameG_tcName
956 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
958 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
959 -> DsM Type -- The type
960 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
961 return (mkTyConApp tc []) }
963 wrapGenSyns :: [GenSymBind]
964 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
965 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
966 -- --> bindQ (gensym nm1) (\ id1 ->
967 -- bindQ (gensym nm2 (\ id2 ->
970 wrapGenSyns binds body@(MkC b)
971 = do { var_ty <- lookupType nameTyConName
974 [elt_ty] = tcTyConAppArgs (exprType b)
975 -- b :: Q a, so we can get the type 'a' by looking at the
976 -- argument type. NB: this relies on Q being a data/newtype,
977 -- not a type synonym
979 go var_ty [] = return body
980 go var_ty ((name,id) : binds)
981 = do { MkC body' <- go var_ty binds
982 ; lit_str <- occNameLit name
983 ; gensym_app <- repGensym lit_str
984 ; repBindQ var_ty elt_ty
985 gensym_app (MkC (Lam id body')) }
987 -- Just like wrapGenSym, but don't actually do the gensym
988 -- Instead use the existing name:
989 -- let x = "x" in ...
990 -- Only used for [Decl], and for the class ops in class
991 -- and instance decls
992 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
993 wrapNongenSyms binds (MkC body)
994 = do { binds' <- mapM do_one binds ;
995 return (MkC (mkLets binds' body)) }
998 = do { MkC lit_str <- occNameLit name
999 ; MkC var <- rep2 mkNameName [lit_str]
1000 ; return (NonRec id var) }
1002 occNameLit :: Name -> DsM (Core String)
1003 occNameLit n = coreStringLit (occNameString (nameOccName n))
1006 -- %*********************************************************************
1008 -- Constructing code
1010 -- %*********************************************************************
1012 -----------------------------------------------------------------------------
1013 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1014 -- we invent a new datatype which uses phantom types.
1016 newtype Core a = MkC CoreExpr
1019 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1020 rep2 n xs = do { id <- dsLookupGlobalId n
1021 ; return (MkC (foldl App (Var id) xs)) }
1023 -- Then we make "repConstructors" which use the phantom types for each of the
1024 -- smart constructors of the Meta.Meta datatypes.
1027 -- %*********************************************************************
1029 -- The 'smart constructors'
1031 -- %*********************************************************************
1033 --------------- Patterns -----------------
1034 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1035 repPlit (MkC l) = rep2 litPName [l]
1037 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1038 repPvar (MkC s) = rep2 varPName [s]
1040 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1041 repPtup (MkC ps) = rep2 tupPName [ps]
1043 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1044 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1046 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1047 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1049 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1050 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1052 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1053 repPtilde (MkC p) = rep2 tildePName [p]
1055 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1056 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1058 repPwild :: DsM (Core TH.PatQ)
1059 repPwild = rep2 wildPName []
1061 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1062 repPlist (MkC ps) = rep2 listPName [ps]
1064 --------------- Expressions -----------------
1065 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1066 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1067 | otherwise = repVar str
1069 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1070 repVar (MkC s) = rep2 varEName [s]
1072 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1073 repCon (MkC s) = rep2 conEName [s]
1075 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1076 repLit (MkC c) = rep2 litEName [c]
1078 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1079 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1081 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1082 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1084 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1085 repTup (MkC es) = rep2 tupEName [es]
1087 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1088 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1090 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1091 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1093 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1094 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1096 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1097 repDoE (MkC ss) = rep2 doEName [ss]
1099 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1100 repComp (MkC ss) = rep2 compEName [ss]
1102 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1103 repListExp (MkC es) = rep2 listEName [es]
1105 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1106 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1108 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1109 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1111 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1112 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1114 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1115 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1117 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1118 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1120 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1121 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1123 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1124 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1126 ------------ Right hand sides (guarded expressions) ----
1127 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1128 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1130 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1131 repNormal (MkC e) = rep2 normalBName [e]
1133 ------------ Guards ----
1134 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1135 repLNormalGE g e = do g' <- repLE g
1139 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1140 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1142 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1143 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1145 ------------- Stmts -------------------
1146 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1147 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1149 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1150 repLetSt (MkC ds) = rep2 letSName [ds]
1152 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1153 repNoBindSt (MkC e) = rep2 noBindSName [e]
1155 -------------- Range (Arithmetic sequences) -----------
1156 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1157 repFrom (MkC x) = rep2 fromEName [x]
1159 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1160 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1162 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1163 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1165 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1166 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1168 ------------ Match and Clause Tuples -----------
1169 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1170 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1172 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1173 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1175 -------------- Dec -----------------------------
1176 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1177 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1179 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1180 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1182 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1183 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1184 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1186 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1187 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1188 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1190 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1191 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1193 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1194 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1196 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1197 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1199 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1200 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1202 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1203 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1205 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1206 repCtxt (MkC tys) = rep2 cxtName [tys]
1208 repConstr :: Core TH.Name -> HsConDeclDetails Name
1209 -> DsM (Core TH.ConQ)
1210 repConstr con (PrefixCon ps)
1211 = do arg_tys <- mapM repBangTy ps
1212 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1213 rep2 normalCName [unC con, unC arg_tys1]
1214 repConstr con (RecCon ips)
1215 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1216 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1217 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1219 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1220 rep2 recCName [unC con, unC arg_vtys']
1221 repConstr con (InfixCon st1 st2)
1222 = do arg1 <- repBangTy st1
1223 arg2 <- repBangTy st2
1224 rep2 infixCName [unC arg1, unC con, unC arg2]
1226 ------------ Types -------------------
1228 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1229 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1230 = rep2 forallTName [tvars, ctxt, ty]
1232 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1233 repTvar (MkC s) = rep2 varTName [s]
1235 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1236 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1238 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1239 repTapps f [] = return f
1240 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1242 --------- Type constructors --------------
1244 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1245 repNamedTyCon (MkC s) = rep2 conTName [s]
1247 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1248 -- Note: not Core Int; it's easier to be direct here
1249 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1251 repArrowTyCon :: DsM (Core TH.TypeQ)
1252 repArrowTyCon = rep2 arrowTName []
1254 repListTyCon :: DsM (Core TH.TypeQ)
1255 repListTyCon = rep2 listTName []
1258 ----------------------------------------------------------
1261 repLiteral :: HsLit -> DsM (Core TH.Lit)
1263 = do lit' <- case lit of
1264 HsIntPrim i -> mk_integer i
1265 HsInt i -> mk_integer i
1266 HsFloatPrim r -> mk_rational r
1267 HsDoublePrim r -> mk_rational r
1269 lit_expr <- dsLit lit'
1271 Just lit_name -> rep2 lit_name [lit_expr]
1272 Nothing -> notHandled "Exotic literal" (ppr lit)
1274 mb_lit_name = case lit of
1275 HsInteger _ _ -> Just integerLName
1276 HsInt _ -> Just integerLName
1277 HsIntPrim _ -> Just intPrimLName
1278 HsFloatPrim _ -> Just floatPrimLName
1279 HsDoublePrim _ -> Just doublePrimLName
1280 HsChar _ -> Just charLName
1281 HsString _ -> Just stringLName
1282 HsRat _ _ -> Just rationalLName
1285 mk_integer i = do integer_ty <- lookupType integerTyConName
1286 return $ HsInteger i integer_ty
1287 mk_rational r = do rat_ty <- lookupType rationalTyConName
1288 return $ HsRat r rat_ty
1289 mk_string s = do string_ty <- lookupType stringTyConName
1292 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1293 repOverloadedLiteral (HsIntegral i _ _) = do { lit <- mk_integer i; repLiteral lit }
1294 repOverloadedLiteral (HsFractional f _ _) = do { lit <- mk_rational f; repLiteral lit }
1295 repOverloadedLiteral (HsIsString s _ _) = do { lit <- mk_string s; repLiteral lit }
1296 -- The type Rational will be in the environment, becuase
1297 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1298 -- and rationalL is sucked in when any TH stuff is used
1300 --------------- Miscellaneous -------------------
1302 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1303 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1305 repBindQ :: Type -> Type -- a and b
1306 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1307 repBindQ ty_a ty_b (MkC x) (MkC y)
1308 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1310 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1311 repSequenceQ ty_a (MkC list)
1312 = rep2 sequenceQName [Type ty_a, list]
1314 ------------ Lists and Tuples -------------------
1315 -- turn a list of patterns into a single pattern matching a list
1317 coreList :: Name -- Of the TyCon of the element type
1318 -> [Core a] -> DsM (Core [a])
1320 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1322 coreList' :: Type -- The element type
1323 -> [Core a] -> Core [a]
1324 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1326 nonEmptyCoreList :: [Core a] -> Core [a]
1327 -- The list must be non-empty so we can get the element type
1328 -- Otherwise use coreList
1329 nonEmptyCoreList [] = panic "coreList: empty argument"
1330 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1332 corePair :: (Core a, Core b) -> Core (a,b)
1333 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1335 coreStringLit :: String -> DsM (Core String)
1336 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1338 coreIntLit :: Int -> DsM (Core Int)
1339 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1341 coreVar :: Id -> Core TH.Name -- The Id has type Name
1342 coreVar id = MkC (Var id)
1344 ----------------- Failure -----------------------
1345 notHandled :: String -> SDoc -> DsM a
1346 notHandled what doc = failWithDs msg
1348 msg = hang (text what <+> ptext SLIT("not (yet) handled by Template Haskell"))
1352 -- %************************************************************************
1354 -- The known-key names for Template Haskell
1356 -- %************************************************************************
1358 -- To add a name, do three things
1360 -- 1) Allocate a key
1362 -- 3) Add the name to knownKeyNames
1364 templateHaskellNames :: [Name]
1365 -- The names that are implicitly mentioned by ``bracket''
1366 -- Should stay in sync with the import list of DsMeta
1368 templateHaskellNames = [
1369 returnQName, bindQName, sequenceQName, newNameName, liftName,
1370 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1373 charLName, stringLName, integerLName, intPrimLName,
1374 floatPrimLName, doublePrimLName, rationalLName,
1376 litPName, varPName, tupPName, conPName, tildePName, infixPName,
1377 asPName, wildPName, recPName, listPName, sigPName,
1385 varEName, conEName, litEName, appEName, infixEName,
1386 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1387 condEName, letEName, caseEName, doEName, compEName,
1388 fromEName, fromThenEName, fromToEName, fromThenToEName,
1389 listEName, sigEName, recConEName, recUpdEName,
1393 guardedBName, normalBName,
1395 normalGEName, patGEName,
1397 bindSName, letSName, noBindSName, parSName,
1399 funDName, valDName, dataDName, newtypeDName, tySynDName,
1400 classDName, instanceDName, sigDName, forImpDName,
1404 isStrictName, notStrictName,
1406 normalCName, recCName, infixCName, forallCName,
1412 forallTName, varTName, conTName, appTName,
1413 tupleTName, arrowTName, listTName,
1415 cCallName, stdCallName,
1424 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1425 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1426 decQTyConName, conQTyConName, strictTypeQTyConName,
1427 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1428 typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1429 fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1432 quoteExpName, quotePatName]
1435 thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax")
1436 thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
1437 qqLib = mkTHModule FSLIT("Language.Haskell.TH.Quote")
1439 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1441 libFun = mk_known_key_name OccName.varName thLib
1442 libTc = mk_known_key_name OccName.tcName thLib
1443 thFun = mk_known_key_name OccName.varName thSyn
1444 thTc = mk_known_key_name OccName.tcName thSyn
1445 qqFun = mk_known_key_name OccName.varName qqLib
1447 -------------------- TH.Syntax -----------------------
1448 qTyConName = thTc FSLIT("Q") qTyConKey
1449 nameTyConName = thTc FSLIT("Name") nameTyConKey
1450 fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
1451 patTyConName = thTc FSLIT("Pat") patTyConKey
1452 fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
1453 expTyConName = thTc FSLIT("Exp") expTyConKey
1454 decTyConName = thTc FSLIT("Dec") decTyConKey
1455 typeTyConName = thTc FSLIT("Type") typeTyConKey
1456 matchTyConName = thTc FSLIT("Match") matchTyConKey
1457 clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
1458 funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
1460 returnQName = thFun FSLIT("returnQ") returnQIdKey
1461 bindQName = thFun FSLIT("bindQ") bindQIdKey
1462 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1463 newNameName = thFun FSLIT("newName") newNameIdKey
1464 liftName = thFun FSLIT("lift") liftIdKey
1465 mkNameName = thFun FSLIT("mkName") mkNameIdKey
1466 mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
1467 mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
1468 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1469 mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
1472 -------------------- TH.Lib -----------------------
1474 charLName = libFun FSLIT("charL") charLIdKey
1475 stringLName = libFun FSLIT("stringL") stringLIdKey
1476 integerLName = libFun FSLIT("integerL") integerLIdKey
1477 intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
1478 floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
1479 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1480 rationalLName = libFun FSLIT("rationalL") rationalLIdKey
1483 litPName = libFun FSLIT("litP") litPIdKey
1484 varPName = libFun FSLIT("varP") varPIdKey
1485 tupPName = libFun FSLIT("tupP") tupPIdKey
1486 conPName = libFun FSLIT("conP") conPIdKey
1487 infixPName = libFun FSLIT("infixP") infixPIdKey
1488 tildePName = libFun FSLIT("tildeP") tildePIdKey
1489 asPName = libFun FSLIT("asP") asPIdKey
1490 wildPName = libFun FSLIT("wildP") wildPIdKey
1491 recPName = libFun FSLIT("recP") recPIdKey
1492 listPName = libFun FSLIT("listP") listPIdKey
1493 sigPName = libFun FSLIT("sigP") sigPIdKey
1495 -- type FieldPat = ...
1496 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1499 matchName = libFun FSLIT("match") matchIdKey
1501 -- data Clause = ...
1502 clauseName = libFun FSLIT("clause") clauseIdKey
1505 varEName = libFun FSLIT("varE") varEIdKey
1506 conEName = libFun FSLIT("conE") conEIdKey
1507 litEName = libFun FSLIT("litE") litEIdKey
1508 appEName = libFun FSLIT("appE") appEIdKey
1509 infixEName = libFun FSLIT("infixE") infixEIdKey
1510 infixAppName = libFun FSLIT("infixApp") infixAppIdKey
1511 sectionLName = libFun FSLIT("sectionL") sectionLIdKey
1512 sectionRName = libFun FSLIT("sectionR") sectionRIdKey
1513 lamEName = libFun FSLIT("lamE") lamEIdKey
1514 tupEName = libFun FSLIT("tupE") tupEIdKey
1515 condEName = libFun FSLIT("condE") condEIdKey
1516 letEName = libFun FSLIT("letE") letEIdKey
1517 caseEName = libFun FSLIT("caseE") caseEIdKey
1518 doEName = libFun FSLIT("doE") doEIdKey
1519 compEName = libFun FSLIT("compE") compEIdKey
1520 -- ArithSeq skips a level
1521 fromEName = libFun FSLIT("fromE") fromEIdKey
1522 fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
1523 fromToEName = libFun FSLIT("fromToE") fromToEIdKey
1524 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1526 listEName = libFun FSLIT("listE") listEIdKey
1527 sigEName = libFun FSLIT("sigE") sigEIdKey
1528 recConEName = libFun FSLIT("recConE") recConEIdKey
1529 recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
1531 -- type FieldExp = ...
1532 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1535 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1536 normalBName = libFun FSLIT("normalB") normalBIdKey
1539 normalGEName = libFun FSLIT("normalGE") normalGEIdKey
1540 patGEName = libFun FSLIT("patGE") patGEIdKey
1543 bindSName = libFun FSLIT("bindS") bindSIdKey
1544 letSName = libFun FSLIT("letS") letSIdKey
1545 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1546 parSName = libFun FSLIT("parS") parSIdKey
1549 funDName = libFun FSLIT("funD") funDIdKey
1550 valDName = libFun FSLIT("valD") valDIdKey
1551 dataDName = libFun FSLIT("dataD") dataDIdKey
1552 newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
1553 tySynDName = libFun FSLIT("tySynD") tySynDIdKey
1554 classDName = libFun FSLIT("classD") classDIdKey
1555 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1556 sigDName = libFun FSLIT("sigD") sigDIdKey
1557 forImpDName = libFun FSLIT("forImpD") forImpDIdKey
1560 cxtName = libFun FSLIT("cxt") cxtIdKey
1562 -- data Strict = ...
1563 isStrictName = libFun FSLIT("isStrict") isStrictKey
1564 notStrictName = libFun FSLIT("notStrict") notStrictKey
1567 normalCName = libFun FSLIT("normalC") normalCIdKey
1568 recCName = libFun FSLIT("recC") recCIdKey
1569 infixCName = libFun FSLIT("infixC") infixCIdKey
1570 forallCName = libFun FSLIT("forallC") forallCIdKey
1572 -- type StrictType = ...
1573 strictTypeName = libFun FSLIT("strictType") strictTKey
1575 -- type VarStrictType = ...
1576 varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
1579 forallTName = libFun FSLIT("forallT") forallTIdKey
1580 varTName = libFun FSLIT("varT") varTIdKey
1581 conTName = libFun FSLIT("conT") conTIdKey
1582 tupleTName = libFun FSLIT("tupleT") tupleTIdKey
1583 arrowTName = libFun FSLIT("arrowT") arrowTIdKey
1584 listTName = libFun FSLIT("listT") listTIdKey
1585 appTName = libFun FSLIT("appT") appTIdKey
1587 -- data Callconv = ...
1588 cCallName = libFun FSLIT("cCall") cCallIdKey
1589 stdCallName = libFun FSLIT("stdCall") stdCallIdKey
1591 -- data Safety = ...
1592 unsafeName = libFun FSLIT("unsafe") unsafeIdKey
1593 safeName = libFun FSLIT("safe") safeIdKey
1594 threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
1596 -- data FunDep = ...
1597 funDepName = libFun FSLIT("funDep") funDepIdKey
1599 matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
1600 clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
1601 expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
1602 stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
1603 decQTyConName = libTc FSLIT("DecQ") decQTyConKey
1604 conQTyConName = libTc FSLIT("ConQ") conQTyConKey
1605 strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
1606 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1607 typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
1608 fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
1609 patQTyConName = libTc FSLIT("PatQ") patQTyConKey
1610 fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
1613 quoteExpName = qqFun FSLIT("quoteExp") quoteExpKey
1614 quotePatName = qqFun FSLIT("quotePat") quotePatKey
1616 -- TyConUniques available: 100-129
1617 -- Check in PrelNames if you want to change this
1619 expTyConKey = mkPreludeTyConUnique 100
1620 matchTyConKey = mkPreludeTyConUnique 101
1621 clauseTyConKey = mkPreludeTyConUnique 102
1622 qTyConKey = mkPreludeTyConUnique 103
1623 expQTyConKey = mkPreludeTyConUnique 104
1624 decQTyConKey = mkPreludeTyConUnique 105
1625 patTyConKey = mkPreludeTyConUnique 106
1626 matchQTyConKey = mkPreludeTyConUnique 107
1627 clauseQTyConKey = mkPreludeTyConUnique 108
1628 stmtQTyConKey = mkPreludeTyConUnique 109
1629 conQTyConKey = mkPreludeTyConUnique 110
1630 typeQTyConKey = mkPreludeTyConUnique 111
1631 typeTyConKey = mkPreludeTyConUnique 112
1632 decTyConKey = mkPreludeTyConUnique 113
1633 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1634 strictTypeQTyConKey = mkPreludeTyConUnique 115
1635 fieldExpTyConKey = mkPreludeTyConUnique 116
1636 fieldPatTyConKey = mkPreludeTyConUnique 117
1637 nameTyConKey = mkPreludeTyConUnique 118
1638 patQTyConKey = mkPreludeTyConUnique 119
1639 fieldPatQTyConKey = mkPreludeTyConUnique 120
1640 fieldExpQTyConKey = mkPreludeTyConUnique 121
1641 funDepTyConKey = mkPreludeTyConUnique 122
1643 -- IdUniques available: 200-399
1644 -- If you want to change this, make sure you check in PrelNames
1646 returnQIdKey = mkPreludeMiscIdUnique 200
1647 bindQIdKey = mkPreludeMiscIdUnique 201
1648 sequenceQIdKey = mkPreludeMiscIdUnique 202
1649 liftIdKey = mkPreludeMiscIdUnique 203
1650 newNameIdKey = mkPreludeMiscIdUnique 204
1651 mkNameIdKey = mkPreludeMiscIdUnique 205
1652 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
1653 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
1654 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
1655 mkNameLIdKey = mkPreludeMiscIdUnique 209
1659 charLIdKey = mkPreludeMiscIdUnique 210
1660 stringLIdKey = mkPreludeMiscIdUnique 211
1661 integerLIdKey = mkPreludeMiscIdUnique 212
1662 intPrimLIdKey = mkPreludeMiscIdUnique 213
1663 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1664 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1665 rationalLIdKey = mkPreludeMiscIdUnique 216
1668 litPIdKey = mkPreludeMiscIdUnique 220
1669 varPIdKey = mkPreludeMiscIdUnique 221
1670 tupPIdKey = mkPreludeMiscIdUnique 222
1671 conPIdKey = mkPreludeMiscIdUnique 223
1672 infixPIdKey = mkPreludeMiscIdUnique 312
1673 tildePIdKey = mkPreludeMiscIdUnique 224
1674 asPIdKey = mkPreludeMiscIdUnique 225
1675 wildPIdKey = mkPreludeMiscIdUnique 226
1676 recPIdKey = mkPreludeMiscIdUnique 227
1677 listPIdKey = mkPreludeMiscIdUnique 228
1678 sigPIdKey = mkPreludeMiscIdUnique 229
1680 -- type FieldPat = ...
1681 fieldPatIdKey = mkPreludeMiscIdUnique 230
1684 matchIdKey = mkPreludeMiscIdUnique 231
1686 -- data Clause = ...
1687 clauseIdKey = mkPreludeMiscIdUnique 232
1690 varEIdKey = mkPreludeMiscIdUnique 240
1691 conEIdKey = mkPreludeMiscIdUnique 241
1692 litEIdKey = mkPreludeMiscIdUnique 242
1693 appEIdKey = mkPreludeMiscIdUnique 243
1694 infixEIdKey = mkPreludeMiscIdUnique 244
1695 infixAppIdKey = mkPreludeMiscIdUnique 245
1696 sectionLIdKey = mkPreludeMiscIdUnique 246
1697 sectionRIdKey = mkPreludeMiscIdUnique 247
1698 lamEIdKey = mkPreludeMiscIdUnique 248
1699 tupEIdKey = mkPreludeMiscIdUnique 249
1700 condEIdKey = mkPreludeMiscIdUnique 250
1701 letEIdKey = mkPreludeMiscIdUnique 251
1702 caseEIdKey = mkPreludeMiscIdUnique 252
1703 doEIdKey = mkPreludeMiscIdUnique 253
1704 compEIdKey = mkPreludeMiscIdUnique 254
1705 fromEIdKey = mkPreludeMiscIdUnique 255
1706 fromThenEIdKey = mkPreludeMiscIdUnique 256
1707 fromToEIdKey = mkPreludeMiscIdUnique 257
1708 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1709 listEIdKey = mkPreludeMiscIdUnique 259
1710 sigEIdKey = mkPreludeMiscIdUnique 260
1711 recConEIdKey = mkPreludeMiscIdUnique 261
1712 recUpdEIdKey = mkPreludeMiscIdUnique 262
1714 -- type FieldExp = ...
1715 fieldExpIdKey = mkPreludeMiscIdUnique 265
1718 guardedBIdKey = mkPreludeMiscIdUnique 266
1719 normalBIdKey = mkPreludeMiscIdUnique 267
1722 normalGEIdKey = mkPreludeMiscIdUnique 310
1723 patGEIdKey = mkPreludeMiscIdUnique 311
1726 bindSIdKey = mkPreludeMiscIdUnique 268
1727 letSIdKey = mkPreludeMiscIdUnique 269
1728 noBindSIdKey = mkPreludeMiscIdUnique 270
1729 parSIdKey = mkPreludeMiscIdUnique 271
1732 funDIdKey = mkPreludeMiscIdUnique 272
1733 valDIdKey = mkPreludeMiscIdUnique 273
1734 dataDIdKey = mkPreludeMiscIdUnique 274
1735 newtypeDIdKey = mkPreludeMiscIdUnique 275
1736 tySynDIdKey = mkPreludeMiscIdUnique 276
1737 classDIdKey = mkPreludeMiscIdUnique 277
1738 instanceDIdKey = mkPreludeMiscIdUnique 278
1739 sigDIdKey = mkPreludeMiscIdUnique 279
1740 forImpDIdKey = mkPreludeMiscIdUnique 297
1743 cxtIdKey = mkPreludeMiscIdUnique 280
1745 -- data Strict = ...
1746 isStrictKey = mkPreludeMiscIdUnique 281
1747 notStrictKey = mkPreludeMiscIdUnique 282
1750 normalCIdKey = mkPreludeMiscIdUnique 283
1751 recCIdKey = mkPreludeMiscIdUnique 284
1752 infixCIdKey = mkPreludeMiscIdUnique 285
1753 forallCIdKey = mkPreludeMiscIdUnique 288
1755 -- type StrictType = ...
1756 strictTKey = mkPreludeMiscIdUnique 286
1758 -- type VarStrictType = ...
1759 varStrictTKey = mkPreludeMiscIdUnique 287
1762 forallTIdKey = mkPreludeMiscIdUnique 290
1763 varTIdKey = mkPreludeMiscIdUnique 291
1764 conTIdKey = mkPreludeMiscIdUnique 292
1765 tupleTIdKey = mkPreludeMiscIdUnique 294
1766 arrowTIdKey = mkPreludeMiscIdUnique 295
1767 listTIdKey = mkPreludeMiscIdUnique 296
1768 appTIdKey = mkPreludeMiscIdUnique 293
1770 -- data Callconv = ...
1771 cCallIdKey = mkPreludeMiscIdUnique 300
1772 stdCallIdKey = mkPreludeMiscIdUnique 301
1774 -- data Safety = ...
1775 unsafeIdKey = mkPreludeMiscIdUnique 305
1776 safeIdKey = mkPreludeMiscIdUnique 306
1777 threadsafeIdKey = mkPreludeMiscIdUnique 307
1779 -- data FunDep = ...
1780 funDepIdKey = mkPreludeMiscIdUnique 320
1783 quoteExpKey = mkPreludeMiscIdUnique 321
1784 quotePatKey = mkPreludeMiscIdUnique 322