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, mkCoreTup, mkIntExpr )
28 import qualified Language.Haskell.TH as TH
32 import PrelNames ( rationalTyConName, integerTyConName, negateName )
33 import OccName ( isDataOcc, isTvOcc, occNameUserString )
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, moduleUserString )
41 import Id ( Id, mkLocalId )
42 import OccName ( mkOccFS )
43 import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
44 isExternalName, getSrcLoc )
46 import Type ( Type, mkGenTyConApp )
47 import TcType ( tcTyConAppArgs )
48 import TyCon ( tyConName )
49 import TysWiredIn ( parrTyCon )
51 import CoreUtils ( exprType )
52 import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
53 import Maybe ( catMaybes )
54 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
55 import BasicTypes ( isBoxed )
57 import Bag ( bagToList )
58 import FastString ( unpackFS )
59 import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..),
62 import Monad ( zipWithM )
63 import List ( sortBy )
65 -----------------------------------------------------------------------------
66 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
67 -- Returns a CoreExpr of type TH.ExpQ
68 -- The quoted thing is parameterised over Name, even though it has
69 -- been type checked. We don't want all those type decorations!
71 dsBracket brack splices
72 = dsExtendMetaEnv new_bit (do_brack brack)
74 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
76 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
77 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
78 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
79 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
80 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
82 {- -------------- Examples --------------------
86 gensym (unpackString "x"#) `bindQ` \ x1::String ->
87 lam (pvar x1) (var x1)
90 [| \x -> $(f [| x |]) |]
92 gensym (unpackString "x"#) `bindQ` \ x1::String ->
93 lam (pvar x1) (f (var x1))
97 -------------------------------------------------------
99 -------------------------------------------------------
101 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
103 = do { let { bndrs = map unLoc (groupBinders group) } ;
104 ss <- mkGenSyms bndrs ;
106 -- Bind all the names mainly to avoid repeated use of explicit strings.
108 -- do { t :: String <- genSym "T" ;
109 -- return (Data t [] ...more t's... }
110 -- The other important reason is that the output must mention
111 -- only "T", not "Foo:T" where Foo is the current module
114 decls <- addBinds ss (do {
115 val_ds <- mapM rep_bind_group (hs_valds group) ;
116 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
117 inst_ds <- mapM repInstD' (hs_instds group) ;
118 for_ds <- mapM repForD (hs_fords group) ;
120 return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
122 decl_ty <- lookupType decQTyConName ;
123 let { core_list = coreList' decl_ty decls } ;
125 dec_ty <- lookupType decTyConName ;
126 q_decs <- repSequenceQ dec_ty core_list ;
128 wrapNongenSyms ss q_decs
129 -- Do *not* gensym top-level binders
132 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
133 hs_fords = foreign_decls })
134 -- Collect the binders of a Group
135 = collectGroupBinders val_decls ++
136 [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
137 [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
140 {- Note [Binders and occurrences]
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 When we desugar [d| data T = MkT |]
144 Data "T" [] [Con "MkT" []] []
146 Data "Foo:T" [] [Con "Foo:MkT" []] []
147 That is, the new data decl should fit into whatever new module it is
148 asked to fit in. We do *not* clone, though; no need for this:
155 then we must desugar to
156 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
158 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
159 And we use lookupOcc, rather than lookupBinder
160 in repTyClD and repC.
164 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
166 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
167 tcdLName = tc, tcdTyVars = tvs,
168 tcdCons = cons, tcdDerivs = mb_derivs }))
169 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
170 dec <- addTyVarBinds tvs $ \bndrs -> do {
171 cxt1 <- repLContext cxt ;
172 cons1 <- mapM repC cons ;
173 cons2 <- coreList conQTyConName cons1 ;
174 derivs1 <- repDerivs mb_derivs ;
175 bndrs1 <- coreList nameTyConName bndrs ;
176 repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
177 return $ Just (loc, dec) }
179 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
180 tcdLName = tc, tcdTyVars = tvs,
181 tcdCons = [con], tcdDerivs = mb_derivs }))
182 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
183 dec <- addTyVarBinds tvs $ \bndrs -> do {
184 cxt1 <- repLContext cxt ;
186 derivs1 <- repDerivs mb_derivs ;
187 bndrs1 <- coreList nameTyConName bndrs ;
188 repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
189 return $ Just (loc, dec) }
191 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
192 = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences]
193 dec <- addTyVarBinds tvs $ \bndrs -> do {
195 bndrs1 <- coreList nameTyConName bndrs ;
196 repTySyn tc1 bndrs1 ty1 } ;
197 return (Just (loc, dec)) }
199 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
202 tcdSigs = sigs, tcdMeths = meth_binds }))
203 = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences]
204 dec <- addTyVarBinds tvs $ \bndrs -> do {
205 cxt1 <- repLContext cxt ;
206 sigs1 <- rep_sigs sigs ;
207 binds1 <- rep_binds meth_binds ;
208 fds1 <- repLFunDeps fds;
209 decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
210 bndrs1 <- coreList nameTyConName bndrs ;
211 repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
212 return $ Just (loc, dec) }
215 repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
221 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
222 repLFunDeps fds = do fds' <- mapM repLFunDep fds
223 fdList <- coreList funDepTyConName fds'
226 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
227 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
228 ys' <- mapM lookupBinder ys
229 xs_list <- coreList nameTyConName xs'
230 ys_list <- coreList nameTyConName ys'
231 repFunDep xs_list ys_list
233 repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now
234 = do { i <- addTyVarBinds tvs $ \tv_bndrs ->
235 -- We must bring the type variables into scope, so their occurrences
236 -- don't fail, even though the binders don't appear in the resulting
238 do { cxt1 <- repContext cxt
239 ; inst_ty1 <- repPred (HsClassP cls tys)
240 ; ss <- mkGenSyms (collectHsBindBinders binds)
241 ; binds1 <- addBinds ss (rep_binds binds)
242 ; decls1 <- coreList decQTyConName binds1
243 ; decls2 <- wrapNongenSyms ss decls1
244 -- wrapNonGenSyms: do not clone the class op names!
245 -- They must be called 'op' etc, not 'op34'
246 ; repInst cxt1 inst_ty1 decls2 }
250 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
252 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
253 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
254 = do MkC name' <- lookupLOcc name
255 MkC typ' <- repLTy typ
256 MkC cc' <- repCCallConv cc
257 MkC s' <- repSafety s
258 MkC str <- coreStringLit $ static
259 ++ unpackFS ch ++ " "
260 ++ unpackFS cn ++ " "
261 ++ conv_cimportspec cis
262 dec <- rep2 forImpDName [cc', s', str, name', typ']
265 conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
266 conv_cimportspec (CFunction DynamicTarget) = "dynamic"
267 conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
268 conv_cimportspec CWrapper = "wrapper"
270 CFunction (StaticTarget _) -> "static "
273 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
274 repCCallConv CCallConv = rep2 cCallName []
275 repCCallConv StdCallConv = rep2 stdCallName []
277 repSafety :: Safety -> DsM (Core TH.Safety)
278 repSafety PlayRisky = rep2 unsafeName []
279 repSafety (PlaySafe False) = rep2 safeName []
280 repSafety (PlaySafe True) = rep2 threadsafeName []
282 ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
284 -------------------------------------------------------
286 -------------------------------------------------------
288 repC :: LConDecl Name -> DsM (Core TH.ConQ)
289 repC (L loc (ConDecl con [] (L _ []) details))
290 = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
291 repConstr con1 details }
292 repC (L loc (ConDecl con tvs (L cloc ctxt) details))
293 = do { addTyVarBinds tvs $ \bndrs -> do {
294 c' <- repC (L loc (ConDecl con [] (L cloc []) details));
295 ctxt' <- repContext ctxt;
296 bndrs' <- coreList nameTyConName bndrs;
297 rep2 forallCName [unC bndrs', unC ctxt', unC c']
300 repC (L loc con_decl)
301 = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
302 ; return (panic "DsMeta:repC") }
304 -- gaw 2004 FIX! Need a case for GadtDecl
306 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
310 rep2 strictTypeName [s, t]
312 (str, ty') = case ty of
313 L _ (HsBangTy _ ty) -> (isStrictName, ty)
314 other -> (notStrictName, ty)
316 -------------------------------------------------------
318 -------------------------------------------------------
320 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
321 repDerivs Nothing = coreList nameTyConName []
322 repDerivs (Just ctxt)
323 = do { strs <- mapM rep_deriv ctxt ;
324 coreList nameTyConName strs }
326 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
327 -- Deriving clauses must have the simple H98 form
328 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
329 rep_deriv other = panic "rep_deriv"
332 -------------------------------------------------------
333 -- Signatures in a class decl, or a group of bindings
334 -------------------------------------------------------
336 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
337 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
338 return $ de_loc $ sort_by_loc locs_cores
340 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
341 -- We silently ignore ones we don't recognise
342 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
343 return (concat sigs1) }
345 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
347 -- Empty => Too hard, signature ignored
348 rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
349 rep_sig other = return []
351 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
352 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
354 sig <- repProto nm1 ty1 ;
355 return [(loc, sig)] }
358 -------------------------------------------------------
360 -------------------------------------------------------
362 -- gensym a list of type variables and enter them into the meta environment;
363 -- the computations passed as the second argument is executed in that extended
364 -- meta environment and gets the *new* names on Core-level as an argument
366 addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added
367 -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
368 -> DsM (Core (TH.Q a))
369 addTyVarBinds tvs m =
371 let names = map (hsTyVarName.unLoc) tvs
372 freshNames <- mkGenSyms names
373 term <- addBinds freshNames $ do
374 bndrs <- mapM lookupBinder names
376 wrapGenSyns freshNames term
378 -- represent a type context
380 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
381 repLContext (L _ ctxt) = repContext ctxt
383 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
385 preds <- mapM repLPred ctxt
386 predList <- coreList typeQTyConName preds
389 -- represent a type predicate
391 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
392 repLPred (L _ p) = repPred p
394 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
395 repPred (HsClassP cls tys) = do
396 tcon <- repTy (HsTyVar cls)
399 repPred (HsIParam _ _) =
400 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
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
452 panic "DsMeta.repTy: Can't represent number types (for generics)"
453 repTy (HsPredTy pred) = repPred pred
454 repTy (HsKindSig ty kind) =
455 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
458 -----------------------------------------------------------------------------
460 -----------------------------------------------------------------------------
462 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
463 repLEs es = do { es' <- mapM repLE es ;
464 coreList expQTyConName es' }
466 -- FIXME: some of these panics should be converted into proper error messages
467 -- unless we can make sure that constructs, which are plainly not
468 -- supported in TH already lead to error messages at an earlier stage
469 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
470 repLE (L _ e) = repE e
472 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
474 do { mb_val <- dsLookupMetaEnv x
476 Nothing -> do { str <- globalVar x
477 ; repVarOrCon x str }
478 Just (Bound y) -> repVarOrCon x (coreVar y)
479 Just (Splice e) -> do { e' <- dsExpr e
480 ; return (MkC e') } }
481 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
483 -- Remember, we're desugaring renamer output here, so
484 -- HsOverlit can definitely occur
485 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
486 repE (HsLit l) = do { a <- repLiteral l; repLit a }
487 repE (HsLam (MatchGroup [m] _)) = repLambda m
488 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
490 repE (OpApp e1 op fix e2) =
491 do { arg1 <- repLE e1;
494 repInfixApp arg1 the_op arg2 }
495 repE (NegApp x nm) = do
497 negateVar <- lookupOcc negateName >>= repVar
499 repE (HsPar x) = repLE x
500 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
501 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
502 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
503 ; ms2 <- mapM repMatchTup ms
504 ; repCaseE arg (nonEmptyCoreList ms2) }
505 repE (HsIf x y z) = do
510 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
511 ; e2 <- addBinds ss (repLE e)
514 -- FIXME: I haven't got the types here right yet
515 repE (HsDo DoExpr sts body ty)
516 = do { (ss,zs) <- repLSts sts;
517 body' <- addBinds ss $ repLE body;
518 ret <- repNoBindSt body';
519 e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
521 repE (HsDo ListComp sts body ty)
522 = do { (ss,zs) <- repLSts sts;
523 body' <- addBinds ss $ repLE body;
524 ret <- repNoBindSt body';
525 e <- repComp (nonEmptyCoreList (zs ++ [ret]));
527 repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
528 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
529 repE (ExplicitPArr ty es) =
530 panic "DsMeta.repE: No explicit parallel arrays yet"
531 repE (ExplicitTuple es boxed)
532 | isBoxed boxed = do { xs <- repLEs es; repTup xs }
533 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
534 repE (RecordCon c _ flds)
535 = do { x <- lookupLOcc c;
536 fs <- repFields flds;
538 repE (RecordUpd e flds _ _)
540 fs <- repFields flds;
543 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
544 repE (ArithSeq _ aseq) =
546 From e -> do { ds1 <- repLE e; repFrom ds1 }
555 FromThenTo e1 e2 e3 -> do
559 repFromThenTo ds1 ds2 ds3
560 repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
561 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
562 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
563 repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets"
564 repE (HsSpliceE (HsSplice n _))
565 = do { mb_val <- dsLookupMetaEnv n
567 Just (Splice e) -> do { e' <- dsExpr e
569 other -> pprPanic "HsSplice" (ppr n) }
571 repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
573 -----------------------------------------------------------------------------
574 -- Building representations of auxillary structures like Match, Clause, Stmt,
576 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
577 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
578 do { ss1 <- mkGenSyms (collectPatBinders p)
579 ; addBinds ss1 $ do {
581 ; (ss2,ds) <- repBinds wheres
582 ; addBinds ss2 $ do {
583 ; gs <- repGuards guards
584 ; match <- repMatch p1 gs ds
585 ; wrapGenSyns (ss1++ss2) match }}}
587 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
588 repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
589 do { ss1 <- mkGenSyms (collectPatsBinders ps)
590 ; addBinds ss1 $ do {
592 ; (ss2,ds) <- repBinds wheres
593 ; addBinds ss2 $ do {
594 gs <- repGuards guards
595 ; clause <- repClause ps1 gs ds
596 ; wrapGenSyns (ss1++ss2) clause }}}
598 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
599 repGuards [L _ (GRHS [] e)]
600 = do {a <- repLE e; repNormal a }
602 = do { zs <- mapM process other;
603 let {(xs, ys) = unzip zs};
604 gd <- repGuarded (nonEmptyCoreList ys);
605 wrapGenSyns (concat xs) gd }
607 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
608 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
609 = do { x <- repLNormalGE e1 e2;
611 process (L _ (GRHS ss rhs))
612 = do (gs, ss') <- repLSts ss
613 rhs' <- addBinds gs $ repLE rhs
614 g <- repPatGE (nonEmptyCoreList ss') rhs'
617 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
619 fnames <- mapM lookupLOcc (map fst flds)
620 es <- mapM repLE (map snd flds)
621 fs <- zipWithM repFieldExp fnames es
622 coreList fieldExpQTyConName fs
625 -----------------------------------------------------------------------------
626 -- Representing Stmt's is tricky, especially if bound variables
627 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
628 -- First gensym new names for every variable in any of the patterns.
629 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
630 -- if variables didn't shaddow, the static gensym wouldn't be necessary
631 -- and we could reuse the original names (x and x).
633 -- do { x'1 <- gensym "x"
634 -- ; x'2 <- gensym "x"
635 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
636 -- , BindSt (pvar x'2) [| f x |]
637 -- , NoBindSt [| g x |]
641 -- The strategy is to translate a whole list of do-bindings by building a
642 -- bigger environment, and a bigger set of meta bindings
643 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
644 -- of the expressions within the Do
646 -----------------------------------------------------------------------------
647 -- The helper function repSts computes the translation of each sub expression
648 -- and a bunch of prefix bindings denoting the dynamic renaming.
650 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
651 repLSts stmts = repSts (map unLoc stmts)
653 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
654 repSts (BindStmt p e _ _ : ss) =
656 ; ss1 <- mkGenSyms (collectPatBinders p)
657 ; addBinds ss1 $ do {
659 ; (ss2,zs) <- repSts ss
660 ; z <- repBindSt p1 e2
661 ; return (ss1++ss2, z : zs) }}
662 repSts (LetStmt bs : ss) =
663 do { (ss1,ds) <- repBinds bs
665 ; (ss2,zs) <- addBinds ss1 (repSts ss)
666 ; return (ss1++ss2, z : zs) }
667 repSts (ExprStmt e _ _ : ss) =
669 ; z <- repNoBindSt e2
670 ; (ss2,zs) <- repSts ss
671 ; return (ss2, z : zs) }
672 repSts [] = return ([],[])
673 repSts other = panic "Exotic Stmt in meta brackets"
676 -----------------------------------------------------------
678 -----------------------------------------------------------
680 repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ])
682 = do { let { bndrs = map unLoc (collectGroupBinders decs) }
683 -- No need to worrry about detailed scopes within
684 -- the binding group, because we are talking Names
685 -- here, so we can safely treat it as a mutually
687 ; ss <- mkGenSyms bndrs
688 ; core <- addBinds ss (rep_bind_groups decs)
689 ; core_list <- coreList decQTyConName core
690 ; return (ss, core_list) }
692 rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ]
693 -- Assumes: all the binders of the binding are alrady in the meta-env
694 rep_bind_groups binds = do
695 locs_cores_s <- mapM rep_bind_group binds
696 return $ de_loc $ sort_by_loc (concat locs_cores_s)
698 rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)]
699 -- Assumes: all the binders of the binding are alrady in the meta-env
700 rep_bind_group (HsBindGroup bs sigs _)
701 = do { core1 <- mapM rep_bind (bagToList bs)
702 ; core2 <- rep_sigs' sigs
703 ; return (core1 ++ core2) }
704 rep_bind_group (HsIPBinds _)
705 = panic "DsMeta:repBinds: can't do implicit parameters"
707 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
708 -- Assumes: all the binders of the binding are alrady in the meta-env
710 locs_cores <- mapM rep_bind (bagToList binds)
711 return $ de_loc $ sort_by_loc locs_cores
713 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
714 -- Assumes: all the binders of the binding are alrady in the meta-env
716 -- Note GHC treats declarations of a variable (not a pattern)
717 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
718 -- with an empty list of patterns
719 rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _)))
720 = do { (ss,wherecore) <- repBinds wheres
721 ; guardcore <- addBinds ss (repGuards guards)
722 ; fn' <- lookupLBinder fn
724 ; ans <- repVal p guardcore wherecore
725 ; ans' <- wrapGenSyns ss ans
726 ; return (loc, ans') }
728 rep_bind (L loc (FunBind fn infx (MatchGroup ms _)))
729 = do { ms1 <- mapM repClauseTup ms
730 ; fn' <- lookupLBinder fn
731 ; ans <- repFun fn' (nonEmptyCoreList ms1)
732 ; return (loc, ans) }
734 rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2))
735 = do { patcore <- repLP pat
736 ; (ss,wherecore) <- repBinds wheres
737 ; guardcore <- addBinds ss (repGuards guards)
738 ; ans <- repVal patcore guardcore wherecore
739 ; ans' <- wrapGenSyns ss ans
740 ; return (loc, ans') }
742 rep_bind (L loc (VarBind v e))
743 = do { v' <- lookupBinder v
746 ; patcore <- repPvar v'
747 ; empty_decls <- coreList decQTyConName []
748 ; ans <- repVal patcore x empty_decls
749 ; return (srcLocSpan (getSrcLoc v), ans) }
751 -----------------------------------------------------------------------------
752 -- Since everything in a Bind is mutually recursive we need rename all
753 -- all the variables simultaneously. For example:
754 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
755 -- do { f'1 <- gensym "f"
756 -- ; g'2 <- gensym "g"
757 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
758 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
760 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
761 -- environment ( f |-> f'1 ) from each binding, and then unioning them
762 -- together. As we do this we collect GenSymBinds's which represent the renamed
763 -- variables bound by the Bindings. In order not to lose track of these
764 -- representations we build a shadow datatype MB with the same structure as
765 -- MonoBinds, but which has slots for the representations
768 -----------------------------------------------------------------------------
769 -- GHC allows a more general form of lambda abstraction than specified
770 -- by Haskell 98. In particular it allows guarded lambda's like :
771 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
772 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
773 -- (\ p1 .. pn -> exp) by causing an error.
775 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
776 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] [])))
777 = do { let bndrs = collectPatsBinders ps ;
778 ; ss <- mkGenSyms bndrs
779 ; lam <- addBinds ss (
780 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
781 ; wrapGenSyns ss lam }
783 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
786 -----------------------------------------------------------------------------
788 -- repP deals with patterns. It assumes that we have already
789 -- walked over the pattern(s) once to collect the binders, and
790 -- have extended the environment. So every pattern-bound
791 -- variable should already appear in the environment.
793 -- Process a list of patterns
794 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
795 repLPs ps = do { ps' <- mapM repLP ps ;
796 coreList patQTyConName ps' }
798 repLP :: LPat Name -> DsM (Core TH.PatQ)
799 repLP (L _ p) = repP p
801 repP :: Pat Name -> DsM (Core TH.PatQ)
802 repP (WildPat _) = repPwild
803 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
804 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
805 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
806 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
807 repP (ParPat p) = repLP p
808 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
809 repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs }
810 repP (ConPatIn dc details)
811 = do { con_str <- lookupLOcc dc
813 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
814 RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
815 ; ps <- sequence $ map repLP (map snd pairs)
816 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
817 ; fps' <- coreList fieldPatQTyConName fps
818 ; repPrec con_str fps' }
819 InfixCon p1 p2 -> do { p1' <- repLP p1;
821 repPinfix p1' con_str p2' }
823 repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
824 repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
825 repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
826 repP other = panic "Exotic pattern inside meta brackets"
828 ----------------------------------------------------------
829 -- Declaration ordering helpers
831 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
832 sort_by_loc xs = sortBy comp xs
833 where comp x y = compare (fst x) (fst y)
835 de_loc :: [(a, b)] -> [b]
838 ----------------------------------------------------------
839 -- The meta-environment
841 -- A name/identifier association for fresh names of locally bound entities
842 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
843 -- I.e. (x, x_id) means
844 -- let x_id = gensym "x" in ...
846 -- Generate a fresh name for a locally bound entity
848 mkGenSyms :: [Name] -> DsM [GenSymBind]
849 -- We can use the existing name. For example:
850 -- [| \x_77 -> x_77 + x_77 |]
852 -- do { x_77 <- genSym "x"; .... }
853 -- We use the same x_77 in the desugared program, but with the type Bndr
856 -- We do make it an Internal name, though (hence localiseName)
858 -- Nevertheless, it's monadic because we have to generate nameTy
859 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
860 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
863 addBinds :: [GenSymBind] -> DsM a -> DsM a
864 -- Add a list of fresh names for locally bound entities to the
865 -- meta environment (which is part of the state carried around
866 -- by the desugarer monad)
867 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
869 -- Look up a locally bound name
871 lookupLBinder :: Located Name -> DsM (Core TH.Name)
872 lookupLBinder (L _ n) = lookupBinder n
874 lookupBinder :: Name -> DsM (Core TH.Name)
876 = do { mb_val <- dsLookupMetaEnv n;
878 Just (Bound x) -> return (coreVar x)
879 other -> pprPanic "Failed binder lookup:" (ppr n) }
881 -- Look up a name that is either locally bound or a global name
883 -- * If it is a global name, generate the "original name" representation (ie,
884 -- the <module>:<name> form) for the associated entity
886 lookupLOcc :: Located Name -> DsM (Core TH.Name)
887 -- Lookup an occurrence; it can't be a splice.
888 -- Use the in-scope bindings if they exist
889 lookupLOcc (L _ n) = lookupOcc n
891 lookupOcc :: Name -> DsM (Core TH.Name)
893 = do { mb_val <- dsLookupMetaEnv n ;
895 Nothing -> globalVar n
896 Just (Bound x) -> return (coreVar x)
897 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
900 globalVar :: Name -> DsM (Core TH.Name)
901 -- Not bound by the meta-env
902 -- Could be top-level; or could be local
903 -- f x = $(g [| x |])
904 -- Here the x will be local
906 | isExternalName name
907 = do { MkC mod <- coreStringLit name_mod
908 ; MkC occ <- occNameLit name
909 ; rep2 mk_varg [mod,occ] }
911 = do { MkC occ <- occNameLit name
912 ; MkC uni <- coreIntLit (getKey (getUnique name))
913 ; rep2 mkNameLName [occ,uni] }
915 name_mod = moduleUserString (nameModule name)
916 name_occ = nameOccName name
917 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
918 | OccName.isVarOcc name_occ = mkNameG_vName
919 | OccName.isTcOcc name_occ = mkNameG_tcName
920 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
922 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
923 -> DsM Type -- The type
924 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
925 return (mkGenTyConApp tc []) }
927 wrapGenSyns :: [GenSymBind]
928 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
929 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
930 -- --> bindQ (gensym nm1) (\ id1 ->
931 -- bindQ (gensym nm2 (\ id2 ->
934 wrapGenSyns binds body@(MkC b)
935 = do { var_ty <- lookupType nameTyConName
938 [elt_ty] = tcTyConAppArgs (exprType b)
939 -- b :: Q a, so we can get the type 'a' by looking at the
940 -- argument type. NB: this relies on Q being a data/newtype,
941 -- not a type synonym
943 go var_ty [] = return body
944 go var_ty ((name,id) : binds)
945 = do { MkC body' <- go var_ty binds
946 ; lit_str <- occNameLit name
947 ; gensym_app <- repGensym lit_str
948 ; repBindQ var_ty elt_ty
949 gensym_app (MkC (Lam id body')) }
951 -- Just like wrapGenSym, but don't actually do the gensym
952 -- Instead use the existing name:
953 -- let x = "x" in ...
954 -- Only used for [Decl], and for the class ops in class
955 -- and instance decls
956 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
957 wrapNongenSyms binds (MkC body)
958 = do { binds' <- mapM do_one binds ;
959 return (MkC (mkLets binds' body)) }
962 = do { MkC lit_str <- occNameLit name
963 ; MkC var <- rep2 mkNameName [lit_str]
964 ; return (NonRec id var) }
966 occNameLit :: Name -> DsM (Core String)
967 occNameLit n = coreStringLit (occNameUserString (nameOccName n))
970 -- %*********************************************************************
974 -- %*********************************************************************
976 -----------------------------------------------------------------------------
977 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
978 -- we invent a new datatype which uses phantom types.
980 newtype Core a = MkC CoreExpr
983 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
984 rep2 n xs = do { id <- dsLookupGlobalId n
985 ; return (MkC (foldl App (Var id) xs)) }
987 -- Then we make "repConstructors" which use the phantom types for each of the
988 -- smart constructors of the Meta.Meta datatypes.
991 -- %*********************************************************************
993 -- The 'smart constructors'
995 -- %*********************************************************************
997 --------------- Patterns -----------------
998 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
999 repPlit (MkC l) = rep2 litPName [l]
1001 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1002 repPvar (MkC s) = rep2 varPName [s]
1004 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1005 repPtup (MkC ps) = rep2 tupPName [ps]
1007 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1008 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1010 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1011 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1013 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1014 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1016 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1017 repPtilde (MkC p) = rep2 tildePName [p]
1019 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1020 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1022 repPwild :: DsM (Core TH.PatQ)
1023 repPwild = rep2 wildPName []
1025 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1026 repPlist (MkC ps) = rep2 listPName [ps]
1028 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1029 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1031 --------------- Expressions -----------------
1032 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1033 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1034 | otherwise = repVar str
1036 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1037 repVar (MkC s) = rep2 varEName [s]
1039 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1040 repCon (MkC s) = rep2 conEName [s]
1042 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1043 repLit (MkC c) = rep2 litEName [c]
1045 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1046 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1048 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1049 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1051 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1052 repTup (MkC es) = rep2 tupEName [es]
1054 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1055 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1057 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1058 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1060 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1061 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1063 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1064 repDoE (MkC ss) = rep2 doEName [ss]
1066 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1067 repComp (MkC ss) = rep2 compEName [ss]
1069 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1070 repListExp (MkC es) = rep2 listEName [es]
1072 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1073 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1075 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1076 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1078 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1079 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1081 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1082 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1084 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1085 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1087 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1088 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1090 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1091 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1093 ------------ Right hand sides (guarded expressions) ----
1094 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1095 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1097 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1098 repNormal (MkC e) = rep2 normalBName [e]
1100 ------------ Guards ----
1101 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1102 repLNormalGE g e = do g' <- repLE g
1106 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1107 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1109 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1110 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1112 ------------- Stmts -------------------
1113 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1114 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1116 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1117 repLetSt (MkC ds) = rep2 letSName [ds]
1119 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1120 repNoBindSt (MkC e) = rep2 noBindSName [e]
1122 -------------- Range (Arithmetic sequences) -----------
1123 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1124 repFrom (MkC x) = rep2 fromEName [x]
1126 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1127 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1129 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1130 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1132 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1133 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1135 ------------ Match and Clause Tuples -----------
1136 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1137 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1139 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1140 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1142 -------------- Dec -----------------------------
1143 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1144 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1146 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1147 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1149 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1150 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1151 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1153 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1154 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1155 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1157 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1158 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1160 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1161 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1163 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1164 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1166 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1167 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1169 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1170 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1172 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1173 repCtxt (MkC tys) = rep2 cxtName [tys]
1175 repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
1176 -> DsM (Core TH.ConQ)
1177 repConstr con (PrefixCon ps)
1178 = do arg_tys <- mapM repBangTy ps
1179 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1180 rep2 normalCName [unC con, unC arg_tys1]
1181 repConstr con (RecCon ips)
1182 = do arg_vs <- mapM lookupLOcc (map fst ips)
1183 arg_tys <- mapM repBangTy (map snd ips)
1184 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1186 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1187 rep2 recCName [unC con, unC arg_vtys']
1188 repConstr con (InfixCon st1 st2)
1189 = do arg1 <- repBangTy st1
1190 arg2 <- repBangTy st2
1191 rep2 infixCName [unC arg1, unC con, unC arg2]
1193 ------------ Types -------------------
1195 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1196 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1197 = rep2 forallTName [tvars, ctxt, ty]
1199 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1200 repTvar (MkC s) = rep2 varTName [s]
1202 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1203 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1205 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1206 repTapps f [] = return f
1207 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1209 --------- Type constructors --------------
1211 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1212 repNamedTyCon (MkC s) = rep2 conTName [s]
1214 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1215 -- Note: not Core Int; it's easier to be direct here
1216 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1218 repArrowTyCon :: DsM (Core TH.TypeQ)
1219 repArrowTyCon = rep2 arrowTName []
1221 repListTyCon :: DsM (Core TH.TypeQ)
1222 repListTyCon = rep2 listTName []
1225 ----------------------------------------------------------
1228 repLiteral :: HsLit -> DsM (Core TH.Lit)
1230 = do lit' <- case lit of
1231 HsIntPrim i -> mk_integer i
1232 HsInt i -> mk_integer i
1233 HsFloatPrim r -> mk_rational r
1234 HsDoublePrim r -> mk_rational r
1236 lit_expr <- dsLit lit'
1237 rep2 lit_name [lit_expr]
1239 lit_name = case lit of
1240 HsInteger _ _ -> integerLName
1241 HsInt _ -> integerLName
1242 HsIntPrim _ -> intPrimLName
1243 HsFloatPrim _ -> floatPrimLName
1244 HsDoublePrim _ -> doublePrimLName
1245 HsChar _ -> charLName
1246 HsString _ -> stringLName
1247 HsRat _ _ -> rationalLName
1249 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1252 mk_integer i = do integer_ty <- lookupType integerTyConName
1253 return $ HsInteger i integer_ty
1254 mk_rational r = do rat_ty <- lookupType rationalTyConName
1255 return $ HsRat r rat_ty
1257 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1258 repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit }
1259 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1260 -- The type Rational will be in the environment, becuase
1261 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1262 -- and rationalL is sucked in when any TH stuff is used
1264 --------------- Miscellaneous -------------------
1266 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1267 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1269 repBindQ :: Type -> Type -- a and b
1270 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1271 repBindQ ty_a ty_b (MkC x) (MkC y)
1272 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1274 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1275 repSequenceQ ty_a (MkC list)
1276 = rep2 sequenceQName [Type ty_a, list]
1278 ------------ Lists and Tuples -------------------
1279 -- turn a list of patterns into a single pattern matching a list
1281 coreList :: Name -- Of the TyCon of the element type
1282 -> [Core a] -> DsM (Core [a])
1284 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1286 coreList' :: Type -- The element type
1287 -> [Core a] -> Core [a]
1288 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1290 nonEmptyCoreList :: [Core a] -> Core [a]
1291 -- The list must be non-empty so we can get the element type
1292 -- Otherwise use coreList
1293 nonEmptyCoreList [] = panic "coreList: empty argument"
1294 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1296 corePair :: (Core a, Core b) -> Core (a,b)
1297 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1299 coreStringLit :: String -> DsM (Core String)
1300 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1302 coreIntLit :: Int -> DsM (Core Int)
1303 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1305 coreVar :: Id -> Core TH.Name -- The Id has type Name
1306 coreVar id = MkC (Var id)
1310 -- %************************************************************************
1312 -- The known-key names for Template Haskell
1314 -- %************************************************************************
1316 -- To add a name, do three things
1318 -- 1) Allocate a key
1320 -- 3) Add the name to knownKeyNames
1322 templateHaskellNames :: [Name]
1323 -- The names that are implicitly mentioned by ``bracket''
1324 -- Should stay in sync with the import list of DsMeta
1326 templateHaskellNames = [
1327 returnQName, bindQName, sequenceQName, newNameName, liftName,
1328 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1331 charLName, stringLName, integerLName, intPrimLName,
1332 floatPrimLName, doublePrimLName, rationalLName,
1334 litPName, varPName, tupPName, conPName, tildePName, infixPName,
1335 asPName, wildPName, recPName, listPName, sigPName,
1343 varEName, conEName, litEName, appEName, infixEName,
1344 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1345 condEName, letEName, caseEName, doEName, compEName,
1346 fromEName, fromThenEName, fromToEName, fromThenToEName,
1347 listEName, sigEName, recConEName, recUpdEName,
1351 guardedBName, normalBName,
1353 normalGEName, patGEName,
1355 bindSName, letSName, noBindSName, parSName,
1357 funDName, valDName, dataDName, newtypeDName, tySynDName,
1358 classDName, instanceDName, sigDName, forImpDName,
1362 isStrictName, notStrictName,
1364 normalCName, recCName, infixCName, forallCName,
1370 forallTName, varTName, conTName, appTName,
1371 tupleTName, arrowTName, listTName,
1373 cCallName, stdCallName,
1382 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1383 clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1384 decQTyConName, conQTyConName, strictTypeQTyConName,
1385 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1386 typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1387 fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
1390 thSyn = mkModule "Language.Haskell.TH.Syntax"
1391 thLib = mkModule "Language.Haskell.TH.Lib"
1393 mk_known_key_name mod space str uniq
1394 = mkExternalName uniq mod (mkOccFS space str)
1397 libFun = mk_known_key_name thLib OccName.varName
1398 libTc = mk_known_key_name thLib OccName.tcName
1399 thFun = mk_known_key_name thSyn OccName.varName
1400 thTc = mk_known_key_name thSyn OccName.tcName
1402 -------------------- TH.Syntax -----------------------
1403 qTyConName = thTc FSLIT("Q") qTyConKey
1404 nameTyConName = thTc FSLIT("Name") nameTyConKey
1405 fieldExpTyConName = thTc FSLIT("FieldExp") fieldExpTyConKey
1406 patTyConName = thTc FSLIT("Pat") patTyConKey
1407 fieldPatTyConName = thTc FSLIT("FieldPat") fieldPatTyConKey
1408 expTyConName = thTc FSLIT("Exp") expTyConKey
1409 decTyConName = thTc FSLIT("Dec") decTyConKey
1410 typeTyConName = thTc FSLIT("Type") typeTyConKey
1411 matchTyConName = thTc FSLIT("Match") matchTyConKey
1412 clauseTyConName = thTc FSLIT("Clause") clauseTyConKey
1413 funDepTyConName = thTc FSLIT("FunDep") funDepTyConKey
1415 returnQName = thFun FSLIT("returnQ") returnQIdKey
1416 bindQName = thFun FSLIT("bindQ") bindQIdKey
1417 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1418 newNameName = thFun FSLIT("newName") newNameIdKey
1419 liftName = thFun FSLIT("lift") liftIdKey
1420 mkNameName = thFun FSLIT("mkName") mkNameIdKey
1421 mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
1422 mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
1423 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1424 mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
1427 -------------------- TH.Lib -----------------------
1429 charLName = libFun FSLIT("charL") charLIdKey
1430 stringLName = libFun FSLIT("stringL") stringLIdKey
1431 integerLName = libFun FSLIT("integerL") integerLIdKey
1432 intPrimLName = libFun FSLIT("intPrimL") intPrimLIdKey
1433 floatPrimLName = libFun FSLIT("floatPrimL") floatPrimLIdKey
1434 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1435 rationalLName = libFun FSLIT("rationalL") rationalLIdKey
1438 litPName = libFun FSLIT("litP") litPIdKey
1439 varPName = libFun FSLIT("varP") varPIdKey
1440 tupPName = libFun FSLIT("tupP") tupPIdKey
1441 conPName = libFun FSLIT("conP") conPIdKey
1442 infixPName = libFun FSLIT("infixP") infixPIdKey
1443 tildePName = libFun FSLIT("tildeP") tildePIdKey
1444 asPName = libFun FSLIT("asP") asPIdKey
1445 wildPName = libFun FSLIT("wildP") wildPIdKey
1446 recPName = libFun FSLIT("recP") recPIdKey
1447 listPName = libFun FSLIT("listP") listPIdKey
1448 sigPName = libFun FSLIT("sigP") sigPIdKey
1450 -- type FieldPat = ...
1451 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1454 matchName = libFun FSLIT("match") matchIdKey
1456 -- data Clause = ...
1457 clauseName = libFun FSLIT("clause") clauseIdKey
1460 varEName = libFun FSLIT("varE") varEIdKey
1461 conEName = libFun FSLIT("conE") conEIdKey
1462 litEName = libFun FSLIT("litE") litEIdKey
1463 appEName = libFun FSLIT("appE") appEIdKey
1464 infixEName = libFun FSLIT("infixE") infixEIdKey
1465 infixAppName = libFun FSLIT("infixApp") infixAppIdKey
1466 sectionLName = libFun FSLIT("sectionL") sectionLIdKey
1467 sectionRName = libFun FSLIT("sectionR") sectionRIdKey
1468 lamEName = libFun FSLIT("lamE") lamEIdKey
1469 tupEName = libFun FSLIT("tupE") tupEIdKey
1470 condEName = libFun FSLIT("condE") condEIdKey
1471 letEName = libFun FSLIT("letE") letEIdKey
1472 caseEName = libFun FSLIT("caseE") caseEIdKey
1473 doEName = libFun FSLIT("doE") doEIdKey
1474 compEName = libFun FSLIT("compE") compEIdKey
1475 -- ArithSeq skips a level
1476 fromEName = libFun FSLIT("fromE") fromEIdKey
1477 fromThenEName = libFun FSLIT("fromThenE") fromThenEIdKey
1478 fromToEName = libFun FSLIT("fromToE") fromToEIdKey
1479 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1481 listEName = libFun FSLIT("listE") listEIdKey
1482 sigEName = libFun FSLIT("sigE") sigEIdKey
1483 recConEName = libFun FSLIT("recConE") recConEIdKey
1484 recUpdEName = libFun FSLIT("recUpdE") recUpdEIdKey
1486 -- type FieldExp = ...
1487 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1490 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1491 normalBName = libFun FSLIT("normalB") normalBIdKey
1494 normalGEName = libFun FSLIT("normalGE") normalGEIdKey
1495 patGEName = libFun FSLIT("patGE") patGEIdKey
1498 bindSName = libFun FSLIT("bindS") bindSIdKey
1499 letSName = libFun FSLIT("letS") letSIdKey
1500 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1501 parSName = libFun FSLIT("parS") parSIdKey
1504 funDName = libFun FSLIT("funD") funDIdKey
1505 valDName = libFun FSLIT("valD") valDIdKey
1506 dataDName = libFun FSLIT("dataD") dataDIdKey
1507 newtypeDName = libFun FSLIT("newtypeD") newtypeDIdKey
1508 tySynDName = libFun FSLIT("tySynD") tySynDIdKey
1509 classDName = libFun FSLIT("classD") classDIdKey
1510 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1511 sigDName = libFun FSLIT("sigD") sigDIdKey
1512 forImpDName = libFun FSLIT("forImpD") forImpDIdKey
1515 cxtName = libFun FSLIT("cxt") cxtIdKey
1517 -- data Strict = ...
1518 isStrictName = libFun FSLIT("isStrict") isStrictKey
1519 notStrictName = libFun FSLIT("notStrict") notStrictKey
1522 normalCName = libFun FSLIT("normalC") normalCIdKey
1523 recCName = libFun FSLIT("recC") recCIdKey
1524 infixCName = libFun FSLIT("infixC") infixCIdKey
1525 forallCName = libFun FSLIT("forallC") forallCIdKey
1527 -- type StrictType = ...
1528 strictTypeName = libFun FSLIT("strictType") strictTKey
1530 -- type VarStrictType = ...
1531 varStrictTypeName = libFun FSLIT("varStrictType") varStrictTKey
1534 forallTName = libFun FSLIT("forallT") forallTIdKey
1535 varTName = libFun FSLIT("varT") varTIdKey
1536 conTName = libFun FSLIT("conT") conTIdKey
1537 tupleTName = libFun FSLIT("tupleT") tupleTIdKey
1538 arrowTName = libFun FSLIT("arrowT") arrowTIdKey
1539 listTName = libFun FSLIT("listT") listTIdKey
1540 appTName = libFun FSLIT("appT") appTIdKey
1542 -- data Callconv = ...
1543 cCallName = libFun FSLIT("cCall") cCallIdKey
1544 stdCallName = libFun FSLIT("stdCall") stdCallIdKey
1546 -- data Safety = ...
1547 unsafeName = libFun FSLIT("unsafe") unsafeIdKey
1548 safeName = libFun FSLIT("safe") safeIdKey
1549 threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
1551 -- data FunDep = ...
1552 funDepName = libFun FSLIT("funDep") funDepIdKey
1554 matchQTyConName = libTc FSLIT("MatchQ") matchQTyConKey
1555 clauseQTyConName = libTc FSLIT("ClauseQ") clauseQTyConKey
1556 expQTyConName = libTc FSLIT("ExpQ") expQTyConKey
1557 stmtQTyConName = libTc FSLIT("StmtQ") stmtQTyConKey
1558 decQTyConName = libTc FSLIT("DecQ") decQTyConKey
1559 conQTyConName = libTc FSLIT("ConQ") conQTyConKey
1560 strictTypeQTyConName = libTc FSLIT("StrictTypeQ") strictTypeQTyConKey
1561 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1562 typeQTyConName = libTc FSLIT("TypeQ") typeQTyConKey
1563 fieldExpQTyConName = libTc FSLIT("FieldExpQ") fieldExpQTyConKey
1564 patQTyConName = libTc FSLIT("PatQ") patQTyConKey
1565 fieldPatQTyConName = libTc FSLIT("FieldPatQ") fieldPatQTyConKey
1567 -- TyConUniques available: 100-129
1568 -- Check in PrelNames if you want to change this
1570 expTyConKey = mkPreludeTyConUnique 100
1571 matchTyConKey = mkPreludeTyConUnique 101
1572 clauseTyConKey = mkPreludeTyConUnique 102
1573 qTyConKey = mkPreludeTyConUnique 103
1574 expQTyConKey = mkPreludeTyConUnique 104
1575 decQTyConKey = mkPreludeTyConUnique 105
1576 patTyConKey = mkPreludeTyConUnique 106
1577 matchQTyConKey = mkPreludeTyConUnique 107
1578 clauseQTyConKey = mkPreludeTyConUnique 108
1579 stmtQTyConKey = mkPreludeTyConUnique 109
1580 conQTyConKey = mkPreludeTyConUnique 110
1581 typeQTyConKey = mkPreludeTyConUnique 111
1582 typeTyConKey = mkPreludeTyConUnique 112
1583 decTyConKey = mkPreludeTyConUnique 113
1584 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
1585 strictTypeQTyConKey = mkPreludeTyConUnique 115
1586 fieldExpTyConKey = mkPreludeTyConUnique 116
1587 fieldPatTyConKey = mkPreludeTyConUnique 117
1588 nameTyConKey = mkPreludeTyConUnique 118
1589 patQTyConKey = mkPreludeTyConUnique 119
1590 fieldPatQTyConKey = mkPreludeTyConUnique 120
1591 fieldExpQTyConKey = mkPreludeTyConUnique 121
1592 funDepTyConKey = mkPreludeTyConUnique 122
1594 -- IdUniques available: 200-399
1595 -- If you want to change this, make sure you check in PrelNames
1597 returnQIdKey = mkPreludeMiscIdUnique 200
1598 bindQIdKey = mkPreludeMiscIdUnique 201
1599 sequenceQIdKey = mkPreludeMiscIdUnique 202
1600 liftIdKey = mkPreludeMiscIdUnique 203
1601 newNameIdKey = mkPreludeMiscIdUnique 204
1602 mkNameIdKey = mkPreludeMiscIdUnique 205
1603 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
1604 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
1605 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
1606 mkNameLIdKey = mkPreludeMiscIdUnique 209
1610 charLIdKey = mkPreludeMiscIdUnique 210
1611 stringLIdKey = mkPreludeMiscIdUnique 211
1612 integerLIdKey = mkPreludeMiscIdUnique 212
1613 intPrimLIdKey = mkPreludeMiscIdUnique 213
1614 floatPrimLIdKey = mkPreludeMiscIdUnique 214
1615 doublePrimLIdKey = mkPreludeMiscIdUnique 215
1616 rationalLIdKey = mkPreludeMiscIdUnique 216
1619 litPIdKey = mkPreludeMiscIdUnique 220
1620 varPIdKey = mkPreludeMiscIdUnique 221
1621 tupPIdKey = mkPreludeMiscIdUnique 222
1622 conPIdKey = mkPreludeMiscIdUnique 223
1623 infixPIdKey = mkPreludeMiscIdUnique 312
1624 tildePIdKey = mkPreludeMiscIdUnique 224
1625 asPIdKey = mkPreludeMiscIdUnique 225
1626 wildPIdKey = mkPreludeMiscIdUnique 226
1627 recPIdKey = mkPreludeMiscIdUnique 227
1628 listPIdKey = mkPreludeMiscIdUnique 228
1629 sigPIdKey = mkPreludeMiscIdUnique 229
1631 -- type FieldPat = ...
1632 fieldPatIdKey = mkPreludeMiscIdUnique 230
1635 matchIdKey = mkPreludeMiscIdUnique 231
1637 -- data Clause = ...
1638 clauseIdKey = mkPreludeMiscIdUnique 232
1641 varEIdKey = mkPreludeMiscIdUnique 240
1642 conEIdKey = mkPreludeMiscIdUnique 241
1643 litEIdKey = mkPreludeMiscIdUnique 242
1644 appEIdKey = mkPreludeMiscIdUnique 243
1645 infixEIdKey = mkPreludeMiscIdUnique 244
1646 infixAppIdKey = mkPreludeMiscIdUnique 245
1647 sectionLIdKey = mkPreludeMiscIdUnique 246
1648 sectionRIdKey = mkPreludeMiscIdUnique 247
1649 lamEIdKey = mkPreludeMiscIdUnique 248
1650 tupEIdKey = mkPreludeMiscIdUnique 249
1651 condEIdKey = mkPreludeMiscIdUnique 250
1652 letEIdKey = mkPreludeMiscIdUnique 251
1653 caseEIdKey = mkPreludeMiscIdUnique 252
1654 doEIdKey = mkPreludeMiscIdUnique 253
1655 compEIdKey = mkPreludeMiscIdUnique 254
1656 fromEIdKey = mkPreludeMiscIdUnique 255
1657 fromThenEIdKey = mkPreludeMiscIdUnique 256
1658 fromToEIdKey = mkPreludeMiscIdUnique 257
1659 fromThenToEIdKey = mkPreludeMiscIdUnique 258
1660 listEIdKey = mkPreludeMiscIdUnique 259
1661 sigEIdKey = mkPreludeMiscIdUnique 260
1662 recConEIdKey = mkPreludeMiscIdUnique 261
1663 recUpdEIdKey = mkPreludeMiscIdUnique 262
1665 -- type FieldExp = ...
1666 fieldExpIdKey = mkPreludeMiscIdUnique 265
1669 guardedBIdKey = mkPreludeMiscIdUnique 266
1670 normalBIdKey = mkPreludeMiscIdUnique 267
1673 normalGEIdKey = mkPreludeMiscIdUnique 310
1674 patGEIdKey = mkPreludeMiscIdUnique 311
1677 bindSIdKey = mkPreludeMiscIdUnique 268
1678 letSIdKey = mkPreludeMiscIdUnique 269
1679 noBindSIdKey = mkPreludeMiscIdUnique 270
1680 parSIdKey = mkPreludeMiscIdUnique 271
1683 funDIdKey = mkPreludeMiscIdUnique 272
1684 valDIdKey = mkPreludeMiscIdUnique 273
1685 dataDIdKey = mkPreludeMiscIdUnique 274
1686 newtypeDIdKey = mkPreludeMiscIdUnique 275
1687 tySynDIdKey = mkPreludeMiscIdUnique 276
1688 classDIdKey = mkPreludeMiscIdUnique 277
1689 instanceDIdKey = mkPreludeMiscIdUnique 278
1690 sigDIdKey = mkPreludeMiscIdUnique 279
1691 forImpDIdKey = mkPreludeMiscIdUnique 297
1694 cxtIdKey = mkPreludeMiscIdUnique 280
1696 -- data Strict = ...
1697 isStrictKey = mkPreludeMiscIdUnique 281
1698 notStrictKey = mkPreludeMiscIdUnique 282
1701 normalCIdKey = mkPreludeMiscIdUnique 283
1702 recCIdKey = mkPreludeMiscIdUnique 284
1703 infixCIdKey = mkPreludeMiscIdUnique 285
1704 forallCIdKey = mkPreludeMiscIdUnique 288
1706 -- type StrictType = ...
1707 strictTKey = mkPreludeMiscIdUnique 286
1709 -- type VarStrictType = ...
1710 varStrictTKey = mkPreludeMiscIdUnique 287
1713 forallTIdKey = mkPreludeMiscIdUnique 290
1714 varTIdKey = mkPreludeMiscIdUnique 291
1715 conTIdKey = mkPreludeMiscIdUnique 292
1716 tupleTIdKey = mkPreludeMiscIdUnique 294
1717 arrowTIdKey = mkPreludeMiscIdUnique 295
1718 listTIdKey = mkPreludeMiscIdUnique 296
1719 appTIdKey = mkPreludeMiscIdUnique 293
1721 -- data Callconv = ...
1722 cCallIdKey = mkPreludeMiscIdUnique 300
1723 stdCallIdKey = mkPreludeMiscIdUnique 301
1725 -- data Safety = ...
1726 unsafeIdKey = mkPreludeMiscIdUnique 305
1727 safeIdKey = mkPreludeMiscIdUnique 306
1728 threadsafeIdKey = mkPreludeMiscIdUnique 307
1730 -- data FunDep = ...
1731 funDepIdKey = mkPreludeMiscIdUnique 320