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 )
60 import Util( equalLength )
66 -----------------------------------------------------------------------------
67 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
68 -- Returns a CoreExpr of type TH.ExpQ
69 -- The quoted thing is parameterised over Name, even though it has
70 -- been type checked. We don't want all those type decorations!
72 dsBracket brack splices
73 = dsExtendMetaEnv new_bit (do_brack brack)
75 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
77 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
78 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
79 do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
80 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
81 do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
82 do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
84 {- -------------- Examples --------------------
88 gensym (unpackString "x"#) `bindQ` \ x1::String ->
89 lam (pvar x1) (var x1)
92 [| \x -> $(f [| x |]) |]
94 gensym (unpackString "x"#) `bindQ` \ x1::String ->
95 lam (pvar x1) (f (var x1))
99 -------------------------------------------------------
101 -------------------------------------------------------
103 repTopP :: LPat Name -> DsM (Core TH.PatQ)
104 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
105 ; pat' <- addBinds ss (repLP pat)
106 ; wrapNongenSyms ss pat' }
108 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110 = do { let { bndrs = hsGroupBinders group } ;
111 ss <- mkGenSyms bndrs ;
113 -- Bind all the names mainly to avoid repeated use of explicit strings.
115 -- do { t :: String <- genSym "T" ;
116 -- return (Data t [] ...more t's... }
117 -- The other important reason is that the output must mention
118 -- only "T", not "Foo:T" where Foo is the current module
121 decls <- addBinds ss (do {
122 val_ds <- rep_val_binds (hs_valds group) ;
123 tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
124 inst_ds <- mapM repInstD' (hs_instds group) ;
125 for_ds <- mapM repForD (hs_fords group) ;
127 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
129 decl_ty <- lookupType decQTyConName ;
130 let { core_list = coreList' decl_ty decls } ;
132 dec_ty <- lookupType decTyConName ;
133 q_decs <- repSequenceQ dec_ty core_list ;
135 wrapNongenSyms ss q_decs
136 -- Do *not* gensym top-level binders
140 {- Note [Binders and occurrences]
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 When we desugar [d| data T = MkT |]
144 Data "T" [] [Con "MkT" []] []
146 Data "Foo:T" [] [Con "Foo:MkT" []] []
147 That is, the new data decl should fit into whatever new module it is
148 asked to fit in. We do *not* clone, though; no need for this:
155 then we must desugar to
156 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
158 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
159 And we use lookupOcc, rather than lookupBinder
160 in repTyClD and repC.
164 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
166 repTyClD tydecl@(L _ (TyFamily {}))
167 = repTyFamily tydecl addTyVarBinds
169 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
170 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
171 tcdCons = cons, tcdDerivs = mb_derivs }))
172 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
173 ; dec <- addTyVarBinds tvs $ \bndrs ->
174 do { cxt1 <- repLContext cxt
175 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
176 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
177 ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons
178 ; cons2 <- coreList conQTyConName cons1
179 ; derivs1 <- repDerivs mb_derivs
180 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
181 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
183 ; return $ Just (loc, dec)
186 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
187 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
188 tcdCons = [con], tcdDerivs = mb_derivs }))
189 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
190 ; dec <- addTyVarBinds tvs $ \bndrs ->
191 do { cxt1 <- repLContext cxt
192 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
193 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
194 ; con1 <- repC (hsLTyVarNames tvs) con
195 ; derivs1 <- repDerivs mb_derivs
196 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
197 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
199 ; return $ Just (loc, dec)
202 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
204 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
205 ; dec <- addTyVarBinds tvs $ \bndrs ->
206 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
207 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
209 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
210 ; repTySyn tc1 bndrs1 opt_tys2 ty1
212 ; return (Just (loc, dec))
215 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
216 tcdTyVars = tvs, tcdFDs = fds,
217 tcdSigs = sigs, tcdMeths = meth_binds,
219 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
220 ; dec <- addTyVarBinds tvs $ \bndrs ->
221 do { cxt1 <- repLContext cxt
222 ; sigs1 <- rep_sigs sigs
223 ; binds1 <- rep_binds meth_binds
224 ; fds1 <- repLFunDeps fds
225 ; ats1 <- repLAssocFamilys ats
226 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
227 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
228 ; repClass cxt1 cls1 bndrs1 fds1 decls1
230 ; return $ Just (loc, dec)
234 repTyClD (L loc d) = putSrcSpanDs loc $
235 do { warnDs (hang ds_msg 4 (ppr d))
238 -- The type variables in the head of families are treated differently when the
239 -- family declaration is associated. In that case, they are usage, not binding
242 repTyFamily :: LTyClDecl Name
243 -> ProcessTyVarBinds TH.Dec
244 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
245 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
246 tcdLName = tc, tcdTyVars = tvs,
247 tcdKind = opt_kind }))
249 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
250 ; dec <- tyVarBinds tvs $ \bndrs ->
251 do { flav <- repFamilyFlavour flavour
252 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
254 Nothing -> repFamilyNoKind flav tc1 bndrs1
255 Just ki -> do { ki1 <- repKind ki
256 ; repFamilyKind flav tc1 bndrs1 ki1
259 ; return $ Just (loc, dec)
261 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
265 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
266 repLFunDeps fds = do fds' <- mapM repLFunDep fds
267 fdList <- coreList funDepTyConName fds'
270 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
271 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
272 ys' <- mapM lookupBinder ys
273 xs_list <- coreList nameTyConName xs'
274 ys_list <- coreList nameTyConName ys'
275 repFunDep xs_list ys_list
277 -- represent family declaration flavours
279 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
280 repFamilyFlavour TypeFamily = rep2 typeFamName []
281 repFamilyFlavour DataFamily = rep2 dataFamName []
283 -- represent associated family declarations
285 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
286 repLAssocFamilys = mapM repLAssocFamily
288 repLAssocFamily tydecl@(L _ (TyFamily {}))
289 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
290 repLAssocFamily tydecl
293 msg = ptext (sLit "Illegal associated declaration in class:") <+>
296 -- represent associated family instances
298 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
299 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
301 -- represent instance declarations
303 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
304 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
305 = do { i <- addTyVarBinds tvs $ \_ ->
306 -- We must bring the type variables into scope, so their
307 -- occurrences don't fail, even though the binders don't
308 -- appear in the resulting data structure
309 do { cxt1 <- repContext cxt
310 ; inst_ty1 <- repPredTy (HsClassP cls tys)
311 ; ss <- mkGenSyms (collectHsBindsBinders binds)
312 ; binds1 <- addBinds ss (rep_binds binds)
313 ; ats1 <- repLAssocFamInst ats
314 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
315 ; decls2 <- wrapNongenSyms ss decls1
316 -- wrapNongenSyms: do not clone the class op names!
317 -- They must be called 'op' etc, not 'op34'
318 ; repInst cxt1 inst_ty1 (decls2)
322 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
324 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
325 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
326 = do MkC name' <- lookupLOcc name
327 MkC typ' <- repLTy typ
328 MkC cc' <- repCCallConv cc
329 MkC s' <- repSafety s
330 cis' <- conv_cimportspec cis
331 MkC str <- coreStringLit $ static
332 ++ unpackFS ch ++ " "
334 dec <- rep2 forImpDName [cc', s', str, name', typ']
337 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
338 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
339 conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
340 conv_cimportspec CWrapper = return "wrapper"
342 CFunction (StaticTarget _ _) -> "static "
344 repForD decl = notHandled "Foreign declaration" (ppr decl)
346 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
347 repCCallConv CCallConv = rep2 cCallName []
348 repCCallConv StdCallConv = rep2 stdCallName []
349 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
351 repSafety :: Safety -> DsM (Core TH.Safety)
352 repSafety PlayRisky = rep2 unsafeName []
353 repSafety PlayInterruptible = rep2 interruptibleName []
354 repSafety (PlaySafe False) = rep2 safeName []
355 repSafety (PlaySafe True) = rep2 threadsafeName []
358 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
360 -------------------------------------------------------
362 -------------------------------------------------------
364 repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
365 repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
366 , con_details = details, con_res = ResTyH98 }))
367 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
368 ; repConstr con1 details }
369 repC tvs (L _ (ConDecl { con_name = con
370 , con_qvars = con_tvs, con_cxt = L _ ctxt
371 , con_details = details
372 , con_res = res_ty }))
373 = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
374 ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
375 ; binds <- mapM dupBinder con_tv_subst
376 ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
377 addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
378 do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
379 ; c' <- repConstr con1 details
380 ; ctxt' <- repContext (eq_ctxt ++ ctxt)
381 ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs
382 ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } }
384 in_subst :: Name -> [(Name,Name)] -> Bool
385 in_subst _ [] = False
386 in_subst n ((n',_):ns) = n==n' || in_subst n ns
388 mkGadtCtxt :: [Name] -- Tyvars of the data type
390 -> DsM (HsContext Name, [(Name,Name)])
391 -- Given a data type in GADT syntax, figure out the equality
392 -- context, so that we can represent it with an explicit
393 -- equality context, because that is the only way to express
394 -- the GADT in TH syntax
397 -- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
398 -- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
400 -- (b~[e], c~e), [d->a]
402 -- This function is fiddly, but not really hard
403 mkGadtCtxt _ ResTyH98
405 mkGadtCtxt data_tvs (ResTyGADT res_ty)
406 | let (head_ty, tys) = splitHsAppTys res_ty []
407 , Just _ <- is_hs_tyvar head_ty
408 , data_tvs `equalLength` tys
409 = return (go [] [] (data_tvs `zip` tys))
412 = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty)
414 go cxt subst [] = (cxt, subst)
415 go cxt subst ((data_tv, ty) : rest)
416 | Just con_tv <- is_hs_tyvar ty
418 , not (in_subst con_tv subst)
419 = go cxt ((con_tv, data_tv) : subst) rest
421 = go (eq_pred : cxt) subst rest
424 eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty)
426 is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
427 is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
428 is_hs_tyvar _ = Nothing
431 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
435 rep2 strictTypeName [s, t]
437 (str, ty') = case ty of
438 L _ (HsBangTy _ ty) -> (isStrictName, ty)
439 _ -> (notStrictName, ty)
441 -------------------------------------------------------
443 -------------------------------------------------------
445 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
446 repDerivs Nothing = coreList nameTyConName []
447 repDerivs (Just ctxt)
448 = do { strs <- mapM rep_deriv ctxt ;
449 coreList nameTyConName strs }
451 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
452 -- Deriving clauses must have the simple H98 form
453 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
454 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
457 -------------------------------------------------------
458 -- Signatures in a class decl, or a group of bindings
459 -------------------------------------------------------
461 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
462 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
463 return $ de_loc $ sort_by_loc locs_cores
465 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
466 -- We silently ignore ones we don't recognise
467 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
468 return (concat sigs1) }
470 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
472 -- Empty => Too hard, signature ignored
473 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
474 rep_sig (L _ (GenericSig nm _)) = failWithDs msg
475 where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
476 , ptext (sLit "Default signatures are not supported by Template Haskell") ]
478 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
479 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
480 rep_sig _ = return []
482 rep_proto :: Located Name -> LHsType Name -> SrcSpan
483 -> DsM [(SrcSpan, Core TH.DecQ)]
485 = do { nm1 <- lookupLOcc nm
487 ; sig <- repProto nm1 ty1
488 ; return [(loc, sig)]
491 rep_inline :: Located Name
492 -> InlinePragma -- Never defaultInlinePragma
494 -> DsM [(SrcSpan, Core TH.DecQ)]
495 rep_inline nm ispec loc
496 = do { nm1 <- lookupLOcc nm
497 ; ispec1 <- rep_InlinePrag ispec
498 ; pragma <- repPragInl nm1 ispec1
499 ; return [(loc, pragma)]
502 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
503 -> DsM [(SrcSpan, Core TH.DecQ)]
504 rep_specialise nm ty ispec loc
505 = do { nm1 <- lookupLOcc nm
507 ; pragma <- if isDefaultInlinePragma ispec
508 then repPragSpec nm1 ty1 -- SPECIALISE
509 else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
510 ; repPragSpecInl nm1 ty1 ispec1 }
511 ; return [(loc, pragma)]
514 -- Extract all the information needed to build a TH.InlinePrag
516 rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
517 -> DsM (Core TH.InlineSpecQ)
518 rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
519 | Just (flag, phase) <- activation1
520 = repInlineSpecPhase inline1 match1 flag phase
522 = repInlineSpecNoPhase inline1 match1
524 match1 = coreBool (rep_RuleMatchInfo match)
525 activation1 = rep_Activation activation
526 inline1 = case inline of
527 Inline -> coreBool True
528 _other -> coreBool False
529 -- We have no representation for Inlinable
531 rep_RuleMatchInfo FunLike = False
532 rep_RuleMatchInfo ConLike = True
534 rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
535 rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
536 rep_Activation (ActiveBefore phase) = Just (coreBool False,
537 MkC $ mkIntExprInt phase)
538 rep_Activation (ActiveAfter phase) = Just (coreBool True,
539 MkC $ mkIntExprInt phase)
542 -------------------------------------------------------
544 -------------------------------------------------------
546 -- We process type variable bindings in two ways, either by generating fresh
547 -- names or looking up existing names. The difference is crucial for type
548 -- families, depending on whether they are associated or not.
550 type ProcessTyVarBinds a =
551 [LHsTyVarBndr Name] -- the binders to be added
552 -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
553 -> DsM (Core (TH.Q a))
555 -- gensym a list of type variables and enter them into the meta environment;
556 -- the computations passed as the second argument is executed in that extended
557 -- meta environment and gets the *new* names on Core-level as an argument
559 addTyVarBinds :: ProcessTyVarBinds a
561 = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
562 ; term <- addBinds freshNames $
563 do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames)
565 ; wrapGenSyms freshNames term }
567 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
569 -- Look up a list of type variables; the computations passed as the second
570 -- argument gets the *new* names on Core-level as an argument
572 lookupTyVarBinds :: ProcessTyVarBinds a
573 lookupTyVarBinds tvs m =
575 let names = hsLTyVarNames tvs
576 mkWithKinds = map repTyVarBndrWithKind tvs
577 bndrs <- mapM lookupBinder names
578 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
581 -- Produce kinded binder constructors from the Haskell tyvar binders
583 repTyVarBndrWithKind :: LHsTyVarBndr Name
584 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
585 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
587 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
588 = repKind ki >>= repKindedTV nm
590 -- represent a type context
592 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
593 repLContext (L _ ctxt) = repContext ctxt
595 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
597 preds <- mapM repLPred ctxt
598 predList <- coreList predQTyConName preds
601 -- represent a type predicate
603 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
604 repLPred (L _ p) = repPred p
606 repPred :: HsPred Name -> DsM (Core TH.PredQ)
607 repPred (HsClassP cls tys)
609 cls1 <- lookupOcc cls
611 tys2 <- coreList typeQTyConName tys1
613 repPred (HsEqualP tyleft tyright)
615 tyleft1 <- repLTy tyleft
616 tyright1 <- repLTy tyright
617 repEqualP tyleft1 tyright1
618 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
620 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
621 repPredTy (HsClassP cls tys)
623 tcon <- repTy (HsTyVar cls)
626 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
628 -- yield the representation of a list of types
630 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
631 repLTys tys = mapM repLTy tys
635 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
636 repLTy (L _ ty) = repTy ty
638 repTy :: HsType Name -> DsM (Core TH.TypeQ)
639 repTy (HsForAllTy _ tvs ctxt ty) =
640 addTyVarBinds tvs $ \bndrs -> do
641 ctxt1 <- repLContext ctxt
643 bndrs1 <- coreList tyVarBndrTyConName bndrs
644 repTForall bndrs1 ctxt1 ty1
647 | isTvOcc (nameOccName n) = do
653 repTy (HsAppTy f a) = do
657 repTy (HsFunTy f a) = do
660 tcon <- repArrowTyCon
661 repTapps tcon [f1, a1]
662 repTy (HsListTy t) = do
666 repTy (HsPArrTy t) = do
668 tcon <- repTy (HsTyVar (tyConName parrTyCon))
670 repTy (HsTupleTy Boxed tys) = do
672 tcon <- repTupleTyCon (length tys)
674 repTy (HsTupleTy Unboxed tys) = do
676 tcon <- repUnboxedTupleTyCon (length tys)
678 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
680 repTy (HsParTy t) = repLTy t
681 repTy (HsPredTy pred) = repPredTy pred
682 repTy (HsKindSig t k) = do
686 repTy (HsSpliceTy splice _ _) = repSplice splice
687 repTy ty = notHandled "Exotic form of type" (ppr ty)
691 repKind :: Kind -> DsM (Core TH.Kind)
693 = do { let (kis, ki') = splitKindFunTys ki
694 ; kis_rep <- mapM repKind kis
695 ; ki'_rep <- repNonArrowKind ki'
696 ; foldrM repArrowK ki'_rep kis_rep
699 repNonArrowKind k | isLiftedTypeKind k = repStarK
700 | otherwise = notHandled "Exotic form of kind"
703 -----------------------------------------------------------------------------
705 -----------------------------------------------------------------------------
707 repSplice :: HsSplice Name -> DsM (Core a)
708 -- See Note [How brackets and nested splices are handled] in TcSplice
709 -- We return a CoreExpr of any old type; the context should know
710 repSplice (HsSplice n _)
711 = do { mb_val <- dsLookupMetaEnv n
713 Just (Splice e) -> do { e' <- dsExpr e
715 _ -> pprPanic "HsSplice" (ppr n) }
716 -- Should not happen; statically checked
718 -----------------------------------------------------------------------------
720 -----------------------------------------------------------------------------
722 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
723 repLEs es = do { es' <- mapM repLE es ;
724 coreList expQTyConName es' }
726 -- FIXME: some of these panics should be converted into proper error messages
727 -- unless we can make sure that constructs, which are plainly not
728 -- supported in TH already lead to error messages at an earlier stage
729 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
730 repLE (L loc e) = putSrcSpanDs loc (repE e)
732 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
734 do { mb_val <- dsLookupMetaEnv x
736 Nothing -> do { str <- globalVar x
737 ; repVarOrCon x str }
738 Just (Bound y) -> repVarOrCon x (coreVar y)
739 Just (Splice e) -> do { e' <- dsExpr e
740 ; return (MkC e') } }
741 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
743 -- Remember, we're desugaring renamer output here, so
744 -- HsOverlit can definitely occur
745 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
746 repE (HsLit l) = do { a <- repLiteral l; repLit a }
747 repE (HsLam (MatchGroup [m] _)) = repLambda m
748 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
750 repE (OpApp e1 op _ e2) =
751 do { arg1 <- repLE e1;
754 repInfixApp arg1 the_op arg2 }
755 repE (NegApp x _) = do
757 negateVar <- lookupOcc negateName >>= repVar
759 repE (HsPar x) = repLE x
760 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
761 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
762 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
763 ; ms2 <- mapM repMatchTup ms
764 ; repCaseE arg (nonEmptyCoreList ms2) }
765 repE (HsIf _ x y z) = do
770 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
771 ; e2 <- addBinds ss (repLE e)
775 -- FIXME: I haven't got the types here right yet
776 repE e@(HsDo ctxt sts _)
777 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
778 = do { (ss,zs) <- repLSts sts;
779 e' <- repDoE (nonEmptyCoreList zs);
783 = do { (ss,zs) <- repLSts sts;
784 e' <- repComp (nonEmptyCoreList zs);
788 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
790 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
791 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
792 repE e@(ExplicitTuple es boxed)
793 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
794 | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
795 | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
797 repE (RecordCon c _ flds)
798 = do { x <- lookupLOcc c;
799 fs <- repFields flds;
801 repE (RecordUpd e flds _ _ _)
803 fs <- repFields flds;
806 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
807 repE (ArithSeq _ aseq) =
809 From e -> do { ds1 <- repLE e; repFrom ds1 }
818 FromThenTo e1 e2 e3 -> do
822 repFromThenTo ds1 ds2 ds3
824 repE (HsSpliceE splice) = repSplice splice
825 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
826 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
827 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
828 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
829 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
830 repE e = notHandled "Expression form" (ppr e)
832 -----------------------------------------------------------------------------
833 -- Building representations of auxillary structures like Match, Clause, Stmt,
835 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
836 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
837 do { ss1 <- mkGenSyms (collectPatBinders p)
838 ; addBinds ss1 $ do {
840 ; (ss2,ds) <- repBinds wheres
841 ; addBinds ss2 $ do {
842 ; gs <- repGuards guards
843 ; match <- repMatch p1 gs ds
844 ; wrapGenSyms (ss1++ss2) match }}}
845 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
847 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
848 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
849 do { ss1 <- mkGenSyms (collectPatsBinders ps)
850 ; addBinds ss1 $ do {
852 ; (ss2,ds) <- repBinds wheres
853 ; addBinds ss2 $ do {
854 gs <- repGuards guards
855 ; clause <- repClause ps1 gs ds
856 ; wrapGenSyms (ss1++ss2) clause }}}
858 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
859 repGuards [L _ (GRHS [] e)]
860 = do {a <- repLE e; repNormal a }
862 = do { zs <- mapM process other;
863 let {(xs, ys) = unzip zs};
864 gd <- repGuarded (nonEmptyCoreList ys);
865 wrapGenSyms (concat xs) gd }
867 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
868 process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
869 = do { x <- repLNormalGE e1 e2;
871 process (L _ (GRHS ss rhs))
872 = do (gs, ss') <- repLSts ss
873 rhs' <- addBinds gs $ repLE rhs
874 g <- repPatGE (nonEmptyCoreList ss') rhs'
877 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
878 repFields (HsRecFields { rec_flds = flds })
879 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
880 ; es <- mapM repLE (map hsRecFieldArg flds)
881 ; fs <- zipWithM repFieldExp fnames es
882 ; coreList fieldExpQTyConName fs }
885 -----------------------------------------------------------------------------
886 -- Representing Stmt's is tricky, especially if bound variables
887 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
888 -- First gensym new names for every variable in any of the patterns.
889 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
890 -- if variables didn't shaddow, the static gensym wouldn't be necessary
891 -- and we could reuse the original names (x and x).
893 -- do { x'1 <- gensym "x"
894 -- ; x'2 <- gensym "x"
895 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
896 -- , BindSt (pvar x'2) [| f x |]
897 -- , NoBindSt [| g x |]
901 -- The strategy is to translate a whole list of do-bindings by building a
902 -- bigger environment, and a bigger set of meta bindings
903 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
904 -- of the expressions within the Do
906 -----------------------------------------------------------------------------
907 -- The helper function repSts computes the translation of each sub expression
908 -- and a bunch of prefix bindings denoting the dynamic renaming.
910 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
911 repLSts stmts = repSts (map unLoc stmts)
913 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
914 repSts (BindStmt p e _ _ : ss) =
916 ; ss1 <- mkGenSyms (collectPatBinders p)
917 ; addBinds ss1 $ do {
919 ; (ss2,zs) <- repSts ss
920 ; z <- repBindSt p1 e2
921 ; return (ss1++ss2, z : zs) }}
922 repSts (LetStmt bs : ss) =
923 do { (ss1,ds) <- repBinds bs
925 ; (ss2,zs) <- addBinds ss1 (repSts ss)
926 ; return (ss1++ss2, z : zs) }
927 repSts (ExprStmt e _ _ _ : ss) =
929 ; z <- repNoBindSt e2
930 ; (ss2,zs) <- repSts ss
931 ; return (ss2, z : zs) }
932 repSts [LastStmt e _]
934 ; z <- repNoBindSt e2
936 repSts [] = return ([],[])
937 repSts other = notHandled "Exotic statement" (ppr other)
940 -----------------------------------------------------------
942 -----------------------------------------------------------
944 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
945 repBinds EmptyLocalBinds
946 = do { core_list <- coreList decQTyConName []
947 ; return ([], core_list) }
949 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
951 repBinds (HsValBinds decs)
952 = do { let { bndrs = collectHsValBinders decs }
953 -- No need to worrry about detailed scopes within
954 -- the binding group, because we are talking Names
955 -- here, so we can safely treat it as a mutually
957 ; ss <- mkGenSyms bndrs
958 ; prs <- addBinds ss (rep_val_binds decs)
959 ; core_list <- coreList decQTyConName
960 (de_loc (sort_by_loc prs))
961 ; return (ss, core_list) }
963 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
964 -- Assumes: all the binders of the binding are alrady in the meta-env
965 rep_val_binds (ValBindsOut binds sigs)
966 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
967 ; core2 <- rep_sigs' sigs
968 ; return (core1 ++ core2) }
969 rep_val_binds (ValBindsIn _ _)
970 = panic "rep_val_binds: ValBindsIn"
972 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
973 rep_binds binds = do { binds_w_locs <- rep_binds' binds
974 ; return (de_loc (sort_by_loc binds_w_locs)) }
976 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
977 rep_binds' binds = mapM rep_bind (bagToList binds)
979 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
980 -- Assumes: all the binders of the binding are alrady in the meta-env
982 -- Note GHC treats declarations of a variable (not a pattern)
983 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
984 -- with an empty list of patterns
985 rep_bind (L loc (FunBind { fun_id = fn,
986 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
987 = do { (ss,wherecore) <- repBinds wheres
988 ; guardcore <- addBinds ss (repGuards guards)
989 ; fn' <- lookupLBinder fn
991 ; ans <- repVal p guardcore wherecore
992 ; ans' <- wrapGenSyms ss ans
993 ; return (loc, ans') }
995 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
996 = do { ms1 <- mapM repClauseTup ms
997 ; fn' <- lookupLBinder fn
998 ; ans <- repFun fn' (nonEmptyCoreList ms1)
999 ; return (loc, ans) }
1001 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1002 = do { patcore <- repLP pat
1003 ; (ss,wherecore) <- repBinds wheres
1004 ; guardcore <- addBinds ss (repGuards guards)
1005 ; ans <- repVal patcore guardcore wherecore
1006 ; ans' <- wrapGenSyms ss ans
1007 ; return (loc, ans') }
1009 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1010 = do { v' <- lookupBinder v
1013 ; patcore <- repPvar v'
1014 ; empty_decls <- coreList decQTyConName []
1015 ; ans <- repVal patcore x empty_decls
1016 ; return (srcLocSpan (getSrcLoc v), ans) }
1018 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1020 -----------------------------------------------------------------------------
1021 -- Since everything in a Bind is mutually recursive we need rename all
1022 -- all the variables simultaneously. For example:
1023 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1024 -- do { f'1 <- gensym "f"
1025 -- ; g'2 <- gensym "g"
1026 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1027 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1029 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1030 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1031 -- together. As we do this we collect GenSymBinds's which represent the renamed
1032 -- variables bound by the Bindings. In order not to lose track of these
1033 -- representations we build a shadow datatype MB with the same structure as
1034 -- MonoBinds, but which has slots for the representations
1037 -----------------------------------------------------------------------------
1038 -- GHC allows a more general form of lambda abstraction than specified
1039 -- by Haskell 98. In particular it allows guarded lambda's like :
1040 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1041 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1042 -- (\ p1 .. pn -> exp) by causing an error.
1044 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
1045 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1046 = do { let bndrs = collectPatsBinders ps ;
1047 ; ss <- mkGenSyms bndrs
1048 ; lam <- addBinds ss (
1049 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1050 ; wrapGenSyms ss lam }
1052 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1055 -----------------------------------------------------------------------------
1057 -- repP deals with patterns. It assumes that we have already
1058 -- walked over the pattern(s) once to collect the binders, and
1059 -- have extended the environment. So every pattern-bound
1060 -- variable should already appear in the environment.
1062 -- Process a list of patterns
1063 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1064 repLPs ps = do { ps' <- mapM repLP ps ;
1065 coreList patQTyConName ps' }
1067 repLP :: LPat Name -> DsM (Core TH.PatQ)
1068 repLP (L _ p) = repP p
1070 repP :: Pat Name -> DsM (Core TH.PatQ)
1071 repP (WildPat _) = repPwild
1072 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1073 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1074 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1075 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1076 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1077 repP (ParPat p) = repLP p
1078 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1079 repP (TuplePat ps boxed _)
1080 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1081 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1082 repP (ConPatIn dc details)
1083 = do { con_str <- lookupLOcc dc
1085 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1086 RecCon rec -> do { let flds = rec_flds rec
1087 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1088 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1089 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1090 ; fps' <- coreList fieldPatQTyConName fps
1091 ; repPrec con_str fps' }
1092 InfixCon p1 p2 -> do { p1' <- repLP p1;
1094 repPinfix p1' con_str p2' }
1096 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1097 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1098 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1099 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1100 -- The problem is to do with scoped type variables.
1101 -- To implement them, we have to implement the scoping rules
1102 -- here in DsMeta, and I don't want to do that today!
1103 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1104 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1105 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1107 repP other = notHandled "Exotic pattern" (ppr other)
1109 ----------------------------------------------------------
1110 -- Declaration ordering helpers
1112 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1113 sort_by_loc xs = sortBy comp xs
1114 where comp x y = compare (fst x) (fst y)
1116 de_loc :: [(a, b)] -> [b]
1119 ----------------------------------------------------------
1120 -- The meta-environment
1122 -- A name/identifier association for fresh names of locally bound entities
1123 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1124 -- I.e. (x, x_id) means
1125 -- let x_id = gensym "x" in ...
1127 -- Generate a fresh name for a locally bound entity
1129 mkGenSyms :: [Name] -> DsM [GenSymBind]
1130 -- We can use the existing name. For example:
1131 -- [| \x_77 -> x_77 + x_77 |]
1133 -- do { x_77 <- genSym "x"; .... }
1134 -- We use the same x_77 in the desugared program, but with the type Bndr
1137 -- We do make it an Internal name, though (hence localiseName)
1139 -- Nevertheless, it's monadic because we have to generate nameTy
1140 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1141 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1144 addBinds :: [GenSymBind] -> DsM a -> DsM a
1145 -- Add a list of fresh names for locally bound entities to the
1146 -- meta environment (which is part of the state carried around
1147 -- by the desugarer monad)
1148 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1150 -- Look up a locally bound name
1152 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1153 lookupLBinder (L _ n) = lookupBinder n
1155 lookupBinder :: Name -> DsM (Core TH.Name)
1157 = do { mb_val <- dsLookupMetaEnv n;
1159 Just (Bound x) -> return (coreVar x)
1160 _ -> failWithDs msg }
1162 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1164 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1165 dupBinder (new, old)
1166 = do { mb_val <- dsLookupMetaEnv old
1168 Just val -> return (new, val)
1169 Nothing -> pprPanic "dupBinder" (ppr old) }
1171 -- Look up a name that is either locally bound or a global name
1173 -- * If it is a global name, generate the "original name" representation (ie,
1174 -- the <module>:<name> form) for the associated entity
1176 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1177 -- Lookup an occurrence; it can't be a splice.
1178 -- Use the in-scope bindings if they exist
1179 lookupLOcc (L _ n) = lookupOcc n
1181 lookupOcc :: Name -> DsM (Core TH.Name)
1183 = do { mb_val <- dsLookupMetaEnv n ;
1185 Nothing -> globalVar n
1186 Just (Bound x) -> return (coreVar x)
1187 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1190 lookupTvOcc :: Name -> DsM (Core TH.Name)
1191 -- Type variables can't be staged and are not lexically scoped in TH
1193 = do { mb_val <- dsLookupMetaEnv n ;
1195 Just (Bound x) -> return (coreVar x)
1199 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1200 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1202 globalVar :: Name -> DsM (Core TH.Name)
1203 -- Not bound by the meta-env
1204 -- Could be top-level; or could be local
1205 -- f x = $(g [| x |])
1206 -- Here the x will be local
1208 | isExternalName name
1209 = do { MkC mod <- coreStringLit name_mod
1210 ; MkC pkg <- coreStringLit name_pkg
1211 ; MkC occ <- occNameLit name
1212 ; rep2 mk_varg [pkg,mod,occ] }
1214 = do { MkC occ <- occNameLit name
1215 ; MkC uni <- coreIntLit (getKey (getUnique name))
1216 ; rep2 mkNameLName [occ,uni] }
1218 mod = ASSERT( isExternalName name) nameModule name
1219 name_mod = moduleNameString (moduleName mod)
1220 name_pkg = packageIdString (modulePackageId mod)
1221 name_occ = nameOccName name
1222 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1223 | OccName.isVarOcc name_occ = mkNameG_vName
1224 | OccName.isTcOcc name_occ = mkNameG_tcName
1225 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1227 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1228 -> DsM Type -- The type
1229 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1230 return (mkTyConApp tc []) }
1232 wrapGenSyms :: [GenSymBind]
1233 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1234 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1235 -- --> bindQ (gensym nm1) (\ id1 ->
1236 -- bindQ (gensym nm2 (\ id2 ->
1239 wrapGenSyms binds body@(MkC b)
1240 = do { var_ty <- lookupType nameTyConName
1243 [elt_ty] = tcTyConAppArgs (exprType b)
1244 -- b :: Q a, so we can get the type 'a' by looking at the
1245 -- argument type. NB: this relies on Q being a data/newtype,
1246 -- not a type synonym
1248 go _ [] = return body
1249 go var_ty ((name,id) : binds)
1250 = do { MkC body' <- go var_ty binds
1251 ; lit_str <- occNameLit name
1252 ; gensym_app <- repGensym lit_str
1253 ; repBindQ var_ty elt_ty
1254 gensym_app (MkC (Lam id body')) }
1256 -- Just like wrapGenSym, but don't actually do the gensym
1257 -- Instead use the existing name:
1258 -- let x = "x" in ...
1259 -- Only used for [Decl], and for the class ops in class
1260 -- and instance decls
1261 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1262 wrapNongenSyms binds (MkC body)
1263 = do { binds' <- mapM do_one binds ;
1264 return (MkC (mkLets binds' body)) }
1267 = do { MkC lit_str <- occNameLit name
1268 ; MkC var <- rep2 mkNameName [lit_str]
1269 ; return (NonRec id var) }
1271 occNameLit :: Name -> DsM (Core String)
1272 occNameLit n = coreStringLit (occNameString (nameOccName n))
1275 -- %*********************************************************************
1277 -- Constructing code
1279 -- %*********************************************************************
1281 -----------------------------------------------------------------------------
1282 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1283 -- we invent a new datatype which uses phantom types.
1285 newtype Core a = MkC CoreExpr
1286 unC :: Core a -> CoreExpr
1289 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1290 rep2 n xs = do { id <- dsLookupGlobalId n
1291 ; return (MkC (foldl App (Var id) xs)) }
1293 -- Then we make "repConstructors" which use the phantom types for each of the
1294 -- smart constructors of the Meta.Meta datatypes.
1297 -- %*********************************************************************
1299 -- The 'smart constructors'
1301 -- %*********************************************************************
1303 --------------- Patterns -----------------
1304 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1305 repPlit (MkC l) = rep2 litPName [l]
1307 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1308 repPvar (MkC s) = rep2 varPName [s]
1310 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1311 repPtup (MkC ps) = rep2 tupPName [ps]
1313 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1314 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1316 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1317 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1319 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1320 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1322 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1323 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1325 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1326 repPtilde (MkC p) = rep2 tildePName [p]
1328 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1329 repPbang (MkC p) = rep2 bangPName [p]
1331 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1332 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1334 repPwild :: DsM (Core TH.PatQ)
1335 repPwild = rep2 wildPName []
1337 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1338 repPlist (MkC ps) = rep2 listPName [ps]
1340 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1341 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1343 --------------- Expressions -----------------
1344 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1345 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1346 | otherwise = repVar str
1348 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1349 repVar (MkC s) = rep2 varEName [s]
1351 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1352 repCon (MkC s) = rep2 conEName [s]
1354 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1355 repLit (MkC c) = rep2 litEName [c]
1357 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1358 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1360 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1361 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1363 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1364 repTup (MkC es) = rep2 tupEName [es]
1366 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1367 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1369 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1370 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1372 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1373 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1375 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1376 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1378 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1379 repDoE (MkC ss) = rep2 doEName [ss]
1381 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1382 repComp (MkC ss) = rep2 compEName [ss]
1384 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1385 repListExp (MkC es) = rep2 listEName [es]
1387 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1388 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1390 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1391 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1393 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1394 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1396 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1397 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1399 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1400 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1402 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1403 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1405 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1406 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1408 ------------ Right hand sides (guarded expressions) ----
1409 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1410 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1412 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1413 repNormal (MkC e) = rep2 normalBName [e]
1415 ------------ Guards ----
1416 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1417 repLNormalGE g e = do g' <- repLE g
1421 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1422 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1424 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1425 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1427 ------------- Stmts -------------------
1428 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1429 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1431 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1432 repLetSt (MkC ds) = rep2 letSName [ds]
1434 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1435 repNoBindSt (MkC e) = rep2 noBindSName [e]
1437 -------------- Range (Arithmetic sequences) -----------
1438 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1439 repFrom (MkC x) = rep2 fromEName [x]
1441 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1442 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1444 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1445 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1447 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1448 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1450 ------------ Match and Clause Tuples -----------
1451 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1452 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1454 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1455 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1457 -------------- Dec -----------------------------
1458 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1459 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1461 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1462 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1464 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1465 -> Maybe (Core [TH.TypeQ])
1466 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1467 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1468 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1469 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1470 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1472 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1473 -> Maybe (Core [TH.TypeQ])
1474 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1475 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1476 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1477 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1478 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1480 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1481 -> Maybe (Core [TH.TypeQ])
1482 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1483 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1484 = rep2 tySynDName [nm, tvs, rhs]
1485 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1486 = rep2 tySynInstDName [nm, tys, rhs]
1488 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1489 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1491 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1492 -> Core [TH.FunDep] -> Core [TH.DecQ]
1493 -> DsM (Core TH.DecQ)
1494 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1495 = rep2 classDName [cxt, cls, tvs, fds, ds]
1497 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1498 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1500 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1501 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1503 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1504 -> DsM (Core TH.DecQ)
1505 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1506 = rep2 pragSpecInlDName [nm, ty, ispec]
1508 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1509 -> DsM (Core TH.DecQ)
1510 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1511 = rep2 familyNoKindDName [flav, nm, tvs]
1513 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1515 -> DsM (Core TH.DecQ)
1516 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1517 = rep2 familyKindDName [flav, nm, tvs, ki]
1519 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1520 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1521 = rep2 inlineSpecNoPhaseName [inline, conlike]
1523 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1524 -> DsM (Core TH.InlineSpecQ)
1525 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1526 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1528 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1529 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1531 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1532 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1534 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1535 repCtxt (MkC tys) = rep2 cxtName [tys]
1537 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1538 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1540 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1541 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1543 repConstr :: Core TH.Name -> HsConDeclDetails Name
1544 -> DsM (Core TH.ConQ)
1545 repConstr con (PrefixCon ps)
1546 = do arg_tys <- mapM repBangTy ps
1547 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1548 rep2 normalCName [unC con, unC arg_tys1]
1549 repConstr con (RecCon ips)
1550 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1551 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1552 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1554 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1555 rep2 recCName [unC con, unC arg_vtys']
1556 repConstr con (InfixCon st1 st2)
1557 = do arg1 <- repBangTy st1
1558 arg2 <- repBangTy st2
1559 rep2 infixCName [unC arg1, unC con, unC arg2]
1561 ------------ Types -------------------
1563 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1564 -> DsM (Core TH.TypeQ)
1565 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1566 = rep2 forallTName [tvars, ctxt, ty]
1568 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1569 repTvar (MkC s) = rep2 varTName [s]
1571 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1572 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1574 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1575 repTapps f [] = return f
1576 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1578 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1579 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1581 --------- Type constructors --------------
1583 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1584 repNamedTyCon (MkC s) = rep2 conTName [s]
1586 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1587 -- Note: not Core Int; it's easier to be direct here
1588 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1590 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1591 -- Note: not Core Int; it's easier to be direct here
1592 repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
1594 repArrowTyCon :: DsM (Core TH.TypeQ)
1595 repArrowTyCon = rep2 arrowTName []
1597 repListTyCon :: DsM (Core TH.TypeQ)
1598 repListTyCon = rep2 listTName []
1600 ------------ Kinds -------------------
1602 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1603 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1605 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1606 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1608 repStarK :: DsM (Core TH.Kind)
1609 repStarK = rep2 starKName []
1611 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1612 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1614 ----------------------------------------------------------
1617 repLiteral :: HsLit -> DsM (Core TH.Lit)
1619 = do lit' <- case lit of
1620 HsIntPrim i -> mk_integer i
1621 HsWordPrim w -> mk_integer w
1622 HsInt i -> mk_integer i
1623 HsFloatPrim r -> mk_rational r
1624 HsDoublePrim r -> mk_rational r
1626 lit_expr <- dsLit lit'
1628 Just lit_name -> rep2 lit_name [lit_expr]
1629 Nothing -> notHandled "Exotic literal" (ppr lit)
1631 mb_lit_name = case lit of
1632 HsInteger _ _ -> Just integerLName
1633 HsInt _ -> Just integerLName
1634 HsIntPrim _ -> Just intPrimLName
1635 HsWordPrim _ -> Just wordPrimLName
1636 HsFloatPrim _ -> Just floatPrimLName
1637 HsDoublePrim _ -> Just doublePrimLName
1638 HsChar _ -> Just charLName
1639 HsString _ -> Just stringLName
1640 HsRat _ _ -> Just rationalLName
1643 mk_integer :: Integer -> DsM HsLit
1644 mk_integer i = do integer_ty <- lookupType integerTyConName
1645 return $ HsInteger i integer_ty
1646 mk_rational :: FractionalLit -> DsM HsLit
1647 mk_rational r = do rat_ty <- lookupType rationalTyConName
1648 return $ HsRat r rat_ty
1649 mk_string :: FastString -> DsM HsLit
1650 mk_string s = return $ HsString s
1652 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1653 repOverloadedLiteral (OverLit { ol_val = val})
1654 = do { lit <- mk_lit val; repLiteral lit }
1655 -- The type Rational will be in the environment, becuase
1656 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1657 -- and rationalL is sucked in when any TH stuff is used
1659 mk_lit :: OverLitVal -> DsM HsLit
1660 mk_lit (HsIntegral i) = mk_integer i
1661 mk_lit (HsFractional f) = mk_rational f
1662 mk_lit (HsIsString s) = mk_string s
1664 --------------- Miscellaneous -------------------
1666 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1667 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1669 repBindQ :: Type -> Type -- a and b
1670 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1671 repBindQ ty_a ty_b (MkC x) (MkC y)
1672 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1674 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1675 repSequenceQ ty_a (MkC list)
1676 = rep2 sequenceQName [Type ty_a, list]
1678 ------------ Lists and Tuples -------------------
1679 -- turn a list of patterns into a single pattern matching a list
1681 coreList :: Name -- Of the TyCon of the element type
1682 -> [Core a] -> DsM (Core [a])
1684 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1686 coreList' :: Type -- The element type
1687 -> [Core a] -> Core [a]
1688 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1690 nonEmptyCoreList :: [Core a] -> Core [a]
1691 -- The list must be non-empty so we can get the element type
1692 -- Otherwise use coreList
1693 nonEmptyCoreList [] = panic "coreList: empty argument"
1694 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1696 coreStringLit :: String -> DsM (Core String)
1697 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1699 ------------ Bool, Literals & Variables -------------------
1701 coreBool :: Bool -> Core Bool
1702 coreBool False = MkC $ mkConApp falseDataCon []
1703 coreBool True = MkC $ mkConApp trueDataCon []
1705 coreIntLit :: Int -> DsM (Core Int)
1706 coreIntLit i = return (MkC (mkIntExprInt i))
1708 coreVar :: Id -> Core TH.Name -- The Id has type Name
1709 coreVar id = MkC (Var id)
1711 ----------------- Failure -----------------------
1712 notHandled :: String -> SDoc -> DsM a
1713 notHandled what doc = failWithDs msg
1715 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1719 -- %************************************************************************
1721 -- The known-key names for Template Haskell
1723 -- %************************************************************************
1725 -- To add a name, do three things
1727 -- 1) Allocate a key
1729 -- 3) Add the name to knownKeyNames
1731 templateHaskellNames :: [Name]
1732 -- The names that are implicitly mentioned by ``bracket''
1733 -- Should stay in sync with the import list of DsMeta
1735 templateHaskellNames = [
1736 returnQName, bindQName, sequenceQName, newNameName, liftName,
1737 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1741 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1742 floatPrimLName, doublePrimLName, rationalLName,
1744 litPName, varPName, tupPName, unboxedTupPName,
1745 conPName, tildePName, bangPName, infixPName,
1746 asPName, wildPName, recPName, listPName, sigPName, viewPName,
1754 varEName, conEName, litEName, appEName, infixEName,
1755 infixAppName, sectionLName, sectionRName, lamEName,
1756 tupEName, unboxedTupEName,
1757 condEName, letEName, caseEName, doEName, compEName,
1758 fromEName, fromThenEName, fromToEName, fromThenToEName,
1759 listEName, sigEName, recConEName, recUpdEName,
1763 guardedBName, normalBName,
1765 normalGEName, patGEName,
1767 bindSName, letSName, noBindSName, parSName,
1769 funDName, valDName, dataDName, newtypeDName, tySynDName,
1770 classDName, instanceDName, sigDName, forImpDName,
1771 pragInlDName, pragSpecDName, pragSpecInlDName,
1772 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1777 classPName, equalPName,
1779 isStrictName, notStrictName,
1781 normalCName, recCName, infixCName, forallCName,
1787 forallTName, varTName, conTName, appTName,
1788 tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName,
1790 plainTVName, kindedTVName,
1792 starKName, arrowKName,
1794 cCallName, stdCallName,
1801 inlineSpecNoPhaseName, inlineSpecPhaseName,
1805 typeFamName, dataFamName,
1808 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1809 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1810 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1811 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1812 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1813 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1814 predQTyConName, decsQTyConName,
1817 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1819 thSyn, thLib, qqLib :: Module
1820 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1821 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1822 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1824 mkTHModule :: FastString -> Module
1825 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1827 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1828 libFun = mk_known_key_name OccName.varName thLib
1829 libTc = mk_known_key_name OccName.tcName thLib
1830 thFun = mk_known_key_name OccName.varName thSyn
1831 thTc = mk_known_key_name OccName.tcName thSyn
1832 qqFun = mk_known_key_name OccName.varName qqLib
1834 -------------------- TH.Syntax -----------------------
1835 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1836 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1837 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1838 predTyConName :: Name
1839 qTyConName = thTc (fsLit "Q") qTyConKey
1840 nameTyConName = thTc (fsLit "Name") nameTyConKey
1841 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1842 patTyConName = thTc (fsLit "Pat") patTyConKey
1843 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1844 expTyConName = thTc (fsLit "Exp") expTyConKey
1845 decTyConName = thTc (fsLit "Dec") decTyConKey
1846 typeTyConName = thTc (fsLit "Type") typeTyConKey
1847 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1848 matchTyConName = thTc (fsLit "Match") matchTyConKey
1849 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1850 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1851 predTyConName = thTc (fsLit "Pred") predTyConKey
1853 returnQName, bindQName, sequenceQName, newNameName, liftName,
1854 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1855 mkNameLName, liftStringName :: Name
1856 returnQName = thFun (fsLit "returnQ") returnQIdKey
1857 bindQName = thFun (fsLit "bindQ") bindQIdKey
1858 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1859 newNameName = thFun (fsLit "newName") newNameIdKey
1860 liftName = thFun (fsLit "lift") liftIdKey
1861 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1862 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1863 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1864 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1865 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1866 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1869 -------------------- TH.Lib -----------------------
1871 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1872 floatPrimLName, doublePrimLName, rationalLName :: Name
1873 charLName = libFun (fsLit "charL") charLIdKey
1874 stringLName = libFun (fsLit "stringL") stringLIdKey
1875 integerLName = libFun (fsLit "integerL") integerLIdKey
1876 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1877 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1878 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1879 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1880 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1883 litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
1884 asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
1885 litPName = libFun (fsLit "litP") litPIdKey
1886 varPName = libFun (fsLit "varP") varPIdKey
1887 tupPName = libFun (fsLit "tupP") tupPIdKey
1888 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
1889 conPName = libFun (fsLit "conP") conPIdKey
1890 infixPName = libFun (fsLit "infixP") infixPIdKey
1891 tildePName = libFun (fsLit "tildeP") tildePIdKey
1892 bangPName = libFun (fsLit "bangP") bangPIdKey
1893 asPName = libFun (fsLit "asP") asPIdKey
1894 wildPName = libFun (fsLit "wildP") wildPIdKey
1895 recPName = libFun (fsLit "recP") recPIdKey
1896 listPName = libFun (fsLit "listP") listPIdKey
1897 sigPName = libFun (fsLit "sigP") sigPIdKey
1898 viewPName = libFun (fsLit "viewP") viewPIdKey
1900 -- type FieldPat = ...
1901 fieldPatName :: Name
1902 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1906 matchName = libFun (fsLit "match") matchIdKey
1908 -- data Clause = ...
1910 clauseName = libFun (fsLit "clause") clauseIdKey
1913 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1914 sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
1915 letEName, caseEName, doEName, compEName :: Name
1916 varEName = libFun (fsLit "varE") varEIdKey
1917 conEName = libFun (fsLit "conE") conEIdKey
1918 litEName = libFun (fsLit "litE") litEIdKey
1919 appEName = libFun (fsLit "appE") appEIdKey
1920 infixEName = libFun (fsLit "infixE") infixEIdKey
1921 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1922 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1923 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1924 lamEName = libFun (fsLit "lamE") lamEIdKey
1925 tupEName = libFun (fsLit "tupE") tupEIdKey
1926 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
1927 condEName = libFun (fsLit "condE") condEIdKey
1928 letEName = libFun (fsLit "letE") letEIdKey
1929 caseEName = libFun (fsLit "caseE") caseEIdKey
1930 doEName = libFun (fsLit "doE") doEIdKey
1931 compEName = libFun (fsLit "compE") compEIdKey
1932 -- ArithSeq skips a level
1933 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1934 fromEName = libFun (fsLit "fromE") fromEIdKey
1935 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1936 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1937 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1939 listEName, sigEName, recConEName, recUpdEName :: Name
1940 listEName = libFun (fsLit "listE") listEIdKey
1941 sigEName = libFun (fsLit "sigE") sigEIdKey
1942 recConEName = libFun (fsLit "recConE") recConEIdKey
1943 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1945 -- type FieldExp = ...
1946 fieldExpName :: Name
1947 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1950 guardedBName, normalBName :: Name
1951 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1952 normalBName = libFun (fsLit "normalB") normalBIdKey
1955 normalGEName, patGEName :: Name
1956 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1957 patGEName = libFun (fsLit "patGE") patGEIdKey
1960 bindSName, letSName, noBindSName, parSName :: Name
1961 bindSName = libFun (fsLit "bindS") bindSIdKey
1962 letSName = libFun (fsLit "letS") letSIdKey
1963 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1964 parSName = libFun (fsLit "parS") parSIdKey
1967 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1968 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1969 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1970 newtypeInstDName, tySynInstDName :: Name
1971 funDName = libFun (fsLit "funD") funDIdKey
1972 valDName = libFun (fsLit "valD") valDIdKey
1973 dataDName = libFun (fsLit "dataD") dataDIdKey
1974 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1975 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1976 classDName = libFun (fsLit "classD") classDIdKey
1977 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1978 sigDName = libFun (fsLit "sigD") sigDIdKey
1979 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1980 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1981 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1982 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1983 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1984 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1985 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1986 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1987 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1991 cxtName = libFun (fsLit "cxt") cxtIdKey
1994 classPName, equalPName :: Name
1995 classPName = libFun (fsLit "classP") classPIdKey
1996 equalPName = libFun (fsLit "equalP") equalPIdKey
1998 -- data Strict = ...
1999 isStrictName, notStrictName :: Name
2000 isStrictName = libFun (fsLit "isStrict") isStrictKey
2001 notStrictName = libFun (fsLit "notStrict") notStrictKey
2004 normalCName, recCName, infixCName, forallCName :: Name
2005 normalCName = libFun (fsLit "normalC") normalCIdKey
2006 recCName = libFun (fsLit "recC") recCIdKey
2007 infixCName = libFun (fsLit "infixC") infixCIdKey
2008 forallCName = libFun (fsLit "forallC") forallCIdKey
2010 -- type StrictType = ...
2011 strictTypeName :: Name
2012 strictTypeName = libFun (fsLit "strictType") strictTKey
2014 -- type VarStrictType = ...
2015 varStrictTypeName :: Name
2016 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
2019 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
2020 listTName, appTName, sigTName :: Name
2021 forallTName = libFun (fsLit "forallT") forallTIdKey
2022 varTName = libFun (fsLit "varT") varTIdKey
2023 conTName = libFun (fsLit "conT") conTIdKey
2024 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
2025 unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
2026 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
2027 listTName = libFun (fsLit "listT") listTIdKey
2028 appTName = libFun (fsLit "appT") appTIdKey
2029 sigTName = libFun (fsLit "sigT") sigTIdKey
2031 -- data TyVarBndr = ...
2032 plainTVName, kindedTVName :: Name
2033 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
2034 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
2037 starKName, arrowKName :: Name
2038 starKName = libFun (fsLit "starK") starKIdKey
2039 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
2041 -- data Callconv = ...
2042 cCallName, stdCallName :: Name
2043 cCallName = libFun (fsLit "cCall") cCallIdKey
2044 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
2046 -- data Safety = ...
2047 unsafeName, safeName, threadsafeName, interruptibleName :: Name
2048 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
2049 safeName = libFun (fsLit "safe") safeIdKey
2050 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
2051 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
2053 -- data InlineSpec = ...
2054 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
2055 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
2056 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
2058 -- data FunDep = ...
2060 funDepName = libFun (fsLit "funDep") funDepIdKey
2062 -- data FamFlavour = ...
2063 typeFamName, dataFamName :: Name
2064 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2065 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2067 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2068 decQTyConName, conQTyConName, strictTypeQTyConName,
2069 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2070 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
2071 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2072 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2073 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2074 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2075 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2076 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2077 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2078 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2079 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2080 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2081 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2082 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2083 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2084 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2087 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2088 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2089 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2090 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2091 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2093 -- TyConUniques available: 200-299
2094 -- Check in PrelNames if you want to change this
2096 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2097 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2098 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2099 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2100 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2101 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2102 predQTyConKey, decsQTyConKey :: Unique
2103 expTyConKey = mkPreludeTyConUnique 200
2104 matchTyConKey = mkPreludeTyConUnique 201
2105 clauseTyConKey = mkPreludeTyConUnique 202
2106 qTyConKey = mkPreludeTyConUnique 203
2107 expQTyConKey = mkPreludeTyConUnique 204
2108 decQTyConKey = mkPreludeTyConUnique 205
2109 patTyConKey = mkPreludeTyConUnique 206
2110 matchQTyConKey = mkPreludeTyConUnique 207
2111 clauseQTyConKey = mkPreludeTyConUnique 208
2112 stmtQTyConKey = mkPreludeTyConUnique 209
2113 conQTyConKey = mkPreludeTyConUnique 210
2114 typeQTyConKey = mkPreludeTyConUnique 211
2115 typeTyConKey = mkPreludeTyConUnique 212
2116 decTyConKey = mkPreludeTyConUnique 213
2117 varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2118 strictTypeQTyConKey = mkPreludeTyConUnique 215
2119 fieldExpTyConKey = mkPreludeTyConUnique 216
2120 fieldPatTyConKey = mkPreludeTyConUnique 217
2121 nameTyConKey = mkPreludeTyConUnique 218
2122 patQTyConKey = mkPreludeTyConUnique 219
2123 fieldPatQTyConKey = mkPreludeTyConUnique 220
2124 fieldExpQTyConKey = mkPreludeTyConUnique 221
2125 funDepTyConKey = mkPreludeTyConUnique 222
2126 predTyConKey = mkPreludeTyConUnique 223
2127 predQTyConKey = mkPreludeTyConUnique 224
2128 tyVarBndrTyConKey = mkPreludeTyConUnique 225
2129 decsQTyConKey = mkPreludeTyConUnique 226
2131 -- IdUniques available: 200-399
2132 -- If you want to change this, make sure you check in PrelNames
2134 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2135 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2136 mkNameLIdKey :: Unique
2137 returnQIdKey = mkPreludeMiscIdUnique 200
2138 bindQIdKey = mkPreludeMiscIdUnique 201
2139 sequenceQIdKey = mkPreludeMiscIdUnique 202
2140 liftIdKey = mkPreludeMiscIdUnique 203
2141 newNameIdKey = mkPreludeMiscIdUnique 204
2142 mkNameIdKey = mkPreludeMiscIdUnique 205
2143 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2144 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2145 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2146 mkNameLIdKey = mkPreludeMiscIdUnique 209
2150 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2151 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2152 charLIdKey = mkPreludeMiscIdUnique 220
2153 stringLIdKey = mkPreludeMiscIdUnique 221
2154 integerLIdKey = mkPreludeMiscIdUnique 222
2155 intPrimLIdKey = mkPreludeMiscIdUnique 223
2156 wordPrimLIdKey = mkPreludeMiscIdUnique 224
2157 floatPrimLIdKey = mkPreludeMiscIdUnique 225
2158 doublePrimLIdKey = mkPreludeMiscIdUnique 226
2159 rationalLIdKey = mkPreludeMiscIdUnique 227
2161 liftStringIdKey :: Unique
2162 liftStringIdKey = mkPreludeMiscIdUnique 228
2165 litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2166 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2167 litPIdKey = mkPreludeMiscIdUnique 240
2168 varPIdKey = mkPreludeMiscIdUnique 241
2169 tupPIdKey = mkPreludeMiscIdUnique 242
2170 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2171 conPIdKey = mkPreludeMiscIdUnique 244
2172 infixPIdKey = mkPreludeMiscIdUnique 245
2173 tildePIdKey = mkPreludeMiscIdUnique 246
2174 bangPIdKey = mkPreludeMiscIdUnique 247
2175 asPIdKey = mkPreludeMiscIdUnique 248
2176 wildPIdKey = mkPreludeMiscIdUnique 249
2177 recPIdKey = mkPreludeMiscIdUnique 250
2178 listPIdKey = mkPreludeMiscIdUnique 251
2179 sigPIdKey = mkPreludeMiscIdUnique 252
2180 viewPIdKey = mkPreludeMiscIdUnique 253
2182 -- type FieldPat = ...
2183 fieldPatIdKey :: Unique
2184 fieldPatIdKey = mkPreludeMiscIdUnique 260
2187 matchIdKey :: Unique
2188 matchIdKey = mkPreludeMiscIdUnique 261
2190 -- data Clause = ...
2191 clauseIdKey :: Unique
2192 clauseIdKey = mkPreludeMiscIdUnique 262
2196 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2197 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
2199 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2200 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2201 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2202 varEIdKey = mkPreludeMiscIdUnique 270
2203 conEIdKey = mkPreludeMiscIdUnique 271
2204 litEIdKey = mkPreludeMiscIdUnique 272
2205 appEIdKey = mkPreludeMiscIdUnique 273
2206 infixEIdKey = mkPreludeMiscIdUnique 274
2207 infixAppIdKey = mkPreludeMiscIdUnique 275
2208 sectionLIdKey = mkPreludeMiscIdUnique 276
2209 sectionRIdKey = mkPreludeMiscIdUnique 277
2210 lamEIdKey = mkPreludeMiscIdUnique 278
2211 tupEIdKey = mkPreludeMiscIdUnique 279
2212 unboxedTupEIdKey = mkPreludeMiscIdUnique 280
2213 condEIdKey = mkPreludeMiscIdUnique 281
2214 letEIdKey = mkPreludeMiscIdUnique 282
2215 caseEIdKey = mkPreludeMiscIdUnique 283
2216 doEIdKey = mkPreludeMiscIdUnique 284
2217 compEIdKey = mkPreludeMiscIdUnique 285
2218 fromEIdKey = mkPreludeMiscIdUnique 286
2219 fromThenEIdKey = mkPreludeMiscIdUnique 287
2220 fromToEIdKey = mkPreludeMiscIdUnique 288
2221 fromThenToEIdKey = mkPreludeMiscIdUnique 289
2222 listEIdKey = mkPreludeMiscIdUnique 290
2223 sigEIdKey = mkPreludeMiscIdUnique 291
2224 recConEIdKey = mkPreludeMiscIdUnique 292
2225 recUpdEIdKey = mkPreludeMiscIdUnique 293
2227 -- type FieldExp = ...
2228 fieldExpIdKey :: Unique
2229 fieldExpIdKey = mkPreludeMiscIdUnique 310
2232 guardedBIdKey, normalBIdKey :: Unique
2233 guardedBIdKey = mkPreludeMiscIdUnique 311
2234 normalBIdKey = mkPreludeMiscIdUnique 312
2237 normalGEIdKey, patGEIdKey :: Unique
2238 normalGEIdKey = mkPreludeMiscIdUnique 313
2239 patGEIdKey = mkPreludeMiscIdUnique 314
2242 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2243 bindSIdKey = mkPreludeMiscIdUnique 320
2244 letSIdKey = mkPreludeMiscIdUnique 321
2245 noBindSIdKey = mkPreludeMiscIdUnique 322
2246 parSIdKey = mkPreludeMiscIdUnique 323
2249 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2250 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2251 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2252 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2253 funDIdKey = mkPreludeMiscIdUnique 330
2254 valDIdKey = mkPreludeMiscIdUnique 331
2255 dataDIdKey = mkPreludeMiscIdUnique 332
2256 newtypeDIdKey = mkPreludeMiscIdUnique 333
2257 tySynDIdKey = mkPreludeMiscIdUnique 334
2258 classDIdKey = mkPreludeMiscIdUnique 335
2259 instanceDIdKey = mkPreludeMiscIdUnique 336
2260 sigDIdKey = mkPreludeMiscIdUnique 337
2261 forImpDIdKey = mkPreludeMiscIdUnique 338
2262 pragInlDIdKey = mkPreludeMiscIdUnique 339
2263 pragSpecDIdKey = mkPreludeMiscIdUnique 340
2264 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2265 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2266 familyKindDIdKey = mkPreludeMiscIdUnique 343
2267 dataInstDIdKey = mkPreludeMiscIdUnique 344
2268 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2269 tySynInstDIdKey = mkPreludeMiscIdUnique 346
2273 cxtIdKey = mkPreludeMiscIdUnique 360
2276 classPIdKey, equalPIdKey :: Unique
2277 classPIdKey = mkPreludeMiscIdUnique 361
2278 equalPIdKey = mkPreludeMiscIdUnique 362
2280 -- data Strict = ...
2281 isStrictKey, notStrictKey :: Unique
2282 isStrictKey = mkPreludeMiscIdUnique 363
2283 notStrictKey = mkPreludeMiscIdUnique 364
2286 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2287 normalCIdKey = mkPreludeMiscIdUnique 370
2288 recCIdKey = mkPreludeMiscIdUnique 371
2289 infixCIdKey = mkPreludeMiscIdUnique 372
2290 forallCIdKey = mkPreludeMiscIdUnique 373
2292 -- type StrictType = ...
2293 strictTKey :: Unique
2294 strictTKey = mkPreludeMiscIdUnique 374
2296 -- type VarStrictType = ...
2297 varStrictTKey :: Unique
2298 varStrictTKey = mkPreludeMiscIdUnique 375
2301 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2302 listTIdKey, appTIdKey, sigTIdKey :: Unique
2303 forallTIdKey = mkPreludeMiscIdUnique 380
2304 varTIdKey = mkPreludeMiscIdUnique 381
2305 conTIdKey = mkPreludeMiscIdUnique 382
2306 tupleTIdKey = mkPreludeMiscIdUnique 383
2307 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2308 arrowTIdKey = mkPreludeMiscIdUnique 385
2309 listTIdKey = mkPreludeMiscIdUnique 386
2310 appTIdKey = mkPreludeMiscIdUnique 387
2311 sigTIdKey = mkPreludeMiscIdUnique 388
2313 -- data TyVarBndr = ...
2314 plainTVIdKey, kindedTVIdKey :: Unique
2315 plainTVIdKey = mkPreludeMiscIdUnique 390
2316 kindedTVIdKey = mkPreludeMiscIdUnique 391
2319 starKIdKey, arrowKIdKey :: Unique
2320 starKIdKey = mkPreludeMiscIdUnique 392
2321 arrowKIdKey = mkPreludeMiscIdUnique 393
2323 -- data Callconv = ...
2324 cCallIdKey, stdCallIdKey :: Unique
2325 cCallIdKey = mkPreludeMiscIdUnique 394
2326 stdCallIdKey = mkPreludeMiscIdUnique 395
2328 -- data Safety = ...
2329 unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
2330 unsafeIdKey = mkPreludeMiscIdUnique 400
2331 safeIdKey = mkPreludeMiscIdUnique 401
2332 threadsafeIdKey = mkPreludeMiscIdUnique 402
2333 interruptibleIdKey = mkPreludeMiscIdUnique 403
2335 -- data InlineSpec =
2336 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2337 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404
2338 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405
2340 -- data FunDep = ...
2341 funDepIdKey :: Unique
2342 funDepIdKey = mkPreludeMiscIdUnique 406
2344 -- data FamFlavour = ...
2345 typeFamIdKey, dataFamIdKey :: Unique
2346 typeFamIdKey = mkPreludeMiscIdUnique 407
2347 dataFamIdKey = mkPreludeMiscIdUnique 408
2350 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2351 quoteExpKey = mkPreludeMiscIdUnique 410
2352 quotePatKey = mkPreludeMiscIdUnique 411
2353 quoteDecKey = mkPreludeMiscIdUnique 412
2354 quoteTypeKey = mkPreludeMiscIdUnique 413