Merge branch 'master' into ghc-parmake-gsoc
[ghc.git] / compiler / deSugar / DsMeta.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2006
4 --
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.
9 --
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, because
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
15
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
22 ) where
23
24 #include "HsVersions.h"
25
26 import {-# SOURCE #-} DsExpr ( dsExpr )
27
28 import MatchLit
29 import DsMonad
30
31 import qualified Language.Haskell.TH as TH
32
33 import HsSyn
34 import Class
35 import PrelNames
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, dataName )
41
42 import Module
43 import Id
44 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
45 import NameEnv
46 import TcType
47 import TyCon
48 import TysWiredIn
49 import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
50 import CoreSyn
51 import MkCore
52 import CoreUtils
53 import SrcLoc
54 import Unique
55 import BasicTypes
56 import Outputable
57 import Bag
58 import DynFlags
59 import FastString
60 import ForeignCall
61 import Util
62
63 import Data.Maybe
64 import Control.Monad
65 import Data.List
66
67 -----------------------------------------------------------------------------
68 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
69 -- Returns a CoreExpr of type TH.ExpQ
70 -- The quoted thing is parameterised over Name, even though it has
71 -- been type checked. We don't want all those type decorations!
72
73 dsBracket brack splices
74 = dsExtendMetaEnv new_bit (do_brack brack)
75 where
76 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
77
78 do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
79 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
80 do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
81 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
82 do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
83 do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
84
85 {- -------------- Examples --------------------
86
87 [| \x -> x |]
88 ====>
89 gensym (unpackString "x"#) `bindQ` \ x1::String ->
90 lam (pvar x1) (var x1)
91
92
93 [| \x -> $(f [| x |]) |]
94 ====>
95 gensym (unpackString "x"#) `bindQ` \ x1::String ->
96 lam (pvar x1) (f (var x1))
97 -}
98
99
100 -------------------------------------------------------
101 -- Declarations
102 -------------------------------------------------------
103
104 repTopP :: LPat Name -> DsM (Core TH.PatQ)
105 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
106 ; pat' <- addBinds ss (repLP pat)
107 ; wrapGenSyms ss pat' }
108
109 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110 repTopDs group
111 = do { let { tv_bndrs = hsSigTvBinders (hs_valds group)
112 ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
113 ss <- mkGenSyms bndrs ;
114
115 -- Bind all the names mainly to avoid repeated use of explicit strings.
116 -- Thus we get
117 -- do { t :: String <- genSym "T" ;
118 -- return (Data t [] ...more t's... }
119 -- The other important reason is that the output must mention
120 -- only "T", not "Foo:T" where Foo is the current module
121
122 decls <- addBinds ss (do {
123 fix_ds <- mapM repFixD (hs_fixds group) ;
124 val_ds <- rep_val_binds (hs_valds group) ;
125 tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ;
126 inst_ds <- mapM repInstD (hs_instds group) ;
127 rule_ds <- mapM repRuleD (hs_ruleds group) ;
128 for_ds <- mapM repForD (hs_fords group) ;
129 -- more needed
130 return (de_loc $ sort_by_loc $
131 val_ds ++ catMaybes tycl_ds ++ fix_ds
132 ++ inst_ds ++ rule_ds ++ for_ds) }) ;
133
134 decl_ty <- lookupType decQTyConName ;
135 let { core_list = coreList' decl_ty decls } ;
136
137 dec_ty <- lookupType decTyConName ;
138 q_decs <- repSequenceQ dec_ty core_list ;
139
140 wrapGenSyms ss q_decs
141 }
142
143
144 hsSigTvBinders :: HsValBinds Name -> [Name]
145 -- See Note [Scoped type variables in bindings]
146 hsSigTvBinders binds
147 = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
148 , tv <- hsQTvBndrs qtvs]
149 where
150 sigs = case binds of
151 ValBindsIn _ sigs -> sigs
152 ValBindsOut _ sigs -> sigs
153
154
155 {- Notes
156
157 Note [Scoped type variables in bindings]
158 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
159 Consider
160 f :: forall a. a -> a
161 f x = x::a
162 Here the 'forall a' brings 'a' into scope over the binding group.
163 To achieve this we
164
165 a) Gensym a binding for 'a' at the same time as we do one for 'f'
166 collecting the relevant binders with hsSigTvBinders
167
168 b) When processing the 'forall', don't gensym
169
170 The relevant places are signposted with references to this Note
171
172 Note [Binders and occurrences]
173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
174 When we desugar [d| data T = MkT |]
175 we want to get
176 Data "T" [] [Con "MkT" []] []
177 and *not*
178 Data "Foo:T" [] [Con "Foo:MkT" []] []
179 That is, the new data decl should fit into whatever new module it is
180 asked to fit in. We do *not* clone, though; no need for this:
181 Data "T79" ....
182
183 But if we see this:
184 data T = MkT
185 foo = reifyDecl T
186
187 then we must desugar to
188 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
189
190 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
191 And we use lookupOcc, rather than lookupBinder
192 in repTyClD and repC.
193
194 -}
195
196 -- represent associated family instances
197 --
198 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
199
200 repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
201
202 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
203 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
204 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
205 repSynDecl tc1 bndrs rhs
206 ; return (Just (loc, dec)) }
207
208 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
209 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
210 ; tc_tvs <- mk_extra_tvs tc tvs defn
211 ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
212 repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
213 ; return (Just (loc, dec)) }
214
215 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
216 tcdTyVars = tvs, tcdFDs = fds,
217 tcdSigs = sigs, tcdMeths = meth_binds,
218 tcdATs = ats, tcdATDefs = [] }))
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 <- repFamilyDecls ats
226 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
227 ; repClass cxt1 cls1 bndrs fds1 decls1
228 }
229 ; return $ Just (loc, dec)
230 }
231
232 -- Un-handled cases
233 repTyClD (L loc d) = putSrcSpanDs loc $
234 do { warnDs (hang ds_msg 4 (ppr d))
235 ; return Nothing }
236
237 -------------------------
238 repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
239 -> Maybe (Core [TH.TypeQ])
240 -> [Name] -> HsDataDefn Name
241 -> DsM (Core TH.DecQ)
242 repDataDefn tc bndrs opt_tys tv_names
243 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
244 , dd_cons = cons, dd_derivs = mb_derivs })
245 = do { cxt1 <- repLContext cxt
246 ; derivs1 <- repDerivs mb_derivs
247 ; case new_or_data of
248 NewType -> do { con1 <- repC tv_names (head cons)
249 ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 }
250 DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons
251 ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
252
253 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
254 -> LHsType Name
255 -> DsM (Core TH.DecQ)
256 repSynDecl tc bndrs ty
257 = do { ty1 <- repLTy ty
258 ; repTySyn tc bndrs ty1 }
259
260 repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
261 repFamilyDecl (L loc (FamilyDecl { fdInfo = info,
262 fdLName = tc,
263 fdTyVars = tvs,
264 fdKindSig = opt_kind }))
265 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
266 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
267 case (opt_kind, info) of
268 (Nothing, ClosedTypeFamily eqns) ->
269 do { eqns1 <- mapM repTyFamEqn eqns
270 ; eqns2 <- coreList tySynEqnQTyConName eqns1
271 ; repClosedFamilyNoKind tc1 bndrs eqns2 }
272 (Just ki, ClosedTypeFamily eqns) ->
273 do { eqns1 <- mapM repTyFamEqn eqns
274 ; eqns2 <- coreList tySynEqnQTyConName eqns1
275 ; ki1 <- repLKind ki
276 ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
277 (Nothing, _) ->
278 do { info' <- repFamilyInfo info
279 ; repFamilyNoKind info' tc1 bndrs }
280 (Just ki, _) ->
281 do { info' <- repFamilyInfo info
282 ; ki1 <- repLKind ki
283 ; repFamilyKind info' tc1 bndrs ki1 }
284 ; return (loc, dec)
285 }
286
287 repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
288 repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
289
290 -------------------------
291 mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
292 -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
293 -- If there is a kind signature it must be of form
294 -- k1 -> .. -> kn -> *
295 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
296 mk_extra_tvs tc tvs defn
297 | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
298 = do { extra_tvs <- go hs_kind
299 ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
300 | otherwise
301 = return tvs
302 where
303 go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
304 go (L loc (HsFunTy kind rest))
305 = do { uniq <- newUnique
306 ; let { occ = mkTyVarOccFS (fsLit "t")
307 ; nm = mkInternalName uniq occ loc
308 ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) }
309 ; hs_tvs <- go rest
310 ; return (hs_tv : hs_tvs) }
311
312 go (L _ (HsTyVar n))
313 | n == liftedTypeKindTyConName
314 = return []
315
316 go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
317
318 -------------------------
319 -- represent fundeps
320 --
321 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
322 repLFunDeps fds = repList funDepTyConName repLFunDep fds
323
324 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
325 repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs
326 ys' <- repList nameTyConName lookupBinder ys
327 repFunDep xs' ys'
328
329 -- represent family declaration flavours
330 --
331 repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
332 repFamilyInfo OpenTypeFamily = rep2 typeFamName []
333 repFamilyInfo DataFamily = rep2 dataFamName []
334 repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
335
336 -- Represent instance declarations
337 --
338 repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
339 repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
340 = do { dec <- repTyFamInstD fi_decl
341 ; return (loc, dec) }
342 repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
343 = do { dec <- repDataFamInstD fi_decl
344 ; return (loc, dec) }
345 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
346 = do { dec <- repClsInstD cls_decl
347 ; return (loc, dec) }
348
349 repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
350 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
351 , cid_sigs = prags, cid_tyfam_insts = ats
352 , cid_datafam_insts = adts })
353 = addTyVarBinds tvs $ \_ ->
354 -- We must bring the type variables into scope, so their
355 -- occurrences don't fail, even though the binders don't
356 -- appear in the resulting data structure
357 --
358 -- But we do NOT bring the binders of 'binds' into scope
359 -- because they are properly regarded as occurrences
360 -- For example, the method names should be bound to
361 -- the selector Ids, not to fresh names (Trac #5410)
362 --
363 do { cxt1 <- repContext cxt
364 ; cls_tcon <- repTy (HsTyVar (unLoc cls))
365 ; cls_tys <- repLTys tys
366 ; inst_ty1 <- repTapps cls_tcon cls_tys
367 ; binds1 <- rep_binds binds
368 ; prags1 <- rep_sigs prags
369 ; ats1 <- mapM (repTyFamInstD . unLoc) ats
370 ; adts1 <- mapM (repDataFamInstD . unLoc) adts
371 ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
372 ; repInst cxt1 inst_ty1 decls }
373 where
374 Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
375
376 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
377 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
378 = do { let tc_name = tyFamInstDeclLName decl
379 ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
380 ; eqn1 <- repTyFamEqn eqn
381 ; repTySynInst tc eqn1 }
382
383 repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
384 repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys
385 , hswb_kvs = kv_names
386 , hswb_tvs = tv_names }
387 , tfie_rhs = rhs }))
388 = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
389 , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
390 ; addTyClTyVarBinds hs_tvs $ \ _ ->
391 do { tys1 <- repLTys tys
392 ; tys2 <- coreList typeQTyConName tys1
393 ; rhs1 <- repLTy rhs
394 ; repTySynEqn tys2 rhs1 } }
395
396 repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
397 repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
398 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
399 , dfid_defn = defn })
400 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
401 ; let loc = getLoc tc_name
402 hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
403 ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
404 do { tys1 <- repList typeQTyConName repLTy tys
405 ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
406
407 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
408 repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
409 = do MkC name' <- lookupLOcc name
410 MkC typ' <- repLTy typ
411 MkC cc' <- repCCallConv cc
412 MkC s' <- repSafety s
413 cis' <- conv_cimportspec cis
414 MkC str <- coreStringLit (static ++ chStr ++ cis')
415 dec <- rep2 forImpDName [cc', s', str, name', typ']
416 return (loc, dec)
417 where
418 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
419 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
420 conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
421 conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet"
422 conv_cimportspec CWrapper = return "wrapper"
423 static = case cis of
424 CFunction (StaticTarget _ _ _) -> "static "
425 _ -> ""
426 chStr = case mch of
427 Nothing -> ""
428 Just (Header h) -> unpackFS h ++ " "
429 repForD decl = notHandled "Foreign declaration" (ppr decl)
430
431 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
432 repCCallConv CCallConv = rep2 cCallName []
433 repCCallConv StdCallConv = rep2 stdCallName []
434 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
435
436 repSafety :: Safety -> DsM (Core TH.Safety)
437 repSafety PlayRisky = rep2 unsafeName []
438 repSafety PlayInterruptible = rep2 interruptibleName []
439 repSafety PlaySafe = rep2 safeName []
440
441 repFixD :: LFixitySig Name -> DsM (SrcSpan, Core TH.DecQ)
442 repFixD (L loc (FixitySig name (Fixity prec dir)))
443 = do { MkC name' <- lookupLOcc name
444 ; MkC prec' <- coreIntLit prec
445 ; let rep_fn = case dir of
446 InfixL -> infixLDName
447 InfixR -> infixRDName
448 InfixN -> infixNDName
449 ; dec <- rep2 rep_fn [prec', name']
450 ; return (loc, dec) }
451
452 repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
453 repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
454 = do { let bndr_names = concatMap ruleBndrNames bndrs
455 ; ss <- mkGenSyms bndr_names
456 ; rule1 <- addBinds ss $
457 do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
458 ; n' <- coreStringLit $ unpackFS n
459 ; act' <- repPhases act
460 ; lhs' <- repLE lhs
461 ; rhs' <- repLE rhs
462 ; repPragRule n' bndrs' lhs' rhs' act' }
463 ; rule2 <- wrapGenSyms ss rule1
464 ; return (loc, rule2) }
465
466 ruleBndrNames :: RuleBndr Name -> [Name]
467 ruleBndrNames (RuleBndr n) = [unLoc n]
468 ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs }))
469 = unLoc n : kvs ++ tvs
470
471 repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ)
472 repRuleBndr (RuleBndr n)
473 = do { MkC n' <- lookupLBinder n
474 ; rep2 ruleVarName [n'] }
475 repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty }))
476 = do { MkC n' <- lookupLBinder n
477 ; MkC ty' <- repLTy ty
478 ; rep2 typedRuleVarName [n', ty'] }
479
480 ds_msg :: SDoc
481 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
482
483 -------------------------------------------------------
484 -- Constructors
485 -------------------------------------------------------
486
487 repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
488 repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
489 , con_details = details, con_res = ResTyH98 }))
490 | null (hsQTvBndrs con_tvs)
491 = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
492 ; repConstr con1 details }
493
494 repC tvs (L _ (ConDecl { con_name = con
495 , con_qvars = con_tvs, con_cxt = L _ ctxt
496 , con_details = details
497 , con_res = res_ty }))
498 = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
499 ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
500 , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
501
502 ; binds <- mapM dupBinder con_tv_subst
503 ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
504 addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
505 do { con1 <- lookupLOcc con -- See Note [Binders and occurrences]
506 ; c' <- repConstr con1 details
507 ; ctxt' <- repContext (eq_ctxt ++ ctxt)
508 ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } }
509
510 in_subst :: [(Name,Name)] -> Name -> Bool
511 in_subst [] _ = False
512 in_subst ((n',_):ns) n = n==n' || in_subst ns n
513
514 mkGadtCtxt :: [Name] -- Tyvars of the data type
515 -> ResType (LHsType Name)
516 -> DsM (HsContext Name, [(Name,Name)])
517 -- Given a data type in GADT syntax, figure out the equality
518 -- context, so that we can represent it with an explicit
519 -- equality context, because that is the only way to express
520 -- the GADT in TH syntax
521 --
522 -- Example:
523 -- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
524 -- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
525 -- returns
526 -- (b~[e], c~e), [d->a]
527 --
528 -- This function is fiddly, but not really hard
529 mkGadtCtxt _ ResTyH98
530 = return ([], [])
531 mkGadtCtxt data_tvs (ResTyGADT res_ty)
532 | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
533 , data_tvs `equalLength` tys
534 = return (go [] [] (data_tvs `zip` tys))
535
536 | otherwise
537 = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
538 where
539 go cxt subst [] = (cxt, subst)
540 go cxt subst ((data_tv, ty) : rest)
541 | Just con_tv <- is_hs_tyvar ty
542 , isTyVarName con_tv
543 , not (in_subst subst con_tv)
544 = go cxt ((con_tv, data_tv) : subst) rest
545 | otherwise
546 = go (eq_pred : cxt) subst rest
547 where
548 loc = getLoc ty
549 eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
550
551 is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
552 is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
553 is_hs_tyvar _ = Nothing
554
555
556 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
557 repBangTy ty= do
558 MkC s <- rep2 str []
559 MkC t <- repLTy ty'
560 rep2 strictTypeName [s, t]
561 where
562 (str, ty') = case ty of
563 L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName, ty)
564 L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty)
565 _ -> (notStrictName, ty)
566
567 -------------------------------------------------------
568 -- Deriving clause
569 -------------------------------------------------------
570
571 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
572 repDerivs Nothing = coreList nameTyConName []
573 repDerivs (Just ctxt)
574 = repList nameTyConName rep_deriv ctxt
575 where
576 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
577 -- Deriving clauses must have the simple H98 form
578 rep_deriv ty
579 | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
580 = lookupOcc cls
581 | otherwise
582 = notHandled "Non-H98 deriving clause" (ppr ty)
583
584
585 -------------------------------------------------------
586 -- Signatures in a class decl, or a group of bindings
587 -------------------------------------------------------
588
589 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
590 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
591 return $ de_loc $ sort_by_loc locs_cores
592
593 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
594 -- We silently ignore ones we don't recognise
595 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
596 return (concat sigs1) }
597
598 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
599 -- Singleton => Ok
600 -- Empty => Too hard, signature ignored
601 rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms
602 rep_sig (L _ (GenericSig nm _)) = failWithDs msg
603 where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
604 , ptext (sLit "Default signatures are not supported by Template Haskell") ]
605
606 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
607 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
608 rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc
609 rep_sig _ = return []
610
611 rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
612 -> DsM (SrcSpan, Core TH.DecQ)
613 rep_ty_sig loc (L _ ty) nm
614 = do { nm1 <- lookupLOcc nm
615 ; ty1 <- rep_ty ty
616 ; sig <- repProto nm1 ty1
617 ; return (loc, sig) }
618 where
619 -- We must special-case the top-level explicit for-all of a TypeSig
620 -- See Note [Scoped type variables in bindings]
621 rep_ty (HsForAllTy Explicit tvs ctxt ty)
622 = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
623 ; repTyVarBndrWithKind tv name }
624 ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
625 ; ctxt1 <- repLContext ctxt
626 ; ty1 <- repLTy ty
627 ; repTForall bndrs1 ctxt1 ty1 }
628
629 rep_ty ty = repTy ty
630
631
632 rep_inline :: Located Name
633 -> InlinePragma -- Never defaultInlinePragma
634 -> SrcSpan
635 -> DsM [(SrcSpan, Core TH.DecQ)]
636 rep_inline nm ispec loc
637 = do { nm1 <- lookupLOcc nm
638 ; inline <- repInline $ inl_inline ispec
639 ; rm <- repRuleMatch $ inl_rule ispec
640 ; phases <- repPhases $ inl_act ispec
641 ; pragma <- repPragInl nm1 inline rm phases
642 ; return [(loc, pragma)]
643 }
644
645 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
646 -> DsM [(SrcSpan, Core TH.DecQ)]
647 rep_specialise nm ty ispec loc
648 = do { nm1 <- lookupLOcc nm
649 ; ty1 <- repLTy ty
650 ; phases <- repPhases $ inl_act ispec
651 ; let inline = inl_inline ispec
652 ; pragma <- if isEmptyInlineSpec inline
653 then -- SPECIALISE
654 repPragSpec nm1 ty1 phases
655 else -- SPECIALISE INLINE
656 do { inline1 <- repInline inline
657 ; repPragSpecInl nm1 ty1 inline1 phases }
658 ; return [(loc, pragma)]
659 }
660
661 rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
662 rep_specialiseInst ty loc
663 = do { ty1 <- repLTy ty
664 ; pragma <- repPragSpecInst ty1
665 ; return [(loc, pragma)] }
666
667 repInline :: InlineSpec -> DsM (Core TH.Inline)
668 repInline NoInline = dataCon noInlineDataConName
669 repInline Inline = dataCon inlineDataConName
670 repInline Inlinable = dataCon inlinableDataConName
671 repInline spec = notHandled "repInline" (ppr spec)
672
673 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
674 repRuleMatch ConLike = dataCon conLikeDataConName
675 repRuleMatch FunLike = dataCon funLikeDataConName
676
677 repPhases :: Activation -> DsM (Core TH.Phases)
678 repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
679 ; dataCon' beforePhaseDataConName [arg] }
680 repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i
681 ; dataCon' fromPhaseDataConName [arg] }
682 repPhases _ = dataCon allPhasesDataConName
683
684 -------------------------------------------------------
685 -- Types
686 -------------------------------------------------------
687
688 addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
689 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
690 -> DsM (Core (TH.Q a))
691 -- gensym a list of type variables and enter them into the meta environment;
692 -- the computations passed as the second argument is executed in that extended
693 -- meta environment and gets the *new* names on Core-level as an argument
694
695 addTyVarBinds tvs m
696 = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs)
697 ; term <- addBinds freshNames $
698 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
699 ; m kbs }
700 ; wrapGenSyms freshNames term }
701 where
702 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
703
704 addTyClTyVarBinds :: LHsTyVarBndrs Name
705 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
706 -> DsM (Core (TH.Q a))
707
708 -- Used for data/newtype declarations, and family instances,
709 -- so that the nested type variables work right
710 -- instance C (T a) where
711 -- type W (T a) = blah
712 -- The 'a' in the type instance is the one bound by the instance decl
713 addTyClTyVarBinds tvs m
714 = do { let tv_names = hsLKiTyVarNames tvs
715 ; env <- dsGetMetaEnv
716 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
717 -- Make fresh names for the ones that are not already in scope
718 -- This makes things work for family declarations
719
720 ; term <- addBinds freshNames $
721 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
722 ; m kbs }
723
724 ; wrapGenSyms freshNames term }
725 where
726 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
727 ; repTyVarBndrWithKind tv v }
728
729 -- Produce kinded binder constructors from the Haskell tyvar binders
730 --
731 repTyVarBndrWithKind :: LHsTyVarBndr Name
732 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
733 repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm
734 = repPlainTV nm
735 repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm
736 = repLKind ki >>= repKindedTV nm
737 repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm
738 = repRole r >>= repRoledTV nm
739 repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm
740 = do { ki' <- repLKind ki
741 ; r' <- repRole r
742 ; repKindedRoledTV nm ki' r' }
743
744 -- represent a type context
745 --
746 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
747 repLContext (L _ ctxt) = repContext ctxt
748
749 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
750 repContext ctxt = do preds <- repList predQTyConName repLPred ctxt
751 repCtxt preds
752
753 -- represent a type predicate
754 --
755 repLPred :: LHsType Name -> DsM (Core TH.PredQ)
756 repLPred (L _ p) = repPred p
757
758 repPred :: HsType Name -> DsM (Core TH.PredQ)
759 repPred ty
760 | Just (cls, tys) <- splitHsClassTy_maybe ty
761 = do
762 cls1 <- lookupOcc cls
763 tys1 <- repList typeQTyConName repLTy tys
764 repClassP cls1 tys1
765 repPred (HsEqTy tyleft tyright)
766 = do
767 tyleft1 <- repLTy tyleft
768 tyright1 <- repLTy tyright
769 repEqualP tyleft1 tyright1
770 repPred ty
771 = notHandled "Exotic predicate type" (ppr ty)
772
773 -- yield the representation of a list of types
774 --
775 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
776 repLTys tys = mapM repLTy tys
777
778 -- represent a type
779 --
780 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
781 repLTy (L _ ty) = repTy ty
782
783 repTy :: HsType Name -> DsM (Core TH.TypeQ)
784 repTy (HsForAllTy _ tvs ctxt ty) =
785 addTyVarBinds tvs $ \bndrs -> do
786 ctxt1 <- repLContext ctxt
787 ty1 <- repLTy ty
788 repTForall bndrs ctxt1 ty1
789
790 repTy (HsTyVar n)
791 | isTvOcc occ = do tv1 <- lookupOcc n
792 repTvar tv1
793 | isDataOcc occ = do tc1 <- lookupOcc n
794 repPromotedTyCon tc1
795 | otherwise = do tc1 <- lookupOcc n
796 repNamedTyCon tc1
797 where
798 occ = nameOccName n
799
800 repTy (HsAppTy f a) = do
801 f1 <- repLTy f
802 a1 <- repLTy a
803 repTapp f1 a1
804 repTy (HsFunTy f a) = do
805 f1 <- repLTy f
806 a1 <- repLTy a
807 tcon <- repArrowTyCon
808 repTapps tcon [f1, a1]
809 repTy (HsListTy t) = do
810 t1 <- repLTy t
811 tcon <- repListTyCon
812 repTapp tcon t1
813 repTy (HsPArrTy t) = do
814 t1 <- repLTy t
815 tcon <- repTy (HsTyVar (tyConName parrTyCon))
816 repTapp tcon t1
817 repTy (HsTupleTy HsUnboxedTuple tys) = do
818 tys1 <- repLTys tys
819 tcon <- repUnboxedTupleTyCon (length tys)
820 repTapps tcon tys1
821 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
822 tcon <- repTupleTyCon (length tys)
823 repTapps tcon tys1
824 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
825 `nlHsAppTy` ty2)
826 repTy (HsParTy t) = repLTy t
827 repTy (HsKindSig t k) = do
828 t1 <- repLTy t
829 k1 <- repLKind k
830 repTSig t1 k1
831 repTy (HsSpliceTy splice _ _) = repSplice splice
832 repTy (HsExplicitListTy _ tys) = do
833 tys1 <- repLTys tys
834 repTPromotedList tys1
835 repTy (HsExplicitTupleTy _ tys) = do
836 tys1 <- repLTys tys
837 tcon <- repPromotedTupleTyCon (length tys)
838 repTapps tcon tys1
839 repTy (HsTyLit lit) = do
840 lit' <- repTyLit lit
841 repTLit lit'
842 repTy ty = notHandled "Exotic form of type" (ppr ty)
843
844 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
845 repTyLit (HsNumTy i) = do dflags <- getDynFlags
846 rep2 numTyLitName [mkIntExpr dflags i]
847 repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
848 ; rep2 strTyLitName [s']
849 }
850
851 -- represent a kind
852 --
853 repLKind :: LHsKind Name -> DsM (Core TH.Kind)
854 repLKind ki
855 = do { let (kis, ki') = splitHsFunType ki
856 ; kis_rep <- mapM repLKind kis
857 ; ki'_rep <- repNonArrowLKind ki'
858 ; kcon <- repKArrow
859 ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
860 ; foldrM f ki'_rep kis_rep
861 }
862
863 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
864 repNonArrowLKind (L _ ki) = repNonArrowKind ki
865
866 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
867 repNonArrowKind (HsTyVar name)
868 | name == liftedTypeKindTyConName = repKStar
869 | name == constraintKindTyConName = repKConstraint
870 | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
871 | otherwise = lookupOcc name >>= repKCon
872 repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
873 ; a' <- repLKind a
874 ; repKApp f' a'
875 }
876 repNonArrowKind (HsListTy k) = do { k' <- repLKind k
877 ; kcon <- repKList
878 ; repKApp kcon k'
879 }
880 repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
881 ; kcon <- repKTuple (length ks)
882 ; repKApps kcon ks'
883 }
884 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
885
886 repRole :: Role -> DsM (Core TH.Role)
887 repRole Nominal = rep2 nominalName []
888 repRole Representational = rep2 representationalName []
889 repRole Phantom = rep2 phantomName []
890
891 -----------------------------------------------------------------------------
892 -- Splices
893 -----------------------------------------------------------------------------
894
895 repSplice :: HsSplice Name -> DsM (Core a)
896 -- See Note [How brackets and nested splices are handled] in TcSplice
897 -- We return a CoreExpr of any old type; the context should know
898 repSplice (HsSplice n _)
899 = do { mb_val <- dsLookupMetaEnv n
900 ; case mb_val of
901 Just (Splice e) -> do { e' <- dsExpr e
902 ; return (MkC e') }
903 _ -> pprPanic "HsSplice" (ppr n) }
904 -- Should not happen; statically checked
905
906 -----------------------------------------------------------------------------
907 -- Expressions
908 -----------------------------------------------------------------------------
909
910 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
911 repLEs es = repList expQTyConName repLE es
912
913 -- FIXME: some of these panics should be converted into proper error messages
914 -- unless we can make sure that constructs, which are plainly not
915 -- supported in TH already lead to error messages at an earlier stage
916 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
917 repLE (L loc e) = putSrcSpanDs loc (repE e)
918
919 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
920 repE (HsVar x) =
921 do { mb_val <- dsLookupMetaEnv x
922 ; case mb_val of
923 Nothing -> do { str <- globalVar x
924 ; repVarOrCon x str }
925 Just (Bound y) -> repVarOrCon x (coreVar y)
926 Just (Splice e) -> do { e' <- dsExpr e
927 ; return (MkC e') } }
928 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
929
930 -- Remember, we're desugaring renamer output here, so
931 -- HsOverlit can definitely occur
932 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
933 repE (HsLit l) = do { a <- repLiteral l; repLit a }
934 repE (HsLam (MG { mg_alts = [m] })) = repLambda m
935 repE (HsLamCase _ (MG { mg_alts = ms }))
936 = do { ms' <- mapM repMatchTup ms
937 ; core_ms <- coreList matchQTyConName ms'
938 ; repLamCase core_ms }
939 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
940
941 repE (OpApp e1 op _ e2) =
942 do { arg1 <- repLE e1;
943 arg2 <- repLE e2;
944 the_op <- repLE op ;
945 repInfixApp arg1 the_op arg2 }
946 repE (NegApp x _) = do
947 a <- repLE x
948 negateVar <- lookupOcc negateName >>= repVar
949 negateVar `repApp` a
950 repE (HsPar x) = repLE x
951 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
952 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
953 repE (HsCase e (MG { mg_alts = ms }))
954 = do { arg <- repLE e
955 ; ms2 <- mapM repMatchTup ms
956 ; core_ms2 <- coreList matchQTyConName ms2
957 ; repCaseE arg core_ms2 }
958 repE (HsIf _ x y z) = do
959 a <- repLE x
960 b <- repLE y
961 c <- repLE z
962 repCond a b c
963 repE (HsMultiIf _ alts)
964 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
965 ; expr' <- repMultiIf (nonEmptyCoreList alts')
966 ; wrapGenSyms (concat binds) expr' }
967 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
968 ; e2 <- addBinds ss (repLE e)
969 ; z <- repLetE ds e2
970 ; wrapGenSyms ss z }
971
972 -- FIXME: I haven't got the types here right yet
973 repE e@(HsDo ctxt sts _)
974 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
975 = do { (ss,zs) <- repLSts sts;
976 e' <- repDoE (nonEmptyCoreList zs);
977 wrapGenSyms ss e' }
978
979 | ListComp <- ctxt
980 = do { (ss,zs) <- repLSts sts;
981 e' <- repComp (nonEmptyCoreList zs);
982 wrapGenSyms ss e' }
983
984 | otherwise
985 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
986
987 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
988 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
989 repE e@(ExplicitTuple es boxed)
990 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
991 | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
992 | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
993
994 repE (RecordCon c _ flds)
995 = do { x <- lookupLOcc c;
996 fs <- repFields flds;
997 repRecCon x fs }
998 repE (RecordUpd e flds _ _ _)
999 = do { x <- repLE e;
1000 fs <- repFields flds;
1001 repRecUpd x fs }
1002
1003 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
1004 repE (ArithSeq _ _ aseq) =
1005 case aseq of
1006 From e -> do { ds1 <- repLE e; repFrom ds1 }
1007 FromThen e1 e2 -> do
1008 ds1 <- repLE e1
1009 ds2 <- repLE e2
1010 repFromThen ds1 ds2
1011 FromTo e1 e2 -> do
1012 ds1 <- repLE e1
1013 ds2 <- repLE e2
1014 repFromTo ds1 ds2
1015 FromThenTo e1 e2 e3 -> do
1016 ds1 <- repLE e1
1017 ds2 <- repLE e2
1018 ds3 <- repLE e3
1019 repFromThenTo ds1 ds2 ds3
1020
1021 repE (HsSpliceE splice) = repSplice splice
1022 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1023 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1024 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1025 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1026 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
1027 repE e = notHandled "Expression form" (ppr e)
1028
1029 -----------------------------------------------------------------------------
1030 -- Building representations of auxillary structures like Match, Clause, Stmt,
1031
1032 repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
1033 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
1034 do { ss1 <- mkGenSyms (collectPatBinders p)
1035 ; addBinds ss1 $ do {
1036 ; p1 <- repLP p
1037 ; (ss2,ds) <- repBinds wheres
1038 ; addBinds ss2 $ do {
1039 ; gs <- repGuards guards
1040 ; match <- repMatch p1 gs ds
1041 ; wrapGenSyms (ss1++ss2) match }}}
1042 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1043
1044 repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
1045 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
1046 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1047 ; addBinds ss1 $ do {
1048 ps1 <- repLPs ps
1049 ; (ss2,ds) <- repBinds wheres
1050 ; addBinds ss2 $ do {
1051 gs <- repGuards guards
1052 ; clause <- repClause ps1 gs ds
1053 ; wrapGenSyms (ss1++ss2) clause }}}
1054
1055 repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
1056 repGuards [L _ (GRHS [] e)]
1057 = do {a <- repLE e; repNormal a }
1058 repGuards other
1059 = do { zs <- mapM repLGRHS other
1060 ; let (xs, ys) = unzip zs
1061 ; gd <- repGuarded (nonEmptyCoreList ys)
1062 ; wrapGenSyms (concat xs) gd }
1063
1064 repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1065 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1066 = do { guarded <- repLNormalGE e1 e2
1067 ; return ([], guarded) }
1068 repLGRHS (L _ (GRHS ss rhs))
1069 = do { (gs, ss') <- repLSts ss
1070 ; rhs' <- addBinds gs $ repLE rhs
1071 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1072 ; return (gs, guarded) }
1073
1074 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
1075 repFields (HsRecFields { rec_flds = flds })
1076 = repList fieldExpQTyConName rep_fld flds
1077 where
1078 rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)
1079 ; e <- repLE (hsRecFieldArg fld)
1080 ; repFieldExp fn e }
1081
1082
1083 -----------------------------------------------------------------------------
1084 -- Representing Stmt's is tricky, especially if bound variables
1085 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1086 -- First gensym new names for every variable in any of the patterns.
1087 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1088 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1089 -- and we could reuse the original names (x and x).
1090 --
1091 -- do { x'1 <- gensym "x"
1092 -- ; x'2 <- gensym "x"
1093 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1094 -- , BindSt (pvar x'2) [| f x |]
1095 -- , NoBindSt [| g x |]
1096 -- ]
1097 -- }
1098
1099 -- The strategy is to translate a whole list of do-bindings by building a
1100 -- bigger environment, and a bigger set of meta bindings
1101 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1102 -- of the expressions within the Do
1103
1104 -----------------------------------------------------------------------------
1105 -- The helper function repSts computes the translation of each sub expression
1106 -- and a bunch of prefix bindings denoting the dynamic renaming.
1107
1108 repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1109 repLSts stmts = repSts (map unLoc stmts)
1110
1111 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1112 repSts (BindStmt p e _ _ : ss) =
1113 do { e2 <- repLE e
1114 ; ss1 <- mkGenSyms (collectPatBinders p)
1115 ; addBinds ss1 $ do {
1116 ; p1 <- repLP p;
1117 ; (ss2,zs) <- repSts ss
1118 ; z <- repBindSt p1 e2
1119 ; return (ss1++ss2, z : zs) }}
1120 repSts (LetStmt bs : ss) =
1121 do { (ss1,ds) <- repBinds bs
1122 ; z <- repLetSt ds
1123 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1124 ; return (ss1++ss2, z : zs) }
1125 repSts (BodyStmt e _ _ _ : ss) =
1126 do { e2 <- repLE e
1127 ; z <- repNoBindSt e2
1128 ; (ss2,zs) <- repSts ss
1129 ; return (ss2, z : zs) }
1130 repSts (ParStmt stmt_blocks _ _ : ss) =
1131 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1132 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1133 ss1 = concat ss_s
1134 ; z <- repParSt stmt_blocks2
1135 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1136 ; return (ss1++ss2, z : zs) }
1137 where
1138 rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])
1139 rep_stmt_block (ParStmtBlock stmts _ _) =
1140 do { (ss1, zs) <- repSts (map unLoc stmts)
1141 ; zs1 <- coreList stmtQTyConName zs
1142 ; return (ss1, zs1) }
1143 repSts [LastStmt e _]
1144 = do { e2 <- repLE e
1145 ; z <- repNoBindSt e2
1146 ; return ([], [z]) }
1147 repSts [] = return ([],[])
1148 repSts other = notHandled "Exotic statement" (ppr other)
1149
1150
1151 -----------------------------------------------------------
1152 -- Bindings
1153 -----------------------------------------------------------
1154
1155 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1156 repBinds EmptyLocalBinds
1157 = do { core_list <- coreList decQTyConName []
1158 ; return ([], core_list) }
1159
1160 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1161
1162 repBinds (HsValBinds decs)
1163 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1164 -- No need to worrry about detailed scopes within
1165 -- the binding group, because we are talking Names
1166 -- here, so we can safely treat it as a mutually
1167 -- recursive group
1168 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1169 ; ss <- mkGenSyms bndrs
1170 ; prs <- addBinds ss (rep_val_binds decs)
1171 ; core_list <- coreList decQTyConName
1172 (de_loc (sort_by_loc prs))
1173 ; return (ss, core_list) }
1174
1175 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1176 -- Assumes: all the binders of the binding are alrady in the meta-env
1177 rep_val_binds (ValBindsOut binds sigs)
1178 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1179 ; core2 <- rep_sigs' sigs
1180 ; return (core1 ++ core2) }
1181 rep_val_binds (ValBindsIn _ _)
1182 = panic "rep_val_binds: ValBindsIn"
1183
1184 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1185 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1186 ; return (de_loc (sort_by_loc binds_w_locs)) }
1187
1188 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1189 rep_binds' binds = mapM rep_bind (bagToList binds)
1190
1191 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1192 -- Assumes: all the binders of the binding are alrady in the meta-env
1193
1194 -- Note GHC treats declarations of a variable (not a pattern)
1195 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1196 -- with an empty list of patterns
1197 rep_bind (L loc (FunBind { fun_id = fn,
1198 fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
1199 = do { (ss,wherecore) <- repBinds wheres
1200 ; guardcore <- addBinds ss (repGuards guards)
1201 ; fn' <- lookupLBinder fn
1202 ; p <- repPvar fn'
1203 ; ans <- repVal p guardcore wherecore
1204 ; ans' <- wrapGenSyms ss ans
1205 ; return (loc, ans') }
1206
1207 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
1208 = do { ms1 <- mapM repClauseTup ms
1209 ; fn' <- lookupLBinder fn
1210 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1211 ; return (loc, ans) }
1212
1213 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1214 = do { patcore <- repLP pat
1215 ; (ss,wherecore) <- repBinds wheres
1216 ; guardcore <- addBinds ss (repGuards guards)
1217 ; ans <- repVal patcore guardcore wherecore
1218 ; ans' <- wrapGenSyms ss ans
1219 ; return (loc, ans') }
1220
1221 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1222 = do { v' <- lookupBinder v
1223 ; e2 <- repLE e
1224 ; x <- repNormal e2
1225 ; patcore <- repPvar v'
1226 ; empty_decls <- coreList decQTyConName []
1227 ; ans <- repVal patcore x empty_decls
1228 ; return (srcLocSpan (getSrcLoc v), ans) }
1229
1230 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1231
1232 -----------------------------------------------------------------------------
1233 -- Since everything in a Bind is mutually recursive we need rename all
1234 -- all the variables simultaneously. For example:
1235 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1236 -- do { f'1 <- gensym "f"
1237 -- ; g'2 <- gensym "g"
1238 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1239 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1240 -- ]}
1241 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1242 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1243 -- together. As we do this we collect GenSymBinds's which represent the renamed
1244 -- variables bound by the Bindings. In order not to lose track of these
1245 -- representations we build a shadow datatype MB with the same structure as
1246 -- MonoBinds, but which has slots for the representations
1247
1248
1249 -----------------------------------------------------------------------------
1250 -- GHC allows a more general form of lambda abstraction than specified
1251 -- by Haskell 98. In particular it allows guarded lambda's like :
1252 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1253 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1254 -- (\ p1 .. pn -> exp) by causing an error.
1255
1256 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
1257 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1258 = do { let bndrs = collectPatsBinders ps ;
1259 ; ss <- mkGenSyms bndrs
1260 ; lam <- addBinds ss (
1261 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1262 ; wrapGenSyms ss lam }
1263
1264 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1265
1266
1267 -----------------------------------------------------------------------------
1268 -- Patterns
1269 -- repP deals with patterns. It assumes that we have already
1270 -- walked over the pattern(s) once to collect the binders, and
1271 -- have extended the environment. So every pattern-bound
1272 -- variable should already appear in the environment.
1273
1274 -- Process a list of patterns
1275 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1276 repLPs ps = repList patQTyConName repLP ps
1277
1278 repLP :: LPat Name -> DsM (Core TH.PatQ)
1279 repLP (L _ p) = repP p
1280
1281 repP :: Pat Name -> DsM (Core TH.PatQ)
1282 repP (WildPat _) = repPwild
1283 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1284 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1285 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1286 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1287 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1288 repP (ParPat p) = repLP p
1289 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1290 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
1291 repP (TuplePat ps boxed _)
1292 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1293 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1294 repP (ConPatIn dc details)
1295 = do { con_str <- lookupLOcc dc
1296 ; case details of
1297 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1298 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1299 ; repPrec con_str fps }
1300 InfixCon p1 p2 -> do { p1' <- repLP p1;
1301 p2' <- repLP p2;
1302 repPinfix p1' con_str p2' }
1303 }
1304 where
1305 rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)
1306 ; MkC p <- repLP (hsRecFieldArg fld)
1307 ; rep2 fieldPatName [v,p] }
1308
1309 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1310 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1311 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1312 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1313 -- The problem is to do with scoped type variables.
1314 -- To implement them, we have to implement the scoping rules
1315 -- here in DsMeta, and I don't want to do that today!
1316 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1317 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1318 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1319
1320 repP other = notHandled "Exotic pattern" (ppr other)
1321
1322 ----------------------------------------------------------
1323 -- Declaration ordering helpers
1324
1325 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1326 sort_by_loc xs = sortBy comp xs
1327 where comp x y = compare (fst x) (fst y)
1328
1329 de_loc :: [(a, b)] -> [b]
1330 de_loc = map snd
1331
1332 ----------------------------------------------------------
1333 -- The meta-environment
1334
1335 -- A name/identifier association for fresh names of locally bound entities
1336 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1337 -- I.e. (x, x_id) means
1338 -- let x_id = gensym "x" in ...
1339
1340 -- Generate a fresh name for a locally bound entity
1341
1342 mkGenSyms :: [Name] -> DsM [GenSymBind]
1343 -- We can use the existing name. For example:
1344 -- [| \x_77 -> x_77 + x_77 |]
1345 -- desugars to
1346 -- do { x_77 <- genSym "x"; .... }
1347 -- We use the same x_77 in the desugared program, but with the type Bndr
1348 -- instead of Int
1349 --
1350 -- We do make it an Internal name, though (hence localiseName)
1351 --
1352 -- Nevertheless, it's monadic because we have to generate nameTy
1353 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1354 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1355
1356
1357 addBinds :: [GenSymBind] -> DsM a -> DsM a
1358 -- Add a list of fresh names for locally bound entities to the
1359 -- meta environment (which is part of the state carried around
1360 -- by the desugarer monad)
1361 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1362
1363 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1364 dupBinder (new, old)
1365 = do { mb_val <- dsLookupMetaEnv old
1366 ; case mb_val of
1367 Just val -> return (new, val)
1368 Nothing -> pprPanic "dupBinder" (ppr old) }
1369
1370 -- Look up a locally bound name
1371 --
1372 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1373 lookupLBinder (L _ n) = lookupBinder n
1374
1375 lookupBinder :: Name -> DsM (Core TH.Name)
1376 lookupBinder = lookupOcc
1377 -- Binders are brought into scope before the pattern or what-not is
1378 -- desugared. Moreover, in instance declaration the binder of a method
1379 -- will be the selector Id and hence a global; so we need the
1380 -- globalVar case of lookupOcc
1381
1382 -- Look up a name that is either locally bound or a global name
1383 --
1384 -- * If it is a global name, generate the "original name" representation (ie,
1385 -- the <module>:<name> form) for the associated entity
1386 --
1387 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1388 -- Lookup an occurrence; it can't be a splice.
1389 -- Use the in-scope bindings if they exist
1390 lookupLOcc (L _ n) = lookupOcc n
1391
1392 lookupOcc :: Name -> DsM (Core TH.Name)
1393 lookupOcc n
1394 = do { mb_val <- dsLookupMetaEnv n ;
1395 case mb_val of
1396 Nothing -> globalVar n
1397 Just (Bound x) -> return (coreVar x)
1398 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1399 }
1400
1401 globalVar :: Name -> DsM (Core TH.Name)
1402 -- Not bound by the meta-env
1403 -- Could be top-level; or could be local
1404 -- f x = $(g [| x |])
1405 -- Here the x will be local
1406 globalVar name
1407 | isExternalName name
1408 = do { MkC mod <- coreStringLit name_mod
1409 ; MkC pkg <- coreStringLit name_pkg
1410 ; MkC occ <- occNameLit name
1411 ; rep2 mk_varg [pkg,mod,occ] }
1412 | otherwise
1413 = do { MkC occ <- occNameLit name
1414 ; MkC uni <- coreIntLit (getKey (getUnique name))
1415 ; rep2 mkNameLName [occ,uni] }
1416 where
1417 mod = ASSERT( isExternalName name) nameModule name
1418 name_mod = moduleNameString (moduleName mod)
1419 name_pkg = packageIdString (modulePackageId mod)
1420 name_occ = nameOccName name
1421 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1422 | OccName.isVarOcc name_occ = mkNameG_vName
1423 | OccName.isTcOcc name_occ = mkNameG_tcName
1424 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1425
1426 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1427 -> DsM Type -- The type
1428 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1429 return (mkTyConApp tc []) }
1430
1431 wrapGenSyms :: [GenSymBind]
1432 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1433 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1434 -- --> bindQ (gensym nm1) (\ id1 ->
1435 -- bindQ (gensym nm2 (\ id2 ->
1436 -- y))
1437
1438 wrapGenSyms binds body@(MkC b)
1439 = do { var_ty <- lookupType nameTyConName
1440 ; go var_ty binds }
1441 where
1442 [elt_ty] = tcTyConAppArgs (exprType b)
1443 -- b :: Q a, so we can get the type 'a' by looking at the
1444 -- argument type. NB: this relies on Q being a data/newtype,
1445 -- not a type synonym
1446
1447 go _ [] = return body
1448 go var_ty ((name,id) : binds)
1449 = do { MkC body' <- go var_ty binds
1450 ; lit_str <- occNameLit name
1451 ; gensym_app <- repGensym lit_str
1452 ; repBindQ var_ty elt_ty
1453 gensym_app (MkC (Lam id body')) }
1454
1455 occNameLit :: Name -> DsM (Core String)
1456 occNameLit n = coreStringLit (occNameString (nameOccName n))
1457
1458
1459 -- %*********************************************************************
1460 -- %* *
1461 -- Constructing code
1462 -- %* *
1463 -- %*********************************************************************
1464
1465 -----------------------------------------------------------------------------
1466 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1467 -- we invent a new datatype which uses phantom types.
1468
1469 newtype Core a = MkC CoreExpr
1470 unC :: Core a -> CoreExpr
1471 unC (MkC x) = x
1472
1473 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1474 rep2 n xs = do { id <- dsLookupGlobalId n
1475 ; return (MkC (foldl App (Var id) xs)) }
1476
1477 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1478 dataCon' n args = do { id <- dsLookupDataCon n
1479 ; return $ MkC $ mkConApp id args }
1480
1481 dataCon :: Name -> DsM (Core a)
1482 dataCon n = dataCon' n []
1483
1484 -- Then we make "repConstructors" which use the phantom types for each of the
1485 -- smart constructors of the Meta.Meta datatypes.
1486
1487
1488 -- %*********************************************************************
1489 -- %* *
1490 -- The 'smart constructors'
1491 -- %* *
1492 -- %*********************************************************************
1493
1494 --------------- Patterns -----------------
1495 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1496 repPlit (MkC l) = rep2 litPName [l]
1497
1498 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1499 repPvar (MkC s) = rep2 varPName [s]
1500
1501 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1502 repPtup (MkC ps) = rep2 tupPName [ps]
1503
1504 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1505 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1506
1507 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1508 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1509
1510 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1511 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1512
1513 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1514 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1515
1516 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1517 repPtilde (MkC p) = rep2 tildePName [p]
1518
1519 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1520 repPbang (MkC p) = rep2 bangPName [p]
1521
1522 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1523 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1524
1525 repPwild :: DsM (Core TH.PatQ)
1526 repPwild = rep2 wildPName []
1527
1528 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1529 repPlist (MkC ps) = rep2 listPName [ps]
1530
1531 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1532 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1533
1534 --------------- Expressions -----------------
1535 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1536 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1537 | otherwise = repVar str
1538
1539 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1540 repVar (MkC s) = rep2 varEName [s]
1541
1542 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1543 repCon (MkC s) = rep2 conEName [s]
1544
1545 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1546 repLit (MkC c) = rep2 litEName [c]
1547
1548 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1549 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1550
1551 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1552 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1553
1554 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1555 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1556
1557 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1558 repTup (MkC es) = rep2 tupEName [es]
1559
1560 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1561 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1562
1563 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1564 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1565
1566 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1567 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1568
1569 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1570 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1571
1572 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1573 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1574
1575 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1576 repDoE (MkC ss) = rep2 doEName [ss]
1577
1578 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1579 repComp (MkC ss) = rep2 compEName [ss]
1580
1581 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1582 repListExp (MkC es) = rep2 listEName [es]
1583
1584 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1585 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1586
1587 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1588 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1589
1590 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1591 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1592
1593 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1594 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1595
1596 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1597 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1598
1599 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1600 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1601
1602 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1603 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1604
1605 ------------ Right hand sides (guarded expressions) ----
1606 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1607 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1608
1609 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1610 repNormal (MkC e) = rep2 normalBName [e]
1611
1612 ------------ Guards ----
1613 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1614 repLNormalGE g e = do g' <- repLE g
1615 e' <- repLE e
1616 repNormalGE g' e'
1617
1618 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1619 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1620
1621 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1622 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1623
1624 ------------- Stmts -------------------
1625 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1626 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1627
1628 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1629 repLetSt (MkC ds) = rep2 letSName [ds]
1630
1631 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1632 repNoBindSt (MkC e) = rep2 noBindSName [e]
1633
1634 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
1635 repParSt (MkC sss) = rep2 parSName [sss]
1636
1637 -------------- Range (Arithmetic sequences) -----------
1638 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1639 repFrom (MkC x) = rep2 fromEName [x]
1640
1641 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1642 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1643
1644 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1645 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1646
1647 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1648 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1649
1650 ------------ Match and Clause Tuples -----------
1651 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1652 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1653
1654 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1655 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1656
1657 -------------- Dec -----------------------------
1658 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1659 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1660
1661 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1662 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1663
1664 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1665 -> Maybe (Core [TH.TypeQ])
1666 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1667 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1668 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1669 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1670 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1671
1672 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1673 -> Maybe (Core [TH.TypeQ])
1674 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1675 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1676 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1677 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1678 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1679
1680 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1681 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1682 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
1683 = rep2 tySynDName [nm, tvs, rhs]
1684
1685 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1686 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1687
1688 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1689 -> Core [TH.FunDep] -> Core [TH.DecQ]
1690 -> DsM (Core TH.DecQ)
1691 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1692 = rep2 classDName [cxt, cls, tvs, fds, ds]
1693
1694 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
1695 -> Core TH.Phases -> DsM (Core TH.DecQ)
1696 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
1697 = rep2 pragInlDName [nm, inline, rm, phases]
1698
1699 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
1700 -> DsM (Core TH.DecQ)
1701 repPragSpec (MkC nm) (MkC ty) (MkC phases)
1702 = rep2 pragSpecDName [nm, ty, phases]
1703
1704 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
1705 -> Core TH.Phases -> DsM (Core TH.DecQ)
1706 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
1707 = rep2 pragSpecInlDName [nm, ty, inline, phases]
1708
1709 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
1710 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
1711
1712 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
1713 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
1714 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
1715 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
1716
1717 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1718 -> DsM (Core TH.DecQ)
1719 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1720 = rep2 familyNoKindDName [flav, nm, tvs]
1721
1722 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1723 -> Core TH.Kind
1724 -> DsM (Core TH.DecQ)
1725 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1726 = rep2 familyKindDName [flav, nm, tvs, ki]
1727
1728 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
1729 repTySynInst (MkC nm) (MkC eqn)
1730 = rep2 tySynInstDName [nm, eqn]
1731
1732 repClosedFamilyNoKind :: Core TH.Name
1733 -> Core [TH.TyVarBndr]
1734 -> Core [TH.TySynEqnQ]
1735 -> DsM (Core TH.DecQ)
1736 repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
1737 = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
1738
1739 repClosedFamilyKind :: Core TH.Name
1740 -> Core [TH.TyVarBndr]
1741 -> Core TH.Kind
1742 -> Core [TH.TySynEqnQ]
1743 -> DsM (Core TH.DecQ)
1744 repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
1745 = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
1746
1747 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
1748 repTySynEqn (MkC lhs) (MkC rhs)
1749 = rep2 tySynEqnName [lhs, rhs]
1750
1751 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1752 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1753
1754 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1755 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1756
1757 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1758 repCtxt (MkC tys) = rep2 cxtName [tys]
1759
1760 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1761 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1762
1763 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1764 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1765
1766 repConstr :: Core TH.Name -> HsConDeclDetails Name
1767 -> DsM (Core TH.ConQ)
1768 repConstr con (PrefixCon ps)
1769 = do arg_tys <- repList strictTypeQTyConName repBangTy ps
1770 rep2 normalCName [unC con, unC arg_tys]
1771 repConstr con (RecCon ips)
1772 = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips
1773 ; rep2 recCName [unC con, unC arg_vtys] }
1774 where
1775 rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip)
1776 ; MkC ty <- repBangTy (cd_fld_type ip)
1777 ; rep2 varStrictTypeName [v,ty] }
1778
1779 repConstr con (InfixCon st1 st2)
1780 = do arg1 <- repBangTy st1
1781 arg2 <- repBangTy st2
1782 rep2 infixCName [unC arg1, unC con, unC arg2]
1783
1784 ------------ Types -------------------
1785
1786 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1787 -> DsM (Core TH.TypeQ)
1788 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1789 = rep2 forallTName [tvars, ctxt, ty]
1790
1791 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1792 repTvar (MkC s) = rep2 varTName [s]
1793
1794 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1795 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1796
1797 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1798 repTapps f [] = return f
1799 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1800
1801 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1802 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1803
1804 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1805 repTPromotedList [] = repPromotedNilTyCon
1806 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
1807 ; f <- repTapp tcon t
1808 ; t' <- repTPromotedList ts
1809 ; repTapp f t'
1810 }
1811
1812 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
1813 repTLit (MkC lit) = rep2 litTName [lit]
1814
1815 --------- Type constructors --------------
1816
1817 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1818 repNamedTyCon (MkC s) = rep2 conTName [s]
1819
1820 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1821 -- Note: not Core Int; it's easier to be direct here
1822 repTupleTyCon i = do dflags <- getDynFlags
1823 rep2 tupleTName [mkIntExprInt dflags i]
1824
1825 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1826 -- Note: not Core Int; it's easier to be direct here
1827 repUnboxedTupleTyCon i = do dflags <- getDynFlags
1828 rep2 unboxedTupleTName [mkIntExprInt dflags i]
1829
1830 repArrowTyCon :: DsM (Core TH.TypeQ)
1831 repArrowTyCon = rep2 arrowTName []
1832
1833 repListTyCon :: DsM (Core TH.TypeQ)
1834 repListTyCon = rep2 listTName []
1835
1836 repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1837 repPromotedTyCon (MkC s) = rep2 promotedTName [s]
1838
1839 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1840 repPromotedTupleTyCon i = do dflags <- getDynFlags
1841 rep2 promotedTupleTName [mkIntExprInt dflags i]
1842
1843 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
1844 repPromotedNilTyCon = rep2 promotedNilTName []
1845
1846 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
1847 repPromotedConsTyCon = rep2 promotedConsTName []
1848
1849 ------------ Kinds -------------------
1850
1851 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1852 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1853
1854 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1855 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1856
1857 repRoledTV :: Core TH.Name -> Core TH.Role -> DsM (Core TH.TyVarBndr)
1858 repRoledTV (MkC nm) (MkC r) = rep2 roledTVName [nm, r]
1859
1860 repKindedRoledTV :: Core TH.Name -> Core TH.Kind -> Core TH.Role
1861 -> DsM (Core TH.TyVarBndr)
1862 repKindedRoledTV (MkC nm) (MkC k) (MkC r) = rep2 kindedRoledTVName [nm, k, r]
1863
1864 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
1865 repKVar (MkC s) = rep2 varKName [s]
1866
1867 repKCon :: Core TH.Name -> DsM (Core TH.Kind)
1868 repKCon (MkC s) = rep2 conKName [s]
1869
1870 repKTuple :: Int -> DsM (Core TH.Kind)
1871 repKTuple i = do dflags <- getDynFlags
1872 rep2 tupleKName [mkIntExprInt dflags i]
1873
1874 repKArrow :: DsM (Core TH.Kind)
1875 repKArrow = rep2 arrowKName []
1876
1877 repKList :: DsM (Core TH.Kind)
1878 repKList = rep2 listKName []
1879
1880 repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1881 repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
1882
1883 repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
1884 repKApps f [] = return f
1885 repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
1886
1887 repKStar :: DsM (Core TH.Kind)
1888 repKStar = rep2 starKName []
1889
1890 repKConstraint :: DsM (Core TH.Kind)
1891 repKConstraint = rep2 constraintKName []
1892
1893 ----------------------------------------------------------
1894 -- Literals
1895
1896 repLiteral :: HsLit -> DsM (Core TH.Lit)
1897 repLiteral lit
1898 = do lit' <- case lit of
1899 HsIntPrim i -> mk_integer i
1900 HsWordPrim w -> mk_integer w
1901 HsInt i -> mk_integer i
1902 HsFloatPrim r -> mk_rational r
1903 HsDoublePrim r -> mk_rational r
1904 _ -> return lit
1905 lit_expr <- dsLit lit'
1906 case mb_lit_name of
1907 Just lit_name -> rep2 lit_name [lit_expr]
1908 Nothing -> notHandled "Exotic literal" (ppr lit)
1909 where
1910 mb_lit_name = case lit of
1911 HsInteger _ _ -> Just integerLName
1912 HsInt _ -> Just integerLName
1913 HsIntPrim _ -> Just intPrimLName
1914 HsWordPrim _ -> Just wordPrimLName
1915 HsFloatPrim _ -> Just floatPrimLName
1916 HsDoublePrim _ -> Just doublePrimLName
1917 HsChar _ -> Just charLName
1918 HsString _ -> Just stringLName
1919 HsRat _ _ -> Just rationalLName
1920 _ -> Nothing
1921
1922 mk_integer :: Integer -> DsM HsLit
1923 mk_integer i = do integer_ty <- lookupType integerTyConName
1924 return $ HsInteger i integer_ty
1925 mk_rational :: FractionalLit -> DsM HsLit
1926 mk_rational r = do rat_ty <- lookupType rationalTyConName
1927 return $ HsRat r rat_ty
1928 mk_string :: FastString -> DsM HsLit
1929 mk_string s = return $ HsString s
1930
1931 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1932 repOverloadedLiteral (OverLit { ol_val = val})
1933 = do { lit <- mk_lit val; repLiteral lit }
1934 -- The type Rational will be in the environment, because
1935 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1936 -- and rationalL is sucked in when any TH stuff is used
1937
1938 mk_lit :: OverLitVal -> DsM HsLit
1939 mk_lit (HsIntegral i) = mk_integer i
1940 mk_lit (HsFractional f) = mk_rational f
1941 mk_lit (HsIsString s) = mk_string s
1942
1943 --------------- Miscellaneous -------------------
1944
1945 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1946 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1947
1948 repBindQ :: Type -> Type -- a and b
1949 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1950 repBindQ ty_a ty_b (MkC x) (MkC y)
1951 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1952
1953 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1954 repSequenceQ ty_a (MkC list)
1955 = rep2 sequenceQName [Type ty_a, list]
1956
1957 ------------ Lists and Tuples -------------------
1958 -- turn a list of patterns into a single pattern matching a list
1959
1960 repList :: Name -> (a -> DsM (Core b))
1961 -> [a] -> DsM (Core [b])
1962 repList tc_name f args
1963 = do { args1 <- mapM f args
1964 ; coreList tc_name args1 }
1965
1966 coreList :: Name -- Of the TyCon of the element type
1967 -> [Core a] -> DsM (Core [a])
1968 coreList tc_name es
1969 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1970
1971 coreList' :: Type -- The element type
1972 -> [Core a] -> Core [a]
1973 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1974
1975 nonEmptyCoreList :: [Core a] -> Core [a]
1976 -- The list must be non-empty so we can get the element type
1977 -- Otherwise use coreList
1978 nonEmptyCoreList [] = panic "coreList: empty argument"
1979 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1980
1981 coreStringLit :: String -> DsM (Core String)
1982 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1983
1984 ------------ Literals & Variables -------------------
1985
1986 coreIntLit :: Int -> DsM (Core Int)
1987 coreIntLit i = do dflags <- getDynFlags
1988 return (MkC (mkIntExprInt dflags i))
1989
1990 coreVar :: Id -> Core TH.Name -- The Id has type Name
1991 coreVar id = MkC (Var id)
1992
1993 ----------------- Failure -----------------------
1994 notHandled :: String -> SDoc -> DsM a
1995 notHandled what doc = failWithDs msg
1996 where
1997 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1998 2 doc
1999
2000
2001 -- %************************************************************************
2002 -- %* *
2003 -- The known-key names for Template Haskell
2004 -- %* *
2005 -- %************************************************************************
2006
2007 -- To add a name, do three things
2008 --
2009 -- 1) Allocate a key
2010 -- 2) Make a "Name"
2011 -- 3) Add the name to knownKeyNames
2012
2013 templateHaskellNames :: [Name]
2014 -- The names that are implicitly mentioned by ``bracket''
2015 -- Should stay in sync with the import list of DsMeta
2016
2017 templateHaskellNames = [
2018 returnQName, bindQName, sequenceQName, newNameName, liftName,
2019 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
2020 liftStringName,
2021
2022 -- Lit
2023 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
2024 floatPrimLName, doublePrimLName, rationalLName,
2025 -- Pat
2026 litPName, varPName, tupPName, unboxedTupPName,
2027 conPName, tildePName, bangPName, infixPName,
2028 asPName, wildPName, recPName, listPName, sigPName, viewPName,
2029 -- FieldPat
2030 fieldPatName,
2031 -- Match
2032 matchName,
2033 -- Clause
2034 clauseName,
2035 -- Exp
2036 varEName, conEName, litEName, appEName, infixEName,
2037 infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
2038 tupEName, unboxedTupEName,
2039 condEName, multiIfEName, letEName, caseEName, doEName, compEName,
2040 fromEName, fromThenEName, fromToEName, fromThenToEName,
2041 listEName, sigEName, recConEName, recUpdEName,
2042 -- FieldExp
2043 fieldExpName,
2044 -- Body
2045 guardedBName, normalBName,
2046 -- Guard
2047 normalGEName, patGEName,
2048 -- Stmt
2049 bindSName, letSName, noBindSName, parSName,
2050 -- Dec
2051 funDName, valDName, dataDName, newtypeDName, tySynDName,
2052 classDName, instanceDName, sigDName, forImpDName,
2053 pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
2054 pragRuleDName,
2055 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
2056 tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
2057 infixLDName, infixRDName, infixNDName,
2058 -- Cxt
2059 cxtName,
2060 -- Pred
2061 classPName, equalPName,
2062 -- Strict
2063 isStrictName, notStrictName, unpackedName,
2064 -- Con
2065 normalCName, recCName, infixCName, forallCName,
2066 -- StrictType
2067 strictTypeName,
2068 -- VarStrictType
2069 varStrictTypeName,
2070 -- Type
2071 forallTName, varTName, conTName, appTName,
2072 tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
2073 promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
2074 -- TyLit
2075 numTyLitName, strTyLitName,
2076 -- TyVarBndr
2077 plainTVName, kindedTVName, roledTVName, kindedRoledTVName,
2078 -- Role
2079 nominalName, representationalName, phantomName,
2080 -- Kind
2081 varKName, conKName, tupleKName, arrowKName, listKName, appKName,
2082 starKName, constraintKName,
2083 -- Callconv
2084 cCallName, stdCallName,
2085 -- Safety
2086 unsafeName,
2087 safeName,
2088 interruptibleName,
2089 -- Inline
2090 noInlineDataConName, inlineDataConName, inlinableDataConName,
2091 -- RuleMatch
2092 conLikeDataConName, funLikeDataConName,
2093 -- Phases
2094 allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
2095 -- RuleBndr
2096 ruleVarName, typedRuleVarName,
2097 -- FunDep
2098 funDepName,
2099 -- FamFlavour
2100 typeFamName, dataFamName,
2101 -- TySynEqn
2102 tySynEqnName,
2103
2104 -- And the tycons
2105 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
2106 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
2107 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
2108 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
2109 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
2110 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
2111 predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
2112
2113 -- Quasiquoting
2114 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
2115
2116 thSyn, thLib, qqLib :: Module
2117 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
2118 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
2119 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
2120
2121 mkTHModule :: FastString -> Module
2122 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
2123
2124 libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name
2125 libFun = mk_known_key_name OccName.varName thLib
2126 libTc = mk_known_key_name OccName.tcName thLib
2127 thFun = mk_known_key_name OccName.varName thSyn
2128 thTc = mk_known_key_name OccName.tcName thSyn
2129 thCon = mk_known_key_name OccName.dataName thSyn
2130 qqFun = mk_known_key_name OccName.varName qqLib
2131
2132 -------------------- TH.Syntax -----------------------
2133 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
2134 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
2135 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
2136 predTyConName :: Name
2137 qTyConName = thTc (fsLit "Q") qTyConKey
2138 nameTyConName = thTc (fsLit "Name") nameTyConKey
2139 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
2140 patTyConName = thTc (fsLit "Pat") patTyConKey
2141 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
2142 expTyConName = thTc (fsLit "Exp") expTyConKey
2143 decTyConName = thTc (fsLit "Dec") decTyConKey
2144 typeTyConName = thTc (fsLit "Type") typeTyConKey
2145 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
2146 matchTyConName = thTc (fsLit "Match") matchTyConKey
2147 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
2148 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
2149 predTyConName = thTc (fsLit "Pred") predTyConKey
2150
2151 returnQName, bindQName, sequenceQName, newNameName, liftName,
2152 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
2153 mkNameLName, liftStringName :: Name
2154 returnQName = thFun (fsLit "returnQ") returnQIdKey
2155 bindQName = thFun (fsLit "bindQ") bindQIdKey
2156 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
2157 newNameName = thFun (fsLit "newName") newNameIdKey
2158 liftName = thFun (fsLit "lift") liftIdKey
2159 liftStringName = thFun (fsLit "liftString") liftStringIdKey
2160 mkNameName = thFun (fsLit "mkName") mkNameIdKey
2161 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
2162 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
2163 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
2164 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
2165
2166
2167 -------------------- TH.Lib -----------------------
2168 -- data Lit = ...
2169 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
2170 floatPrimLName, doublePrimLName, rationalLName :: Name
2171 charLName = libFun (fsLit "charL") charLIdKey
2172 stringLName = libFun (fsLit "stringL") stringLIdKey
2173 integerLName = libFun (fsLit "integerL") integerLIdKey
2174 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
2175 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
2176 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
2177 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
2178 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
2179
2180 -- data Pat = ...
2181 litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
2182 asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
2183 litPName = libFun (fsLit "litP") litPIdKey
2184 varPName = libFun (fsLit "varP") varPIdKey
2185 tupPName = libFun (fsLit "tupP") tupPIdKey
2186 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
2187 conPName = libFun (fsLit "conP") conPIdKey
2188 infixPName = libFun (fsLit "infixP") infixPIdKey
2189 tildePName = libFun (fsLit "tildeP") tildePIdKey
2190 bangPName = libFun (fsLit "bangP") bangPIdKey
2191 asPName = libFun (fsLit "asP") asPIdKey
2192 wildPName = libFun (fsLit "wildP") wildPIdKey
2193 recPName = libFun (fsLit "recP") recPIdKey
2194 listPName = libFun (fsLit "listP") listPIdKey
2195 sigPName = libFun (fsLit "sigP") sigPIdKey
2196 viewPName = libFun (fsLit "viewP") viewPIdKey
2197
2198 -- type FieldPat = ...
2199 fieldPatName :: Name
2200 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
2201
2202 -- data Match = ...
2203 matchName :: Name
2204 matchName = libFun (fsLit "match") matchIdKey
2205
2206 -- data Clause = ...
2207 clauseName :: Name
2208 clauseName = libFun (fsLit "clause") clauseIdKey
2209
2210 -- data Exp = ...
2211 varEName, conEName, litEName, appEName, infixEName, infixAppName,
2212 sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
2213 unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
2214 doEName, compEName :: Name
2215 varEName = libFun (fsLit "varE") varEIdKey
2216 conEName = libFun (fsLit "conE") conEIdKey
2217 litEName = libFun (fsLit "litE") litEIdKey
2218 appEName = libFun (fsLit "appE") appEIdKey
2219 infixEName = libFun (fsLit "infixE") infixEIdKey
2220 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
2221 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
2222 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
2223 lamEName = libFun (fsLit "lamE") lamEIdKey
2224 lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
2225 tupEName = libFun (fsLit "tupE") tupEIdKey
2226 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
2227 condEName = libFun (fsLit "condE") condEIdKey
2228 multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
2229 letEName = libFun (fsLit "letE") letEIdKey
2230 caseEName = libFun (fsLit "caseE") caseEIdKey
2231 doEName = libFun (fsLit "doE") doEIdKey
2232 compEName = libFun (fsLit "compE") compEIdKey
2233 -- ArithSeq skips a level
2234 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
2235 fromEName = libFun (fsLit "fromE") fromEIdKey
2236 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
2237 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
2238 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
2239 -- end ArithSeq
2240 listEName, sigEName, recConEName, recUpdEName :: Name
2241 listEName = libFun (fsLit "listE") listEIdKey
2242 sigEName = libFun (fsLit "sigE") sigEIdKey
2243 recConEName = libFun (fsLit "recConE") recConEIdKey
2244 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
2245
2246 -- type FieldExp = ...
2247 fieldExpName :: Name
2248 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
2249
2250 -- data Body = ...
2251 guardedBName, normalBName :: Name
2252 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
2253 normalBName = libFun (fsLit "normalB") normalBIdKey
2254
2255 -- data Guard = ...
2256 normalGEName, patGEName :: Name
2257 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
2258 patGEName = libFun (fsLit "patGE") patGEIdKey
2259
2260 -- data Stmt = ...
2261 bindSName, letSName, noBindSName, parSName :: Name
2262 bindSName = libFun (fsLit "bindS") bindSIdKey
2263 letSName = libFun (fsLit "letS") letSIdKey
2264 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
2265 parSName = libFun (fsLit "parS") parSIdKey
2266
2267 -- data Dec = ...
2268 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
2269 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
2270 pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
2271 familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
2272 closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
2273 infixLDName, infixRDName, infixNDName :: Name
2274 funDName = libFun (fsLit "funD") funDIdKey
2275 valDName = libFun (fsLit "valD") valDIdKey
2276 dataDName = libFun (fsLit "dataD") dataDIdKey
2277 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
2278 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
2279 classDName = libFun (fsLit "classD") classDIdKey
2280 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
2281 sigDName = libFun (fsLit "sigD") sigDIdKey
2282 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
2283 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
2284 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
2285 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
2286 pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
2287 pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
2288 familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey
2289 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
2290 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
2291 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
2292 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
2293 closedTypeFamilyKindDName
2294 = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
2295 closedTypeFamilyNoKindDName
2296 = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
2297 infixLDName = libFun (fsLit "infixLD") infixLDIdKey
2298 infixRDName = libFun (fsLit "infixRD") infixRDIdKey
2299 infixNDName = libFun (fsLit "infixND") infixNDIdKey
2300
2301 -- type Ctxt = ...
2302 cxtName :: Name
2303 cxtName = libFun (fsLit "cxt") cxtIdKey
2304
2305 -- data Pred = ...
2306 classPName, equalPName :: Name
2307 classPName = libFun (fsLit "classP") classPIdKey
2308 equalPName = libFun (fsLit "equalP") equalPIdKey
2309
2310 -- data Strict = ...
2311 isStrictName, notStrictName, unpackedName :: Name
2312 isStrictName = libFun (fsLit "isStrict") isStrictKey
2313 notStrictName = libFun (fsLit "notStrict") notStrictKey
2314 unpackedName = libFun (fsLit "unpacked") unpackedKey
2315
2316 -- data Con = ...
2317 normalCName, recCName, infixCName, forallCName :: Name
2318 normalCName = libFun (fsLit "normalC") normalCIdKey
2319 recCName = libFun (fsLit "recC") recCIdKey
2320 infixCName = libFun (fsLit "infixC") infixCIdKey
2321 forallCName = libFun (fsLit "forallC") forallCIdKey
2322
2323 -- type StrictType = ...
2324 strictTypeName :: Name
2325 strictTypeName = libFun (fsLit "strictType") strictTKey
2326
2327 -- type VarStrictType = ...
2328 varStrictTypeName :: Name
2329 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
2330
2331 -- data Type = ...
2332 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
2333 listTName, appTName, sigTName, litTName,
2334 promotedTName, promotedTupleTName,
2335 promotedNilTName, promotedConsTName :: Name
2336 forallTName = libFun (fsLit "forallT") forallTIdKey
2337 varTName = libFun (fsLit "varT") varTIdKey
2338 conTName = libFun (fsLit "conT") conTIdKey
2339 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
2340 unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
2341 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
2342 listTName = libFun (fsLit "listT") listTIdKey
2343 appTName = libFun (fsLit "appT") appTIdKey
2344 sigTName = libFun (fsLit "sigT") sigTIdKey
2345 litTName = libFun (fsLit "litT") litTIdKey
2346 promotedTName = libFun (fsLit "promotedT") promotedTIdKey
2347 promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
2348 promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey
2349 promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey
2350
2351 -- data TyLit = ...
2352 numTyLitName, strTyLitName :: Name
2353 numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
2354 strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
2355
2356 -- data TyVarBndr = ...
2357 plainTVName, kindedTVName, roledTVName, kindedRoledTVName :: Name
2358 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
2359 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
2360 roledTVName = libFun (fsLit "roledTV") roledTVIdKey
2361 kindedRoledTVName = libFun (fsLit "kindedRoledTV") kindedRoledTVIdKey
2362
2363 -- data Role = ...
2364 nominalName, representationalName, phantomName :: Name
2365 nominalName = libFun (fsLit "nominal") nominalIdKey
2366 representationalName = libFun (fsLit "representational") representationalIdKey
2367 phantomName = libFun (fsLit "phantom") phantomIdKey
2368
2369 -- data Kind = ...
2370 varKName, conKName, tupleKName, arrowKName, listKName, appKName,
2371 starKName, constraintKName :: Name
2372 varKName = libFun (fsLit "varK") varKIdKey
2373 conKName = libFun (fsLit "conK") conKIdKey
2374 tupleKName = libFun (fsLit "tupleK") tupleKIdKey
2375 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
2376 listKName = libFun (fsLit "listK") listKIdKey
2377 appKName = libFun (fsLit "appK") appKIdKey
2378 starKName = libFun (fsLit "starK") starKIdKey
2379 constraintKName = libFun (fsLit "constraintK") constraintKIdKey
2380
2381 -- data Callconv = ...
2382 cCallName, stdCallName :: Name
2383 cCallName = libFun (fsLit "cCall") cCallIdKey
2384 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
2385
2386 -- data Safety = ...
2387 unsafeName, safeName, interruptibleName :: Name
2388 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
2389 safeName = libFun (fsLit "safe") safeIdKey
2390 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
2391
2392 -- data Inline = ...
2393 noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
2394 noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
2395 inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
2396 inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
2397
2398 -- data RuleMatch = ...
2399 conLikeDataConName, funLikeDataConName :: Name
2400 conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
2401 funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
2402
2403 -- data Phases = ...
2404 allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
2405 allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
2406 fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
2407 beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
2408
2409 -- data RuleBndr = ...
2410 ruleVarName, typedRuleVarName :: Name
2411 ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
2412 typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
2413
2414 -- data FunDep = ...
2415 funDepName :: Name
2416 funDepName = libFun (fsLit "funDep") funDepIdKey
2417
2418 -- data FamFlavour = ...
2419 typeFamName, dataFamName :: Name
2420 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2421 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2422
2423 -- data TySynEqn = ...
2424 tySynEqnName :: Name
2425 tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
2426
2427 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2428 decQTyConName, conQTyConName, strictTypeQTyConName,
2429 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2430 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
2431 ruleBndrQTyConName, tySynEqnQTyConName :: Name
2432 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2433 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2434 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2435 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2436 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2437 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2438 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2439 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2440 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2441 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2442 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2443 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2444 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2445 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2446 ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
2447 tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
2448
2449 -- quasiquoting
2450 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2451 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2452 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2453 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2454 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2455
2456 -- TyConUniques available: 200-299
2457 -- Check in PrelNames if you want to change this
2458
2459 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2460 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2461 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2462 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2463 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2464 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2465 predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey :: Unique
2466 expTyConKey = mkPreludeTyConUnique 200
2467 matchTyConKey = mkPreludeTyConUnique 201
2468 clauseTyConKey = mkPreludeTyConUnique 202
2469 qTyConKey = mkPreludeTyConUnique 203
2470 expQTyConKey = mkPreludeTyConUnique 204
2471 decQTyConKey = mkPreludeTyConUnique 205
2472 patTyConKey = mkPreludeTyConUnique 206
2473 matchQTyConKey = mkPreludeTyConUnique 207
2474 clauseQTyConKey = mkPreludeTyConUnique 208
2475 stmtQTyConKey = mkPreludeTyConUnique 209
2476 conQTyConKey = mkPreludeTyConUnique 210
2477 typeQTyConKey = mkPreludeTyConUnique 211
2478 typeTyConKey = mkPreludeTyConUnique 212
2479 decTyConKey = mkPreludeTyConUnique 213
2480 varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2481 strictTypeQTyConKey = mkPreludeTyConUnique 215
2482 fieldExpTyConKey = mkPreludeTyConUnique 216
2483 fieldPatTyConKey = mkPreludeTyConUnique 217
2484 nameTyConKey = mkPreludeTyConUnique 218
2485 patQTyConKey = mkPreludeTyConUnique 219
2486 fieldPatQTyConKey = mkPreludeTyConUnique 220
2487 fieldExpQTyConKey = mkPreludeTyConUnique 221
2488 funDepTyConKey = mkPreludeTyConUnique 222
2489 predTyConKey = mkPreludeTyConUnique 223
2490 predQTyConKey = mkPreludeTyConUnique 224
2491 tyVarBndrTyConKey = mkPreludeTyConUnique 225
2492 decsQTyConKey = mkPreludeTyConUnique 226
2493 ruleBndrQTyConKey = mkPreludeTyConUnique 227
2494 tySynEqnQTyConKey = mkPreludeTyConUnique 228
2495
2496 -- IdUniques available: 200-499
2497 -- If you want to change this, make sure you check in PrelNames
2498
2499 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2500 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2501 mkNameLIdKey :: Unique
2502 returnQIdKey = mkPreludeMiscIdUnique 200
2503 bindQIdKey = mkPreludeMiscIdUnique 201
2504 sequenceQIdKey = mkPreludeMiscIdUnique 202
2505 liftIdKey = mkPreludeMiscIdUnique 203
2506 newNameIdKey = mkPreludeMiscIdUnique 204
2507 mkNameIdKey = mkPreludeMiscIdUnique 205
2508 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2509 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2510 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2511 mkNameLIdKey = mkPreludeMiscIdUnique 209
2512
2513
2514 -- data Lit = ...
2515 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2516 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2517 charLIdKey = mkPreludeMiscIdUnique 220
2518 stringLIdKey = mkPreludeMiscIdUnique 221
2519 integerLIdKey = mkPreludeMiscIdUnique 222
2520 intPrimLIdKey = mkPreludeMiscIdUnique 223
2521 wordPrimLIdKey = mkPreludeMiscIdUnique 224
2522 floatPrimLIdKey = mkPreludeMiscIdUnique 225
2523 doublePrimLIdKey = mkPreludeMiscIdUnique 226
2524 rationalLIdKey = mkPreludeMiscIdUnique 227
2525
2526 liftStringIdKey :: Unique
2527 liftStringIdKey = mkPreludeMiscIdUnique 228
2528
2529 -- data Pat = ...
2530 litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2531 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2532 litPIdKey = mkPreludeMiscIdUnique 240
2533 varPIdKey = mkPreludeMiscIdUnique 241
2534 tupPIdKey = mkPreludeMiscIdUnique 242
2535 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2536 conPIdKey = mkPreludeMiscIdUnique 244
2537 infixPIdKey = mkPreludeMiscIdUnique 245
2538 tildePIdKey = mkPreludeMiscIdUnique 246
2539 bangPIdKey = mkPreludeMiscIdUnique 247
2540 asPIdKey = mkPreludeMiscIdUnique 248
2541 wildPIdKey = mkPreludeMiscIdUnique 249
2542 recPIdKey = mkPreludeMiscIdUnique 250
2543 listPIdKey = mkPreludeMiscIdUnique 251
2544 sigPIdKey = mkPreludeMiscIdUnique 252
2545 viewPIdKey = mkPreludeMiscIdUnique 253
2546
2547 -- type FieldPat = ...
2548 fieldPatIdKey :: Unique
2549 fieldPatIdKey = mkPreludeMiscIdUnique 260
2550
2551 -- data Match = ...
2552 matchIdKey :: Unique
2553 matchIdKey = mkPreludeMiscIdUnique 261
2554
2555 -- data Clause = ...
2556 clauseIdKey :: Unique
2557 clauseIdKey = mkPreludeMiscIdUnique 262
2558
2559
2560 -- data Exp = ...
2561 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2562 sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
2563 unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
2564 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2565 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2566 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2567 varEIdKey = mkPreludeMiscIdUnique 270
2568 conEIdKey = mkPreludeMiscIdUnique 271
2569 litEIdKey = mkPreludeMiscIdUnique 272
2570 appEIdKey = mkPreludeMiscIdUnique 273
2571 infixEIdKey = mkPreludeMiscIdUnique 274
2572 infixAppIdKey = mkPreludeMiscIdUnique 275
2573 sectionLIdKey = mkPreludeMiscIdUnique 276
2574 sectionRIdKey = mkPreludeMiscIdUnique 277
2575 lamEIdKey = mkPreludeMiscIdUnique 278
2576 lamCaseEIdKey = mkPreludeMiscIdUnique 279
2577 tupEIdKey = mkPreludeMiscIdUnique 280
2578 unboxedTupEIdKey = mkPreludeMiscIdUnique 281
2579 condEIdKey = mkPreludeMiscIdUnique 282
2580 multiIfEIdKey = mkPreludeMiscIdUnique 283
2581 letEIdKey = mkPreludeMiscIdUnique 284
2582 caseEIdKey = mkPreludeMiscIdUnique 285
2583 doEIdKey = mkPreludeMiscIdUnique 286
2584 compEIdKey = mkPreludeMiscIdUnique 287
2585 fromEIdKey = mkPreludeMiscIdUnique 288
2586 fromThenEIdKey = mkPreludeMiscIdUnique 289
2587 fromToEIdKey = mkPreludeMiscIdUnique 290
2588 fromThenToEIdKey = mkPreludeMiscIdUnique 291
2589 listEIdKey = mkPreludeMiscIdUnique 292
2590 sigEIdKey = mkPreludeMiscIdUnique 293
2591 recConEIdKey = mkPreludeMiscIdUnique 294
2592 recUpdEIdKey = mkPreludeMiscIdUnique 295
2593
2594 -- type FieldExp = ...
2595 fieldExpIdKey :: Unique
2596 fieldExpIdKey = mkPreludeMiscIdUnique 310
2597
2598 -- data Body = ...
2599 guardedBIdKey, normalBIdKey :: Unique
2600 guardedBIdKey = mkPreludeMiscIdUnique 311
2601 normalBIdKey = mkPreludeMiscIdUnique 312
2602
2603 -- data Guard = ...
2604 normalGEIdKey, patGEIdKey :: Unique
2605 normalGEIdKey = mkPreludeMiscIdUnique 313
2606 patGEIdKey = mkPreludeMiscIdUnique 314
2607
2608 -- data Stmt = ...
2609 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2610 bindSIdKey = mkPreludeMiscIdUnique 320
2611 letSIdKey = mkPreludeMiscIdUnique 321
2612 noBindSIdKey = mkPreludeMiscIdUnique 322
2613 parSIdKey = mkPreludeMiscIdUnique 323
2614
2615 -- data Dec = ...
2616 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2617 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2618 pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
2619 familyNoKindDIdKey, familyKindDIdKey,
2620 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
2621 closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
2622 infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
2623 funDIdKey = mkPreludeMiscIdUnique 330
2624 valDIdKey = mkPreludeMiscIdUnique 331
2625 dataDIdKey = mkPreludeMiscIdUnique 332
2626 newtypeDIdKey = mkPreludeMiscIdUnique 333
2627 tySynDIdKey = mkPreludeMiscIdUnique 334
2628 classDIdKey = mkPreludeMiscIdUnique 335
2629 instanceDIdKey = mkPreludeMiscIdUnique 336
2630 sigDIdKey = mkPreludeMiscIdUnique 337
2631 forImpDIdKey = mkPreludeMiscIdUnique 338
2632 pragInlDIdKey = mkPreludeMiscIdUnique 339
2633 pragSpecDIdKey = mkPreludeMiscIdUnique 340
2634 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2635 pragSpecInstDIdKey = mkPreludeMiscIdUnique 416
2636 pragRuleDIdKey = mkPreludeMiscIdUnique 417
2637 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2638 familyKindDIdKey = mkPreludeMiscIdUnique 343
2639 dataInstDIdKey = mkPreludeMiscIdUnique 344
2640 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2641 tySynInstDIdKey = mkPreludeMiscIdUnique 346
2642 closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347
2643 closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
2644 infixLDIdKey = mkPreludeMiscIdUnique 349
2645 infixRDIdKey = mkPreludeMiscIdUnique 350
2646 infixNDIdKey = mkPreludeMiscIdUnique 351
2647
2648 -- type Cxt = ...
2649 cxtIdKey :: Unique
2650 cxtIdKey = mkPreludeMiscIdUnique 360
2651
2652 -- data Pred = ...
2653 classPIdKey, equalPIdKey :: Unique
2654 classPIdKey = mkPreludeMiscIdUnique 361
2655 equalPIdKey = mkPreludeMiscIdUnique 362
2656
2657 -- data Strict = ...
2658 isStrictKey, notStrictKey, unpackedKey :: Unique
2659 isStrictKey = mkPreludeMiscIdUnique 363
2660 notStrictKey = mkPreludeMiscIdUnique 364
2661 unpackedKey = mkPreludeMiscIdUnique 365
2662
2663 -- data Con = ...
2664 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2665 normalCIdKey = mkPreludeMiscIdUnique 370
2666 recCIdKey = mkPreludeMiscIdUnique 371
2667 infixCIdKey = mkPreludeMiscIdUnique 372
2668 forallCIdKey = mkPreludeMiscIdUnique 373
2669
2670 -- type StrictType = ...
2671 strictTKey :: Unique
2672 strictTKey = mkPreludeMiscIdUnique 374
2673
2674 -- type VarStrictType = ...
2675 varStrictTKey :: Unique
2676 varStrictTKey = mkPreludeMiscIdUnique 375
2677
2678 -- data Type = ...
2679 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2680 listTIdKey, appTIdKey, sigTIdKey, litTIdKey,
2681 promotedTIdKey, promotedTupleTIdKey,
2682 promotedNilTIdKey, promotedConsTIdKey :: Unique
2683 forallTIdKey = mkPreludeMiscIdUnique 380
2684 varTIdKey = mkPreludeMiscIdUnique 381
2685 conTIdKey = mkPreludeMiscIdUnique 382
2686 tupleTIdKey = mkPreludeMiscIdUnique 383
2687 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2688 arrowTIdKey = mkPreludeMiscIdUnique 385
2689 listTIdKey = mkPreludeMiscIdUnique 386
2690 appTIdKey = mkPreludeMiscIdUnique 387
2691 sigTIdKey = mkPreludeMiscIdUnique 388
2692 litTIdKey = mkPreludeMiscIdUnique 389
2693 promotedTIdKey = mkPreludeMiscIdUnique 390
2694 promotedTupleTIdKey = mkPreludeMiscIdUnique 391
2695 promotedNilTIdKey = mkPreludeMiscIdUnique 392
2696 promotedConsTIdKey = mkPreludeMiscIdUnique 393
2697
2698 -- data TyLit = ...
2699 numTyLitIdKey, strTyLitIdKey :: Unique
2700 numTyLitIdKey = mkPreludeMiscIdUnique 394
2701 strTyLitIdKey = mkPreludeMiscIdUnique 395
2702
2703 -- data TyVarBndr = ...
2704 plainTVIdKey, kindedTVIdKey, roledTVIdKey, kindedRoledTVIdKey :: Unique
2705 plainTVIdKey = mkPreludeMiscIdUnique 396
2706 kindedTVIdKey = mkPreludeMiscIdUnique 397
2707 roledTVIdKey = mkPreludeMiscIdUnique 398
2708 kindedRoledTVIdKey = mkPreludeMiscIdUnique 399
2709
2710 -- data Role = ...
2711 nominalIdKey, representationalIdKey, phantomIdKey :: Unique
2712 nominalIdKey = mkPreludeMiscIdUnique 400
2713 representationalIdKey = mkPreludeMiscIdUnique 401
2714 phantomIdKey = mkPreludeMiscIdUnique 402
2715
2716 -- data Kind = ...
2717 varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
2718 starKIdKey, constraintKIdKey :: Unique
2719 varKIdKey = mkPreludeMiscIdUnique 403
2720 conKIdKey = mkPreludeMiscIdUnique 404
2721 tupleKIdKey = mkPreludeMiscIdUnique 405
2722 arrowKIdKey = mkPreludeMiscIdUnique 406
2723 listKIdKey = mkPreludeMiscIdUnique 407
2724 appKIdKey = mkPreludeMiscIdUnique 408
2725 starKIdKey = mkPreludeMiscIdUnique 409
2726 constraintKIdKey = mkPreludeMiscIdUnique 410
2727
2728 -- data Callconv = ...
2729 cCallIdKey, stdCallIdKey :: Unique
2730 cCallIdKey = mkPreludeMiscIdUnique 411
2731 stdCallIdKey = mkPreludeMiscIdUnique 412
2732
2733 -- data Safety = ...
2734 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
2735 unsafeIdKey = mkPreludeMiscIdUnique 413
2736 safeIdKey = mkPreludeMiscIdUnique 414
2737 interruptibleIdKey = mkPreludeMiscIdUnique 415
2738
2739 -- data Inline = ...
2740 noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
2741 noInlineDataConKey = mkPreludeDataConUnique 40
2742 inlineDataConKey = mkPreludeDataConUnique 41
2743 inlinableDataConKey = mkPreludeDataConUnique 42
2744
2745 -- data RuleMatch = ...
2746 conLikeDataConKey, funLikeDataConKey :: Unique
2747 conLikeDataConKey = mkPreludeDataConUnique 43
2748 funLikeDataConKey = mkPreludeDataConUnique 44
2749
2750 -- data Phases = ...
2751 allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
2752 allPhasesDataConKey = mkPreludeDataConUnique 45
2753 fromPhaseDataConKey = mkPreludeDataConUnique 46
2754 beforePhaseDataConKey = mkPreludeDataConUnique 47
2755
2756 -- data FunDep = ...
2757 funDepIdKey :: Unique
2758 funDepIdKey = mkPreludeMiscIdUnique 418
2759
2760 -- data FamFlavour = ...
2761 typeFamIdKey, dataFamIdKey :: Unique
2762 typeFamIdKey = mkPreludeMiscIdUnique 419
2763 dataFamIdKey = mkPreludeMiscIdUnique 420
2764
2765 -- data TySynEqn = ...
2766 tySynEqnIdKey :: Unique
2767 tySynEqnIdKey = mkPreludeMiscIdUnique 421
2768
2769 -- quasiquoting
2770 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2771 quoteExpKey = mkPreludeMiscIdUnique 422
2772 quotePatKey = mkPreludeMiscIdUnique 423
2773 quoteDecKey = mkPreludeMiscIdUnique 424
2774 quoteTypeKey = mkPreludeMiscIdUnique 425
2775
2776 -- data RuleBndr = ...
2777 ruleVarIdKey, typedRuleVarIdKey :: Unique
2778 ruleVarIdKey = mkPreludeMiscIdUnique 426
2779 typedRuleVarIdKey = mkPreludeMiscIdUnique 427