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