1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2006
5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
7 -- input HsExpr. We do this in the DsM monad, which supplies access to
8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
10 -- It also defines a bunch of knownKeyNames, in the same way as is done
11 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
16 module DsMeta( dsBracket,
17 templateHaskellNames, qTyConName, nameTyConName,
18 liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
19 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
20 quoteExpName, quotePatName
23 #include "HsVersions.h"
25 import {-# SOURCE #-} DsExpr ( dsExpr )
30 import qualified Language.Haskell.TH as TH
35 -- To avoid clashes with DsMeta.varName we must make a local alias for
36 -- OccName.varName we do this by removing varName from the import of
37 -- OccName above, making a qualified instance of OccName and using
38 -- OccNameAlias.varName where varName ws previously used in this file.
39 import qualified OccName
64 -----------------------------------------------------------------------------
65 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
66 -- Returns a CoreExpr of type TH.ExpQ
67 -- The quoted thing is parameterised over Name, even though it has
68 -- been type checked. We don't want all those type decorations!
70 dsBracket brack splices
71 = dsExtendMetaEnv new_bit (do_brack brack)
73 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
75 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
76 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
77 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
78 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
79 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
81 {- -------------- Examples --------------------
85 gensym (unpackString "x"#) `bindQ` \ x1::String ->
86 lam (pvar x1) (var x1)
89 [| \x -> $(f [| x |]) |]
91 gensym (unpackString "x"#) `bindQ` \ x1::String ->
92 lam (pvar x1) (f (var x1))
96 -------------------------------------------------------
98 -------------------------------------------------------
100 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
102 = do { let { bndrs = map unLoc (groupBinders group) } ;
103 ss <- mkGenSyms bndrs ;
105 -- Bind all the names mainly to avoid repeated use of explicit strings.
107 -- do { t :: String <- genSym "T" ;
108 -- return (Data t [] ...more t's... }
109 -- The other important reason is that the output must mention
110 -- only "T", not "Foo:T" where Foo is the current module
113 decls <- addBinds ss (do {
114 val_ds <- rep_val_binds (hs_valds group) ;
115 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
116 inst_ds <- mapM repInstD' (hs_instds group) ;
117 for_ds <- mapM repForD (hs_fords group) ;
119 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
121 decl_ty <- lookupType decQTyConName ;
122 let { core_list = coreList' decl_ty decls } ;
124 dec_ty <- lookupType decTyConName ;
125 q_decs <- repSequenceQ dec_ty core_list ;
127 wrapNongenSyms ss q_decs
128 -- Do *not* gensym top-level binders
131 groupBinders :: HsGroup Name -> [Located Name]
132 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
133 hs_instds = inst_decls, hs_fords = foreign_decls })
134 -- Collect the binders of a Group
135 = collectHsValBinders val_decls ++
136 [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
137 [n | L _ (ForeignImport n _ _) <- foreign_decls]
139 assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
142 {- Note [Binders and occurrences]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 When we desugar [d| data T = MkT |]
146 Data "T" [] [Con "MkT" []] []
148 Data "Foo:T" [] [Con "Foo:MkT" []] []
149 That is, the new data decl should fit into whatever new module it is
150 asked to fit in. We do *not* clone, though; no need for this:
157 then we must desugar to
158 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
160 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
161 And we use lookupOcc, rather than lookupBinder
162 in repTyClD and repC.
166 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
168 repTyClD tydecl@(L _ (TyFamily {}))
169 = repTyFamily tydecl addTyVarBinds
171 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
172 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
173 tcdCons = cons, tcdDerivs = mb_derivs }))
174 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
175 ; dec <- addTyVarBinds tvs $ \bndrs ->
176 do { cxt1 <- repLContext cxt
177 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
178 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
179 ; cons1 <- mapM repC cons
180 ; cons2 <- coreList conQTyConName cons1
181 ; derivs1 <- repDerivs mb_derivs
182 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
183 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
185 ; return $ Just (loc, dec)
188 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
189 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
190 tcdCons = [con], tcdDerivs = mb_derivs }))
191 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
192 ; dec <- addTyVarBinds tvs $ \bndrs ->
193 do { cxt1 <- repLContext cxt
194 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
195 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
197 ; derivs1 <- repDerivs mb_derivs
198 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
199 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
201 ; return $ Just (loc, dec)
204 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
206 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
207 ; dec <- addTyVarBinds tvs $ \bndrs ->
208 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
209 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
211 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
212 ; repTySyn tc1 bndrs1 opt_tys2 ty1
214 ; return (Just (loc, dec))
217 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
218 tcdTyVars = tvs, tcdFDs = fds,
219 tcdSigs = sigs, tcdMeths = meth_binds,
221 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
222 ; dec <- addTyVarBinds tvs $ \bndrs ->
223 do { cxt1 <- repLContext cxt
224 ; sigs1 <- rep_sigs sigs
225 ; binds1 <- rep_binds meth_binds
226 ; fds1 <- repLFunDeps fds
227 ; ats1 <- repLAssocFamilys ats
228 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
229 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
230 ; repClass cxt1 cls1 bndrs1 fds1 decls1
232 ; return $ Just (loc, dec)
236 repTyClD (L loc d) = putSrcSpanDs loc $
237 do { warnDs (hang ds_msg 4 (ppr d))
240 -- The type variables in the head of families are treated differently when the
241 -- family declaration is associated. In that case, they are usage, not binding
244 repTyFamily :: LTyClDecl Name
245 -> ProcessTyVarBinds TH.Dec
246 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
247 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
248 tcdLName = tc, tcdTyVars = tvs,
249 tcdKind = opt_kind }))
251 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
252 ; dec <- tyVarBinds tvs $ \bndrs ->
253 do { flav <- repFamilyFlavour flavour
254 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
256 Nothing -> repFamilyNoKind flav tc1 bndrs1
257 Just ki -> do { ki1 <- repKind ki
258 ; repFamilyKind flav tc1 bndrs1 ki1
261 ; return $ Just (loc, dec)
263 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
267 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
268 repLFunDeps fds = do fds' <- mapM repLFunDep fds
269 fdList <- coreList funDepTyConName fds'
272 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
273 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
274 ys' <- mapM lookupBinder ys
275 xs_list <- coreList nameTyConName xs'
276 ys_list <- coreList nameTyConName ys'
277 repFunDep xs_list ys_list
279 -- represent family declaration flavours
281 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
282 repFamilyFlavour TypeFamily = rep2 typeFamName []
283 repFamilyFlavour DataFamily = rep2 dataFamName []
285 -- represent associated family declarations
287 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
288 repLAssocFamilys = mapM repLAssocFamily
290 repLAssocFamily tydecl@(L _ (TyFamily {}))
291 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
292 repLAssocFamily tydecl
295 msg = ptext (sLit "Illegal associated declaration in class:") <+>
298 -- represent associated family instances
300 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
301 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
303 -- represent instance declarations
305 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
306 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
307 = do { i <- addTyVarBinds tvs $ \_ ->
308 -- We must bring the type variables into scope, so their
309 -- occurrences don't fail, even though the binders don't
310 -- appear in the resulting data structure
311 do { cxt1 <- repContext cxt
312 ; inst_ty1 <- repPredTy (HsClassP cls tys)
313 ; ss <- mkGenSyms (collectHsBindBinders binds)
314 ; binds1 <- addBinds ss (rep_binds binds)
315 ; ats1 <- repLAssocFamInst ats
316 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
317 ; decls2 <- wrapNongenSyms ss decls1
318 -- wrapNongenSyms: do not clone the class op names!
319 -- They must be called 'op' etc, not 'op34'
320 ; repInst cxt1 inst_ty1 (decls2)
324 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
326 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
327 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
328 = do MkC name' <- lookupLOcc name
329 MkC typ' <- repLTy typ
330 MkC cc' <- repCCallConv cc
331 MkC s' <- repSafety s
332 cis' <- conv_cimportspec cis
333 MkC str <- coreStringLit $ static
334 ++ unpackFS ch ++ " "
336 dec <- rep2 forImpDName [cc', s', str, name', typ']
339 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
340 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
341 conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
342 conv_cimportspec CWrapper = return "wrapper"
344 CFunction (StaticTarget _) -> "static "
346 repForD decl = notHandled "Foreign declaration" (ppr decl)
348 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
349 repCCallConv CCallConv = rep2 cCallName []
350 repCCallConv StdCallConv = rep2 stdCallName []
351 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
353 repSafety :: Safety -> DsM (Core TH.Safety)
354 repSafety PlayRisky = rep2 unsafeName []
355 repSafety (PlaySafe False) = rep2 safeName []
356 repSafety (PlaySafe True) = rep2 threadsafeName []
359 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
361 -------------------------------------------------------
363 -------------------------------------------------------
365 repC :: LConDecl Name -> DsM (Core TH.ConQ)
366 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
367 , con_details = details, con_res = ResTyH98 }))
368 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
369 ; repConstr con1 details
371 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
372 = addTyVarBinds tvs $ \bndrs ->
373 do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
374 ; ctxt' <- repContext ctxt
375 ; bndrs' <- coreList tyVarBndrTyConName bndrs
376 ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
378 repC (L loc con_decl) -- GADTs
380 notHandled "GADT declaration" (ppr con_decl)
382 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
386 rep2 strictTypeName [s, t]
388 (str, ty') = case ty of
389 L _ (HsBangTy _ ty) -> (isStrictName, ty)
390 _ -> (notStrictName, ty)
392 -------------------------------------------------------
394 -------------------------------------------------------
396 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
397 repDerivs Nothing = coreList nameTyConName []
398 repDerivs (Just ctxt)
399 = do { strs <- mapM rep_deriv ctxt ;
400 coreList nameTyConName strs }
402 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
403 -- Deriving clauses must have the simple H98 form
404 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
405 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
408 -------------------------------------------------------
409 -- Signatures in a class decl, or a group of bindings
410 -------------------------------------------------------
412 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
413 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
414 return $ de_loc $ sort_by_loc locs_cores
416 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
417 -- We silently ignore ones we don't recognise
418 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
419 return (concat sigs1) }
421 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
423 -- Empty => Too hard, signature ignored
424 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
425 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
426 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
427 rep_sig _ = return []
429 rep_proto :: Located Name -> LHsType Name -> SrcSpan
430 -> DsM [(SrcSpan, Core TH.DecQ)]
432 = do { nm1 <- lookupLOcc nm
434 ; sig <- repProto nm1 ty1
435 ; return [(loc, sig)]
438 rep_inline :: Located Name -> InlineSpec -> SrcSpan
439 -> DsM [(SrcSpan, Core TH.DecQ)]
440 rep_inline nm ispec loc
441 = do { nm1 <- lookupLOcc nm
442 ; (_, ispec1) <- rep_InlineSpec ispec
443 ; pragma <- repPragInl nm1 ispec1
444 ; return [(loc, pragma)]
447 rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan
448 -> DsM [(SrcSpan, Core TH.DecQ)]
449 rep_specialise nm ty ispec loc
450 = do { nm1 <- lookupLOcc nm
452 ; (hasSpec, ispec1) <- rep_InlineSpec ispec
453 ; pragma <- if hasSpec
454 then repPragSpecInl nm1 ty1 ispec1
455 else repPragSpec nm1 ty1
456 ; return [(loc, pragma)]
459 -- extract all the information needed to build a TH.InlineSpec
461 rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
462 rep_InlineSpec (Inline (InlinePragma activation match) inline)
463 | Nothing <- activation1
464 = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
465 | Just (flag, phase) <- activation1
466 = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase
467 | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
469 match1 = coreBool (rep_RuleMatchInfo match)
470 activation1 = rep_Activation activation
471 inline1 = coreBool inline
473 rep_RuleMatchInfo FunLike = False
474 rep_RuleMatchInfo ConLike = True
476 rep_Activation NeverActive = Nothing
477 rep_Activation AlwaysActive = Nothing
478 rep_Activation (ActiveBefore phase) = Just (coreBool False,
479 MkC $ mkIntExprInt phase)
480 rep_Activation (ActiveAfter phase) = Just (coreBool True,
481 MkC $ mkIntExprInt phase)
484 -------------------------------------------------------
486 -------------------------------------------------------
488 -- We process type variable bindings in two ways, either by generating fresh
489 -- names or looking up existing names. The difference is crucial for type
490 -- families, depending on whether they are associated or not.
492 type ProcessTyVarBinds a =
493 [LHsTyVarBndr Name] -- the binders to be added
494 -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
495 -> DsM (Core (TH.Q a))
497 -- gensym a list of type variables and enter them into the meta environment;
498 -- the computations passed as the second argument is executed in that extended
499 -- meta environment and gets the *new* names on Core-level as an argument
501 addTyVarBinds :: ProcessTyVarBinds a
502 addTyVarBinds tvs m =
504 let names = hsLTyVarNames tvs
505 mkWithKinds = map repTyVarBndrWithKind tvs
506 freshNames <- mkGenSyms names
507 term <- addBinds freshNames $ do
508 bndrs <- mapM lookupBinder names
509 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
511 wrapGenSyns freshNames term
513 -- Look up a list of type variables; the computations passed as the second
514 -- argument gets the *new* names on Core-level as an argument
516 lookupTyVarBinds :: ProcessTyVarBinds a
517 lookupTyVarBinds tvs m =
519 let names = hsLTyVarNames tvs
520 mkWithKinds = map repTyVarBndrWithKind tvs
521 bndrs <- mapM lookupBinder names
522 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
525 -- Produce kinded binder constructors from the Haskell tyvar binders
527 repTyVarBndrWithKind :: LHsTyVarBndr Name
528 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
529 repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV
530 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
531 \nm -> repKind ki >>= repKindedTV nm
533 -- represent a type context
535 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
536 repLContext (L _ ctxt) = repContext ctxt
538 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
540 preds <- mapM repLPred ctxt
541 predList <- coreList predQTyConName preds
544 -- represent a type predicate
546 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
547 repLPred (L _ p) = repPred p
549 repPred :: HsPred Name -> DsM (Core TH.PredQ)
550 repPred (HsClassP cls tys)
552 cls1 <- lookupOcc cls
554 tys2 <- coreList typeQTyConName tys1
556 repPred (HsEqualP tyleft tyright)
558 tyleft1 <- repLTy tyleft
559 tyright1 <- repLTy tyright
560 repEqualP tyleft1 tyright1
561 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
563 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
564 repPredTy (HsClassP cls tys)
566 tcon <- repTy (HsTyVar cls)
569 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
571 -- yield the representation of a list of types
573 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
574 repLTys tys = mapM repLTy tys
578 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
579 repLTy (L _ ty) = repTy ty
581 repTy :: HsType Name -> DsM (Core TH.TypeQ)
582 repTy (HsForAllTy _ tvs ctxt ty) =
583 addTyVarBinds tvs $ \bndrs -> do
584 ctxt1 <- repLContext ctxt
586 bndrs1 <- coreList tyVarBndrTyConName bndrs
587 repTForall bndrs1 ctxt1 ty1
590 | isTvOcc (nameOccName n) = do
596 repTy (HsAppTy f a) = do
600 repTy (HsFunTy f a) = do
603 tcon <- repArrowTyCon
604 repTapps tcon [f1, a1]
605 repTy (HsListTy t) = do
609 repTy (HsPArrTy t) = do
611 tcon <- repTy (HsTyVar (tyConName parrTyCon))
613 repTy (HsTupleTy _ tys) = do
615 tcon <- repTupleTyCon (length tys)
617 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
619 repTy (HsParTy t) = repLTy t
620 repTy (HsPredTy pred) = repPredTy pred
621 repTy (HsKindSig t k) = do
625 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
626 repTy ty = notHandled "Exotic form of type" (ppr ty)
630 repKind :: Kind -> DsM (Core TH.Kind)
632 = do { let (kis, ki') = splitKindFunTys ki
633 ; kis_rep <- mapM repKind kis
634 ; ki'_rep <- repNonArrowKind ki'
635 ; foldlM repArrowK ki'_rep kis_rep
638 repNonArrowKind k | isLiftedTypeKind k = repStarK
639 | otherwise = notHandled "Exotic form of kind"
642 -----------------------------------------------------------------------------
644 -----------------------------------------------------------------------------
646 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
647 repLEs es = do { es' <- mapM repLE es ;
648 coreList expQTyConName es' }
650 -- FIXME: some of these panics should be converted into proper error messages
651 -- unless we can make sure that constructs, which are plainly not
652 -- supported in TH already lead to error messages at an earlier stage
653 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
654 repLE (L loc e) = putSrcSpanDs loc (repE e)
656 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
658 do { mb_val <- dsLookupMetaEnv x
660 Nothing -> do { str <- globalVar x
661 ; repVarOrCon x str }
662 Just (Bound y) -> repVarOrCon x (coreVar y)
663 Just (Splice e) -> do { e' <- dsExpr e
664 ; return (MkC e') } }
665 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
667 -- Remember, we're desugaring renamer output here, so
668 -- HsOverlit can definitely occur
669 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
670 repE (HsLit l) = do { a <- repLiteral l; repLit a }
671 repE (HsLam (MatchGroup [m] _)) = repLambda m
672 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
674 repE (OpApp e1 op _ e2) =
675 do { arg1 <- repLE e1;
678 repInfixApp arg1 the_op arg2 }
679 repE (NegApp x _) = do
681 negateVar <- lookupOcc negateName >>= repVar
683 repE (HsPar x) = repLE x
684 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
685 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
686 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
687 ; ms2 <- mapM repMatchTup ms
688 ; repCaseE arg (nonEmptyCoreList ms2) }
689 repE (HsIf x y z) = do
694 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
695 ; e2 <- addBinds ss (repLE e)
698 -- FIXME: I haven't got the types here right yet
699 repE (HsDo DoExpr sts body _)
700 = do { (ss,zs) <- repLSts sts;
701 body' <- addBinds ss $ repLE body;
702 ret <- repNoBindSt body';
703 e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
705 repE (HsDo ListComp sts body _)
706 = do { (ss,zs) <- repLSts sts;
707 body' <- addBinds ss $ repLE body;
708 ret <- repNoBindSt body';
709 e <- repComp (nonEmptyCoreList (zs ++ [ret]));
711 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
712 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
713 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
714 repE e@(ExplicitTuple es boxed)
715 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
716 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
717 | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
719 repE (RecordCon c _ flds)
720 = do { x <- lookupLOcc c;
721 fs <- repFields flds;
723 repE (RecordUpd e flds _ _ _)
725 fs <- repFields flds;
728 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
729 repE (ArithSeq _ aseq) =
731 From e -> do { ds1 <- repLE e; repFrom ds1 }
740 FromThenTo e1 e2 e3 -> do
744 repFromThenTo ds1 ds2 ds3
745 repE (HsSpliceE (HsSplice n _))
746 = do { mb_val <- dsLookupMetaEnv n
748 Just (Splice e) -> do { e' <- dsExpr e
750 _ -> pprPanic "HsSplice" (ppr n) }
751 -- Should not happen; statically checked
753 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
754 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
755 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
756 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
757 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
758 repE e = notHandled "Expression form" (ppr e)
760 -----------------------------------------------------------------------------
761 -- Building representations of auxillary structures like Match, Clause, Stmt,
763 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
764 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
765 do { ss1 <- mkGenSyms (collectPatBinders p)
766 ; addBinds ss1 $ do {
768 ; (ss2,ds) <- repBinds wheres
769 ; addBinds ss2 $ do {
770 ; gs <- repGuards guards
771 ; match <- repMatch p1 gs ds
772 ; wrapGenSyns (ss1++ss2) match }}}
773 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
775 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
776 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
777 do { ss1 <- mkGenSyms (collectPatsBinders ps)
778 ; addBinds ss1 $ do {
780 ; (ss2,ds) <- repBinds wheres
781 ; addBinds ss2 $ do {
782 gs <- repGuards guards
783 ; clause <- repClause ps1 gs ds
784 ; wrapGenSyns (ss1++ss2) clause }}}
786 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
787 repGuards [L _ (GRHS [] e)]
788 = do {a <- repLE e; repNormal a }
790 = do { zs <- mapM process other;
791 let {(xs, ys) = unzip zs};
792 gd <- repGuarded (nonEmptyCoreList ys);
793 wrapGenSyns (concat xs) gd }
795 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
796 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
797 = do { x <- repLNormalGE e1 e2;
799 process (L _ (GRHS ss rhs))
800 = do (gs, ss') <- repLSts ss
801 rhs' <- addBinds gs $ repLE rhs
802 g <- repPatGE (nonEmptyCoreList ss') rhs'
805 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
806 repFields (HsRecFields { rec_flds = flds })
807 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
808 ; es <- mapM repLE (map hsRecFieldArg flds)
809 ; fs <- zipWithM repFieldExp fnames es
810 ; coreList fieldExpQTyConName fs }
813 -----------------------------------------------------------------------------
814 -- Representing Stmt's is tricky, especially if bound variables
815 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
816 -- First gensym new names for every variable in any of the patterns.
817 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
818 -- if variables didn't shaddow, the static gensym wouldn't be necessary
819 -- and we could reuse the original names (x and x).
821 -- do { x'1 <- gensym "x"
822 -- ; x'2 <- gensym "x"
823 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
824 -- , BindSt (pvar x'2) [| f x |]
825 -- , NoBindSt [| g x |]
829 -- The strategy is to translate a whole list of do-bindings by building a
830 -- bigger environment, and a bigger set of meta bindings
831 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
832 -- of the expressions within the Do
834 -----------------------------------------------------------------------------
835 -- The helper function repSts computes the translation of each sub expression
836 -- and a bunch of prefix bindings denoting the dynamic renaming.
838 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
839 repLSts stmts = repSts (map unLoc stmts)
841 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
842 repSts (BindStmt p e _ _ : ss) =
844 ; ss1 <- mkGenSyms (collectPatBinders p)
845 ; addBinds ss1 $ do {
847 ; (ss2,zs) <- repSts ss
848 ; z <- repBindSt p1 e2
849 ; return (ss1++ss2, z : zs) }}
850 repSts (LetStmt bs : ss) =
851 do { (ss1,ds) <- repBinds bs
853 ; (ss2,zs) <- addBinds ss1 (repSts ss)
854 ; return (ss1++ss2, z : zs) }
855 repSts (ExprStmt e _ _ : ss) =
857 ; z <- repNoBindSt e2
858 ; (ss2,zs) <- repSts ss
859 ; return (ss2, z : zs) }
860 repSts [] = return ([],[])
861 repSts other = notHandled "Exotic statement" (ppr other)
864 -----------------------------------------------------------
866 -----------------------------------------------------------
868 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
869 repBinds EmptyLocalBinds
870 = do { core_list <- coreList decQTyConName []
871 ; return ([], core_list) }
873 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
875 repBinds (HsValBinds decs)
876 = do { let { bndrs = map unLoc (collectHsValBinders decs) }
877 -- No need to worrry about detailed scopes within
878 -- the binding group, because we are talking Names
879 -- here, so we can safely treat it as a mutually
881 ; ss <- mkGenSyms bndrs
882 ; prs <- addBinds ss (rep_val_binds decs)
883 ; core_list <- coreList decQTyConName
884 (de_loc (sort_by_loc prs))
885 ; return (ss, core_list) }
887 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
888 -- Assumes: all the binders of the binding are alrady in the meta-env
889 rep_val_binds (ValBindsOut binds sigs)
890 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
891 ; core2 <- rep_sigs' sigs
892 ; return (core1 ++ core2) }
893 rep_val_binds (ValBindsIn _ _)
894 = panic "rep_val_binds: ValBindsIn"
896 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
897 rep_binds binds = do { binds_w_locs <- rep_binds' binds
898 ; return (de_loc (sort_by_loc binds_w_locs)) }
900 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
901 rep_binds' binds = mapM rep_bind (bagToList binds)
903 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
904 -- Assumes: all the binders of the binding are alrady in the meta-env
906 -- Note GHC treats declarations of a variable (not a pattern)
907 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
908 -- with an empty list of patterns
909 rep_bind (L loc (FunBind { fun_id = fn,
910 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
911 = do { (ss,wherecore) <- repBinds wheres
912 ; guardcore <- addBinds ss (repGuards guards)
913 ; fn' <- lookupLBinder fn
915 ; ans <- repVal p guardcore wherecore
916 ; ans' <- wrapGenSyns ss ans
917 ; return (loc, ans') }
919 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
920 = do { ms1 <- mapM repClauseTup ms
921 ; fn' <- lookupLBinder fn
922 ; ans <- repFun fn' (nonEmptyCoreList ms1)
923 ; return (loc, ans) }
925 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
926 = do { patcore <- repLP pat
927 ; (ss,wherecore) <- repBinds wheres
928 ; guardcore <- addBinds ss (repGuards guards)
929 ; ans <- repVal patcore guardcore wherecore
930 ; ans' <- wrapGenSyns ss ans
931 ; return (loc, ans') }
933 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
934 = do { v' <- lookupBinder v
937 ; patcore <- repPvar v'
938 ; empty_decls <- coreList decQTyConName []
939 ; ans <- repVal patcore x empty_decls
940 ; return (srcLocSpan (getSrcLoc v), ans) }
942 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
944 -----------------------------------------------------------------------------
945 -- Since everything in a Bind is mutually recursive we need rename all
946 -- all the variables simultaneously. For example:
947 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
948 -- do { f'1 <- gensym "f"
949 -- ; g'2 <- gensym "g"
950 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
951 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
953 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
954 -- environment ( f |-> f'1 ) from each binding, and then unioning them
955 -- together. As we do this we collect GenSymBinds's which represent the renamed
956 -- variables bound by the Bindings. In order not to lose track of these
957 -- representations we build a shadow datatype MB with the same structure as
958 -- MonoBinds, but which has slots for the representations
961 -----------------------------------------------------------------------------
962 -- GHC allows a more general form of lambda abstraction than specified
963 -- by Haskell 98. In particular it allows guarded lambda's like :
964 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
965 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
966 -- (\ p1 .. pn -> exp) by causing an error.
968 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
969 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
970 = do { let bndrs = collectPatsBinders ps ;
971 ; ss <- mkGenSyms bndrs
972 ; lam <- addBinds ss (
973 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
974 ; wrapGenSyns ss lam }
976 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
979 -----------------------------------------------------------------------------
981 -- repP deals with patterns. It assumes that we have already
982 -- walked over the pattern(s) once to collect the binders, and
983 -- have extended the environment. So every pattern-bound
984 -- variable should already appear in the environment.
986 -- Process a list of patterns
987 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
988 repLPs ps = do { ps' <- mapM repLP ps ;
989 coreList patQTyConName ps' }
991 repLP :: LPat Name -> DsM (Core TH.PatQ)
992 repLP (L _ p) = repP p
994 repP :: Pat Name -> DsM (Core TH.PatQ)
995 repP (WildPat _) = repPwild
996 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
997 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
998 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
999 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1000 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1001 repP (ParPat p) = repLP p
1002 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1003 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
1004 repP (ConPatIn dc details)
1005 = do { con_str <- lookupLOcc dc
1007 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1008 RecCon rec -> do { let flds = rec_flds rec
1009 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1010 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1011 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1012 ; fps' <- coreList fieldPatQTyConName fps
1013 ; repPrec con_str fps' }
1014 InfixCon p1 p2 -> do { p1' <- repLP p1;
1016 repPinfix p1' con_str p2' }
1018 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1019 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1020 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1021 -- The problem is to do with scoped type variables.
1022 -- To implement them, we have to implement the scoping rules
1023 -- here in DsMeta, and I don't want to do that today!
1024 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1025 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1026 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1028 repP other = notHandled "Exotic pattern" (ppr other)
1030 ----------------------------------------------------------
1031 -- Declaration ordering helpers
1033 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1034 sort_by_loc xs = sortBy comp xs
1035 where comp x y = compare (fst x) (fst y)
1037 de_loc :: [(a, b)] -> [b]
1040 ----------------------------------------------------------
1041 -- The meta-environment
1043 -- A name/identifier association for fresh names of locally bound entities
1044 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1045 -- I.e. (x, x_id) means
1046 -- let x_id = gensym "x" in ...
1048 -- Generate a fresh name for a locally bound entity
1050 mkGenSyms :: [Name] -> DsM [GenSymBind]
1051 -- We can use the existing name. For example:
1052 -- [| \x_77 -> x_77 + x_77 |]
1054 -- do { x_77 <- genSym "x"; .... }
1055 -- We use the same x_77 in the desugared program, but with the type Bndr
1058 -- We do make it an Internal name, though (hence localiseName)
1060 -- Nevertheless, it's monadic because we have to generate nameTy
1061 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1062 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1065 addBinds :: [GenSymBind] -> DsM a -> DsM a
1066 -- Add a list of fresh names for locally bound entities to the
1067 -- meta environment (which is part of the state carried around
1068 -- by the desugarer monad)
1069 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1071 -- Look up a locally bound name
1073 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1074 lookupLBinder (L _ n) = lookupBinder n
1076 lookupBinder :: Name -> DsM (Core TH.Name)
1078 = do { mb_val <- dsLookupMetaEnv n;
1080 Just (Bound x) -> return (coreVar x)
1081 _ -> failWithDs msg }
1083 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1085 -- Look up a name that is either locally bound or a global name
1087 -- * If it is a global name, generate the "original name" representation (ie,
1088 -- the <module>:<name> form) for the associated entity
1090 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1091 -- Lookup an occurrence; it can't be a splice.
1092 -- Use the in-scope bindings if they exist
1093 lookupLOcc (L _ n) = lookupOcc n
1095 lookupOcc :: Name -> DsM (Core TH.Name)
1097 = do { mb_val <- dsLookupMetaEnv n ;
1099 Nothing -> globalVar n
1100 Just (Bound x) -> return (coreVar x)
1101 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1104 lookupTvOcc :: Name -> DsM (Core TH.Name)
1105 -- Type variables can't be staged and are not lexically scoped in TH
1107 = do { mb_val <- dsLookupMetaEnv n ;
1109 Just (Bound x) -> return (coreVar x)
1113 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1114 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1116 globalVar :: Name -> DsM (Core TH.Name)
1117 -- Not bound by the meta-env
1118 -- Could be top-level; or could be local
1119 -- f x = $(g [| x |])
1120 -- Here the x will be local
1122 | isExternalName name
1123 = do { MkC mod <- coreStringLit name_mod
1124 ; MkC pkg <- coreStringLit name_pkg
1125 ; MkC occ <- occNameLit name
1126 ; rep2 mk_varg [pkg,mod,occ] }
1128 = do { MkC occ <- occNameLit name
1129 ; MkC uni <- coreIntLit (getKey (getUnique name))
1130 ; rep2 mkNameLName [occ,uni] }
1132 mod = ASSERT( isExternalName name) nameModule name
1133 name_mod = moduleNameString (moduleName mod)
1134 name_pkg = packageIdString (modulePackageId mod)
1135 name_occ = nameOccName name
1136 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1137 | OccName.isVarOcc name_occ = mkNameG_vName
1138 | OccName.isTcOcc name_occ = mkNameG_tcName
1139 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1141 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1142 -> DsM Type -- The type
1143 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1144 return (mkTyConApp tc []) }
1146 wrapGenSyns :: [GenSymBind]
1147 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1148 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
1149 -- --> bindQ (gensym nm1) (\ id1 ->
1150 -- bindQ (gensym nm2 (\ id2 ->
1153 wrapGenSyns binds body@(MkC b)
1154 = do { var_ty <- lookupType nameTyConName
1157 [elt_ty] = tcTyConAppArgs (exprType b)
1158 -- b :: Q a, so we can get the type 'a' by looking at the
1159 -- argument type. NB: this relies on Q being a data/newtype,
1160 -- not a type synonym
1162 go _ [] = return body
1163 go var_ty ((name,id) : binds)
1164 = do { MkC body' <- go var_ty binds
1165 ; lit_str <- occNameLit name
1166 ; gensym_app <- repGensym lit_str
1167 ; repBindQ var_ty elt_ty
1168 gensym_app (MkC (Lam id body')) }
1170 -- Just like wrapGenSym, but don't actually do the gensym
1171 -- Instead use the existing name:
1172 -- let x = "x" in ...
1173 -- Only used for [Decl], and for the class ops in class
1174 -- and instance decls
1175 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1176 wrapNongenSyms binds (MkC body)
1177 = do { binds' <- mapM do_one binds ;
1178 return (MkC (mkLets binds' body)) }
1181 = do { MkC lit_str <- occNameLit name
1182 ; MkC var <- rep2 mkNameName [lit_str]
1183 ; return (NonRec id var) }
1185 occNameLit :: Name -> DsM (Core String)
1186 occNameLit n = coreStringLit (occNameString (nameOccName n))
1189 -- %*********************************************************************
1191 -- Constructing code
1193 -- %*********************************************************************
1195 -----------------------------------------------------------------------------
1196 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1197 -- we invent a new datatype which uses phantom types.
1199 newtype Core a = MkC CoreExpr
1200 unC :: Core a -> CoreExpr
1203 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1204 rep2 n xs = do { id <- dsLookupGlobalId n
1205 ; return (MkC (foldl App (Var id) xs)) }
1207 -- Then we make "repConstructors" which use the phantom types for each of the
1208 -- smart constructors of the Meta.Meta datatypes.
1211 -- %*********************************************************************
1213 -- The 'smart constructors'
1215 -- %*********************************************************************
1217 --------------- Patterns -----------------
1218 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1219 repPlit (MkC l) = rep2 litPName [l]
1221 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1222 repPvar (MkC s) = rep2 varPName [s]
1224 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1225 repPtup (MkC ps) = rep2 tupPName [ps]
1227 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1228 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1230 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1231 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1233 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1234 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1236 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1237 repPtilde (MkC p) = rep2 tildePName [p]
1239 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1240 repPbang (MkC p) = rep2 bangPName [p]
1242 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1243 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1245 repPwild :: DsM (Core TH.PatQ)
1246 repPwild = rep2 wildPName []
1248 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1249 repPlist (MkC ps) = rep2 listPName [ps]
1251 --------------- Expressions -----------------
1252 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1253 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1254 | otherwise = repVar str
1256 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1257 repVar (MkC s) = rep2 varEName [s]
1259 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1260 repCon (MkC s) = rep2 conEName [s]
1262 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1263 repLit (MkC c) = rep2 litEName [c]
1265 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1266 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1268 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1269 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1271 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1272 repTup (MkC es) = rep2 tupEName [es]
1274 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1275 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1277 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1278 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1280 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1281 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1283 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1284 repDoE (MkC ss) = rep2 doEName [ss]
1286 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1287 repComp (MkC ss) = rep2 compEName [ss]
1289 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1290 repListExp (MkC es) = rep2 listEName [es]
1292 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1293 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1295 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1296 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1298 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1299 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1301 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1302 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1304 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1305 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1307 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1308 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1310 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1311 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1313 ------------ Right hand sides (guarded expressions) ----
1314 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1315 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1317 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1318 repNormal (MkC e) = rep2 normalBName [e]
1320 ------------ Guards ----
1321 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1322 repLNormalGE g e = do g' <- repLE g
1326 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1327 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1329 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1330 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1332 ------------- Stmts -------------------
1333 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1334 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1336 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1337 repLetSt (MkC ds) = rep2 letSName [ds]
1339 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1340 repNoBindSt (MkC e) = rep2 noBindSName [e]
1342 -------------- Range (Arithmetic sequences) -----------
1343 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1344 repFrom (MkC x) = rep2 fromEName [x]
1346 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1347 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1349 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1350 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1352 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1353 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1355 ------------ Match and Clause Tuples -----------
1356 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1357 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1359 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1360 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1362 -------------- Dec -----------------------------
1363 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1364 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1366 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1367 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1369 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1370 -> Maybe (Core [TH.TypeQ])
1371 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1372 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1373 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1374 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1375 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1377 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1378 -> Maybe (Core [TH.TypeQ])
1379 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1380 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1381 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1382 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1383 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1385 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1386 -> Maybe (Core [TH.TypeQ])
1387 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1388 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1389 = rep2 tySynDName [nm, tvs, rhs]
1390 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1391 = rep2 tySynInstDName [nm, tys, rhs]
1393 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1394 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1396 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1397 -> Core [TH.FunDep] -> Core [TH.DecQ]
1398 -> DsM (Core TH.DecQ)
1399 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1400 = rep2 classDName [cxt, cls, tvs, fds, ds]
1402 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1403 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1405 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1406 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1408 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1409 -> DsM (Core TH.DecQ)
1410 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1411 = rep2 pragSpecInlDName [nm, ty, ispec]
1413 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1414 -> DsM (Core TH.DecQ)
1415 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1416 = rep2 familyNoKindDName [flav, nm, tvs]
1418 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1420 -> DsM (Core TH.DecQ)
1421 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1422 = rep2 familyKindDName [flav, nm, tvs, ki]
1424 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1425 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1426 = rep2 inlineSpecNoPhaseName [inline, conlike]
1428 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1429 -> DsM (Core TH.InlineSpecQ)
1430 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1431 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1433 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1434 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1436 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1437 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1439 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1440 repCtxt (MkC tys) = rep2 cxtName [tys]
1442 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1443 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1445 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1446 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1448 repConstr :: Core TH.Name -> HsConDeclDetails Name
1449 -> DsM (Core TH.ConQ)
1450 repConstr con (PrefixCon ps)
1451 = do arg_tys <- mapM repBangTy ps
1452 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1453 rep2 normalCName [unC con, unC arg_tys1]
1454 repConstr con (RecCon ips)
1455 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1456 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1457 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1459 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1460 rep2 recCName [unC con, unC arg_vtys']
1461 repConstr con (InfixCon st1 st2)
1462 = do arg1 <- repBangTy st1
1463 arg2 <- repBangTy st2
1464 rep2 infixCName [unC arg1, unC con, unC arg2]
1466 ------------ Types -------------------
1468 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1469 -> DsM (Core TH.TypeQ)
1470 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1471 = rep2 forallTName [tvars, ctxt, ty]
1473 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1474 repTvar (MkC s) = rep2 varTName [s]
1476 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1477 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1479 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1480 repTapps f [] = return f
1481 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1483 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1484 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1486 --------- Type constructors --------------
1488 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1489 repNamedTyCon (MkC s) = rep2 conTName [s]
1491 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1492 -- Note: not Core Int; it's easier to be direct here
1493 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1495 repArrowTyCon :: DsM (Core TH.TypeQ)
1496 repArrowTyCon = rep2 arrowTName []
1498 repListTyCon :: DsM (Core TH.TypeQ)
1499 repListTyCon = rep2 listTName []
1501 ------------ Kinds -------------------
1503 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1504 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1506 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1507 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1509 repStarK :: DsM (Core TH.Kind)
1510 repStarK = rep2 starKName []
1512 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1513 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1515 ----------------------------------------------------------
1518 repLiteral :: HsLit -> DsM (Core TH.Lit)
1520 = do lit' <- case lit of
1521 HsIntPrim i -> mk_integer i
1522 HsWordPrim w -> mk_integer w
1523 HsInt i -> mk_integer i
1524 HsFloatPrim r -> mk_rational r
1525 HsDoublePrim r -> mk_rational r
1527 lit_expr <- dsLit lit'
1529 Just lit_name -> rep2 lit_name [lit_expr]
1530 Nothing -> notHandled "Exotic literal" (ppr lit)
1532 mb_lit_name = case lit of
1533 HsInteger _ _ -> Just integerLName
1534 HsInt _ -> Just integerLName
1535 HsIntPrim _ -> Just intPrimLName
1536 HsWordPrim _ -> Just wordPrimLName
1537 HsFloatPrim _ -> Just floatPrimLName
1538 HsDoublePrim _ -> Just doublePrimLName
1539 HsChar _ -> Just charLName
1540 HsString _ -> Just stringLName
1541 HsRat _ _ -> Just rationalLName
1544 mk_integer :: Integer -> DsM HsLit
1545 mk_integer i = do integer_ty <- lookupType integerTyConName
1546 return $ HsInteger i integer_ty
1547 mk_rational :: Rational -> DsM HsLit
1548 mk_rational r = do rat_ty <- lookupType rationalTyConName
1549 return $ HsRat r rat_ty
1550 mk_string :: FastString -> DsM HsLit
1551 mk_string s = return $ HsString s
1553 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1554 repOverloadedLiteral (OverLit { ol_val = val})
1555 = do { lit <- mk_lit val; repLiteral lit }
1556 -- The type Rational will be in the environment, becuase
1557 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1558 -- and rationalL is sucked in when any TH stuff is used
1560 mk_lit :: OverLitVal -> DsM HsLit
1561 mk_lit (HsIntegral i) = mk_integer i
1562 mk_lit (HsFractional f) = mk_rational f
1563 mk_lit (HsIsString s) = mk_string s
1565 --------------- Miscellaneous -------------------
1567 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1568 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1570 repBindQ :: Type -> Type -- a and b
1571 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1572 repBindQ ty_a ty_b (MkC x) (MkC y)
1573 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1575 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1576 repSequenceQ ty_a (MkC list)
1577 = rep2 sequenceQName [Type ty_a, list]
1579 ------------ Lists and Tuples -------------------
1580 -- turn a list of patterns into a single pattern matching a list
1582 coreList :: Name -- Of the TyCon of the element type
1583 -> [Core a] -> DsM (Core [a])
1585 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1587 coreList' :: Type -- The element type
1588 -> [Core a] -> Core [a]
1589 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1591 nonEmptyCoreList :: [Core a] -> Core [a]
1592 -- The list must be non-empty so we can get the element type
1593 -- Otherwise use coreList
1594 nonEmptyCoreList [] = panic "coreList: empty argument"
1595 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1597 coreStringLit :: String -> DsM (Core String)
1598 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1600 ------------ Bool, Literals & Variables -------------------
1602 coreBool :: Bool -> Core Bool
1603 coreBool False = MkC $ mkConApp falseDataCon []
1604 coreBool True = MkC $ mkConApp trueDataCon []
1606 coreIntLit :: Int -> DsM (Core Int)
1607 coreIntLit i = return (MkC (mkIntExprInt i))
1609 coreVar :: Id -> Core TH.Name -- The Id has type Name
1610 coreVar id = MkC (Var id)
1612 ----------------- Failure -----------------------
1613 notHandled :: String -> SDoc -> DsM a
1614 notHandled what doc = failWithDs msg
1616 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1620 -- %************************************************************************
1622 -- The known-key names for Template Haskell
1624 -- %************************************************************************
1626 -- To add a name, do three things
1628 -- 1) Allocate a key
1630 -- 3) Add the name to knownKeyNames
1632 templateHaskellNames :: [Name]
1633 -- The names that are implicitly mentioned by ``bracket''
1634 -- Should stay in sync with the import list of DsMeta
1636 templateHaskellNames = [
1637 returnQName, bindQName, sequenceQName, newNameName, liftName,
1638 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1641 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1642 floatPrimLName, doublePrimLName, rationalLName,
1644 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1645 asPName, wildPName, recPName, listPName, sigPName,
1653 varEName, conEName, litEName, appEName, infixEName,
1654 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1655 condEName, letEName, caseEName, doEName, compEName,
1656 fromEName, fromThenEName, fromToEName, fromThenToEName,
1657 listEName, sigEName, recConEName, recUpdEName,
1661 guardedBName, normalBName,
1663 normalGEName, patGEName,
1665 bindSName, letSName, noBindSName, parSName,
1667 funDName, valDName, dataDName, newtypeDName, tySynDName,
1668 classDName, instanceDName, sigDName, forImpDName,
1669 pragInlDName, pragSpecDName, pragSpecInlDName,
1670 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1675 classPName, equalPName,
1677 isStrictName, notStrictName,
1679 normalCName, recCName, infixCName, forallCName,
1685 forallTName, varTName, conTName, appTName,
1686 tupleTName, arrowTName, listTName, sigTName,
1688 plainTVName, kindedTVName,
1690 starKName, arrowKName,
1692 cCallName, stdCallName,
1698 inlineSpecNoPhaseName, inlineSpecPhaseName,
1702 typeFamName, dataFamName,
1705 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1706 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1707 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1708 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1709 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1710 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1714 quoteExpName, quotePatName]
1716 thSyn, thLib, qqLib :: Module
1717 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1718 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1719 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1721 mkTHModule :: FastString -> Module
1722 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1724 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1725 libFun = mk_known_key_name OccName.varName thLib
1726 libTc = mk_known_key_name OccName.tcName thLib
1727 thFun = mk_known_key_name OccName.varName thSyn
1728 thTc = mk_known_key_name OccName.tcName thSyn
1729 qqFun = mk_known_key_name OccName.varName qqLib
1731 -------------------- TH.Syntax -----------------------
1732 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1733 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1734 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1735 predTyConName :: Name
1736 qTyConName = thTc (fsLit "Q") qTyConKey
1737 nameTyConName = thTc (fsLit "Name") nameTyConKey
1738 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1739 patTyConName = thTc (fsLit "Pat") patTyConKey
1740 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1741 expTyConName = thTc (fsLit "Exp") expTyConKey
1742 decTyConName = thTc (fsLit "Dec") decTyConKey
1743 typeTyConName = thTc (fsLit "Type") typeTyConKey
1744 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1745 matchTyConName = thTc (fsLit "Match") matchTyConKey
1746 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1747 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1748 predTyConName = thTc (fsLit "Pred") predTyConKey
1750 returnQName, bindQName, sequenceQName, newNameName, liftName,
1751 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1752 mkNameLName, liftStringName :: Name
1753 returnQName = thFun (fsLit "returnQ") returnQIdKey
1754 bindQName = thFun (fsLit "bindQ") bindQIdKey
1755 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1756 newNameName = thFun (fsLit "newName") newNameIdKey
1757 liftName = thFun (fsLit "lift") liftIdKey
1758 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1759 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1760 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1761 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1762 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1763 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1766 -------------------- TH.Lib -----------------------
1768 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1769 floatPrimLName, doublePrimLName, rationalLName :: Name
1770 charLName = libFun (fsLit "charL") charLIdKey
1771 stringLName = libFun (fsLit "stringL") stringLIdKey
1772 integerLName = libFun (fsLit "integerL") integerLIdKey
1773 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1774 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1775 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1776 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1777 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1780 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1781 asPName, wildPName, recPName, listPName, sigPName :: Name
1782 litPName = libFun (fsLit "litP") litPIdKey
1783 varPName = libFun (fsLit "varP") varPIdKey
1784 tupPName = libFun (fsLit "tupP") tupPIdKey
1785 conPName = libFun (fsLit "conP") conPIdKey
1786 infixPName = libFun (fsLit "infixP") infixPIdKey
1787 tildePName = libFun (fsLit "tildeP") tildePIdKey
1788 bangPName = libFun (fsLit "bangP") bangPIdKey
1789 asPName = libFun (fsLit "asP") asPIdKey
1790 wildPName = libFun (fsLit "wildP") wildPIdKey
1791 recPName = libFun (fsLit "recP") recPIdKey
1792 listPName = libFun (fsLit "listP") listPIdKey
1793 sigPName = libFun (fsLit "sigP") sigPIdKey
1795 -- type FieldPat = ...
1796 fieldPatName :: Name
1797 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1801 matchName = libFun (fsLit "match") matchIdKey
1803 -- data Clause = ...
1805 clauseName = libFun (fsLit "clause") clauseIdKey
1808 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1809 sectionLName, sectionRName, lamEName, tupEName, condEName,
1810 letEName, caseEName, doEName, compEName :: Name
1811 varEName = libFun (fsLit "varE") varEIdKey
1812 conEName = libFun (fsLit "conE") conEIdKey
1813 litEName = libFun (fsLit "litE") litEIdKey
1814 appEName = libFun (fsLit "appE") appEIdKey
1815 infixEName = libFun (fsLit "infixE") infixEIdKey
1816 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1817 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1818 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1819 lamEName = libFun (fsLit "lamE") lamEIdKey
1820 tupEName = libFun (fsLit "tupE") tupEIdKey
1821 condEName = libFun (fsLit "condE") condEIdKey
1822 letEName = libFun (fsLit "letE") letEIdKey
1823 caseEName = libFun (fsLit "caseE") caseEIdKey
1824 doEName = libFun (fsLit "doE") doEIdKey
1825 compEName = libFun (fsLit "compE") compEIdKey
1826 -- ArithSeq skips a level
1827 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1828 fromEName = libFun (fsLit "fromE") fromEIdKey
1829 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1830 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1831 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1833 listEName, sigEName, recConEName, recUpdEName :: Name
1834 listEName = libFun (fsLit "listE") listEIdKey
1835 sigEName = libFun (fsLit "sigE") sigEIdKey
1836 recConEName = libFun (fsLit "recConE") recConEIdKey
1837 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1839 -- type FieldExp = ...
1840 fieldExpName :: Name
1841 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1844 guardedBName, normalBName :: Name
1845 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1846 normalBName = libFun (fsLit "normalB") normalBIdKey
1849 normalGEName, patGEName :: Name
1850 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1851 patGEName = libFun (fsLit "patGE") patGEIdKey
1854 bindSName, letSName, noBindSName, parSName :: Name
1855 bindSName = libFun (fsLit "bindS") bindSIdKey
1856 letSName = libFun (fsLit "letS") letSIdKey
1857 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1858 parSName = libFun (fsLit "parS") parSIdKey
1861 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1862 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1863 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1864 newtypeInstDName, tySynInstDName :: Name
1865 funDName = libFun (fsLit "funD") funDIdKey
1866 valDName = libFun (fsLit "valD") valDIdKey
1867 dataDName = libFun (fsLit "dataD") dataDIdKey
1868 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1869 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1870 classDName = libFun (fsLit "classD") classDIdKey
1871 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1872 sigDName = libFun (fsLit "sigD") sigDIdKey
1873 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1874 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1875 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1876 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1877 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1878 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1879 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1880 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1881 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1885 cxtName = libFun (fsLit "cxt") cxtIdKey
1888 classPName, equalPName :: Name
1889 classPName = libFun (fsLit "classP") classPIdKey
1890 equalPName = libFun (fsLit "equalP") equalPIdKey
1892 -- data Strict = ...
1893 isStrictName, notStrictName :: Name
1894 isStrictName = libFun (fsLit "isStrict") isStrictKey
1895 notStrictName = libFun (fsLit "notStrict") notStrictKey
1898 normalCName, recCName, infixCName, forallCName :: Name
1899 normalCName = libFun (fsLit "normalC") normalCIdKey
1900 recCName = libFun (fsLit "recC") recCIdKey
1901 infixCName = libFun (fsLit "infixC") infixCIdKey
1902 forallCName = libFun (fsLit "forallC") forallCIdKey
1904 -- type StrictType = ...
1905 strictTypeName :: Name
1906 strictTypeName = libFun (fsLit "strictType") strictTKey
1908 -- type VarStrictType = ...
1909 varStrictTypeName :: Name
1910 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1913 forallTName, varTName, conTName, tupleTName, arrowTName,
1914 listTName, appTName, sigTName :: Name
1915 forallTName = libFun (fsLit "forallT") forallTIdKey
1916 varTName = libFun (fsLit "varT") varTIdKey
1917 conTName = libFun (fsLit "conT") conTIdKey
1918 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1919 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1920 listTName = libFun (fsLit "listT") listTIdKey
1921 appTName = libFun (fsLit "appT") appTIdKey
1922 sigTName = libFun (fsLit "sigT") sigTIdKey
1924 -- data TyVarBndr = ...
1925 plainTVName, kindedTVName :: Name
1926 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1927 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1930 starKName, arrowKName :: Name
1931 starKName = libFun (fsLit "starK") starKIdKey
1932 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1934 -- data Callconv = ...
1935 cCallName, stdCallName :: Name
1936 cCallName = libFun (fsLit "cCall") cCallIdKey
1937 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1939 -- data Safety = ...
1940 unsafeName, safeName, threadsafeName :: Name
1941 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1942 safeName = libFun (fsLit "safe") safeIdKey
1943 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1945 -- data InlineSpec = ...
1946 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1947 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1948 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1950 -- data FunDep = ...
1952 funDepName = libFun (fsLit "funDep") funDepIdKey
1954 -- data FamFlavour = ...
1955 typeFamName, dataFamName :: Name
1956 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1957 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1959 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1960 decQTyConName, conQTyConName, strictTypeQTyConName,
1961 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1962 patQTyConName, fieldPatQTyConName, predQTyConName :: Name
1963 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1964 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1965 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1966 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1967 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1968 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1969 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
1970 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1971 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
1972 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
1973 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
1974 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
1975 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
1978 quoteExpName, quotePatName :: Name
1979 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
1980 quotePatName = qqFun (fsLit "quotePat") quotePatKey
1982 -- TyConUniques available: 100-129
1983 -- Check in PrelNames if you want to change this
1985 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
1986 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
1987 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
1988 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
1989 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
1990 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
1991 predQTyConKey :: Unique
1992 expTyConKey = mkPreludeTyConUnique 100
1993 matchTyConKey = mkPreludeTyConUnique 101
1994 clauseTyConKey = mkPreludeTyConUnique 102
1995 qTyConKey = mkPreludeTyConUnique 103
1996 expQTyConKey = mkPreludeTyConUnique 104
1997 decQTyConKey = mkPreludeTyConUnique 105
1998 patTyConKey = mkPreludeTyConUnique 106
1999 matchQTyConKey = mkPreludeTyConUnique 107
2000 clauseQTyConKey = mkPreludeTyConUnique 108
2001 stmtQTyConKey = mkPreludeTyConUnique 109
2002 conQTyConKey = mkPreludeTyConUnique 110
2003 typeQTyConKey = mkPreludeTyConUnique 111
2004 typeTyConKey = mkPreludeTyConUnique 112
2005 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2006 decTyConKey = mkPreludeTyConUnique 113
2007 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2008 strictTypeQTyConKey = mkPreludeTyConUnique 115
2009 fieldExpTyConKey = mkPreludeTyConUnique 116
2010 fieldPatTyConKey = mkPreludeTyConUnique 117
2011 nameTyConKey = mkPreludeTyConUnique 118
2012 patQTyConKey = mkPreludeTyConUnique 119
2013 fieldPatQTyConKey = mkPreludeTyConUnique 120
2014 fieldExpQTyConKey = mkPreludeTyConUnique 121
2015 funDepTyConKey = mkPreludeTyConUnique 122
2016 predTyConKey = mkPreludeTyConUnique 123
2017 predQTyConKey = mkPreludeTyConUnique 124
2019 -- IdUniques available: 200-399
2020 -- If you want to change this, make sure you check in PrelNames
2022 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2023 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2024 mkNameLIdKey :: Unique
2025 returnQIdKey = mkPreludeMiscIdUnique 200
2026 bindQIdKey = mkPreludeMiscIdUnique 201
2027 sequenceQIdKey = mkPreludeMiscIdUnique 202
2028 liftIdKey = mkPreludeMiscIdUnique 203
2029 newNameIdKey = mkPreludeMiscIdUnique 204
2030 mkNameIdKey = mkPreludeMiscIdUnique 205
2031 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2032 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2033 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2034 mkNameLIdKey = mkPreludeMiscIdUnique 209
2038 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2039 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2040 charLIdKey = mkPreludeMiscIdUnique 210
2041 stringLIdKey = mkPreludeMiscIdUnique 211
2042 integerLIdKey = mkPreludeMiscIdUnique 212
2043 intPrimLIdKey = mkPreludeMiscIdUnique 213
2044 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2045 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2046 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2047 rationalLIdKey = mkPreludeMiscIdUnique 217
2049 liftStringIdKey :: Unique
2050 liftStringIdKey = mkPreludeMiscIdUnique 218
2053 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2054 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2055 litPIdKey = mkPreludeMiscIdUnique 220
2056 varPIdKey = mkPreludeMiscIdUnique 221
2057 tupPIdKey = mkPreludeMiscIdUnique 222
2058 conPIdKey = mkPreludeMiscIdUnique 223
2059 infixPIdKey = mkPreludeMiscIdUnique 312
2060 tildePIdKey = mkPreludeMiscIdUnique 224
2061 bangPIdKey = mkPreludeMiscIdUnique 359
2062 asPIdKey = mkPreludeMiscIdUnique 225
2063 wildPIdKey = mkPreludeMiscIdUnique 226
2064 recPIdKey = mkPreludeMiscIdUnique 227
2065 listPIdKey = mkPreludeMiscIdUnique 228
2066 sigPIdKey = mkPreludeMiscIdUnique 229
2068 -- type FieldPat = ...
2069 fieldPatIdKey :: Unique
2070 fieldPatIdKey = mkPreludeMiscIdUnique 230
2073 matchIdKey :: Unique
2074 matchIdKey = mkPreludeMiscIdUnique 231
2076 -- data Clause = ...
2077 clauseIdKey :: Unique
2078 clauseIdKey = mkPreludeMiscIdUnique 232
2082 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2083 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2084 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2085 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2086 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2087 varEIdKey = mkPreludeMiscIdUnique 240
2088 conEIdKey = mkPreludeMiscIdUnique 241
2089 litEIdKey = mkPreludeMiscIdUnique 242
2090 appEIdKey = mkPreludeMiscIdUnique 243
2091 infixEIdKey = mkPreludeMiscIdUnique 244
2092 infixAppIdKey = mkPreludeMiscIdUnique 245
2093 sectionLIdKey = mkPreludeMiscIdUnique 246
2094 sectionRIdKey = mkPreludeMiscIdUnique 247
2095 lamEIdKey = mkPreludeMiscIdUnique 248
2096 tupEIdKey = mkPreludeMiscIdUnique 249
2097 condEIdKey = mkPreludeMiscIdUnique 250
2098 letEIdKey = mkPreludeMiscIdUnique 251
2099 caseEIdKey = mkPreludeMiscIdUnique 252
2100 doEIdKey = mkPreludeMiscIdUnique 253
2101 compEIdKey = mkPreludeMiscIdUnique 254
2102 fromEIdKey = mkPreludeMiscIdUnique 255
2103 fromThenEIdKey = mkPreludeMiscIdUnique 256
2104 fromToEIdKey = mkPreludeMiscIdUnique 257
2105 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2106 listEIdKey = mkPreludeMiscIdUnique 259
2107 sigEIdKey = mkPreludeMiscIdUnique 260
2108 recConEIdKey = mkPreludeMiscIdUnique 261
2109 recUpdEIdKey = mkPreludeMiscIdUnique 262
2111 -- type FieldExp = ...
2112 fieldExpIdKey :: Unique
2113 fieldExpIdKey = mkPreludeMiscIdUnique 265
2116 guardedBIdKey, normalBIdKey :: Unique
2117 guardedBIdKey = mkPreludeMiscIdUnique 266
2118 normalBIdKey = mkPreludeMiscIdUnique 267
2121 normalGEIdKey, patGEIdKey :: Unique
2122 normalGEIdKey = mkPreludeMiscIdUnique 310
2123 patGEIdKey = mkPreludeMiscIdUnique 311
2126 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2127 bindSIdKey = mkPreludeMiscIdUnique 268
2128 letSIdKey = mkPreludeMiscIdUnique 269
2129 noBindSIdKey = mkPreludeMiscIdUnique 270
2130 parSIdKey = mkPreludeMiscIdUnique 271
2133 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2134 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2135 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2136 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2137 funDIdKey = mkPreludeMiscIdUnique 272
2138 valDIdKey = mkPreludeMiscIdUnique 273
2139 dataDIdKey = mkPreludeMiscIdUnique 274
2140 newtypeDIdKey = mkPreludeMiscIdUnique 275
2141 tySynDIdKey = mkPreludeMiscIdUnique 276
2142 classDIdKey = mkPreludeMiscIdUnique 277
2143 instanceDIdKey = mkPreludeMiscIdUnique 278
2144 sigDIdKey = mkPreludeMiscIdUnique 279
2145 forImpDIdKey = mkPreludeMiscIdUnique 297
2146 pragInlDIdKey = mkPreludeMiscIdUnique 348
2147 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2148 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2149 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2150 familyKindDIdKey = mkPreludeMiscIdUnique 353
2151 dataInstDIdKey = mkPreludeMiscIdUnique 341
2152 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2153 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2157 cxtIdKey = mkPreludeMiscIdUnique 280
2160 classPIdKey, equalPIdKey :: Unique
2161 classPIdKey = mkPreludeMiscIdUnique 346
2162 equalPIdKey = mkPreludeMiscIdUnique 347
2164 -- data Strict = ...
2165 isStrictKey, notStrictKey :: Unique
2166 isStrictKey = mkPreludeMiscIdUnique 281
2167 notStrictKey = mkPreludeMiscIdUnique 282
2170 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2171 normalCIdKey = mkPreludeMiscIdUnique 283
2172 recCIdKey = mkPreludeMiscIdUnique 284
2173 infixCIdKey = mkPreludeMiscIdUnique 285
2174 forallCIdKey = mkPreludeMiscIdUnique 288
2176 -- type StrictType = ...
2177 strictTKey :: Unique
2178 strictTKey = mkPreludeMiscIdUnique 286
2180 -- type VarStrictType = ...
2181 varStrictTKey :: Unique
2182 varStrictTKey = mkPreludeMiscIdUnique 287
2185 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2186 listTIdKey, appTIdKey, sigTIdKey :: Unique
2187 forallTIdKey = mkPreludeMiscIdUnique 290
2188 varTIdKey = mkPreludeMiscIdUnique 291
2189 conTIdKey = mkPreludeMiscIdUnique 292
2190 tupleTIdKey = mkPreludeMiscIdUnique 294
2191 arrowTIdKey = mkPreludeMiscIdUnique 295
2192 listTIdKey = mkPreludeMiscIdUnique 296
2193 appTIdKey = mkPreludeMiscIdUnique 293
2194 sigTIdKey = mkPreludeMiscIdUnique 358
2196 -- data TyVarBndr = ...
2197 plainTVIdKey, kindedTVIdKey :: Unique
2198 plainTVIdKey = mkPreludeMiscIdUnique 354
2199 kindedTVIdKey = mkPreludeMiscIdUnique 355
2202 starKIdKey, arrowKIdKey :: Unique
2203 starKIdKey = mkPreludeMiscIdUnique 356
2204 arrowKIdKey = mkPreludeMiscIdUnique 357
2206 -- data Callconv = ...
2207 cCallIdKey, stdCallIdKey :: Unique
2208 cCallIdKey = mkPreludeMiscIdUnique 300
2209 stdCallIdKey = mkPreludeMiscIdUnique 301
2211 -- data Safety = ...
2212 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2213 unsafeIdKey = mkPreludeMiscIdUnique 305
2214 safeIdKey = mkPreludeMiscIdUnique 306
2215 threadsafeIdKey = mkPreludeMiscIdUnique 307
2217 -- data InlineSpec =
2218 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2219 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2220 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2222 -- data FunDep = ...
2223 funDepIdKey :: Unique
2224 funDepIdKey = mkPreludeMiscIdUnique 320
2226 -- data FamFlavour = ...
2227 typeFamIdKey, dataFamIdKey :: Unique
2228 typeFamIdKey = mkPreludeMiscIdUnique 344
2229 dataFamIdKey = mkPreludeMiscIdUnique 345
2232 quoteExpKey, quotePatKey :: Unique
2233 quoteExpKey = mkPreludeMiscIdUnique 321
2234 quotePatKey = mkPreludeMiscIdUnique 322