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,
15 templateHaskellNames, qTyConName, nameTyConName,
16 liftName, expQTyConName, decQTyConName, typeQTyConName,
17 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
20 #include "HsVersions.h"
22 import {-# SOURCE #-} DsExpr ( dsExpr )
24 import MatchLit ( dsLit )
25 import DsUtils ( mkListExpr, mkStringExpr, mkIntExpr )
28 import qualified Language.Haskell.TH as TH
32 import PrelNames ( rationalTyConName, integerTyConName, negateName )
33 import OccName ( isDataOcc, isTvOcc, occNameString )
34 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
35 -- we do this by removing varName from the import of OccName above, making
36 -- a qualified instance of OccName and using OccNameAlias.varName where varName
37 -- ws previously used in this file.
38 import qualified OccName
40 import Module ( Module, mkModule, moduleNameString, moduleName,
41 modulePackageId, mkModuleNameFS )
42 import Id ( Id, mkLocalId )
43 import OccName ( mkOccNameFS )
44 import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
45 isExternalName, getSrcLoc )
47 import Type ( Type, mkTyConApp )
48 import TcType ( tcTyConAppArgs )
49 import TyCon ( tyConName )
50 import TysWiredIn ( parrTyCon )
52 import CoreUtils ( exprType )
53 import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
54 import PackageConfig ( thPackageId, packageIdString )
55 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
56 import BasicTypes ( isBoxed )
58 import Bag ( bagToList, unionManyBags )
59 import FastString ( unpackFS )
60 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
62 import Maybe ( catMaybes )
63 import Monad ( zipWithM )
64 import List ( sortBy )
66 -----------------------------------------------------------------------------
67 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
68 -- Returns a CoreExpr of type TH.ExpQ
69 -- The quoted thing is parameterised over Name, even though it has
70 -- been type checked. We don't want all those type decorations!
72 dsBracket brack splices
73 = dsExtendMetaEnv new_bit (do_brack brack)
75 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
77 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
78 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
79 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
80 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
81 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
83 {- -------------- Examples --------------------
87 gensym (unpackString "x"#) `bindQ` \ x1::String ->
88 lam (pvar x1) (var x1)
91 [| \x -> $(f [| x |]) |]
93 gensym (unpackString "x"#) `bindQ` \ x1::String ->
94 lam (pvar x1) (f (var x1))
98 -------------------------------------------------------
100 -------------------------------------------------------
102 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
104 = do { let { bndrs = map unLoc (groupBinders group) } ;
105 ss <- mkGenSyms bndrs ;
107 -- Bind all the names mainly to avoid repeated use of explicit strings.
109 -- do { t :: String <- genSym "T" ;
110 -- return (Data t [] ...more t's... }
111 -- The other important reason is that the output must mention
112 -- only "T", not "Foo:T" where Foo is the current module
115 decls <- addBinds ss (do {
116 val_ds <- rep_val_binds (hs_valds group) ;
117 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
118 inst_ds <- mapM repInstD' (hs_instds group) ;
119 for_ds <- mapM repForD (hs_fords group) ;
121 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
123 decl_ty <- lookupType decQTyConName ;
124 let { core_list = coreList' decl_ty decls } ;
126 dec_ty <- lookupType decTyConName ;
127 q_decs <- repSequenceQ dec_ty core_list ;
129 wrapNongenSyms ss q_decs
130 -- Do *not* gensym top-level binders
133 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
134 hs_fords = foreign_decls })
135 -- Collect the binders of a Group
136 = collectHsValBinders val_decls ++
137 [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
138 [n | L _ (ForeignImport n _ _) <- foreign_decls]
141 {- Note [Binders and occurrences]
142 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
143 When we desugar [d| data T = MkT |]
145 Data "T" [] [Con "MkT" []] []
147 Data "Foo:T" [] [Con "Foo:MkT" []] []
148 That is, the new data decl should fit into whatever new module it is
149 asked to fit in. We do *not* clone, though; no need for this:
156 then we must desugar to
157 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
159 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
160 And we use lookupOcc, rather than lookupBinder
161 in repTyClD and repC.
165 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
167 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
168 tcdLName = tc, tcdTyVars = tvs,
169 tcdCons = cons, tcdDerivs = mb_derivs }))
170 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
171 dec <- addTyVarBinds tvs $ \bndrs -> do {
172 cxt1 <- repLContext cxt ;
173 cons1 <- mapM repC cons ;
174 cons2 <- coreList conQTyConName cons1 ;
175 derivs1 <- repDerivs mb_derivs ;
176 bndrs1 <- coreList nameTyConName bndrs ;
177 repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
178 return $ Just (loc, dec) }
180 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
181 tcdLName = tc, tcdTyVars = tvs,
182 tcdCons = [con], tcdDerivs = mb_derivs }))
183 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
184 dec <- addTyVarBinds tvs $ \bndrs -> do {
185 cxt1 <- repLContext cxt ;
187 derivs1 <- repDerivs mb_derivs ;
188 bndrs1 <- coreList nameTyConName bndrs ;
189 repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
190 return $ Just (loc, dec) }
192 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
193 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
194 dec <- addTyVarBinds tvs $ \bndrs -> do {
196 bndrs1 <- coreList nameTyConName bndrs ;
197 repTySyn tc1 bndrs1 ty1 } ;
198 return (Just (loc, dec)) }
200 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
203 tcdSigs = sigs, tcdMeths = meth_binds }))
204 = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
205 dec <- addTyVarBinds tvs $ \bndrs -> do {
206 cxt1 <- repLContext cxt ;
207 sigs1 <- rep_sigs sigs ;
208 binds1 <- rep_binds meth_binds ;
209 fds1 <- repLFunDeps fds;
210 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
211 bndrs1 <- coreList nameTyConName bndrs ;
212 repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
213 return $ Just (loc, dec) }
216 repTyClD (L loc d) = putSrcSpanDs loc $
217 do { warnDs (hang ds_msg 4 (ppr d))
222 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
223 repLFunDeps fds = do fds' <- mapM repLFunDep fds
224 fdList <- coreList funDepTyConName fds'
227 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
228 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
229 ys' <- mapM lookupBinder ys
230 xs_list <- coreList nameTyConName xs'
231 ys_list <- coreList nameTyConName ys'
232 repFunDep xs_list ys_list
234 repInstD' (L loc (InstDecl ty binds _ _)) -- Ignore user pragmas for now
235 = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
236 -- We must bring the type variables into scope, so their occurrences
237 -- don't fail, even though the binders don't appear in the resulting
239 do { cxt1 <- repContext cxt
240 ; inst_ty1 <- repPred (HsClassP cls tys)
241 ; ss <- mkGenSyms (collectHsBindBinders binds)
242 ; binds1 <- addBinds ss (rep_binds binds)
243 ; decls1 <- coreList decQTyConName binds1
244 ; decls2 <- wrapNongenSyms ss decls1
245 -- wrapNonGenSyms: do not clone the class op names!
246 -- They must be called 'op' etc, not 'op34'
247 ; repInst cxt1 inst_ty1 decls2 }
251 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
253 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
254 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis)))
255 = do MkC name' <- lookupLOcc name
256 MkC typ' <- repLTy typ
257 MkC cc' <- repCCallConv cc
258 MkC s' <- repSafety s
259 cis' <- conv_cimportspec cis
260 MkC str <- coreStringLit $ static
261 ++ unpackFS ch ++ " "
262 ++ unpackFS cn ++ " "
264 dec <- rep2 forImpDName [cc', s', str, name', typ']
267 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
268 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
269 conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
270 conv_cimportspec CWrapper = return "wrapper"
272 CFunction (StaticTarget _) -> "static "
274 repForD decl = notHandled "Foreign declaration" (ppr decl)
276 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
277 repCCallConv CCallConv = rep2 cCallName []
278 repCCallConv StdCallConv = rep2 stdCallName []
280 repSafety :: Safety -> DsM (Core TH.Safety)
281 repSafety PlayRisky = rep2 unsafeName []
282 repSafety (PlaySafe False) = rep2 safeName []
283 repSafety (PlaySafe True) = rep2 threadsafeName []
285 ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
287 -------------------------------------------------------
289 -------------------------------------------------------
291 repC :: LConDecl Name -> DsM (Core TH.ConQ)
292 repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
293 = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
294 repConstr con1 details }
295 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
296 = do { addTyVarBinds tvs $ \bndrs -> do {
297 c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
298 ctxt' <- repContext ctxt;
299 bndrs' <- coreList nameTyConName bndrs;
300 rep2 forallCName [unC bndrs', unC ctxt', unC c']
303 repC (L loc con_decl) -- GADTs
305 notHandled "GADT declaration" (ppr con_decl)
307 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
311 rep2 strictTypeName [s, t]
313 (str, ty') = case ty of
314 L _ (HsBangTy _ ty) -> (isStrictName, ty)
315 other -> (notStrictName, ty)
317 -------------------------------------------------------
319 -------------------------------------------------------
321 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
322 repDerivs Nothing = coreList nameTyConName []
323 repDerivs (Just ctxt)
324 = do { strs <- mapM rep_deriv ctxt ;
325 coreList nameTyConName strs }
327 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
328 -- Deriving clauses must have the simple H98 form
329 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
330 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
333 -------------------------------------------------------
334 -- Signatures in a class decl, or a group of bindings
335 -------------------------------------------------------
337 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
338 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
339 return $ de_loc $ sort_by_loc locs_cores
341 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
342 -- We silently ignore ones we don't recognise
343 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
344 return (concat sigs1) }
346 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
348 -- Empty => Too hard, signature ignored
349 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
350 rep_sig other = return []
352 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
353 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
355 sig <- repProto nm1 ty1 ;
356 return [(loc, sig)] }
359 -------------------------------------------------------
361 -------------------------------------------------------
363 -- gensym a list of type variables and enter them into the meta environment;
364 -- the computations passed as the second argument is executed in that extended
365 -- meta environment and gets the *new* names on Core-level as an argument
367 addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
368 -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
369 -> DsM (Core (TH.Q a))
370 addTyVarBinds tvs m =
372 let names = map (hsTyVarName.unLoc) tvs
373 freshNames <- mkGenSyms names
374 term <- addBinds freshNames $ do
375 bndrs <- mapM lookupBinder names
377 wrapGenSyns freshNames term
379 -- represent a type context
381 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
382 repLContext (L _ ctxt) = repContext ctxt
384 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
386 preds <- mapM repLPred ctxt
387 predList <- coreList typeQTyConName preds
390 -- represent a type predicate
392 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
393 repLPred (L _ p) = repPred p
395 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
396 repPred (HsClassP cls tys) = do
397 tcon <- repTy (HsTyVar cls)
400 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
402 -- yield the representation of a list of types
404 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
405 repLTys tys = mapM repLTy tys
409 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
410 repLTy (L _ ty) = repTy ty
412 repTy :: HsType Name -> DsM (Core TH.TypeQ)
413 repTy (HsForAllTy _ tvs ctxt ty) =
414 addTyVarBinds tvs $ \bndrs -> do
415 ctxt1 <- repLContext ctxt
417 bndrs1 <- coreList nameTyConName bndrs
418 repTForall bndrs1 ctxt1 ty1
421 | isTvOcc (nameOccName n) = do
422 tv1 <- lookupBinder n
427 repTy (HsAppTy f a) = do
431 repTy (HsFunTy f a) = do
434 tcon <- repArrowTyCon
435 repTapps tcon [f1, a1]
436 repTy (HsListTy t) = do
440 repTy (HsPArrTy t) = do
442 tcon <- repTy (HsTyVar (tyConName parrTyCon))
444 repTy (HsTupleTy tc tys) = do
446 tcon <- repTupleTyCon (length tys)
448 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
450 repTy (HsParTy t) = repLTy t
451 repTy (HsPredTy pred) = repPred pred
452 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
453 repTy ty = notHandled "Exotic form of type" (ppr ty)
456 -----------------------------------------------------------------------------
458 -----------------------------------------------------------------------------
460 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
461 repLEs es = do { es' <- mapM repLE es ;
462 coreList expQTyConName es' }
464 -- FIXME: some of these panics should be converted into proper error messages
465 -- unless we can make sure that constructs, which are plainly not
466 -- supported in TH already lead to error messages at an earlier stage
467 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
468 repLE (L loc e) = putSrcSpanDs loc (repE e)
470 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
472 do { mb_val <- dsLookupMetaEnv x
474 Nothing -> do { str <- globalVar x
475 ; repVarOrCon x str }
476 Just (Bound y) -> repVarOrCon x (coreVar y)
477 Just (Splice e) -> do { e' <- dsExpr e
478 ; return (MkC e') } }
479 repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e)
481 -- Remember, we're desugaring renamer output here, so
482 -- HsOverlit can definitely occur
483 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
484 repE (HsLit l) = do { a <- repLiteral l; repLit a }
485 repE (HsLam (MatchGroup [m] _)) = repLambda m
486 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
488 repE (OpApp e1 op fix e2) =
489 do { arg1 <- repLE e1;
492 repInfixApp arg1 the_op arg2 }
493 repE (NegApp x nm) = do
495 negateVar <- lookupOcc negateName >>= repVar
497 repE (HsPar x) = repLE x
498 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
499 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
500 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
501 ; ms2 <- mapM repMatchTup ms
502 ; repCaseE arg (nonEmptyCoreList ms2) }
503 repE (HsIf x y z) = do
508 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
509 ; e2 <- addBinds ss (repLE e)
512 -- FIXME: I haven't got the types here right yet
513 repE (HsDo DoExpr sts body ty)
514 = do { (ss,zs) <- repLSts sts;
515 body' <- addBinds ss $ repLE body;
516 ret <- repNoBindSt body';
517 e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
519 repE (HsDo ListComp sts body ty)
520 = do { (ss,zs) <- repLSts sts;
521 body' <- addBinds ss $ repLE body;
522 ret <- repNoBindSt body';
523 e <- repComp (nonEmptyCoreList (zs ++ [ret]));
525 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
526 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
527 repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
528 repE e@(ExplicitTuple es boxed)
529 | isBoxed boxed = do { xs <- repLEs es; repTup xs }
530 | otherwise = notHandled "Unboxed tuples" (ppr e)
531 repE (RecordCon c _ flds)
532 = do { x <- lookupLOcc c;
533 fs <- repFields flds;
535 repE (RecordUpd e flds _ _)
537 fs <- repFields flds;
540 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
541 repE (ArithSeq _ aseq) =
543 From e -> do { ds1 <- repLE e; repFrom ds1 }
552 FromThenTo e1 e2 e3 -> do
556 repFromThenTo ds1 ds2 ds3
557 repE (HsSpliceE (HsSplice n _))
558 = do { mb_val <- dsLookupMetaEnv n
560 Just (Splice e) -> do { e' <- dsExpr e
562 other -> pprPanic "HsSplice" (ppr n) }
563 -- Should not happen; statically checked
565 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
566 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
567 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
568 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
569 repE e = notHandled "Expression form" (ppr e)
571 -----------------------------------------------------------------------------
572 -- Building representations of auxillary structures like Match, Clause, Stmt,
574 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
575 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
576 do { ss1 <- mkGenSyms (collectPatBinders p)
577 ; addBinds ss1 $ do {
579 ; (ss2,ds) <- repBinds wheres
580 ; addBinds ss2 $ do {
581 ; gs <- repGuards guards
582 ; match <- repMatch p1 gs ds
583 ; wrapGenSyns (ss1++ss2) match }}}
584 repMatchTup other = panic "repMatchTup: case alt with more than one arg"
586 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
587 repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
588 do { ss1 <- mkGenSyms (collectPatsBinders ps)
589 ; addBinds ss1 $ do {
591 ; (ss2,ds) <- repBinds wheres
592 ; addBinds ss2 $ do {
593 gs <- repGuards guards
594 ; clause <- repClause ps1 gs ds
595 ; wrapGenSyns (ss1++ss2) clause }}}
597 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
598 repGuards [L _ (GRHS [] e)]
599 = do {a <- repLE e; repNormal a }
601 = do { zs <- mapM process other;
602 let {(xs, ys) = unzip zs};
603 gd <- repGuarded (nonEmptyCoreList ys);
604 wrapGenSyns (concat xs) gd }
606 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
607 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
608 = do { x <- repLNormalGE e1 e2;
610 process (L _ (GRHS ss rhs))
611 = do (gs, ss') <- repLSts ss
612 rhs' <- addBinds gs $ repLE rhs
613 g <- repPatGE (nonEmptyCoreList ss') rhs'
616 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
618 fnames <- mapM lookupLOcc (map fst flds)
619 es <- mapM repLE (map snd flds)
620 fs <- zipWithM repFieldExp fnames es
621 coreList fieldExpQTyConName fs
624 -----------------------------------------------------------------------------
625 -- Representing Stmt's is tricky, especially if bound variables
626 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
627 -- First gensym new names for every variable in any of the patterns.
628 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
629 -- if variables didn't shaddow, the static gensym wouldn't be necessary
630 -- and we could reuse the original names (x and x).
632 -- do { x'1 <- gensym "x"
633 -- ; x'2 <- gensym "x"
634 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
635 -- , BindSt (pvar x'2) [| f x |]
636 -- , NoBindSt [| g x |]
640 -- The strategy is to translate a whole list of do-bindings by building a
641 -- bigger environment, and a bigger set of meta bindings
642 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
643 -- of the expressions within the Do
645 -----------------------------------------------------------------------------
646 -- The helper function repSts computes the translation of each sub expression
647 -- and a bunch of prefix bindings denoting the dynamic renaming.
649 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
650 repLSts stmts = repSts (map unLoc stmts)
652 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
653 repSts (BindStmt p e _ _ : ss) =
655 ; ss1 <- mkGenSyms (collectPatBinders p)
656 ; addBinds ss1 $ do {
658 ; (ss2,zs) <- repSts ss
659 ; z <- repBindSt p1 e2
660 ; return (ss1++ss2, z : zs) }}
661 repSts (LetStmt bs : ss) =
662 do { (ss1,ds) <- repBinds bs
664 ; (ss2,zs) <- addBinds ss1 (repSts ss)
665 ; return (ss1++ss2, z : zs) }
666 repSts (ExprStmt e _ _ : ss) =
668 ; z <- repNoBindSt e2
669 ; (ss2,zs) <- repSts ss
670 ; return (ss2, z : zs) }
671 repSts [] = return ([],[])
672 repSts other = notHandled "Exotic statement" (ppr other)
675 -----------------------------------------------------------
677 -----------------------------------------------------------
679 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
680 repBinds EmptyLocalBinds
681 = do { core_list <- coreList decQTyConName []
682 ; return ([], core_list) }
684 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
686 repBinds (HsValBinds decs)
687 = do { let { bndrs = map unLoc (collectHsValBinders decs) }
688 -- No need to worrry about detailed scopes within
689 -- the binding group, because we are talking Names
690 -- here, so we can safely treat it as a mutually
692 ; ss <- mkGenSyms bndrs
693 ; prs <- addBinds ss (rep_val_binds decs)
694 ; core_list <- coreList decQTyConName
695 (de_loc (sort_by_loc prs))
696 ; return (ss, core_list) }
698 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
699 -- Assumes: all the binders of the binding are alrady in the meta-env
700 rep_val_binds (ValBindsOut binds sigs)
701 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
702 ; core2 <- rep_sigs' sigs
703 ; return (core1 ++ core2) }
704 rep_val_binds (ValBindsOut binds sigs)
705 = panic "rep_val_binds: ValBindsOut"
707 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
708 rep_binds binds = do { binds_w_locs <- rep_binds' binds
709 ; return (de_loc (sort_by_loc binds_w_locs)) }
711 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
712 rep_binds' binds = mapM rep_bind (bagToList binds)
714 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
715 -- Assumes: all the binders of the binding are alrady in the meta-env
717 -- Note GHC treats declarations of a variable (not a pattern)
718 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
719 -- with an empty list of patterns
720 rep_bind (L loc (FunBind { fun_id = fn,
721 fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
722 = do { (ss,wherecore) <- repBinds wheres
723 ; guardcore <- addBinds ss (repGuards guards)
724 ; fn' <- lookupLBinder fn
726 ; ans <- repVal p guardcore wherecore
727 ; ans' <- wrapGenSyns ss ans
728 ; return (loc, ans') }
730 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
731 = do { ms1 <- mapM repClauseTup ms
732 ; fn' <- lookupLBinder fn
733 ; ans <- repFun fn' (nonEmptyCoreList ms1)
734 ; return (loc, ans) }
736 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
737 = do { patcore <- repLP pat
738 ; (ss,wherecore) <- repBinds wheres
739 ; guardcore <- addBinds ss (repGuards guards)
740 ; ans <- repVal patcore guardcore wherecore
741 ; ans' <- wrapGenSyns ss ans
742 ; return (loc, ans') }
744 rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
745 = do { v' <- lookupBinder v
748 ; patcore <- repPvar v'
749 ; empty_decls <- coreList decQTyConName []
750 ; ans <- repVal patcore x empty_decls
751 ; return (srcLocSpan (getSrcLoc v), ans) }
753 rep_bind other = panic "rep_bind: AbsBinds"
755 -----------------------------------------------------------------------------
756 -- Since everything in a Bind is mutually recursive we need rename all
757 -- all the variables simultaneously. For example:
758 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
759 -- do { f'1 <- gensym "f"
760 -- ; g'2 <- gensym "g"
761 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
762 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
764 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
765 -- environment ( f |-> f'1 ) from each binding, and then unioning them
766 -- together. As we do this we collect GenSymBinds's which represent the renamed
767 -- variables bound by the Bindings. In order not to lose track of these
768 -- representations we build a shadow datatype MB with the same structure as
769 -- MonoBinds, but which has slots for the representations
772 -----------------------------------------------------------------------------
773 -- GHC allows a more general form of lambda abstraction than specified
774 -- by Haskell 98. In particular it allows guarded lambda's like :
775 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
776 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
777 -- (\ p1 .. pn -> exp) by causing an error.
779 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
780 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
781 = do { let bndrs = collectPatsBinders ps ;
782 ; ss <- mkGenSyms bndrs
783 ; lam <- addBinds ss (
784 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
785 ; wrapGenSyns ss lam }
787 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m)
790 -----------------------------------------------------------------------------
792 -- repP deals with patterns. It assumes that we have already
793 -- walked over the pattern(s) once to collect the binders, and
794 -- have extended the environment. So every pattern-bound
795 -- variable should already appear in the environment.
797 -- Process a list of patterns
798 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
799 repLPs ps = do { ps' <- mapM repLP ps ;
800 coreList patQTyConName ps' }
802 repLP :: LPat Name -> DsM (Core TH.PatQ)
803 repLP (L _ p) = repP p
805 repP :: Pat Name -> DsM (Core TH.PatQ)
806 repP (WildPat _) = repPwild
807 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
808 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
809 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
810 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
811 repP (ParPat p) = repLP p
812 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
813 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
814 repP (ConPatIn dc details)
815 = do { con_str <- lookupLOcc dc
817 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
818 RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
819 ; ps <- sequence $ map repLP (map snd pairs)
820 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
821 ; fps' <- coreList fieldPatQTyConName fps
822 ; repPrec con_str fps' }
823 InfixCon p1 p2 -> do { p1' <- repLP p1;
825 repPinfix p1' con_str p2' }
827 repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
828 repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
829 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
830 -- The problem is to do with scoped type variables.
831 -- To implement them, we have to implement the scoping rules
832 -- here in DsMeta, and I don't want to do that today!
833 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
834 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
835 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
837 repP other = notHandled "Exotic pattern" (ppr other)
839 ----------------------------------------------------------
840 -- Declaration ordering helpers
842 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
843 sort_by_loc xs = sortBy comp xs
844 where comp x y = compare (fst x) (fst y)
846 de_loc :: [(a, b)] -> [b]
849 ----------------------------------------------------------
850 -- The meta-environment
852 -- A name/identifier association for fresh names of locally bound entities
853 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
854 -- I.e. (x, x_id) means
855 -- let x_id = gensym "x" in ...
857 -- Generate a fresh name for a locally bound entity
859 mkGenSyms :: [Name] -> DsM [GenSymBind]
860 -- We can use the existing name. For example:
861 -- [| \x_77 -> x_77 + x_77 |]
863 -- do { x_77 <- genSym "x"; .... }
864 -- We use the same x_77 in the desugared program, but with the type Bndr
867 -- We do make it an Internal name, though (hence localiseName)
869 -- Nevertheless, it's monadic because we have to generate nameTy
870 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
871 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
874 addBinds :: [GenSymBind] -> DsM a -> DsM a
875 -- Add a list of fresh names for locally bound entities to the
876 -- meta environment (which is part of the state carried around
877 -- by the desugarer monad)
878 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
880 -- Look up a locally bound name
882 lookupLBinder :: Located Name -> DsM (Core TH.Name)
883 lookupLBinder (L _ n) = lookupBinder n
885 lookupBinder :: Name -> DsM (Core TH.Name)
887 = do { mb_val <- dsLookupMetaEnv n;
889 Just (Bound x) -> return (coreVar x)
890 other -> failWithDs msg }
892 msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
894 -- Look up a name that is either locally bound or a global name
896 -- * If it is a global name, generate the "original name" representation (ie,
897 -- the <module>:<name> form) for the associated entity
899 lookupLOcc :: Located Name -> DsM (Core TH.Name)
900 -- Lookup an occurrence; it can't be a splice.
901 -- Use the in-scope bindings if they exist
902 lookupLOcc (L _ n) = lookupOcc n
904 lookupOcc :: Name -> DsM (Core TH.Name)
906 = do { mb_val <- dsLookupMetaEnv n ;
908 Nothing -> globalVar n
909 Just (Bound x) -> return (coreVar x)
910 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
913 globalVar :: Name -> DsM (Core TH.Name)
914 -- Not bound by the meta-env
915 -- Could be top-level; or could be local
916 -- f x = $(g [| x |])
917 -- Here the x will be local
919 | isExternalName name
920 = do { MkC mod <- coreStringLit name_mod
921 ; MkC pkg <- coreStringLit name_pkg
922 ; MkC occ <- occNameLit name
923 ; rep2 mk_varg [pkg,mod,occ] }
925 = do { MkC occ <- occNameLit name
926 ; MkC uni <- coreIntLit (getKey (getUnique name))
927 ; rep2 mkNameLName [occ,uni] }
929 mod = nameModule name
930 name_mod = moduleNameString (moduleName mod)
931 name_pkg = packageIdString (modulePackageId mod)
932 name_occ = nameOccName name
933 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
934 | OccName.isVarOcc name_occ = mkNameG_vName
935 | OccName.isTcOcc name_occ = mkNameG_tcName
936 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
938 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
939 -> DsM Type -- The type
940 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
941 return (mkTyConApp tc []) }
943 wrapGenSyns :: [GenSymBind]
944 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
945 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
946 -- --> bindQ (gensym nm1) (\ id1 ->
947 -- bindQ (gensym nm2 (\ id2 ->
950 wrapGenSyns binds body@(MkC b)
951 = do { var_ty <- lookupType nameTyConName
954 [elt_ty] = tcTyConAppArgs (exprType b)
955 -- b :: Q a, so we can get the type 'a' by looking at the
956 -- argument type. NB: this relies on Q being a data/newtype,
957 -- not a type synonym
959 go var_ty [] = return body
960 go var_ty ((name,id) : binds)
961 = do { MkC body' <- go var_ty binds
962 ; lit_str <- occNameLit name
963 ; gensym_app <- repGensym lit_str
964 ; repBindQ var_ty elt_ty
965 gensym_app (MkC (Lam id body')) }
967 -- Just like wrapGenSym, but don't actually do the gensym
968 -- Instead use the existing name:
969 -- let x = "x" in ...
970 -- Only used for [Decl], and for the class ops in class
971 -- and instance decls
972 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
973 wrapNongenSyms binds (MkC body)
974 = do { binds' <- mapM do_one binds ;
975 return (MkC (mkLets binds' body)) }
978 = do { MkC lit_str <- occNameLit name
979 ; MkC var <- rep2 mkNameName [lit_str]
980 ; return (NonRec id var) }
982 occNameLit :: Name -> DsM (Core String)
983 occNameLit n = coreStringLit (occNameString (nameOccName n))
986 -- %*********************************************************************
990 -- %*********************************************************************
992 -----------------------------------------------------------------------------
993 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
994 -- we invent a new datatype which uses phantom types.
996 newtype Core a = MkC CoreExpr
999 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1000 rep2 n xs = do { id <- dsLookupGlobalId n
1001 ; return (MkC (foldl App (Var id) xs)) }
1003 -- Then we make "repConstructors" which use the phantom types for each of the
1004 -- smart constructors of the Meta.Meta datatypes.
1007 -- %*********************************************************************
1009 -- The 'smart constructors'
1011 -- %*********************************************************************
1013 --------------- Patterns -----------------
1014 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1015 repPlit (MkC l) = rep2 litPName [l]
1017 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1018 repPvar (MkC s) = rep2 varPName [s]
1020 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1021 repPtup (MkC ps) = rep2 tupPName [ps]
1023 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1024 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1026 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1027 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1029 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1030 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1032 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1033 repPtilde (MkC p) = rep2 tildePName [p]
1035 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1036 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1038 repPwild :: DsM (Core TH.PatQ)
1039 repPwild = rep2 wildPName []
1041 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1042 repPlist (MkC ps) = rep2 listPName [ps]
1044 --------------- Expressions -----------------
1045 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1046 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1047 | otherwise = repVar str
1049 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1050 repVar (MkC s) = rep2 varEName [s]
1052 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1053 repCon (MkC s) = rep2 conEName [s]
1055 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1056 repLit (MkC c) = rep2 litEName [c]
1058 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1059 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1061 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1062 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1064 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1065 repTup (MkC es) = rep2 tupEName [es]
1067 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1068 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1070 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1071 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1073 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1074 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1076 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1077 repDoE (MkC ss) = rep2 doEName [ss]
1079 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1080 repComp (MkC ss) = rep2 compEName [ss]
1082 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1083 repListExp (MkC es) = rep2 listEName [es]
1085 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1086 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1088 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1089 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1091 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1092 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1094 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1095 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1097 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1098 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1100 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1101 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1103 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1104 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1106 ------------ Right hand sides (guarded expressions) ----
1107 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1108 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1110 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1111 repNormal (MkC e) = rep2 normalBName [e]
1113 ------------ Guards ----
1114 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1115 repLNormalGE g e = do g' <- repLE g
1119 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1120 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1122 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1123 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1125 ------------- Stmts -------------------
1126 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1127 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1129 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1130 repLetSt (MkC ds) = rep2 letSName [ds]
1132 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1133 repNoBindSt (MkC e) = rep2 noBindSName [e]
1135 -------------- Range (Arithmetic sequences) -----------
1136 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1137 repFrom (MkC x) = rep2 fromEName [x]
1139 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1140 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1142 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1143 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1145 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1146 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1148 ------------ Match and Clause Tuples -----------
1149 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1150 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1152 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1153 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1155 -------------- Dec -----------------------------
1156 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1157 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1159 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1160 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1162 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1163 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1164 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1166 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1167 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1168 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1170 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1171 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1173 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1174 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1176 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1177 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1179 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1180 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1182 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1183 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1185 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1186 repCtxt (MkC tys) = rep2 cxtName [tys]
1188 repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
1189 -> DsM (Core TH.ConQ)
1190 repConstr con (PrefixCon ps)
1191 = do arg_tys <- mapM repBangTy ps
1192 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1193 rep2 normalCName [unC con, unC arg_tys1]
1194 repConstr con (RecCon ips)
1195 = do arg_vs <- mapM lookupLOcc (map fst ips)
1196 arg_tys <- mapM repBangTy (map snd ips)
1197 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1199 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1200 rep2 recCName [unC con, unC arg_vtys']
1201 repConstr con (InfixCon st1 st2)
1202 = do arg1 <- repBangTy st1
1203 arg2 <- repBangTy st2
1204 rep2 infixCName [unC arg1, unC con, unC arg2]
1206 ------------ Types -------------------
1208 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1209 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1210 = rep2 forallTName [tvars, ctxt, ty]
1212 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1213 repTvar (MkC s) = rep2 varTName [s]
1215 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1216 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1218 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1219 repTapps f [] = return f
1220 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1222 --------- Type constructors --------------
1224 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1225 repNamedTyCon (MkC s) = rep2 conTName [s]
1227 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1228 -- Note: not Core Int; it's easier to be direct here
1229 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1231 repArrowTyCon :: DsM (Core TH.TypeQ)
1232 repArrowTyCon = rep2 arrowTName []
1234 repListTyCon :: DsM (Core TH.TypeQ)
1235 repListTyCon = rep2 listTName []
1238 ----------------------------------------------------------
1241 repLiteral :: HsLit -> DsM (Core TH.Lit)
1243 = do lit' <- case lit of
1244 HsIntPrim i -> mk_integer i
1245 HsInt i -> mk_integer i
1246 HsFloatPrim r -> mk_rational r
1247 HsDoublePrim r -> mk_rational r
1249 lit_expr <- dsLit lit'
1251 Just lit_name -> rep2 lit_name [lit_expr]
1252 Nothing -> notHandled "Exotic literal" (ppr lit)
1254 mb_lit_name = case lit of
1255 HsInteger _ _ -> Just integerLName
1256 HsInt _ -> Just integerLName
1257 HsIntPrim _ -> Just intPrimLName
1258 HsFloatPrim _ -> Just floatPrimLName
1259 HsDoublePrim _ -> Just doublePrimLName
1260 HsChar _ -> Just charLName
1261 HsString _ -> Just stringLName
1262 HsRat _ _ -> Just rationalLName
1265 mk_integer i = do integer_ty <- lookupType integerTyConName
1266 return $ HsInteger i integer_ty
1267 mk_rational r = do rat_ty <- lookupType rationalTyConName
1268 return $ HsRat r rat_ty
1270 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1271 repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
1272 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1273 -- The type Rational will be in the environment, becuase
1274 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1275 -- and rationalL is sucked in when any TH stuff is used
1277 --------------- Miscellaneous -------------------
1279 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1280 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1282 repBindQ :: Type -> Type -- a and b
1283 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1284 repBindQ ty_a ty_b (MkC x) (MkC y)
1285 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1287 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1288 repSequenceQ ty_a (MkC list)
1289 = rep2 sequenceQName [Type ty_a, list]
1291 ------------ Lists and Tuples -------------------
1292 -- turn a list of patterns into a single pattern matching a list
1294 coreList :: Name -- Of the TyCon of the element type
1295 -> [Core a] -> DsM (Core [a])
1297 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1299 coreList' :: Type -- The element type
1300 -> [Core a] -> Core [a]
1301 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1303 nonEmptyCoreList :: [Core a] -> Core [a]
1304 -- The list must be non-empty so we can get the element type
1305 -- Otherwise use coreList
1306 nonEmptyCoreList [] = panic "coreList: empty argument"
1307 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1309 coreStringLit :: String -> DsM (Core String)
1310 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1312 coreIntLit :: Int -> DsM (Core Int)
1313 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1315 coreVar :: Id -> Core TH.Name -- The Id has type Name
1316 coreVar id = MkC (Var id)
1318 ----------------- Failure -----------------------
1319 notHandled :: String -> SDoc -> DsM a
1320 notHandled what doc = failWithDs msg
1322 msg = hang (text what <+> ptext SLIT("not (yet) handled by Template Haskell"))
1326 -- %************************************************************************
1328 -- The known-key names for Template Haskell
1330 -- %************************************************************************
1332 -- To add a name, do three things
1334 -- 1) Allocate a key
1336 -- 3) Add the name to knownKeyNames
1338 templateHaskellNames :: [Name]
1339 -- The names that are implicitly mentioned by ``bracket''
1340 -- Should stay in sync with the import list of DsMeta
1342 templateHaskellNames = [
1343 returnQName, bindQName, sequenceQName, newNameName, liftName,
1344 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1347 charLName, stringLName, integerLName, intPrimLName,
1348 floatPrimLName, doublePrimLName, rationalLName,
1350 litPName, varPName, tupPName, conPName, tildePName, infixPName,
1351 asPName, wildPName, recPName, listPName, sigPName,
1359 varEName, conEName, litEName, appEName, infixEName,
1360 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1361 condEName, letEName, caseEName, doEName, compEName,
1362 fromEName, fromThenEName, fromToEName, fromThenToEName,
1363 listEName, sigEName, recConEName, recUpdEName,
1367 guardedBName, normalBName,
1369 normalGEName, patGEName,
1371 bindSName, letSName, noBindSName, parSName,
1373 funDName, valDName, dataDName, newtypeDName, tySynDName,
1374 classDName, instanceDName, sigDName, forImpDName,
1378 isStrictName, notStrictName,
1380 normalCName, recCName, infixCName, forallCName,
1386 forallTName, varTName, conTName, appTName,
1387 tupleTName, arrowTName, listTName,
1389 cCallName, stdCallName,
1398 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1399 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1400 decQTyConName, conQTyConName, strictTypeQTyConName,
1401 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1402 typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1403 fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
1406 thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax")
1407 thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
1409 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1411 mk_known_key_name mod space str uniq
1412 = mkExternalName uniq mod (mkOccNameFS space str)
1415 libFun = mk_known_key_name thLib OccName.varName
1416 libTc = mk_known_key_name thLib OccName.tcName
1417 thFun = mk_known_key_name thSyn OccName.varName
1418 thTc = mk_known_key_name thSyn OccName.tcName
1420 -------------------- TH.Syntax -----------------------
1421 qTyConName = thTc FSLIT("Q") qTyConKey
1422 nameTyConName = thTc FSLIT("Name") nameTyConKey
1423 fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
1424 patTyConName = thTc FSLIT("Pat") patTyConKey
1425 fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
1426 expTyConName = thTc FSLIT("Exp") expTyConKey
1427 decTyConName = thTc FSLIT("Dec") decTyConKey
1428 typeTyConName = thTc FSLIT("Type") typeTyConKey
1429 matchTyConName = thTc FSLIT("Match") matchTyConKey
1430 clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
1431 funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
1433 returnQName = thFun FSLIT("returnQ") returnQIdKey
1434 bindQName = thFun FSLIT("bindQ") bindQIdKey
1435 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1436 newNameName = thFun FSLIT("newName") newNameIdKey
1437 liftName = thFun FSLIT("lift") liftIdKey
1438 mkNameName = thFun FSLIT("mkName") mkNameIdKey
1439 mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
1440 mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
1441 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1442 mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
1445 -------------------- TH.Lib -----------------------
1447 charLName = libFun FSLIT("charL") charLIdKey
1448 stringLName = libFun FSLIT("stringL") stringLIdKey
1449 integerLName = libFun FSLIT("integerL") integerLIdKey
1450 intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
1451 floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
1452 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1453 rationalLName = libFun FSLIT("rationalL") rationalLIdKey
1456 litPName = libFun FSLIT("litP") litPIdKey
1457 varPName = libFun FSLIT("varP") varPIdKey
1458 tupPName = libFun FSLIT("tupP") tupPIdKey
1459 conPName = libFun FSLIT("conP") conPIdKey
1460 infixPName = libFun FSLIT("infixP") infixPIdKey
1461 tildePName = libFun FSLIT("tildeP") tildePIdKey
1462 asPName = libFun FSLIT("asP") asPIdKey
1463 wildPName = libFun FSLIT("wildP") wildPIdKey
1464 recPName = libFun FSLIT("recP") recPIdKey
1465 listPName = libFun FSLIT("listP") listPIdKey
1466 sigPName = libFun FSLIT("sigP") sigPIdKey
1468 -- type FieldPat = ...
1469 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1472 matchName = libFun FSLIT("match") matchIdKey
1474 -- data Clause = ...
1475 clauseName = libFun FSLIT("clause") clauseIdKey
1478 varEName = libFun FSLIT("varE") varEIdKey
1479 conEName = libFun FSLIT("conE") conEIdKey
1480 litEName = libFun FSLIT("litE") litEIdKey
1481 appEName = libFun FSLIT("appE") appEIdKey
1482 infixEName = libFun FSLIT("infixE") infixEIdKey
1483 infixAppName = libFun FSLIT("infixApp") infixAppIdKey
1484 sectionLName = libFun FSLIT("sectionL") sectionLIdKey
1485 sectionRName = libFun FSLIT("sectionR") sectionRIdKey
1486 lamEName = libFun FSLIT("lamE") lamEIdKey
1487 tupEName = libFun FSLIT("tupE") tupEIdKey
1488 condEName = libFun FSLIT("condE") condEIdKey
1489 letEName = libFun FSLIT("letE") letEIdKey
1490 caseEName = libFun FSLIT("caseE") caseEIdKey
1491 doEName = libFun FSLIT("doE") doEIdKey
1492 compEName = libFun FSLIT("compE") compEIdKey
1493 -- ArithSeq skips a level
1494 fromEName = libFun FSLIT("fromE") fromEIdKey
1495 fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
1496 fromToEName = libFun FSLIT("fromToE") fromToEIdKey
1497 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1499 listEName = libFun FSLIT("listE") listEIdKey
1500 sigEName = libFun FSLIT("sigE") sigEIdKey
1501 recConEName = libFun FSLIT("recConE") recConEIdKey
1502 recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
1504 -- type FieldExp = ...
1505 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1508 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1509 normalBName = libFun FSLIT("normalB") normalBIdKey
1512 normalGEName = libFun FSLIT("normalGE") normalGEIdKey
1513 patGEName = libFun FSLIT("patGE") patGEIdKey
1516 bindSName = libFun FSLIT("bindS") bindSIdKey
1517 letSName = libFun FSLIT("letS") letSIdKey
1518 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1519 parSName = libFun FSLIT("parS") parSIdKey
1522 funDName = libFun FSLIT("funD") funDIdKey
1523 valDName = libFun FSLIT("valD") valDIdKey
1524 dataDName = libFun FSLIT("dataD") dataDIdKey
1525 newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
1526 tySynDName = libFun FSLIT("tySynD") tySynDIdKey
1527 classDName = libFun FSLIT("classD") classDIdKey
1528 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1529 sigDName = libFun FSLIT("sigD") sigDIdKey
1530 forImpDName = libFun FSLIT("forImpD") forImpDIdKey
1533 cxtName = libFun FSLIT("cxt") cxtIdKey
1535 -- data Strict = ...
1536 isStrictName = libFun FSLIT("isStrict") isStrictKey
1537 notStrictName = libFun FSLIT("notStrict") notStrictKey
1540 normalCName = libFun FSLIT("normalC") normalCIdKey
1541 recCName = libFun FSLIT("recC") recCIdKey
1542 infixCName = libFun FSLIT("infixC") infixCIdKey
1543 forallCName = libFun FSLIT("forallC") forallCIdKey
1545 -- type StrictType = ...
1546 strictTypeName = libFun FSLIT("strictType") strictTKey
1548 -- type VarStrictType = ...
1549 varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
1552 forallTName = libFun FSLIT("forallT") forallTIdKey
1553 varTName = libFun FSLIT("varT") varTIdKey
1554 conTName = libFun FSLIT("conT") conTIdKey
1555 tupleTName = libFun FSLIT("tupleT") tupleTIdKey
1556 arrowTName = libFun FSLIT("arrowT") arrowTIdKey
1557 listTName = libFun FSLIT("listT") listTIdKey
1558 appTName = libFun FSLIT("appT") appTIdKey
1560 -- data Callconv = ...
1561 cCallName = libFun FSLIT("cCall") cCallIdKey
1562 stdCallName = libFun FSLIT("stdCall") stdCallIdKey
1564 -- data Safety = ...
1565 unsafeName = libFun FSLIT("unsafe") unsafeIdKey
1566 safeName = libFun FSLIT("safe") safeIdKey
1567 threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
1569 -- data FunDep = ...
1570 funDepName = libFun FSLIT("funDep") funDepIdKey
1572 matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
1573 clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
1574 expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
1575 stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
1576 decQTyConName = libTc FSLIT("DecQ") decQTyConKey
1577 conQTyConName = libTc FSLIT("ConQ") conQTyConKey
1578 strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
1579 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1580 typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
1581 fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
1582 patQTyConName = libTc FSLIT("PatQ") patQTyConKey
1583 fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
1585 -- TyConUniques available: 100-129
1586 -- Check in PrelNames if you want to change this
1588 expTyConKey = mkPreludeTyConUnique 100
1589 matchTyConKey = mkPreludeTyConUnique 101
1590 clauseTyConKey = mkPreludeTyConUnique 102
1591 qTyConKey = mkPreludeTyConUnique 103
1592 expQTyConKey = mkPreludeTyConUnique 104
1593 decQTyConKey = mkPreludeTyConUnique 105
1594 patTyConKey = mkPreludeTyConUnique 106
1595 matchQTyConKey = mkPreludeTyConUnique 107
1596 clauseQTyConKey = mkPreludeTyConUnique 108
1597 stmtQTyConKey = mkPreludeTyConUnique 109
1598 conQTyConKey = mkPreludeTyConUnique 110
1599 typeQTyConKey = mkPreludeTyConUnique 111
1600 typeTyConKey = mkPreludeTyConUnique 112
1601 decTyConKey = mkPreludeTyConUnique 113
1602 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1603 strictTypeQTyConKey = mkPreludeTyConUnique 115
1604 fieldExpTyConKey = mkPreludeTyConUnique 116
1605 fieldPatTyConKey = mkPreludeTyConUnique 117
1606 nameTyConKey = mkPreludeTyConUnique 118
1607 patQTyConKey = mkPreludeTyConUnique 119
1608 fieldPatQTyConKey = mkPreludeTyConUnique 120
1609 fieldExpQTyConKey = mkPreludeTyConUnique 121
1610 funDepTyConKey = mkPreludeTyConUnique 122
1612 -- IdUniques available: 200-399
1613 -- If you want to change this, make sure you check in PrelNames
1615 returnQIdKey = mkPreludeMiscIdUnique 200
1616 bindQIdKey = mkPreludeMiscIdUnique 201
1617 sequenceQIdKey = mkPreludeMiscIdUnique 202
1618 liftIdKey = mkPreludeMiscIdUnique 203
1619 newNameIdKey = mkPreludeMiscIdUnique 204
1620 mkNameIdKey = mkPreludeMiscIdUnique 205
1621 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
1622 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
1623 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
1624 mkNameLIdKey = mkPreludeMiscIdUnique 209
1628 charLIdKey = mkPreludeMiscIdUnique 210
1629 stringLIdKey = mkPreludeMiscIdUnique 211
1630 integerLIdKey = mkPreludeMiscIdUnique 212
1631 intPrimLIdKey = mkPreludeMiscIdUnique 213
1632 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1633 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1634 rationalLIdKey = mkPreludeMiscIdUnique 216
1637 litPIdKey = mkPreludeMiscIdUnique 220
1638 varPIdKey = mkPreludeMiscIdUnique 221
1639 tupPIdKey = mkPreludeMiscIdUnique 222
1640 conPIdKey = mkPreludeMiscIdUnique 223
1641 infixPIdKey = mkPreludeMiscIdUnique 312
1642 tildePIdKey = mkPreludeMiscIdUnique 224
1643 asPIdKey = mkPreludeMiscIdUnique 225
1644 wildPIdKey = mkPreludeMiscIdUnique 226
1645 recPIdKey = mkPreludeMiscIdUnique 227
1646 listPIdKey = mkPreludeMiscIdUnique 228
1647 sigPIdKey = mkPreludeMiscIdUnique 229
1649 -- type FieldPat = ...
1650 fieldPatIdKey = mkPreludeMiscIdUnique 230
1653 matchIdKey = mkPreludeMiscIdUnique 231
1655 -- data Clause = ...
1656 clauseIdKey = mkPreludeMiscIdUnique 232
1659 varEIdKey = mkPreludeMiscIdUnique 240
1660 conEIdKey = mkPreludeMiscIdUnique 241
1661 litEIdKey = mkPreludeMiscIdUnique 242
1662 appEIdKey = mkPreludeMiscIdUnique 243
1663 infixEIdKey = mkPreludeMiscIdUnique 244
1664 infixAppIdKey = mkPreludeMiscIdUnique 245
1665 sectionLIdKey = mkPreludeMiscIdUnique 246
1666 sectionRIdKey = mkPreludeMiscIdUnique 247
1667 lamEIdKey = mkPreludeMiscIdUnique 248
1668 tupEIdKey = mkPreludeMiscIdUnique 249
1669 condEIdKey = mkPreludeMiscIdUnique 250
1670 letEIdKey = mkPreludeMiscIdUnique 251
1671 caseEIdKey = mkPreludeMiscIdUnique 252
1672 doEIdKey = mkPreludeMiscIdUnique 253
1673 compEIdKey = mkPreludeMiscIdUnique 254
1674 fromEIdKey = mkPreludeMiscIdUnique 255
1675 fromThenEIdKey = mkPreludeMiscIdUnique 256
1676 fromToEIdKey = mkPreludeMiscIdUnique 257
1677 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1678 listEIdKey = mkPreludeMiscIdUnique 259
1679 sigEIdKey = mkPreludeMiscIdUnique 260
1680 recConEIdKey = mkPreludeMiscIdUnique 261
1681 recUpdEIdKey = mkPreludeMiscIdUnique 262
1683 -- type FieldExp = ...
1684 fieldExpIdKey = mkPreludeMiscIdUnique 265
1687 guardedBIdKey = mkPreludeMiscIdUnique 266
1688 normalBIdKey = mkPreludeMiscIdUnique 267
1691 normalGEIdKey = mkPreludeMiscIdUnique 310
1692 patGEIdKey = mkPreludeMiscIdUnique 311
1695 bindSIdKey = mkPreludeMiscIdUnique 268
1696 letSIdKey = mkPreludeMiscIdUnique 269
1697 noBindSIdKey = mkPreludeMiscIdUnique 270
1698 parSIdKey = mkPreludeMiscIdUnique 271
1701 funDIdKey = mkPreludeMiscIdUnique 272
1702 valDIdKey = mkPreludeMiscIdUnique 273
1703 dataDIdKey = mkPreludeMiscIdUnique 274
1704 newtypeDIdKey = mkPreludeMiscIdUnique 275
1705 tySynDIdKey = mkPreludeMiscIdUnique 276
1706 classDIdKey = mkPreludeMiscIdUnique 277
1707 instanceDIdKey = mkPreludeMiscIdUnique 278
1708 sigDIdKey = mkPreludeMiscIdUnique 279
1709 forImpDIdKey = mkPreludeMiscIdUnique 297
1712 cxtIdKey = mkPreludeMiscIdUnique 280
1714 -- data Strict = ...
1715 isStrictKey = mkPreludeMiscIdUnique 281
1716 notStrictKey = mkPreludeMiscIdUnique 282
1719 normalCIdKey = mkPreludeMiscIdUnique 283
1720 recCIdKey = mkPreludeMiscIdUnique 284
1721 infixCIdKey = mkPreludeMiscIdUnique 285
1722 forallCIdKey = mkPreludeMiscIdUnique 288
1724 -- type StrictType = ...
1725 strictTKey = mkPreludeMiscIdUnique 286
1727 -- type VarStrictType = ...
1728 varStrictTKey = mkPreludeMiscIdUnique 287
1731 forallTIdKey = mkPreludeMiscIdUnique 290
1732 varTIdKey = mkPreludeMiscIdUnique 291
1733 conTIdKey = mkPreludeMiscIdUnique 292
1734 tupleTIdKey = mkPreludeMiscIdUnique 294
1735 arrowTIdKey = mkPreludeMiscIdUnique 295
1736 listTIdKey = mkPreludeMiscIdUnique 296
1737 appTIdKey = mkPreludeMiscIdUnique 293
1739 -- data Callconv = ...
1740 cCallIdKey = mkPreludeMiscIdUnique 300
1741 stdCallIdKey = mkPreludeMiscIdUnique 301
1743 -- data Safety = ...
1744 unsafeIdKey = mkPreludeMiscIdUnique 305
1745 safeIdKey = mkPreludeMiscIdUnique 306
1746 threadsafeIdKey = mkPreludeMiscIdUnique 307
1748 -- data FunDep = ...
1749 funDepIdKey = mkPreludeMiscIdUnique 320