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,
19 decQTyConName, decsQTyConName, typeQTyConName,
20 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
21 quoteExpName, quotePatName, quoteDecName, quoteTypeName
24 #include "HsVersions.h"
26 import {-# SOURCE #-} DsExpr ( dsExpr )
31 import qualified Language.Haskell.TH as TH
36 -- To avoid clashes with DsMeta.varName we must make a local alias for
37 -- OccName.varName we do this by removing varName from the import of
38 -- OccName above, making a qualified instance of OccName and using
39 -- OccNameAlias.varName where varName ws previously used in this file.
40 import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
44 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
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 <- repTopP p ; return p1 }
79 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
80 do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
81 do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
83 {- -------------- Examples --------------------
87 gensym (unpackString "x"#) `bindQ` \ x1::String ->
88 lam (pvar x1) (var x1)
91 [| \x -> $(f [| x |]) |]
93 gensym (unpackString "x"#) `bindQ` \ x1::String ->
94 lam (pvar x1) (f (var x1))
98 -------------------------------------------------------
100 -------------------------------------------------------
102 repTopP :: LPat Name -> DsM (Core TH.PatQ)
103 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
104 ; pat' <- addBinds ss (repLP pat)
105 ; wrapNongenSyms ss pat' }
107 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
109 = do { let { bndrs = hsGroupBinders group } ;
110 ss <- mkGenSyms bndrs ;
112 -- Bind all the names mainly to avoid repeated use of explicit strings.
114 -- do { t :: String <- genSym "T" ;
115 -- return (Data t [] ...more t's... }
116 -- The other important reason is that the output must mention
117 -- only "T", not "Foo:T" where Foo is the current module
120 decls <- addBinds ss (do {
121 val_ds <- rep_val_binds (hs_valds group) ;
122 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
123 inst_ds <- mapM repInstD' (hs_instds group) ;
124 for_ds <- mapM repForD (hs_fords group) ;
126 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
128 decl_ty <- lookupType decQTyConName ;
129 let { core_list = coreList' decl_ty decls } ;
131 dec_ty <- lookupType decTyConName ;
132 q_decs <- repSequenceQ dec_ty core_list ;
134 wrapNongenSyms ss q_decs
135 -- Do *not* gensym top-level binders
139 {- Note [Binders and occurrences]
140 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
141 When we desugar [d| data T = MkT |]
143 Data "T" [] [Con "MkT" []] []
145 Data "Foo:T" [] [Con "Foo:MkT" []] []
146 That is, the new data decl should fit into whatever new module it is
147 asked to fit in. We do *not* clone, though; no need for this:
154 then we must desugar to
155 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
157 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
158 And we use lookupOcc, rather than lookupBinder
159 in repTyClD and repC.
163 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
165 repTyClD tydecl@(L _ (TyFamily {}))
166 = repTyFamily tydecl addTyVarBinds
168 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
169 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
170 tcdCons = cons, tcdDerivs = mb_derivs }))
171 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
172 ; dec <- addTyVarBinds tvs $ \bndrs ->
173 do { cxt1 <- repLContext cxt
174 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
175 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
176 ; cons1 <- mapM repC cons
177 ; cons2 <- coreList conQTyConName cons1
178 ; derivs1 <- repDerivs mb_derivs
179 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
180 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
182 ; return $ Just (loc, dec)
185 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
186 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
187 tcdCons = [con], tcdDerivs = mb_derivs }))
188 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
189 ; dec <- addTyVarBinds tvs $ \bndrs ->
190 do { cxt1 <- repLContext cxt
191 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
192 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
194 ; derivs1 <- repDerivs mb_derivs
195 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
196 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
198 ; return $ Just (loc, dec)
201 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
203 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
204 ; dec <- addTyVarBinds tvs $ \bndrs ->
205 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
206 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
208 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
209 ; repTySyn tc1 bndrs1 opt_tys2 ty1
211 ; return (Just (loc, dec))
214 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
215 tcdTyVars = tvs, tcdFDs = fds,
216 tcdSigs = sigs, tcdMeths = meth_binds,
218 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
219 ; dec <- addTyVarBinds tvs $ \bndrs ->
220 do { cxt1 <- repLContext cxt
221 ; sigs1 <- rep_sigs sigs
222 ; binds1 <- rep_binds meth_binds
223 ; fds1 <- repLFunDeps fds
224 ; ats1 <- repLAssocFamilys ats
225 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
226 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
227 ; repClass cxt1 cls1 bndrs1 fds1 decls1
229 ; return $ Just (loc, dec)
233 repTyClD (L loc d) = putSrcSpanDs loc $
234 do { warnDs (hang ds_msg 4 (ppr d))
237 -- The type variables in the head of families are treated differently when the
238 -- family declaration is associated. In that case, they are usage, not binding
241 repTyFamily :: LTyClDecl Name
242 -> ProcessTyVarBinds TH.Dec
243 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
244 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
245 tcdLName = tc, tcdTyVars = tvs,
246 tcdKind = opt_kind }))
248 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
249 ; dec <- tyVarBinds tvs $ \bndrs ->
250 do { flav <- repFamilyFlavour flavour
251 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
253 Nothing -> repFamilyNoKind flav tc1 bndrs1
254 Just ki -> do { ki1 <- repKind ki
255 ; repFamilyKind flav tc1 bndrs1 ki1
258 ; return $ Just (loc, dec)
260 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
264 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
265 repLFunDeps fds = do fds' <- mapM repLFunDep fds
266 fdList <- coreList funDepTyConName fds'
269 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
270 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
271 ys' <- mapM lookupBinder ys
272 xs_list <- coreList nameTyConName xs'
273 ys_list <- coreList nameTyConName ys'
274 repFunDep xs_list ys_list
276 -- represent family declaration flavours
278 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
279 repFamilyFlavour TypeFamily = rep2 typeFamName []
280 repFamilyFlavour DataFamily = rep2 dataFamName []
282 -- represent associated family declarations
284 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
285 repLAssocFamilys = mapM repLAssocFamily
287 repLAssocFamily tydecl@(L _ (TyFamily {}))
288 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
289 repLAssocFamily tydecl
292 msg = ptext (sLit "Illegal associated declaration in class:") <+>
295 -- represent associated family instances
297 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
298 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
300 -- represent instance declarations
302 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
303 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
304 = do { i <- addTyVarBinds tvs $ \_ ->
305 -- We must bring the type variables into scope, so their
306 -- occurrences don't fail, even though the binders don't
307 -- appear in the resulting data structure
308 do { cxt1 <- repContext cxt
309 ; inst_ty1 <- repPredTy (HsClassP cls tys)
310 ; ss <- mkGenSyms (collectHsBindsBinders binds)
311 ; binds1 <- addBinds ss (rep_binds binds)
312 ; ats1 <- repLAssocFamInst ats
313 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
314 ; decls2 <- wrapNongenSyms ss decls1
315 -- wrapNongenSyms: do not clone the class op names!
316 -- They must be called 'op' etc, not 'op34'
317 ; repInst cxt1 inst_ty1 (decls2)
321 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
323 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
324 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
325 = do MkC name' <- lookupLOcc name
326 MkC typ' <- repLTy typ
327 MkC cc' <- repCCallConv cc
328 MkC s' <- repSafety s
329 cis' <- conv_cimportspec cis
330 MkC str <- coreStringLit $ static
331 ++ unpackFS ch ++ " "
333 dec <- rep2 forImpDName [cc', s', str, name', typ']
336 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
337 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
338 conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
339 conv_cimportspec CWrapper = return "wrapper"
341 CFunction (StaticTarget _ _) -> "static "
343 repForD decl = notHandled "Foreign declaration" (ppr decl)
345 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
346 repCCallConv CCallConv = rep2 cCallName []
347 repCCallConv StdCallConv = rep2 stdCallName []
348 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
350 repSafety :: Safety -> DsM (Core TH.Safety)
351 repSafety PlayRisky = rep2 unsafeName []
352 repSafety (PlaySafe False) = rep2 safeName []
353 repSafety (PlaySafe True) = rep2 threadsafeName []
356 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
358 -------------------------------------------------------
360 -------------------------------------------------------
362 repC :: LConDecl Name -> DsM (Core TH.ConQ)
363 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
364 , con_details = details, con_res = ResTyH98 }))
365 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
366 ; repConstr con1 details
368 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
369 = addTyVarBinds tvs $ \bndrs ->
370 do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
371 ; ctxt' <- repContext ctxt
372 ; bndrs' <- coreList tyVarBndrTyConName bndrs
373 ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
375 repC (L loc con_decl) -- GADTs
377 notHandled "GADT declaration" (ppr con_decl)
379 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
383 rep2 strictTypeName [s, t]
385 (str, ty') = case ty of
386 L _ (HsBangTy _ ty) -> (isStrictName, ty)
387 _ -> (notStrictName, ty)
389 -------------------------------------------------------
391 -------------------------------------------------------
393 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
394 repDerivs Nothing = coreList nameTyConName []
395 repDerivs (Just ctxt)
396 = do { strs <- mapM rep_deriv ctxt ;
397 coreList nameTyConName strs }
399 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
400 -- Deriving clauses must have the simple H98 form
401 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
402 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
405 -------------------------------------------------------
406 -- Signatures in a class decl, or a group of bindings
407 -------------------------------------------------------
409 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
410 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
411 return $ de_loc $ sort_by_loc locs_cores
413 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
414 -- We silently ignore ones we don't recognise
415 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
416 return (concat sigs1) }
418 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
420 -- Empty => Too hard, signature ignored
421 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
422 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
423 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
424 rep_sig _ = return []
426 rep_proto :: Located Name -> LHsType Name -> SrcSpan
427 -> DsM [(SrcSpan, Core TH.DecQ)]
429 = do { nm1 <- lookupLOcc nm
431 ; sig <- repProto nm1 ty1
432 ; return [(loc, sig)]
435 rep_inline :: Located Name
436 -> InlinePragma -- Never defaultInlinePragma
438 -> DsM [(SrcSpan, Core TH.DecQ)]
439 rep_inline nm ispec loc
440 = do { nm1 <- lookupLOcc nm
441 ; ispec1 <- rep_InlinePrag ispec
442 ; pragma <- repPragInl nm1 ispec1
443 ; return [(loc, pragma)]
446 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
447 -> DsM [(SrcSpan, Core TH.DecQ)]
448 rep_specialise nm ty ispec loc
449 = do { nm1 <- lookupLOcc nm
451 ; pragma <- if isDefaultInlinePragma ispec
452 then repPragSpec nm1 ty1 -- SPECIALISE
453 else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
454 ; repPragSpecInl nm1 ty1 ispec1 }
455 ; return [(loc, pragma)]
458 -- Extract all the information needed to build a TH.InlinePrag
460 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
461 -> DsM (Core TH.InlineSpecQ)
462 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
463 | Nothing <- activation1
464 = repInlineSpecNoPhase inline1 match1
465 | Just (flag, phase) <- activation1
466 = 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 -- We never have NOINLINE/AlwaysActive
477 rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
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 wrapGenSyms 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 {})) nm
531 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
532 = repKind ki >>= repKindedTV nm
534 -- represent a type context
536 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
537 repLContext (L _ ctxt) = repContext ctxt
539 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
541 preds <- mapM repLPred ctxt
542 predList <- coreList predQTyConName preds
545 -- represent a type predicate
547 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
548 repLPred (L _ p) = repPred p
550 repPred :: HsPred Name -> DsM (Core TH.PredQ)
551 repPred (HsClassP cls tys)
553 cls1 <- lookupOcc cls
555 tys2 <- coreList typeQTyConName tys1
557 repPred (HsEqualP tyleft tyright)
559 tyleft1 <- repLTy tyleft
560 tyright1 <- repLTy tyright
561 repEqualP tyleft1 tyright1
562 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
564 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
565 repPredTy (HsClassP cls tys)
567 tcon <- repTy (HsTyVar cls)
570 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
572 -- yield the representation of a list of types
574 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
575 repLTys tys = mapM repLTy tys
579 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
580 repLTy (L _ ty) = repTy ty
582 repTy :: HsType Name -> DsM (Core TH.TypeQ)
583 repTy (HsForAllTy _ tvs ctxt ty) =
584 addTyVarBinds tvs $ \bndrs -> do
585 ctxt1 <- repLContext ctxt
587 bndrs1 <- coreList tyVarBndrTyConName bndrs
588 repTForall bndrs1 ctxt1 ty1
591 | isTvOcc (nameOccName n) = do
597 repTy (HsAppTy f a) = do
601 repTy (HsFunTy f a) = do
604 tcon <- repArrowTyCon
605 repTapps tcon [f1, a1]
606 repTy (HsListTy t) = do
610 repTy (HsPArrTy t) = do
612 tcon <- repTy (HsTyVar (tyConName parrTyCon))
614 repTy (HsTupleTy _ tys) = do
616 tcon <- repTupleTyCon (length tys)
618 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
620 repTy (HsParTy t) = repLTy t
621 repTy (HsPredTy pred) = repPredTy pred
622 repTy (HsKindSig t k) = do
626 repTy (HsSpliceTy splice _ _) = repSplice splice
627 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
628 repTy ty = notHandled "Exotic form of type" (ppr ty)
632 repKind :: Kind -> DsM (Core TH.Kind)
634 = do { let (kis, ki') = splitKindFunTys ki
635 ; kis_rep <- mapM repKind kis
636 ; ki'_rep <- repNonArrowKind ki'
637 ; foldrM repArrowK ki'_rep kis_rep
640 repNonArrowKind k | isLiftedTypeKind k = repStarK
641 | otherwise = notHandled "Exotic form of kind"
644 -----------------------------------------------------------------------------
646 -----------------------------------------------------------------------------
648 repSplice :: HsSplice Name -> DsM (Core a)
649 -- See Note [How brackets and nested splices are handled] in TcSplice
650 -- We return a CoreExpr of any old type; the context should know
651 repSplice (HsSplice n _)
652 = do { mb_val <- dsLookupMetaEnv n
654 Just (Splice e) -> do { e' <- dsExpr e
656 _ -> pprPanic "HsSplice" (ppr n) }
657 -- Should not happen; statically checked
659 -----------------------------------------------------------------------------
661 -----------------------------------------------------------------------------
663 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
664 repLEs es = do { es' <- mapM repLE es ;
665 coreList expQTyConName es' }
667 -- FIXME: some of these panics should be converted into proper error messages
668 -- unless we can make sure that constructs, which are plainly not
669 -- supported in TH already lead to error messages at an earlier stage
670 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
671 repLE (L loc e) = putSrcSpanDs loc (repE e)
673 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
675 do { mb_val <- dsLookupMetaEnv x
677 Nothing -> do { str <- globalVar x
678 ; repVarOrCon x str }
679 Just (Bound y) -> repVarOrCon x (coreVar y)
680 Just (Splice e) -> do { e' <- dsExpr e
681 ; return (MkC e') } }
682 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
684 -- Remember, we're desugaring renamer output here, so
685 -- HsOverlit can definitely occur
686 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
687 repE (HsLit l) = do { a <- repLiteral l; repLit a }
688 repE (HsLam (MatchGroup [m] _)) = repLambda m
689 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
691 repE (OpApp e1 op _ e2) =
692 do { arg1 <- repLE e1;
695 repInfixApp arg1 the_op arg2 }
696 repE (NegApp x _) = do
698 negateVar <- lookupOcc negateName >>= repVar
700 repE (HsPar x) = repLE x
701 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
702 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
703 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
704 ; ms2 <- mapM repMatchTup ms
705 ; repCaseE arg (nonEmptyCoreList ms2) }
706 repE (HsIf x y z) = do
711 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
712 ; e2 <- addBinds ss (repLE e)
716 -- FIXME: I haven't got the types here right yet
717 repE e@(HsDo ctxt sts body _)
718 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
719 = do { (ss,zs) <- repLSts sts;
720 body' <- addBinds ss $ repLE body;
721 ret <- repNoBindSt body';
722 e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
726 = do { (ss,zs) <- repLSts sts;
727 body' <- addBinds ss $ repLE body;
728 ret <- repNoBindSt body';
729 e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
733 = notHandled "mdo and [: :]" (ppr e)
735 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
736 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
737 repE e@(ExplicitTuple es boxed)
738 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
739 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
740 | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
742 repE (RecordCon c _ flds)
743 = do { x <- lookupLOcc c;
744 fs <- repFields flds;
746 repE (RecordUpd e flds _ _ _)
748 fs <- repFields flds;
751 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
752 repE (ArithSeq _ aseq) =
754 From e -> do { ds1 <- repLE e; repFrom ds1 }
763 FromThenTo e1 e2 e3 -> do
767 repFromThenTo ds1 ds2 ds3
769 repE (HsSpliceE splice) = repSplice splice
770 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
771 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
772 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
773 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
774 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
775 repE e = notHandled "Expression form" (ppr e)
777 -----------------------------------------------------------------------------
778 -- Building representations of auxillary structures like Match, Clause, Stmt,
780 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
781 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
782 do { ss1 <- mkGenSyms (collectPatBinders p)
783 ; addBinds ss1 $ do {
785 ; (ss2,ds) <- repBinds wheres
786 ; addBinds ss2 $ do {
787 ; gs <- repGuards guards
788 ; match <- repMatch p1 gs ds
789 ; wrapGenSyms (ss1++ss2) match }}}
790 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
792 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
793 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
794 do { ss1 <- mkGenSyms (collectPatsBinders ps)
795 ; addBinds ss1 $ do {
797 ; (ss2,ds) <- repBinds wheres
798 ; addBinds ss2 $ do {
799 gs <- repGuards guards
800 ; clause <- repClause ps1 gs ds
801 ; wrapGenSyms (ss1++ss2) clause }}}
803 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
804 repGuards [L _ (GRHS [] e)]
805 = do {a <- repLE e; repNormal a }
807 = do { zs <- mapM process other;
808 let {(xs, ys) = unzip zs};
809 gd <- repGuarded (nonEmptyCoreList ys);
810 wrapGenSyms (concat xs) gd }
812 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
813 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
814 = do { x <- repLNormalGE e1 e2;
816 process (L _ (GRHS ss rhs))
817 = do (gs, ss') <- repLSts ss
818 rhs' <- addBinds gs $ repLE rhs
819 g <- repPatGE (nonEmptyCoreList ss') rhs'
822 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
823 repFields (HsRecFields { rec_flds = flds })
824 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
825 ; es <- mapM repLE (map hsRecFieldArg flds)
826 ; fs <- zipWithM repFieldExp fnames es
827 ; coreList fieldExpQTyConName fs }
830 -----------------------------------------------------------------------------
831 -- Representing Stmt's is tricky, especially if bound variables
832 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
833 -- First gensym new names for every variable in any of the patterns.
834 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
835 -- if variables didn't shaddow, the static gensym wouldn't be necessary
836 -- and we could reuse the original names (x and x).
838 -- do { x'1 <- gensym "x"
839 -- ; x'2 <- gensym "x"
840 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
841 -- , BindSt (pvar x'2) [| f x |]
842 -- , NoBindSt [| g x |]
846 -- The strategy is to translate a whole list of do-bindings by building a
847 -- bigger environment, and a bigger set of meta bindings
848 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
849 -- of the expressions within the Do
851 -----------------------------------------------------------------------------
852 -- The helper function repSts computes the translation of each sub expression
853 -- and a bunch of prefix bindings denoting the dynamic renaming.
855 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
856 repLSts stmts = repSts (map unLoc stmts)
858 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
859 repSts (BindStmt p e _ _ : ss) =
861 ; ss1 <- mkGenSyms (collectPatBinders p)
862 ; addBinds ss1 $ do {
864 ; (ss2,zs) <- repSts ss
865 ; z <- repBindSt p1 e2
866 ; return (ss1++ss2, z : zs) }}
867 repSts (LetStmt bs : ss) =
868 do { (ss1,ds) <- repBinds bs
870 ; (ss2,zs) <- addBinds ss1 (repSts ss)
871 ; return (ss1++ss2, z : zs) }
872 repSts (ExprStmt e _ _ : ss) =
874 ; z <- repNoBindSt e2
875 ; (ss2,zs) <- repSts ss
876 ; return (ss2, z : zs) }
877 repSts [] = return ([],[])
878 repSts other = notHandled "Exotic statement" (ppr other)
881 -----------------------------------------------------------
883 -----------------------------------------------------------
885 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
886 repBinds EmptyLocalBinds
887 = do { core_list <- coreList decQTyConName []
888 ; return ([], core_list) }
890 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
892 repBinds (HsValBinds decs)
893 = do { let { bndrs = collectHsValBinders decs }
894 -- No need to worrry about detailed scopes within
895 -- the binding group, because we are talking Names
896 -- here, so we can safely treat it as a mutually
898 ; ss <- mkGenSyms bndrs
899 ; prs <- addBinds ss (rep_val_binds decs)
900 ; core_list <- coreList decQTyConName
901 (de_loc (sort_by_loc prs))
902 ; return (ss, core_list) }
904 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
905 -- Assumes: all the binders of the binding are alrady in the meta-env
906 rep_val_binds (ValBindsOut binds sigs)
907 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
908 ; core2 <- rep_sigs' sigs
909 ; return (core1 ++ core2) }
910 rep_val_binds (ValBindsIn _ _)
911 = panic "rep_val_binds: ValBindsIn"
913 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
914 rep_binds binds = do { binds_w_locs <- rep_binds' binds
915 ; return (de_loc (sort_by_loc binds_w_locs)) }
917 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
918 rep_binds' binds = mapM rep_bind (bagToList binds)
920 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
921 -- Assumes: all the binders of the binding are alrady in the meta-env
923 -- Note GHC treats declarations of a variable (not a pattern)
924 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
925 -- with an empty list of patterns
926 rep_bind (L loc (FunBind { fun_id = fn,
927 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
928 = do { (ss,wherecore) <- repBinds wheres
929 ; guardcore <- addBinds ss (repGuards guards)
930 ; fn' <- lookupLBinder fn
932 ; ans <- repVal p guardcore wherecore
933 ; ans' <- wrapGenSyms ss ans
934 ; return (loc, ans') }
936 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
937 = do { ms1 <- mapM repClauseTup ms
938 ; fn' <- lookupLBinder fn
939 ; ans <- repFun fn' (nonEmptyCoreList ms1)
940 ; return (loc, ans) }
942 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
943 = do { patcore <- repLP pat
944 ; (ss,wherecore) <- repBinds wheres
945 ; guardcore <- addBinds ss (repGuards guards)
946 ; ans <- repVal patcore guardcore wherecore
947 ; ans' <- wrapGenSyms ss ans
948 ; return (loc, ans') }
950 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
951 = do { v' <- lookupBinder v
954 ; patcore <- repPvar v'
955 ; empty_decls <- coreList decQTyConName []
956 ; ans <- repVal patcore x empty_decls
957 ; return (srcLocSpan (getSrcLoc v), ans) }
959 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
961 -----------------------------------------------------------------------------
962 -- Since everything in a Bind is mutually recursive we need rename all
963 -- all the variables simultaneously. For example:
964 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
965 -- do { f'1 <- gensym "f"
966 -- ; g'2 <- gensym "g"
967 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
968 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
970 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
971 -- environment ( f |-> f'1 ) from each binding, and then unioning them
972 -- together. As we do this we collect GenSymBinds's which represent the renamed
973 -- variables bound by the Bindings. In order not to lose track of these
974 -- representations we build a shadow datatype MB with the same structure as
975 -- MonoBinds, but which has slots for the representations
978 -----------------------------------------------------------------------------
979 -- GHC allows a more general form of lambda abstraction than specified
980 -- by Haskell 98. In particular it allows guarded lambda's like :
981 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
982 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
983 -- (\ p1 .. pn -> exp) by causing an error.
985 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
986 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
987 = do { let bndrs = collectPatsBinders ps ;
988 ; ss <- mkGenSyms bndrs
989 ; lam <- addBinds ss (
990 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
991 ; wrapGenSyms ss lam }
993 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
996 -----------------------------------------------------------------------------
998 -- repP deals with patterns. It assumes that we have already
999 -- walked over the pattern(s) once to collect the binders, and
1000 -- have extended the environment. So every pattern-bound
1001 -- variable should already appear in the environment.
1003 -- Process a list of patterns
1004 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1005 repLPs ps = do { ps' <- mapM repLP ps ;
1006 coreList patQTyConName ps' }
1008 repLP :: LPat Name -> DsM (Core TH.PatQ)
1009 repLP (L _ p) = repP p
1011 repP :: Pat Name -> DsM (Core TH.PatQ)
1012 repP (WildPat _) = repPwild
1013 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1014 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1015 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1016 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1017 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1018 repP (ParPat p) = repLP p
1019 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1020 repP p@(TuplePat ps boxed _)
1021 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
1022 | otherwise = do { qs <- repLPs ps; repPtup qs }
1023 repP (ConPatIn dc details)
1024 = do { con_str <- lookupLOcc dc
1026 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1027 RecCon rec -> do { let flds = rec_flds rec
1028 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1029 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1030 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1031 ; fps' <- coreList fieldPatQTyConName fps
1032 ; repPrec con_str fps' }
1033 InfixCon p1 p2 -> do { p1' <- repLP p1;
1035 repPinfix p1' con_str p2' }
1037 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1038 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1039 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1040 -- The problem is to do with scoped type variables.
1041 -- To implement them, we have to implement the scoping rules
1042 -- here in DsMeta, and I don't want to do that today!
1043 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1044 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1045 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1047 repP other = notHandled "Exotic pattern" (ppr other)
1049 ----------------------------------------------------------
1050 -- Declaration ordering helpers
1052 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1053 sort_by_loc xs = sortBy comp xs
1054 where comp x y = compare (fst x) (fst y)
1056 de_loc :: [(a, b)] -> [b]
1059 ----------------------------------------------------------
1060 -- The meta-environment
1062 -- A name/identifier association for fresh names of locally bound entities
1063 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1064 -- I.e. (x, x_id) means
1065 -- let x_id = gensym "x" in ...
1067 -- Generate a fresh name for a locally bound entity
1069 mkGenSyms :: [Name] -> DsM [GenSymBind]
1070 -- We can use the existing name. For example:
1071 -- [| \x_77 -> x_77 + x_77 |]
1073 -- do { x_77 <- genSym "x"; .... }
1074 -- We use the same x_77 in the desugared program, but with the type Bndr
1077 -- We do make it an Internal name, though (hence localiseName)
1079 -- Nevertheless, it's monadic because we have to generate nameTy
1080 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1081 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1084 addBinds :: [GenSymBind] -> DsM a -> DsM a
1085 -- Add a list of fresh names for locally bound entities to the
1086 -- meta environment (which is part of the state carried around
1087 -- by the desugarer monad)
1088 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1090 -- Look up a locally bound name
1092 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1093 lookupLBinder (L _ n) = lookupBinder n
1095 lookupBinder :: Name -> DsM (Core TH.Name)
1097 = do { mb_val <- dsLookupMetaEnv n;
1099 Just (Bound x) -> return (coreVar x)
1100 _ -> failWithDs msg }
1102 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1104 -- Look up a name that is either locally bound or a global name
1106 -- * If it is a global name, generate the "original name" representation (ie,
1107 -- the <module>:<name> form) for the associated entity
1109 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1110 -- Lookup an occurrence; it can't be a splice.
1111 -- Use the in-scope bindings if they exist
1112 lookupLOcc (L _ n) = lookupOcc n
1114 lookupOcc :: Name -> DsM (Core TH.Name)
1116 = do { mb_val <- dsLookupMetaEnv n ;
1118 Nothing -> globalVar n
1119 Just (Bound x) -> return (coreVar x)
1120 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1123 lookupTvOcc :: Name -> DsM (Core TH.Name)
1124 -- Type variables can't be staged and are not lexically scoped in TH
1126 = do { mb_val <- dsLookupMetaEnv n ;
1128 Just (Bound x) -> return (coreVar x)
1132 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1133 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1135 globalVar :: Name -> DsM (Core TH.Name)
1136 -- Not bound by the meta-env
1137 -- Could be top-level; or could be local
1138 -- f x = $(g [| x |])
1139 -- Here the x will be local
1141 | isExternalName name
1142 = do { MkC mod <- coreStringLit name_mod
1143 ; MkC pkg <- coreStringLit name_pkg
1144 ; MkC occ <- occNameLit name
1145 ; rep2 mk_varg [pkg,mod,occ] }
1147 = do { MkC occ <- occNameLit name
1148 ; MkC uni <- coreIntLit (getKey (getUnique name))
1149 ; rep2 mkNameLName [occ,uni] }
1151 mod = ASSERT( isExternalName name) nameModule name
1152 name_mod = moduleNameString (moduleName mod)
1153 name_pkg = packageIdString (modulePackageId mod)
1154 name_occ = nameOccName name
1155 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1156 | OccName.isVarOcc name_occ = mkNameG_vName
1157 | OccName.isTcOcc name_occ = mkNameG_tcName
1158 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1160 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1161 -> DsM Type -- The type
1162 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1163 return (mkTyConApp tc []) }
1165 wrapGenSyms :: [GenSymBind]
1166 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1167 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1168 -- --> bindQ (gensym nm1) (\ id1 ->
1169 -- bindQ (gensym nm2 (\ id2 ->
1172 wrapGenSyms binds body@(MkC b)
1173 = do { var_ty <- lookupType nameTyConName
1176 [elt_ty] = tcTyConAppArgs (exprType b)
1177 -- b :: Q a, so we can get the type 'a' by looking at the
1178 -- argument type. NB: this relies on Q being a data/newtype,
1179 -- not a type synonym
1181 go _ [] = return body
1182 go var_ty ((name,id) : binds)
1183 = do { MkC body' <- go var_ty binds
1184 ; lit_str <- occNameLit name
1185 ; gensym_app <- repGensym lit_str
1186 ; repBindQ var_ty elt_ty
1187 gensym_app (MkC (Lam id body')) }
1189 -- Just like wrapGenSym, but don't actually do the gensym
1190 -- Instead use the existing name:
1191 -- let x = "x" in ...
1192 -- Only used for [Decl], and for the class ops in class
1193 -- and instance decls
1194 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1195 wrapNongenSyms binds (MkC body)
1196 = do { binds' <- mapM do_one binds ;
1197 return (MkC (mkLets binds' body)) }
1200 = do { MkC lit_str <- occNameLit name
1201 ; MkC var <- rep2 mkNameName [lit_str]
1202 ; return (NonRec id var) }
1204 occNameLit :: Name -> DsM (Core String)
1205 occNameLit n = coreStringLit (occNameString (nameOccName n))
1208 -- %*********************************************************************
1210 -- Constructing code
1212 -- %*********************************************************************
1214 -----------------------------------------------------------------------------
1215 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1216 -- we invent a new datatype which uses phantom types.
1218 newtype Core a = MkC CoreExpr
1219 unC :: Core a -> CoreExpr
1222 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1223 rep2 n xs = do { id <- dsLookupGlobalId n
1224 ; return (MkC (foldl App (Var id) xs)) }
1226 -- Then we make "repConstructors" which use the phantom types for each of the
1227 -- smart constructors of the Meta.Meta datatypes.
1230 -- %*********************************************************************
1232 -- The 'smart constructors'
1234 -- %*********************************************************************
1236 --------------- Patterns -----------------
1237 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1238 repPlit (MkC l) = rep2 litPName [l]
1240 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1241 repPvar (MkC s) = rep2 varPName [s]
1243 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1244 repPtup (MkC ps) = rep2 tupPName [ps]
1246 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1247 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1249 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1250 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1252 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1253 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1255 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1256 repPtilde (MkC p) = rep2 tildePName [p]
1258 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1259 repPbang (MkC p) = rep2 bangPName [p]
1261 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1262 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1264 repPwild :: DsM (Core TH.PatQ)
1265 repPwild = rep2 wildPName []
1267 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1268 repPlist (MkC ps) = rep2 listPName [ps]
1270 --------------- Expressions -----------------
1271 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1272 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1273 | otherwise = repVar str
1275 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1276 repVar (MkC s) = rep2 varEName [s]
1278 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1279 repCon (MkC s) = rep2 conEName [s]
1281 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1282 repLit (MkC c) = rep2 litEName [c]
1284 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1285 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1287 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1288 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1290 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1291 repTup (MkC es) = rep2 tupEName [es]
1293 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1294 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1296 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1297 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1299 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1300 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1302 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1303 repDoE (MkC ss) = rep2 doEName [ss]
1305 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1306 repComp (MkC ss) = rep2 compEName [ss]
1308 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1309 repListExp (MkC es) = rep2 listEName [es]
1311 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1312 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1314 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1315 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1317 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1318 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1320 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1321 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1323 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1324 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1326 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1327 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1329 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1330 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1332 ------------ Right hand sides (guarded expressions) ----
1333 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1334 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1336 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1337 repNormal (MkC e) = rep2 normalBName [e]
1339 ------------ Guards ----
1340 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1341 repLNormalGE g e = do g' <- repLE g
1345 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1346 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1348 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1349 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1351 ------------- Stmts -------------------
1352 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1353 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1355 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1356 repLetSt (MkC ds) = rep2 letSName [ds]
1358 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1359 repNoBindSt (MkC e) = rep2 noBindSName [e]
1361 -------------- Range (Arithmetic sequences) -----------
1362 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1363 repFrom (MkC x) = rep2 fromEName [x]
1365 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1366 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1368 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1369 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1371 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1372 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1374 ------------ Match and Clause Tuples -----------
1375 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1376 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1378 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1379 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1381 -------------- Dec -----------------------------
1382 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1383 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1385 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1386 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1388 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1389 -> Maybe (Core [TH.TypeQ])
1390 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1391 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1392 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1393 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1394 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1396 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1397 -> Maybe (Core [TH.TypeQ])
1398 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1399 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1400 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1401 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1402 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1404 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1405 -> Maybe (Core [TH.TypeQ])
1406 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1407 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1408 = rep2 tySynDName [nm, tvs, rhs]
1409 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1410 = rep2 tySynInstDName [nm, tys, rhs]
1412 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1413 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1415 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1416 -> Core [TH.FunDep] -> Core [TH.DecQ]
1417 -> DsM (Core TH.DecQ)
1418 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1419 = rep2 classDName [cxt, cls, tvs, fds, ds]
1421 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1422 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1424 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1425 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1427 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1428 -> DsM (Core TH.DecQ)
1429 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1430 = rep2 pragSpecInlDName [nm, ty, ispec]
1432 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1433 -> DsM (Core TH.DecQ)
1434 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1435 = rep2 familyNoKindDName [flav, nm, tvs]
1437 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1439 -> DsM (Core TH.DecQ)
1440 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1441 = rep2 familyKindDName [flav, nm, tvs, ki]
1443 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1444 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1445 = rep2 inlineSpecNoPhaseName [inline, conlike]
1447 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1448 -> DsM (Core TH.InlineSpecQ)
1449 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1450 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1452 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1453 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1455 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1456 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1458 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1459 repCtxt (MkC tys) = rep2 cxtName [tys]
1461 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1462 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1464 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1465 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1467 repConstr :: Core TH.Name -> HsConDeclDetails Name
1468 -> DsM (Core TH.ConQ)
1469 repConstr con (PrefixCon ps)
1470 = do arg_tys <- mapM repBangTy ps
1471 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1472 rep2 normalCName [unC con, unC arg_tys1]
1473 repConstr con (RecCon ips)
1474 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1475 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1476 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1478 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1479 rep2 recCName [unC con, unC arg_vtys']
1480 repConstr con (InfixCon st1 st2)
1481 = do arg1 <- repBangTy st1
1482 arg2 <- repBangTy st2
1483 rep2 infixCName [unC arg1, unC con, unC arg2]
1485 ------------ Types -------------------
1487 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1488 -> DsM (Core TH.TypeQ)
1489 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1490 = rep2 forallTName [tvars, ctxt, ty]
1492 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1493 repTvar (MkC s) = rep2 varTName [s]
1495 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1496 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1498 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1499 repTapps f [] = return f
1500 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1502 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1503 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1505 --------- Type constructors --------------
1507 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1508 repNamedTyCon (MkC s) = rep2 conTName [s]
1510 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1511 -- Note: not Core Int; it's easier to be direct here
1512 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1514 repArrowTyCon :: DsM (Core TH.TypeQ)
1515 repArrowTyCon = rep2 arrowTName []
1517 repListTyCon :: DsM (Core TH.TypeQ)
1518 repListTyCon = rep2 listTName []
1520 ------------ Kinds -------------------
1522 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1523 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1525 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1526 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1528 repStarK :: DsM (Core TH.Kind)
1529 repStarK = rep2 starKName []
1531 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1532 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1534 ----------------------------------------------------------
1537 repLiteral :: HsLit -> DsM (Core TH.Lit)
1539 = do lit' <- case lit of
1540 HsIntPrim i -> mk_integer i
1541 HsWordPrim w -> mk_integer w
1542 HsInt i -> mk_integer i
1543 HsFloatPrim r -> mk_rational r
1544 HsDoublePrim r -> mk_rational r
1546 lit_expr <- dsLit lit'
1548 Just lit_name -> rep2 lit_name [lit_expr]
1549 Nothing -> notHandled "Exotic literal" (ppr lit)
1551 mb_lit_name = case lit of
1552 HsInteger _ _ -> Just integerLName
1553 HsInt _ -> Just integerLName
1554 HsIntPrim _ -> Just intPrimLName
1555 HsWordPrim _ -> Just wordPrimLName
1556 HsFloatPrim _ -> Just floatPrimLName
1557 HsDoublePrim _ -> Just doublePrimLName
1558 HsChar _ -> Just charLName
1559 HsString _ -> Just stringLName
1560 HsRat _ _ -> Just rationalLName
1563 mk_integer :: Integer -> DsM HsLit
1564 mk_integer i = do integer_ty <- lookupType integerTyConName
1565 return $ HsInteger i integer_ty
1566 mk_rational :: Rational -> DsM HsLit
1567 mk_rational r = do rat_ty <- lookupType rationalTyConName
1568 return $ HsRat r rat_ty
1569 mk_string :: FastString -> DsM HsLit
1570 mk_string s = return $ HsString s
1572 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1573 repOverloadedLiteral (OverLit { ol_val = val})
1574 = do { lit <- mk_lit val; repLiteral lit }
1575 -- The type Rational will be in the environment, becuase
1576 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1577 -- and rationalL is sucked in when any TH stuff is used
1579 mk_lit :: OverLitVal -> DsM HsLit
1580 mk_lit (HsIntegral i) = mk_integer i
1581 mk_lit (HsFractional f) = mk_rational f
1582 mk_lit (HsIsString s) = mk_string s
1584 --------------- Miscellaneous -------------------
1586 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1587 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1589 repBindQ :: Type -> Type -- a and b
1590 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1591 repBindQ ty_a ty_b (MkC x) (MkC y)
1592 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1594 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1595 repSequenceQ ty_a (MkC list)
1596 = rep2 sequenceQName [Type ty_a, list]
1598 ------------ Lists and Tuples -------------------
1599 -- turn a list of patterns into a single pattern matching a list
1601 coreList :: Name -- Of the TyCon of the element type
1602 -> [Core a] -> DsM (Core [a])
1604 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1606 coreList' :: Type -- The element type
1607 -> [Core a] -> Core [a]
1608 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1610 nonEmptyCoreList :: [Core a] -> Core [a]
1611 -- The list must be non-empty so we can get the element type
1612 -- Otherwise use coreList
1613 nonEmptyCoreList [] = panic "coreList: empty argument"
1614 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1616 coreStringLit :: String -> DsM (Core String)
1617 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1619 ------------ Bool, Literals & Variables -------------------
1621 coreBool :: Bool -> Core Bool
1622 coreBool False = MkC $ mkConApp falseDataCon []
1623 coreBool True = MkC $ mkConApp trueDataCon []
1625 coreIntLit :: Int -> DsM (Core Int)
1626 coreIntLit i = return (MkC (mkIntExprInt i))
1628 coreVar :: Id -> Core TH.Name -- The Id has type Name
1629 coreVar id = MkC (Var id)
1631 ----------------- Failure -----------------------
1632 notHandled :: String -> SDoc -> DsM a
1633 notHandled what doc = failWithDs msg
1635 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1639 -- %************************************************************************
1641 -- The known-key names for Template Haskell
1643 -- %************************************************************************
1645 -- To add a name, do three things
1647 -- 1) Allocate a key
1649 -- 3) Add the name to knownKeyNames
1651 templateHaskellNames :: [Name]
1652 -- The names that are implicitly mentioned by ``bracket''
1653 -- Should stay in sync with the import list of DsMeta
1655 templateHaskellNames = [
1656 returnQName, bindQName, sequenceQName, newNameName, liftName,
1657 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1661 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1662 floatPrimLName, doublePrimLName, rationalLName,
1664 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1665 asPName, wildPName, recPName, listPName, sigPName,
1673 varEName, conEName, litEName, appEName, infixEName,
1674 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1675 condEName, letEName, caseEName, doEName, compEName,
1676 fromEName, fromThenEName, fromToEName, fromThenToEName,
1677 listEName, sigEName, recConEName, recUpdEName,
1681 guardedBName, normalBName,
1683 normalGEName, patGEName,
1685 bindSName, letSName, noBindSName, parSName,
1687 funDName, valDName, dataDName, newtypeDName, tySynDName,
1688 classDName, instanceDName, sigDName, forImpDName,
1689 pragInlDName, pragSpecDName, pragSpecInlDName,
1690 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1695 classPName, equalPName,
1697 isStrictName, notStrictName,
1699 normalCName, recCName, infixCName, forallCName,
1705 forallTName, varTName, conTName, appTName,
1706 tupleTName, arrowTName, listTName, sigTName,
1708 plainTVName, kindedTVName,
1710 starKName, arrowKName,
1712 cCallName, stdCallName,
1718 inlineSpecNoPhaseName, inlineSpecPhaseName,
1722 typeFamName, dataFamName,
1725 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1726 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1727 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1728 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1729 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1730 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1731 predQTyConName, decsQTyConName,
1734 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1736 thSyn, thLib, qqLib :: Module
1737 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1738 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1739 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1741 mkTHModule :: FastString -> Module
1742 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1744 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1745 libFun = mk_known_key_name OccName.varName thLib
1746 libTc = mk_known_key_name OccName.tcName thLib
1747 thFun = mk_known_key_name OccName.varName thSyn
1748 thTc = mk_known_key_name OccName.tcName thSyn
1749 qqFun = mk_known_key_name OccName.varName qqLib
1751 -------------------- TH.Syntax -----------------------
1752 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1753 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1754 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1755 predTyConName :: Name
1756 qTyConName = thTc (fsLit "Q") qTyConKey
1757 nameTyConName = thTc (fsLit "Name") nameTyConKey
1758 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1759 patTyConName = thTc (fsLit "Pat") patTyConKey
1760 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1761 expTyConName = thTc (fsLit "Exp") expTyConKey
1762 decTyConName = thTc (fsLit "Dec") decTyConKey
1763 typeTyConName = thTc (fsLit "Type") typeTyConKey
1764 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1765 matchTyConName = thTc (fsLit "Match") matchTyConKey
1766 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1767 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1768 predTyConName = thTc (fsLit "Pred") predTyConKey
1770 returnQName, bindQName, sequenceQName, newNameName, liftName,
1771 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1772 mkNameLName, liftStringName :: Name
1773 returnQName = thFun (fsLit "returnQ") returnQIdKey
1774 bindQName = thFun (fsLit "bindQ") bindQIdKey
1775 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1776 newNameName = thFun (fsLit "newName") newNameIdKey
1777 liftName = thFun (fsLit "lift") liftIdKey
1778 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1779 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1780 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1781 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1782 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1783 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1786 -------------------- TH.Lib -----------------------
1788 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1789 floatPrimLName, doublePrimLName, rationalLName :: Name
1790 charLName = libFun (fsLit "charL") charLIdKey
1791 stringLName = libFun (fsLit "stringL") stringLIdKey
1792 integerLName = libFun (fsLit "integerL") integerLIdKey
1793 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1794 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1795 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1796 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1797 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1800 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1801 asPName, wildPName, recPName, listPName, sigPName :: Name
1802 litPName = libFun (fsLit "litP") litPIdKey
1803 varPName = libFun (fsLit "varP") varPIdKey
1804 tupPName = libFun (fsLit "tupP") tupPIdKey
1805 conPName = libFun (fsLit "conP") conPIdKey
1806 infixPName = libFun (fsLit "infixP") infixPIdKey
1807 tildePName = libFun (fsLit "tildeP") tildePIdKey
1808 bangPName = libFun (fsLit "bangP") bangPIdKey
1809 asPName = libFun (fsLit "asP") asPIdKey
1810 wildPName = libFun (fsLit "wildP") wildPIdKey
1811 recPName = libFun (fsLit "recP") recPIdKey
1812 listPName = libFun (fsLit "listP") listPIdKey
1813 sigPName = libFun (fsLit "sigP") sigPIdKey
1815 -- type FieldPat = ...
1816 fieldPatName :: Name
1817 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1821 matchName = libFun (fsLit "match") matchIdKey
1823 -- data Clause = ...
1825 clauseName = libFun (fsLit "clause") clauseIdKey
1828 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1829 sectionLName, sectionRName, lamEName, tupEName, condEName,
1830 letEName, caseEName, doEName, compEName :: Name
1831 varEName = libFun (fsLit "varE") varEIdKey
1832 conEName = libFun (fsLit "conE") conEIdKey
1833 litEName = libFun (fsLit "litE") litEIdKey
1834 appEName = libFun (fsLit "appE") appEIdKey
1835 infixEName = libFun (fsLit "infixE") infixEIdKey
1836 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1837 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1838 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1839 lamEName = libFun (fsLit "lamE") lamEIdKey
1840 tupEName = libFun (fsLit "tupE") tupEIdKey
1841 condEName = libFun (fsLit "condE") condEIdKey
1842 letEName = libFun (fsLit "letE") letEIdKey
1843 caseEName = libFun (fsLit "caseE") caseEIdKey
1844 doEName = libFun (fsLit "doE") doEIdKey
1845 compEName = libFun (fsLit "compE") compEIdKey
1846 -- ArithSeq skips a level
1847 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1848 fromEName = libFun (fsLit "fromE") fromEIdKey
1849 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1850 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1851 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1853 listEName, sigEName, recConEName, recUpdEName :: Name
1854 listEName = libFun (fsLit "listE") listEIdKey
1855 sigEName = libFun (fsLit "sigE") sigEIdKey
1856 recConEName = libFun (fsLit "recConE") recConEIdKey
1857 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1859 -- type FieldExp = ...
1860 fieldExpName :: Name
1861 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1864 guardedBName, normalBName :: Name
1865 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1866 normalBName = libFun (fsLit "normalB") normalBIdKey
1869 normalGEName, patGEName :: Name
1870 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1871 patGEName = libFun (fsLit "patGE") patGEIdKey
1874 bindSName, letSName, noBindSName, parSName :: Name
1875 bindSName = libFun (fsLit "bindS") bindSIdKey
1876 letSName = libFun (fsLit "letS") letSIdKey
1877 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1878 parSName = libFun (fsLit "parS") parSIdKey
1881 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1882 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1883 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1884 newtypeInstDName, tySynInstDName :: Name
1885 funDName = libFun (fsLit "funD") funDIdKey
1886 valDName = libFun (fsLit "valD") valDIdKey
1887 dataDName = libFun (fsLit "dataD") dataDIdKey
1888 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1889 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1890 classDName = libFun (fsLit "classD") classDIdKey
1891 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1892 sigDName = libFun (fsLit "sigD") sigDIdKey
1893 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1894 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1895 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1896 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1897 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1898 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1899 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1900 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1901 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1905 cxtName = libFun (fsLit "cxt") cxtIdKey
1908 classPName, equalPName :: Name
1909 classPName = libFun (fsLit "classP") classPIdKey
1910 equalPName = libFun (fsLit "equalP") equalPIdKey
1912 -- data Strict = ...
1913 isStrictName, notStrictName :: Name
1914 isStrictName = libFun (fsLit "isStrict") isStrictKey
1915 notStrictName = libFun (fsLit "notStrict") notStrictKey
1918 normalCName, recCName, infixCName, forallCName :: Name
1919 normalCName = libFun (fsLit "normalC") normalCIdKey
1920 recCName = libFun (fsLit "recC") recCIdKey
1921 infixCName = libFun (fsLit "infixC") infixCIdKey
1922 forallCName = libFun (fsLit "forallC") forallCIdKey
1924 -- type StrictType = ...
1925 strictTypeName :: Name
1926 strictTypeName = libFun (fsLit "strictType") strictTKey
1928 -- type VarStrictType = ...
1929 varStrictTypeName :: Name
1930 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1933 forallTName, varTName, conTName, tupleTName, arrowTName,
1934 listTName, appTName, sigTName :: Name
1935 forallTName = libFun (fsLit "forallT") forallTIdKey
1936 varTName = libFun (fsLit "varT") varTIdKey
1937 conTName = libFun (fsLit "conT") conTIdKey
1938 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1939 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1940 listTName = libFun (fsLit "listT") listTIdKey
1941 appTName = libFun (fsLit "appT") appTIdKey
1942 sigTName = libFun (fsLit "sigT") sigTIdKey
1944 -- data TyVarBndr = ...
1945 plainTVName, kindedTVName :: Name
1946 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1947 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1950 starKName, arrowKName :: Name
1951 starKName = libFun (fsLit "starK") starKIdKey
1952 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1954 -- data Callconv = ...
1955 cCallName, stdCallName :: Name
1956 cCallName = libFun (fsLit "cCall") cCallIdKey
1957 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1959 -- data Safety = ...
1960 unsafeName, safeName, threadsafeName :: Name
1961 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1962 safeName = libFun (fsLit "safe") safeIdKey
1963 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1965 -- data InlineSpec = ...
1966 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1967 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1968 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1970 -- data FunDep = ...
1972 funDepName = libFun (fsLit "funDep") funDepIdKey
1974 -- data FamFlavour = ...
1975 typeFamName, dataFamName :: Name
1976 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1977 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1979 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1980 decQTyConName, conQTyConName, strictTypeQTyConName,
1981 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1982 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
1983 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1984 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1985 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1986 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1987 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1988 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
1989 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1990 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
1991 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1992 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
1993 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
1994 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
1995 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
1996 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
1999 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2000 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2001 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2002 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2003 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2005 -- TyConUniques available: 100-129
2006 -- Check in PrelNames if you want to change this
2008 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2009 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2010 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2011 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2012 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2013 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2014 predQTyConKey, decsQTyConKey :: Unique
2015 expTyConKey = mkPreludeTyConUnique 100
2016 matchTyConKey = mkPreludeTyConUnique 101
2017 clauseTyConKey = mkPreludeTyConUnique 102
2018 qTyConKey = mkPreludeTyConUnique 103
2019 expQTyConKey = mkPreludeTyConUnique 104
2020 decQTyConKey = mkPreludeTyConUnique 105
2021 patTyConKey = mkPreludeTyConUnique 106
2022 matchQTyConKey = mkPreludeTyConUnique 107
2023 clauseQTyConKey = mkPreludeTyConUnique 108
2024 stmtQTyConKey = mkPreludeTyConUnique 109
2025 conQTyConKey = mkPreludeTyConUnique 110
2026 typeQTyConKey = mkPreludeTyConUnique 111
2027 typeTyConKey = mkPreludeTyConUnique 112
2028 decTyConKey = mkPreludeTyConUnique 113
2029 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2030 strictTypeQTyConKey = mkPreludeTyConUnique 115
2031 fieldExpTyConKey = mkPreludeTyConUnique 116
2032 fieldPatTyConKey = mkPreludeTyConUnique 117
2033 nameTyConKey = mkPreludeTyConUnique 118
2034 patQTyConKey = mkPreludeTyConUnique 119
2035 fieldPatQTyConKey = mkPreludeTyConUnique 120
2036 fieldExpQTyConKey = mkPreludeTyConUnique 121
2037 funDepTyConKey = mkPreludeTyConUnique 122
2038 predTyConKey = mkPreludeTyConUnique 123
2039 predQTyConKey = mkPreludeTyConUnique 124
2040 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2041 decsQTyConKey = mkPreludeTyConUnique 126
2043 -- IdUniques available: 200-399
2044 -- If you want to change this, make sure you check in PrelNames
2046 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2047 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2048 mkNameLIdKey :: Unique
2049 returnQIdKey = mkPreludeMiscIdUnique 200
2050 bindQIdKey = mkPreludeMiscIdUnique 201
2051 sequenceQIdKey = mkPreludeMiscIdUnique 202
2052 liftIdKey = mkPreludeMiscIdUnique 203
2053 newNameIdKey = mkPreludeMiscIdUnique 204
2054 mkNameIdKey = mkPreludeMiscIdUnique 205
2055 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2056 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2057 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2058 mkNameLIdKey = mkPreludeMiscIdUnique 209
2062 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2063 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2064 charLIdKey = mkPreludeMiscIdUnique 210
2065 stringLIdKey = mkPreludeMiscIdUnique 211
2066 integerLIdKey = mkPreludeMiscIdUnique 212
2067 intPrimLIdKey = mkPreludeMiscIdUnique 213
2068 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2069 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2070 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2071 rationalLIdKey = mkPreludeMiscIdUnique 217
2073 liftStringIdKey :: Unique
2074 liftStringIdKey = mkPreludeMiscIdUnique 218
2077 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2078 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2079 litPIdKey = mkPreludeMiscIdUnique 220
2080 varPIdKey = mkPreludeMiscIdUnique 221
2081 tupPIdKey = mkPreludeMiscIdUnique 222
2082 conPIdKey = mkPreludeMiscIdUnique 223
2083 infixPIdKey = mkPreludeMiscIdUnique 312
2084 tildePIdKey = mkPreludeMiscIdUnique 224
2085 bangPIdKey = mkPreludeMiscIdUnique 359
2086 asPIdKey = mkPreludeMiscIdUnique 225
2087 wildPIdKey = mkPreludeMiscIdUnique 226
2088 recPIdKey = mkPreludeMiscIdUnique 227
2089 listPIdKey = mkPreludeMiscIdUnique 228
2090 sigPIdKey = mkPreludeMiscIdUnique 229
2092 -- type FieldPat = ...
2093 fieldPatIdKey :: Unique
2094 fieldPatIdKey = mkPreludeMiscIdUnique 230
2097 matchIdKey :: Unique
2098 matchIdKey = mkPreludeMiscIdUnique 231
2100 -- data Clause = ...
2101 clauseIdKey :: Unique
2102 clauseIdKey = mkPreludeMiscIdUnique 232
2106 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2107 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2108 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2109 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2110 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2111 varEIdKey = mkPreludeMiscIdUnique 240
2112 conEIdKey = mkPreludeMiscIdUnique 241
2113 litEIdKey = mkPreludeMiscIdUnique 242
2114 appEIdKey = mkPreludeMiscIdUnique 243
2115 infixEIdKey = mkPreludeMiscIdUnique 244
2116 infixAppIdKey = mkPreludeMiscIdUnique 245
2117 sectionLIdKey = mkPreludeMiscIdUnique 246
2118 sectionRIdKey = mkPreludeMiscIdUnique 247
2119 lamEIdKey = mkPreludeMiscIdUnique 248
2120 tupEIdKey = mkPreludeMiscIdUnique 249
2121 condEIdKey = mkPreludeMiscIdUnique 250
2122 letEIdKey = mkPreludeMiscIdUnique 251
2123 caseEIdKey = mkPreludeMiscIdUnique 252
2124 doEIdKey = mkPreludeMiscIdUnique 253
2125 compEIdKey = mkPreludeMiscIdUnique 254
2126 fromEIdKey = mkPreludeMiscIdUnique 255
2127 fromThenEIdKey = mkPreludeMiscIdUnique 256
2128 fromToEIdKey = mkPreludeMiscIdUnique 257
2129 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2130 listEIdKey = mkPreludeMiscIdUnique 259
2131 sigEIdKey = mkPreludeMiscIdUnique 260
2132 recConEIdKey = mkPreludeMiscIdUnique 261
2133 recUpdEIdKey = mkPreludeMiscIdUnique 262
2135 -- type FieldExp = ...
2136 fieldExpIdKey :: Unique
2137 fieldExpIdKey = mkPreludeMiscIdUnique 265
2140 guardedBIdKey, normalBIdKey :: Unique
2141 guardedBIdKey = mkPreludeMiscIdUnique 266
2142 normalBIdKey = mkPreludeMiscIdUnique 267
2145 normalGEIdKey, patGEIdKey :: Unique
2146 normalGEIdKey = mkPreludeMiscIdUnique 310
2147 patGEIdKey = mkPreludeMiscIdUnique 311
2150 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2151 bindSIdKey = mkPreludeMiscIdUnique 268
2152 letSIdKey = mkPreludeMiscIdUnique 269
2153 noBindSIdKey = mkPreludeMiscIdUnique 270
2154 parSIdKey = mkPreludeMiscIdUnique 271
2157 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2158 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2159 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2160 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2161 funDIdKey = mkPreludeMiscIdUnique 272
2162 valDIdKey = mkPreludeMiscIdUnique 273
2163 dataDIdKey = mkPreludeMiscIdUnique 274
2164 newtypeDIdKey = mkPreludeMiscIdUnique 275
2165 tySynDIdKey = mkPreludeMiscIdUnique 276
2166 classDIdKey = mkPreludeMiscIdUnique 277
2167 instanceDIdKey = mkPreludeMiscIdUnique 278
2168 sigDIdKey = mkPreludeMiscIdUnique 279
2169 forImpDIdKey = mkPreludeMiscIdUnique 297
2170 pragInlDIdKey = mkPreludeMiscIdUnique 348
2171 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2172 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2173 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2174 familyKindDIdKey = mkPreludeMiscIdUnique 353
2175 dataInstDIdKey = mkPreludeMiscIdUnique 341
2176 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2177 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2181 cxtIdKey = mkPreludeMiscIdUnique 280
2184 classPIdKey, equalPIdKey :: Unique
2185 classPIdKey = mkPreludeMiscIdUnique 346
2186 equalPIdKey = mkPreludeMiscIdUnique 347
2188 -- data Strict = ...
2189 isStrictKey, notStrictKey :: Unique
2190 isStrictKey = mkPreludeMiscIdUnique 281
2191 notStrictKey = mkPreludeMiscIdUnique 282
2194 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2195 normalCIdKey = mkPreludeMiscIdUnique 283
2196 recCIdKey = mkPreludeMiscIdUnique 284
2197 infixCIdKey = mkPreludeMiscIdUnique 285
2198 forallCIdKey = mkPreludeMiscIdUnique 288
2200 -- type StrictType = ...
2201 strictTKey :: Unique
2202 strictTKey = mkPreludeMiscIdUnique 286
2204 -- type VarStrictType = ...
2205 varStrictTKey :: Unique
2206 varStrictTKey = mkPreludeMiscIdUnique 287
2209 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2210 listTIdKey, appTIdKey, sigTIdKey :: Unique
2211 forallTIdKey = mkPreludeMiscIdUnique 290
2212 varTIdKey = mkPreludeMiscIdUnique 291
2213 conTIdKey = mkPreludeMiscIdUnique 292
2214 tupleTIdKey = mkPreludeMiscIdUnique 294
2215 arrowTIdKey = mkPreludeMiscIdUnique 295
2216 listTIdKey = mkPreludeMiscIdUnique 296
2217 appTIdKey = mkPreludeMiscIdUnique 293
2218 sigTIdKey = mkPreludeMiscIdUnique 358
2220 -- data TyVarBndr = ...
2221 plainTVIdKey, kindedTVIdKey :: Unique
2222 plainTVIdKey = mkPreludeMiscIdUnique 354
2223 kindedTVIdKey = mkPreludeMiscIdUnique 355
2226 starKIdKey, arrowKIdKey :: Unique
2227 starKIdKey = mkPreludeMiscIdUnique 356
2228 arrowKIdKey = mkPreludeMiscIdUnique 357
2230 -- data Callconv = ...
2231 cCallIdKey, stdCallIdKey :: Unique
2232 cCallIdKey = mkPreludeMiscIdUnique 300
2233 stdCallIdKey = mkPreludeMiscIdUnique 301
2235 -- data Safety = ...
2236 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2237 unsafeIdKey = mkPreludeMiscIdUnique 305
2238 safeIdKey = mkPreludeMiscIdUnique 306
2239 threadsafeIdKey = mkPreludeMiscIdUnique 307
2241 -- data InlineSpec =
2242 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2243 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2244 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2246 -- data FunDep = ...
2247 funDepIdKey :: Unique
2248 funDepIdKey = mkPreludeMiscIdUnique 320
2250 -- data FamFlavour = ...
2251 typeFamIdKey, dataFamIdKey :: Unique
2252 typeFamIdKey = mkPreludeMiscIdUnique 344
2253 dataFamIdKey = mkPreludeMiscIdUnique 345
2256 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2257 quoteExpKey = mkPreludeMiscIdUnique 321
2258 quotePatKey = mkPreludeMiscIdUnique 322
2259 quoteDecKey = mkPreludeMiscIdUnique 323
2260 quoteTypeKey = mkPreludeMiscIdUnique 324