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,
1660 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1661 floatPrimLName, doublePrimLName, rationalLName,
1663 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1664 asPName, wildPName, recPName, listPName, sigPName,
1672 varEName, conEName, litEName, appEName, infixEName,
1673 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1674 condEName, letEName, caseEName, doEName, compEName,
1675 fromEName, fromThenEName, fromToEName, fromThenToEName,
1676 listEName, sigEName, recConEName, recUpdEName,
1680 guardedBName, normalBName,
1682 normalGEName, patGEName,
1684 bindSName, letSName, noBindSName, parSName,
1686 funDName, valDName, dataDName, newtypeDName, tySynDName,
1687 classDName, instanceDName, sigDName, forImpDName,
1688 pragInlDName, pragSpecDName, pragSpecInlDName,
1689 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1694 classPName, equalPName,
1696 isStrictName, notStrictName,
1698 normalCName, recCName, infixCName, forallCName,
1704 forallTName, varTName, conTName, appTName,
1705 tupleTName, arrowTName, listTName, sigTName,
1707 plainTVName, kindedTVName,
1709 starKName, arrowKName,
1711 cCallName, stdCallName,
1717 inlineSpecNoPhaseName, inlineSpecPhaseName,
1721 typeFamName, dataFamName,
1724 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1725 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1726 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1727 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1728 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1729 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1730 predQTyConName, decsQTyConName,
1733 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1735 thSyn, thLib, qqLib :: Module
1736 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1737 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1738 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1740 mkTHModule :: FastString -> Module
1741 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1743 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1744 libFun = mk_known_key_name OccName.varName thLib
1745 libTc = mk_known_key_name OccName.tcName thLib
1746 thFun = mk_known_key_name OccName.varName thSyn
1747 thTc = mk_known_key_name OccName.tcName thSyn
1748 qqFun = mk_known_key_name OccName.varName qqLib
1750 -------------------- TH.Syntax -----------------------
1751 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1752 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1753 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1754 predTyConName :: Name
1755 qTyConName = thTc (fsLit "Q") qTyConKey
1756 nameTyConName = thTc (fsLit "Name") nameTyConKey
1757 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1758 patTyConName = thTc (fsLit "Pat") patTyConKey
1759 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1760 expTyConName = thTc (fsLit "Exp") expTyConKey
1761 decTyConName = thTc (fsLit "Dec") decTyConKey
1762 typeTyConName = thTc (fsLit "Type") typeTyConKey
1763 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1764 matchTyConName = thTc (fsLit "Match") matchTyConKey
1765 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1766 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1767 predTyConName = thTc (fsLit "Pred") predTyConKey
1769 returnQName, bindQName, sequenceQName, newNameName, liftName,
1770 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1771 mkNameLName, liftStringName :: Name
1772 returnQName = thFun (fsLit "returnQ") returnQIdKey
1773 bindQName = thFun (fsLit "bindQ") bindQIdKey
1774 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1775 newNameName = thFun (fsLit "newName") newNameIdKey
1776 liftName = thFun (fsLit "lift") liftIdKey
1777 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1778 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1779 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1780 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1781 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1782 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1785 -------------------- TH.Lib -----------------------
1787 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1788 floatPrimLName, doublePrimLName, rationalLName :: Name
1789 charLName = libFun (fsLit "charL") charLIdKey
1790 stringLName = libFun (fsLit "stringL") stringLIdKey
1791 integerLName = libFun (fsLit "integerL") integerLIdKey
1792 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1793 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1794 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1795 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1796 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1799 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1800 asPName, wildPName, recPName, listPName, sigPName :: Name
1801 litPName = libFun (fsLit "litP") litPIdKey
1802 varPName = libFun (fsLit "varP") varPIdKey
1803 tupPName = libFun (fsLit "tupP") tupPIdKey
1804 conPName = libFun (fsLit "conP") conPIdKey
1805 infixPName = libFun (fsLit "infixP") infixPIdKey
1806 tildePName = libFun (fsLit "tildeP") tildePIdKey
1807 bangPName = libFun (fsLit "bangP") bangPIdKey
1808 asPName = libFun (fsLit "asP") asPIdKey
1809 wildPName = libFun (fsLit "wildP") wildPIdKey
1810 recPName = libFun (fsLit "recP") recPIdKey
1811 listPName = libFun (fsLit "listP") listPIdKey
1812 sigPName = libFun (fsLit "sigP") sigPIdKey
1814 -- type FieldPat = ...
1815 fieldPatName :: Name
1816 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1820 matchName = libFun (fsLit "match") matchIdKey
1822 -- data Clause = ...
1824 clauseName = libFun (fsLit "clause") clauseIdKey
1827 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1828 sectionLName, sectionRName, lamEName, tupEName, condEName,
1829 letEName, caseEName, doEName, compEName :: Name
1830 varEName = libFun (fsLit "varE") varEIdKey
1831 conEName = libFun (fsLit "conE") conEIdKey
1832 litEName = libFun (fsLit "litE") litEIdKey
1833 appEName = libFun (fsLit "appE") appEIdKey
1834 infixEName = libFun (fsLit "infixE") infixEIdKey
1835 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1836 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1837 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1838 lamEName = libFun (fsLit "lamE") lamEIdKey
1839 tupEName = libFun (fsLit "tupE") tupEIdKey
1840 condEName = libFun (fsLit "condE") condEIdKey
1841 letEName = libFun (fsLit "letE") letEIdKey
1842 caseEName = libFun (fsLit "caseE") caseEIdKey
1843 doEName = libFun (fsLit "doE") doEIdKey
1844 compEName = libFun (fsLit "compE") compEIdKey
1845 -- ArithSeq skips a level
1846 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1847 fromEName = libFun (fsLit "fromE") fromEIdKey
1848 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1849 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1850 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1852 listEName, sigEName, recConEName, recUpdEName :: Name
1853 listEName = libFun (fsLit "listE") listEIdKey
1854 sigEName = libFun (fsLit "sigE") sigEIdKey
1855 recConEName = libFun (fsLit "recConE") recConEIdKey
1856 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1858 -- type FieldExp = ...
1859 fieldExpName :: Name
1860 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1863 guardedBName, normalBName :: Name
1864 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1865 normalBName = libFun (fsLit "normalB") normalBIdKey
1868 normalGEName, patGEName :: Name
1869 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1870 patGEName = libFun (fsLit "patGE") patGEIdKey
1873 bindSName, letSName, noBindSName, parSName :: Name
1874 bindSName = libFun (fsLit "bindS") bindSIdKey
1875 letSName = libFun (fsLit "letS") letSIdKey
1876 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1877 parSName = libFun (fsLit "parS") parSIdKey
1880 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1881 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1882 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1883 newtypeInstDName, tySynInstDName :: Name
1884 funDName = libFun (fsLit "funD") funDIdKey
1885 valDName = libFun (fsLit "valD") valDIdKey
1886 dataDName = libFun (fsLit "dataD") dataDIdKey
1887 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1888 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1889 classDName = libFun (fsLit "classD") classDIdKey
1890 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1891 sigDName = libFun (fsLit "sigD") sigDIdKey
1892 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1893 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1894 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1895 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1896 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1897 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1898 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1899 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1900 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1904 cxtName = libFun (fsLit "cxt") cxtIdKey
1907 classPName, equalPName :: Name
1908 classPName = libFun (fsLit "classP") classPIdKey
1909 equalPName = libFun (fsLit "equalP") equalPIdKey
1911 -- data Strict = ...
1912 isStrictName, notStrictName :: Name
1913 isStrictName = libFun (fsLit "isStrict") isStrictKey
1914 notStrictName = libFun (fsLit "notStrict") notStrictKey
1917 normalCName, recCName, infixCName, forallCName :: Name
1918 normalCName = libFun (fsLit "normalC") normalCIdKey
1919 recCName = libFun (fsLit "recC") recCIdKey
1920 infixCName = libFun (fsLit "infixC") infixCIdKey
1921 forallCName = libFun (fsLit "forallC") forallCIdKey
1923 -- type StrictType = ...
1924 strictTypeName :: Name
1925 strictTypeName = libFun (fsLit "strictType") strictTKey
1927 -- type VarStrictType = ...
1928 varStrictTypeName :: Name
1929 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1932 forallTName, varTName, conTName, tupleTName, arrowTName,
1933 listTName, appTName, sigTName :: Name
1934 forallTName = libFun (fsLit "forallT") forallTIdKey
1935 varTName = libFun (fsLit "varT") varTIdKey
1936 conTName = libFun (fsLit "conT") conTIdKey
1937 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1938 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1939 listTName = libFun (fsLit "listT") listTIdKey
1940 appTName = libFun (fsLit "appT") appTIdKey
1941 sigTName = libFun (fsLit "sigT") sigTIdKey
1943 -- data TyVarBndr = ...
1944 plainTVName, kindedTVName :: Name
1945 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1946 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1949 starKName, arrowKName :: Name
1950 starKName = libFun (fsLit "starK") starKIdKey
1951 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1953 -- data Callconv = ...
1954 cCallName, stdCallName :: Name
1955 cCallName = libFun (fsLit "cCall") cCallIdKey
1956 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1958 -- data Safety = ...
1959 unsafeName, safeName, threadsafeName :: Name
1960 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1961 safeName = libFun (fsLit "safe") safeIdKey
1962 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1964 -- data InlineSpec = ...
1965 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1966 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1967 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1969 -- data FunDep = ...
1971 funDepName = libFun (fsLit "funDep") funDepIdKey
1973 -- data FamFlavour = ...
1974 typeFamName, dataFamName :: Name
1975 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1976 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1978 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1979 decQTyConName, conQTyConName, strictTypeQTyConName,
1980 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1981 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
1982 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1983 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1984 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1985 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1986 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1987 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
1988 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1989 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
1990 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1991 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
1992 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
1993 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
1994 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
1995 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
1998 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
1999 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2000 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2001 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2002 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2004 -- TyConUniques available: 100-129
2005 -- Check in PrelNames if you want to change this
2007 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2008 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2009 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2010 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2011 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2012 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2013 predQTyConKey, decsQTyConKey :: Unique
2014 expTyConKey = mkPreludeTyConUnique 100
2015 matchTyConKey = mkPreludeTyConUnique 101
2016 clauseTyConKey = mkPreludeTyConUnique 102
2017 qTyConKey = mkPreludeTyConUnique 103
2018 expQTyConKey = mkPreludeTyConUnique 104
2019 decQTyConKey = mkPreludeTyConUnique 105
2020 patTyConKey = mkPreludeTyConUnique 106
2021 matchQTyConKey = mkPreludeTyConUnique 107
2022 clauseQTyConKey = mkPreludeTyConUnique 108
2023 stmtQTyConKey = mkPreludeTyConUnique 109
2024 conQTyConKey = mkPreludeTyConUnique 110
2025 typeQTyConKey = mkPreludeTyConUnique 111
2026 typeTyConKey = mkPreludeTyConUnique 112
2027 decTyConKey = mkPreludeTyConUnique 113
2028 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2029 strictTypeQTyConKey = mkPreludeTyConUnique 115
2030 fieldExpTyConKey = mkPreludeTyConUnique 116
2031 fieldPatTyConKey = mkPreludeTyConUnique 117
2032 nameTyConKey = mkPreludeTyConUnique 118
2033 patQTyConKey = mkPreludeTyConUnique 119
2034 fieldPatQTyConKey = mkPreludeTyConUnique 120
2035 fieldExpQTyConKey = mkPreludeTyConUnique 121
2036 funDepTyConKey = mkPreludeTyConUnique 122
2037 predTyConKey = mkPreludeTyConUnique 123
2038 predQTyConKey = mkPreludeTyConUnique 124
2039 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2040 decsQTyConKey = mkPreludeTyConUnique 126
2042 -- IdUniques available: 200-399
2043 -- If you want to change this, make sure you check in PrelNames
2045 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2046 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2047 mkNameLIdKey :: Unique
2048 returnQIdKey = mkPreludeMiscIdUnique 200
2049 bindQIdKey = mkPreludeMiscIdUnique 201
2050 sequenceQIdKey = mkPreludeMiscIdUnique 202
2051 liftIdKey = mkPreludeMiscIdUnique 203
2052 newNameIdKey = mkPreludeMiscIdUnique 204
2053 mkNameIdKey = mkPreludeMiscIdUnique 205
2054 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2055 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2056 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2057 mkNameLIdKey = mkPreludeMiscIdUnique 209
2061 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2062 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2063 charLIdKey = mkPreludeMiscIdUnique 210
2064 stringLIdKey = mkPreludeMiscIdUnique 211
2065 integerLIdKey = mkPreludeMiscIdUnique 212
2066 intPrimLIdKey = mkPreludeMiscIdUnique 213
2067 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2068 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2069 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2070 rationalLIdKey = mkPreludeMiscIdUnique 217
2072 liftStringIdKey :: Unique
2073 liftStringIdKey = mkPreludeMiscIdUnique 218
2076 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2077 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2078 litPIdKey = mkPreludeMiscIdUnique 220
2079 varPIdKey = mkPreludeMiscIdUnique 221
2080 tupPIdKey = mkPreludeMiscIdUnique 222
2081 conPIdKey = mkPreludeMiscIdUnique 223
2082 infixPIdKey = mkPreludeMiscIdUnique 312
2083 tildePIdKey = mkPreludeMiscIdUnique 224
2084 bangPIdKey = mkPreludeMiscIdUnique 359
2085 asPIdKey = mkPreludeMiscIdUnique 225
2086 wildPIdKey = mkPreludeMiscIdUnique 226
2087 recPIdKey = mkPreludeMiscIdUnique 227
2088 listPIdKey = mkPreludeMiscIdUnique 228
2089 sigPIdKey = mkPreludeMiscIdUnique 229
2091 -- type FieldPat = ...
2092 fieldPatIdKey :: Unique
2093 fieldPatIdKey = mkPreludeMiscIdUnique 230
2096 matchIdKey :: Unique
2097 matchIdKey = mkPreludeMiscIdUnique 231
2099 -- data Clause = ...
2100 clauseIdKey :: Unique
2101 clauseIdKey = mkPreludeMiscIdUnique 232
2105 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2106 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2107 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2108 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2109 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2110 varEIdKey = mkPreludeMiscIdUnique 240
2111 conEIdKey = mkPreludeMiscIdUnique 241
2112 litEIdKey = mkPreludeMiscIdUnique 242
2113 appEIdKey = mkPreludeMiscIdUnique 243
2114 infixEIdKey = mkPreludeMiscIdUnique 244
2115 infixAppIdKey = mkPreludeMiscIdUnique 245
2116 sectionLIdKey = mkPreludeMiscIdUnique 246
2117 sectionRIdKey = mkPreludeMiscIdUnique 247
2118 lamEIdKey = mkPreludeMiscIdUnique 248
2119 tupEIdKey = mkPreludeMiscIdUnique 249
2120 condEIdKey = mkPreludeMiscIdUnique 250
2121 letEIdKey = mkPreludeMiscIdUnique 251
2122 caseEIdKey = mkPreludeMiscIdUnique 252
2123 doEIdKey = mkPreludeMiscIdUnique 253
2124 compEIdKey = mkPreludeMiscIdUnique 254
2125 fromEIdKey = mkPreludeMiscIdUnique 255
2126 fromThenEIdKey = mkPreludeMiscIdUnique 256
2127 fromToEIdKey = mkPreludeMiscIdUnique 257
2128 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2129 listEIdKey = mkPreludeMiscIdUnique 259
2130 sigEIdKey = mkPreludeMiscIdUnique 260
2131 recConEIdKey = mkPreludeMiscIdUnique 261
2132 recUpdEIdKey = mkPreludeMiscIdUnique 262
2134 -- type FieldExp = ...
2135 fieldExpIdKey :: Unique
2136 fieldExpIdKey = mkPreludeMiscIdUnique 265
2139 guardedBIdKey, normalBIdKey :: Unique
2140 guardedBIdKey = mkPreludeMiscIdUnique 266
2141 normalBIdKey = mkPreludeMiscIdUnique 267
2144 normalGEIdKey, patGEIdKey :: Unique
2145 normalGEIdKey = mkPreludeMiscIdUnique 310
2146 patGEIdKey = mkPreludeMiscIdUnique 311
2149 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2150 bindSIdKey = mkPreludeMiscIdUnique 268
2151 letSIdKey = mkPreludeMiscIdUnique 269
2152 noBindSIdKey = mkPreludeMiscIdUnique 270
2153 parSIdKey = mkPreludeMiscIdUnique 271
2156 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2157 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2158 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2159 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2160 funDIdKey = mkPreludeMiscIdUnique 272
2161 valDIdKey = mkPreludeMiscIdUnique 273
2162 dataDIdKey = mkPreludeMiscIdUnique 274
2163 newtypeDIdKey = mkPreludeMiscIdUnique 275
2164 tySynDIdKey = mkPreludeMiscIdUnique 276
2165 classDIdKey = mkPreludeMiscIdUnique 277
2166 instanceDIdKey = mkPreludeMiscIdUnique 278
2167 sigDIdKey = mkPreludeMiscIdUnique 279
2168 forImpDIdKey = mkPreludeMiscIdUnique 297
2169 pragInlDIdKey = mkPreludeMiscIdUnique 348
2170 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2171 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2172 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2173 familyKindDIdKey = mkPreludeMiscIdUnique 353
2174 dataInstDIdKey = mkPreludeMiscIdUnique 341
2175 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2176 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2180 cxtIdKey = mkPreludeMiscIdUnique 280
2183 classPIdKey, equalPIdKey :: Unique
2184 classPIdKey = mkPreludeMiscIdUnique 346
2185 equalPIdKey = mkPreludeMiscIdUnique 347
2187 -- data Strict = ...
2188 isStrictKey, notStrictKey :: Unique
2189 isStrictKey = mkPreludeMiscIdUnique 281
2190 notStrictKey = mkPreludeMiscIdUnique 282
2193 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2194 normalCIdKey = mkPreludeMiscIdUnique 283
2195 recCIdKey = mkPreludeMiscIdUnique 284
2196 infixCIdKey = mkPreludeMiscIdUnique 285
2197 forallCIdKey = mkPreludeMiscIdUnique 288
2199 -- type StrictType = ...
2200 strictTKey :: Unique
2201 strictTKey = mkPreludeMiscIdUnique 286
2203 -- type VarStrictType = ...
2204 varStrictTKey :: Unique
2205 varStrictTKey = mkPreludeMiscIdUnique 287
2208 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2209 listTIdKey, appTIdKey, sigTIdKey :: Unique
2210 forallTIdKey = mkPreludeMiscIdUnique 290
2211 varTIdKey = mkPreludeMiscIdUnique 291
2212 conTIdKey = mkPreludeMiscIdUnique 292
2213 tupleTIdKey = mkPreludeMiscIdUnique 294
2214 arrowTIdKey = mkPreludeMiscIdUnique 295
2215 listTIdKey = mkPreludeMiscIdUnique 296
2216 appTIdKey = mkPreludeMiscIdUnique 293
2217 sigTIdKey = mkPreludeMiscIdUnique 358
2219 -- data TyVarBndr = ...
2220 plainTVIdKey, kindedTVIdKey :: Unique
2221 plainTVIdKey = mkPreludeMiscIdUnique 354
2222 kindedTVIdKey = mkPreludeMiscIdUnique 355
2225 starKIdKey, arrowKIdKey :: Unique
2226 starKIdKey = mkPreludeMiscIdUnique 356
2227 arrowKIdKey = mkPreludeMiscIdUnique 357
2229 -- data Callconv = ...
2230 cCallIdKey, stdCallIdKey :: Unique
2231 cCallIdKey = mkPreludeMiscIdUnique 300
2232 stdCallIdKey = mkPreludeMiscIdUnique 301
2234 -- data Safety = ...
2235 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2236 unsafeIdKey = mkPreludeMiscIdUnique 305
2237 safeIdKey = mkPreludeMiscIdUnique 306
2238 threadsafeIdKey = mkPreludeMiscIdUnique 307
2240 -- data InlineSpec =
2241 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2242 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2243 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2245 -- data FunDep = ...
2246 funDepIdKey :: Unique
2247 funDepIdKey = mkPreludeMiscIdUnique 320
2249 -- data FamFlavour = ...
2250 typeFamIdKey, dataFamIdKey :: Unique
2251 typeFamIdKey = mkPreludeMiscIdUnique 344
2252 dataFamIdKey = mkPreludeMiscIdUnique 345
2255 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2256 quoteExpKey = mkPreludeMiscIdUnique 321
2257 quotePatKey = mkPreludeMiscIdUnique 322
2258 quoteDecKey = mkPreludeMiscIdUnique 323
2259 quoteTypeKey = mkPreludeMiscIdUnique 324