Merge branch 'master' of git://git.haskell.org/ghc
[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 -> [PendingSplice] -> 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)) | PendingTcSplice 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 ty
767 | Just (cls, tys) <- splitHsClassTy_maybe ty
768 = do
769 cls1 <- lookupOcc cls
770 tys1 <- repList typeQTyConName repLTy tys
771 repClassP cls1 tys1
772 repPred (HsEqTy tyleft tyright)
773 = do
774 tyleft1 <- repLTy tyleft
775 tyright1 <- repLTy tyright
776 repEqualP tyleft1 tyright1
777 repPred ty
778 = notHandled "Exotic predicate type" (ppr ty)
779
780 -- yield the representation of a list of types
781 --
782 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
783 repLTys tys = mapM repLTy tys
784
785 -- represent a type
786 --
787 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
788 repLTy (L _ ty) = repTy ty
789
790 repTy :: HsType Name -> DsM (Core TH.TypeQ)
791 repTy (HsForAllTy _ tvs ctxt ty) =
792 addTyVarBinds tvs $ \bndrs -> do
793 ctxt1 <- repLContext ctxt
794 ty1 <- repLTy ty
795 repTForall bndrs ctxt1 ty1
796
797 repTy (HsTyVar n)
798 | isTvOcc occ = do tv1 <- lookupOcc n
799 repTvar tv1
800 | isDataOcc occ = do tc1 <- lookupOcc n
801 repPromotedTyCon tc1
802 | otherwise = do tc1 <- lookupOcc n
803 repNamedTyCon tc1
804 where
805 occ = nameOccName n
806
807 repTy (HsAppTy f a) = do
808 f1 <- repLTy f
809 a1 <- repLTy a
810 repTapp f1 a1
811 repTy (HsFunTy f a) = do
812 f1 <- repLTy f
813 a1 <- repLTy a
814 tcon <- repArrowTyCon
815 repTapps tcon [f1, a1]
816 repTy (HsListTy t) = do
817 t1 <- repLTy t
818 tcon <- repListTyCon
819 repTapp tcon t1
820 repTy (HsPArrTy t) = do
821 t1 <- repLTy t
822 tcon <- repTy (HsTyVar (tyConName parrTyCon))
823 repTapp tcon t1
824 repTy (HsTupleTy HsUnboxedTuple tys) = do
825 tys1 <- repLTys tys
826 tcon <- repUnboxedTupleTyCon (length tys)
827 repTapps tcon tys1
828 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
829 tcon <- repTupleTyCon (length tys)
830 repTapps tcon tys1
831 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
832 `nlHsAppTy` ty2)
833 repTy (HsParTy t) = repLTy t
834 repTy (HsKindSig t k) = do
835 t1 <- repLTy t
836 k1 <- repLKind k
837 repTSig t1 k1
838 repTy (HsSpliceTy splice _ _) = repSplice splice
839 repTy (HsExplicitListTy _ tys) = do
840 tys1 <- repLTys tys
841 repTPromotedList tys1
842 repTy (HsExplicitTupleTy _ tys) = do
843 tys1 <- repLTys tys
844 tcon <- repPromotedTupleTyCon (length tys)
845 repTapps tcon tys1
846 repTy (HsTyLit lit) = do
847 lit' <- repTyLit lit
848 repTLit lit'
849 repTy ty = notHandled "Exotic form of type" (ppr ty)
850
851 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
852 repTyLit (HsNumTy i) = do iExpr <- mkIntegerExpr i
853 rep2 numTyLitName [iExpr]
854 repTyLit (HsStrTy s) = do { s' <- mkStringExprFS s
855 ; rep2 strTyLitName [s']
856 }
857
858 -- represent a kind
859 --
860 repLKind :: LHsKind Name -> DsM (Core TH.Kind)
861 repLKind ki
862 = do { let (kis, ki') = splitHsFunType ki
863 ; kis_rep <- mapM repLKind kis
864 ; ki'_rep <- repNonArrowLKind ki'
865 ; kcon <- repKArrow
866 ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
867 ; foldrM f ki'_rep kis_rep
868 }
869
870 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
871 repNonArrowLKind (L _ ki) = repNonArrowKind ki
872
873 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
874 repNonArrowKind (HsTyVar name)
875 | name == liftedTypeKindTyConName = repKStar
876 | name == constraintKindTyConName = repKConstraint
877 | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
878 | otherwise = lookupOcc name >>= repKCon
879 repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
880 ; a' <- repLKind a
881 ; repKApp f' a'
882 }
883 repNonArrowKind (HsListTy k) = do { k' <- repLKind k
884 ; kcon <- repKList
885 ; repKApp kcon k'
886 }
887 repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
888 ; kcon <- repKTuple (length ks)
889 ; repKApps kcon ks'
890 }
891 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
892
893 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
894 repRole (L _ (Just Nominal)) = rep2 nominalRName []
895 repRole (L _ (Just Representational)) = rep2 representationalRName []
896 repRole (L _ (Just Phantom)) = rep2 phantomRName []
897 repRole (L _ Nothing) = rep2 inferRName []
898
899 -----------------------------------------------------------------------------
900 -- Splices
901 -----------------------------------------------------------------------------
902
903 repSplice :: HsSplice Name -> DsM (Core a)
904 -- See Note [How brackets and nested splices are handled] in TcSplice
905 -- We return a CoreExpr of any old type; the context should know
906 repSplice (HsSplice _ n _)
907 = do { mb_val <- dsLookupMetaEnv n
908 ; case mb_val of
909 Just (Splice e) -> do { e' <- dsExpr e
910 ; return (MkC e') }
911 _ -> pprPanic "HsSplice" (ppr n) }
912 -- Should not happen; statically checked
913
914 -----------------------------------------------------------------------------
915 -- Expressions
916 -----------------------------------------------------------------------------
917
918 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
919 repLEs es = repList expQTyConName repLE es
920
921 -- FIXME: some of these panics should be converted into proper error messages
922 -- unless we can make sure that constructs, which are plainly not
923 -- supported in TH already lead to error messages at an earlier stage
924 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
925 repLE (L loc e) = putSrcSpanDs loc (repE e)
926
927 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
928 repE (HsVar x) =
929 do { mb_val <- dsLookupMetaEnv x
930 ; case mb_val of
931 Nothing -> do { str <- globalVar x
932 ; repVarOrCon x str }
933 Just (Bound y) -> repVarOrCon x (coreVar y)
934 Just (Splice e) -> do { e' <- dsExpr e
935 ; return (MkC e') } }
936 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
937
938 -- Remember, we're desugaring renamer output here, so
939 -- HsOverlit can definitely occur
940 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
941 repE (HsLit l) = do { a <- repLiteral l; repLit a }
942 repE (HsLam (MG { mg_alts = [m] })) = repLambda m
943 repE (HsLamCase _ (MG { mg_alts = ms }))
944 = do { ms' <- mapM repMatchTup ms
945 ; core_ms <- coreList matchQTyConName ms'
946 ; repLamCase core_ms }
947 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
948
949 repE (OpApp e1 op _ e2) =
950 do { arg1 <- repLE e1;
951 arg2 <- repLE e2;
952 the_op <- repLE op ;
953 repInfixApp arg1 the_op arg2 }
954 repE (NegApp x _) = do
955 a <- repLE x
956 negateVar <- lookupOcc negateName >>= repVar
957 negateVar `repApp` a
958 repE (HsPar x) = repLE x
959 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
960 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
961 repE (HsCase e (MG { mg_alts = ms }))
962 = do { arg <- repLE e
963 ; ms2 <- mapM repMatchTup ms
964 ; core_ms2 <- coreList matchQTyConName ms2
965 ; repCaseE arg core_ms2 }
966 repE (HsIf _ x y z) = do
967 a <- repLE x
968 b <- repLE y
969 c <- repLE z
970 repCond a b c
971 repE (HsMultiIf _ alts)
972 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
973 ; expr' <- repMultiIf (nonEmptyCoreList alts')
974 ; wrapGenSyms (concat binds) expr' }
975 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
976 ; e2 <- addBinds ss (repLE e)
977 ; z <- repLetE ds e2
978 ; wrapGenSyms ss z }
979
980 -- FIXME: I haven't got the types here right yet
981 repE e@(HsDo ctxt sts _)
982 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
983 = do { (ss,zs) <- repLSts sts;
984 e' <- repDoE (nonEmptyCoreList zs);
985 wrapGenSyms ss e' }
986
987 | ListComp <- ctxt
988 = do { (ss,zs) <- repLSts sts;
989 e' <- repComp (nonEmptyCoreList zs);
990 wrapGenSyms ss e' }
991
992 | otherwise
993 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
994
995 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
996 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
997 repE e@(ExplicitTuple es boxed)
998 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
999 | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
1000 | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
1001
1002 repE (RecordCon c _ flds)
1003 = do { x <- lookupLOcc c;
1004 fs <- repFields flds;
1005 repRecCon x fs }
1006 repE (RecordUpd e flds _ _ _)
1007 = do { x <- repLE e;
1008 fs <- repFields flds;
1009 repRecUpd x fs }
1010
1011 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
1012 repE (ArithSeq _ _ aseq) =
1013 case aseq of
1014 From e -> do { ds1 <- repLE e; repFrom ds1 }
1015 FromThen e1 e2 -> do
1016 ds1 <- repLE e1
1017 ds2 <- repLE e2
1018 repFromThen ds1 ds2
1019 FromTo e1 e2 -> do
1020 ds1 <- repLE e1
1021 ds2 <- repLE e2
1022 repFromTo ds1 ds2
1023 FromThenTo e1 e2 e3 -> do
1024 ds1 <- repLE e1
1025 ds2 <- repLE e2
1026 ds3 <- repLE e3
1027 repFromThenTo ds1 ds2 ds3
1028
1029 repE (HsSpliceE splice) = repSplice splice
1030 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1031 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1032 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1033 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1034 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
1035 repE e = notHandled "Expression form" (ppr e)
1036
1037 -----------------------------------------------------------------------------
1038 -- Building representations of auxillary structures like Match, Clause, Stmt,
1039
1040 repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
1041 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
1042 do { ss1 <- mkGenSyms (collectPatBinders p)
1043 ; addBinds ss1 $ do {
1044 ; p1 <- repLP p
1045 ; (ss2,ds) <- repBinds wheres
1046 ; addBinds ss2 $ do {
1047 ; gs <- repGuards guards
1048 ; match <- repMatch p1 gs ds
1049 ; wrapGenSyms (ss1++ss2) match }}}
1050 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1051
1052 repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
1053 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
1054 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1055 ; addBinds ss1 $ do {
1056 ps1 <- repLPs ps
1057 ; (ss2,ds) <- repBinds wheres
1058 ; addBinds ss2 $ do {
1059 gs <- repGuards guards
1060 ; clause <- repClause ps1 gs ds
1061 ; wrapGenSyms (ss1++ss2) clause }}}
1062
1063 repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
1064 repGuards [L _ (GRHS [] e)]
1065 = do {a <- repLE e; repNormal a }
1066 repGuards other
1067 = do { zs <- mapM repLGRHS other
1068 ; let (xs, ys) = unzip zs
1069 ; gd <- repGuarded (nonEmptyCoreList ys)
1070 ; wrapGenSyms (concat xs) gd }
1071
1072 repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1073 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1074 = do { guarded <- repLNormalGE e1 e2
1075 ; return ([], guarded) }
1076 repLGRHS (L _ (GRHS ss rhs))
1077 = do { (gs, ss') <- repLSts ss
1078 ; rhs' <- addBinds gs $ repLE rhs
1079 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1080 ; return (gs, guarded) }
1081
1082 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
1083 repFields (HsRecFields { rec_flds = flds })
1084 = repList fieldExpQTyConName rep_fld flds
1085 where
1086 rep_fld fld = do { fn <- lookupLOcc (hsRecFieldId fld)
1087 ; e <- repLE (hsRecFieldArg fld)
1088 ; repFieldExp fn e }
1089
1090
1091 -----------------------------------------------------------------------------
1092 -- Representing Stmt's is tricky, especially if bound variables
1093 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1094 -- First gensym new names for every variable in any of the patterns.
1095 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1096 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1097 -- and we could reuse the original names (x and x).
1098 --
1099 -- do { x'1 <- gensym "x"
1100 -- ; x'2 <- gensym "x"
1101 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1102 -- , BindSt (pvar x'2) [| f x |]
1103 -- , NoBindSt [| g x |]
1104 -- ]
1105 -- }
1106
1107 -- The strategy is to translate a whole list of do-bindings by building a
1108 -- bigger environment, and a bigger set of meta bindings
1109 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1110 -- of the expressions within the Do
1111
1112 -----------------------------------------------------------------------------
1113 -- The helper function repSts computes the translation of each sub expression
1114 -- and a bunch of prefix bindings denoting the dynamic renaming.
1115
1116 repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1117 repLSts stmts = repSts (map unLoc stmts)
1118
1119 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1120 repSts (BindStmt p e _ _ : ss) =
1121 do { e2 <- repLE e
1122 ; ss1 <- mkGenSyms (collectPatBinders p)
1123 ; addBinds ss1 $ do {
1124 ; p1 <- repLP p;
1125 ; (ss2,zs) <- repSts ss
1126 ; z <- repBindSt p1 e2
1127 ; return (ss1++ss2, z : zs) }}
1128 repSts (LetStmt bs : ss) =
1129 do { (ss1,ds) <- repBinds bs
1130 ; z <- repLetSt ds
1131 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1132 ; return (ss1++ss2, z : zs) }
1133 repSts (BodyStmt e _ _ _ : ss) =
1134 do { e2 <- repLE e
1135 ; z <- repNoBindSt e2
1136 ; (ss2,zs) <- repSts ss
1137 ; return (ss2, z : zs) }
1138 repSts (ParStmt stmt_blocks _ _ : ss) =
1139 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1140 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1141 ss1 = concat ss_s
1142 ; z <- repParSt stmt_blocks2
1143 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1144 ; return (ss1++ss2, z : zs) }
1145 where
1146 rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])
1147 rep_stmt_block (ParStmtBlock stmts _ _) =
1148 do { (ss1, zs) <- repSts (map unLoc stmts)
1149 ; zs1 <- coreList stmtQTyConName zs
1150 ; return (ss1, zs1) }
1151 repSts [LastStmt e _]
1152 = do { e2 <- repLE e
1153 ; z <- repNoBindSt e2
1154 ; return ([], [z]) }
1155 repSts [] = return ([],[])
1156 repSts other = notHandled "Exotic statement" (ppr other)
1157
1158
1159 -----------------------------------------------------------
1160 -- Bindings
1161 -----------------------------------------------------------
1162
1163 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1164 repBinds EmptyLocalBinds
1165 = do { core_list <- coreList decQTyConName []
1166 ; return ([], core_list) }
1167
1168 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1169
1170 repBinds (HsValBinds decs)
1171 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1172 -- No need to worrry about detailed scopes within
1173 -- the binding group, because we are talking Names
1174 -- here, so we can safely treat it as a mutually
1175 -- recursive group
1176 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1177 ; ss <- mkGenSyms bndrs
1178 ; prs <- addBinds ss (rep_val_binds decs)
1179 ; core_list <- coreList decQTyConName
1180 (de_loc (sort_by_loc prs))
1181 ; return (ss, core_list) }
1182
1183 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1184 -- Assumes: all the binders of the binding are alrady in the meta-env
1185 rep_val_binds (ValBindsOut binds sigs)
1186 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1187 ; core2 <- rep_sigs' sigs
1188 ; return (core1 ++ core2) }
1189 rep_val_binds (ValBindsIn _ _)
1190 = panic "rep_val_binds: ValBindsIn"
1191
1192 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1193 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1194 ; return (de_loc (sort_by_loc binds_w_locs)) }
1195
1196 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1197 rep_binds' binds = mapM rep_bind (bagToList binds)
1198
1199 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1200 -- Assumes: all the binders of the binding are alrady in the meta-env
1201
1202 -- Note GHC treats declarations of a variable (not a pattern)
1203 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1204 -- with an empty list of patterns
1205 rep_bind (L loc (FunBind { fun_id = fn,
1206 fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
1207 = do { (ss,wherecore) <- repBinds wheres
1208 ; guardcore <- addBinds ss (repGuards guards)
1209 ; fn' <- lookupLBinder fn
1210 ; p <- repPvar fn'
1211 ; ans <- repVal p guardcore wherecore
1212 ; ans' <- wrapGenSyms ss ans
1213 ; return (loc, ans') }
1214
1215 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
1216 = do { ms1 <- mapM repClauseTup ms
1217 ; fn' <- lookupLBinder fn
1218 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1219 ; return (loc, ans) }
1220
1221 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1222 = do { patcore <- repLP pat
1223 ; (ss,wherecore) <- repBinds wheres
1224 ; guardcore <- addBinds ss (repGuards guards)
1225 ; ans <- repVal patcore guardcore wherecore
1226 ; ans' <- wrapGenSyms ss ans
1227 ; return (loc, ans') }
1228
1229 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1230 = do { v' <- lookupBinder v
1231 ; e2 <- repLE e
1232 ; x <- repNormal e2
1233 ; patcore <- repPvar v'
1234 ; empty_decls <- coreList decQTyConName []
1235 ; ans <- repVal patcore x empty_decls
1236 ; return (srcLocSpan (getSrcLoc v), ans) }
1237
1238 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1239
1240 -----------------------------------------------------------------------------
1241 -- Since everything in a Bind is mutually recursive we need rename all
1242 -- all the variables simultaneously. For example:
1243 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1244 -- do { f'1 <- gensym "f"
1245 -- ; g'2 <- gensym "g"
1246 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1247 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1248 -- ]}
1249 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1250 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1251 -- together. As we do this we collect GenSymBinds's which represent the renamed
1252 -- variables bound by the Bindings. In order not to lose track of these
1253 -- representations we build a shadow datatype MB with the same structure as
1254 -- MonoBinds, but which has slots for the representations
1255
1256
1257 -----------------------------------------------------------------------------
1258 -- GHC allows a more general form of lambda abstraction than specified
1259 -- by Haskell 98. In particular it allows guarded lambda's like :
1260 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1261 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1262 -- (\ p1 .. pn -> exp) by causing an error.
1263
1264 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
1265 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1266 = do { let bndrs = collectPatsBinders ps ;
1267 ; ss <- mkGenSyms bndrs
1268 ; lam <- addBinds ss (
1269 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1270 ; wrapGenSyms ss lam }
1271
1272 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1273
1274
1275 -----------------------------------------------------------------------------
1276 -- Patterns
1277 -- repP deals with patterns. It assumes that we have already
1278 -- walked over the pattern(s) once to collect the binders, and
1279 -- have extended the environment. So every pattern-bound
1280 -- variable should already appear in the environment.
1281
1282 -- Process a list of patterns
1283 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1284 repLPs ps = repList patQTyConName repLP ps
1285
1286 repLP :: LPat Name -> DsM (Core TH.PatQ)
1287 repLP (L _ p) = repP p
1288
1289 repP :: Pat Name -> DsM (Core TH.PatQ)
1290 repP (WildPat _) = repPwild
1291 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1292 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1293 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1294 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1295 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1296 repP (ParPat p) = repLP p
1297 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1298 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
1299 repP (TuplePat ps boxed _)
1300 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1301 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1302 repP (ConPatIn dc details)
1303 = do { con_str <- lookupLOcc dc
1304 ; case details of
1305 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1306 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1307 ; repPrec con_str fps }
1308 InfixCon p1 p2 -> do { p1' <- repLP p1;
1309 p2' <- repLP p2;
1310 repPinfix p1' con_str p2' }
1311 }
1312 where
1313 rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld)
1314 ; MkC p <- repLP (hsRecFieldArg fld)
1315 ; rep2 fieldPatName [v,p] }
1316
1317 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1318 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1319 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1320 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1321 -- The problem is to do with scoped type variables.
1322 -- To implement them, we have to implement the scoping rules
1323 -- here in DsMeta, and I don't want to do that today!
1324 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1325 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1326 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1327
1328 repP (SplicePat splice) = repSplice splice
1329
1330 repP other = notHandled "Exotic pattern" (ppr other)
1331
1332 ----------------------------------------------------------
1333 -- Declaration ordering helpers
1334
1335 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1336 sort_by_loc xs = sortBy comp xs
1337 where comp x y = compare (fst x) (fst y)
1338
1339 de_loc :: [(a, b)] -> [b]
1340 de_loc = map snd
1341
1342 ----------------------------------------------------------
1343 -- The meta-environment
1344
1345 -- A name/identifier association for fresh names of locally bound entities
1346 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1347 -- I.e. (x, x_id) means
1348 -- let x_id = gensym "x" in ...
1349
1350 -- Generate a fresh name for a locally bound entity
1351
1352 mkGenSyms :: [Name] -> DsM [GenSymBind]
1353 -- We can use the existing name. For example:
1354 -- [| \x_77 -> x_77 + x_77 |]
1355 -- desugars to
1356 -- do { x_77 <- genSym "x"; .... }
1357 -- We use the same x_77 in the desugared program, but with the type Bndr
1358 -- instead of Int
1359 --
1360 -- We do make it an Internal name, though (hence localiseName)
1361 --
1362 -- Nevertheless, it's monadic because we have to generate nameTy
1363 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1364 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1365
1366
1367 addBinds :: [GenSymBind] -> DsM a -> DsM a
1368 -- Add a list of fresh names for locally bound entities to the
1369 -- meta environment (which is part of the state carried around
1370 -- by the desugarer monad)
1371 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1372
1373 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1374 dupBinder (new, old)
1375 = do { mb_val <- dsLookupMetaEnv old
1376 ; case mb_val of
1377 Just val -> return (new, val)
1378 Nothing -> pprPanic "dupBinder" (ppr old) }
1379
1380 -- Look up a locally bound name
1381 --
1382 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1383 lookupLBinder (L _ n) = lookupBinder n
1384
1385 lookupBinder :: Name -> DsM (Core TH.Name)
1386 lookupBinder = lookupOcc
1387 -- Binders are brought into scope before the pattern or what-not is
1388 -- desugared. Moreover, in instance declaration the binder of a method
1389 -- will be the selector Id and hence a global; so we need the
1390 -- globalVar case of lookupOcc
1391
1392 -- Look up a name that is either locally bound or a global name
1393 --
1394 -- * If it is a global name, generate the "original name" representation (ie,
1395 -- the <module>:<name> form) for the associated entity
1396 --
1397 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1398 -- Lookup an occurrence; it can't be a splice.
1399 -- Use the in-scope bindings if they exist
1400 lookupLOcc (L _ n) = lookupOcc n
1401
1402 lookupOcc :: Name -> DsM (Core TH.Name)
1403 lookupOcc n
1404 = do { mb_val <- dsLookupMetaEnv n ;
1405 case mb_val of
1406 Nothing -> globalVar n
1407 Just (Bound x) -> return (coreVar x)
1408 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1409 }
1410
1411 globalVar :: Name -> DsM (Core TH.Name)
1412 -- Not bound by the meta-env
1413 -- Could be top-level; or could be local
1414 -- f x = $(g [| x |])
1415 -- Here the x will be local
1416 globalVar name
1417 | isExternalName name
1418 = do { MkC mod <- coreStringLit name_mod
1419 ; MkC pkg <- coreStringLit name_pkg
1420 ; MkC occ <- occNameLit name
1421 ; rep2 mk_varg [pkg,mod,occ] }
1422 | otherwise
1423 = do { MkC occ <- occNameLit name
1424 ; MkC uni <- coreIntLit (getKey (getUnique name))
1425 ; rep2 mkNameLName [occ,uni] }
1426 where
1427 mod = ASSERT( isExternalName name) nameModule name
1428 name_mod = moduleNameString (moduleName mod)
1429 name_pkg = packageIdString (modulePackageId mod)
1430 name_occ = nameOccName name
1431 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1432 | OccName.isVarOcc name_occ = mkNameG_vName
1433 | OccName.isTcOcc name_occ = mkNameG_tcName
1434 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1435
1436 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1437 -> DsM Type -- The type
1438 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1439 return (mkTyConApp tc []) }
1440
1441 wrapGenSyms :: [GenSymBind]
1442 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1443 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1444 -- --> bindQ (gensym nm1) (\ id1 ->
1445 -- bindQ (gensym nm2 (\ id2 ->
1446 -- y))
1447
1448 wrapGenSyms binds body@(MkC b)
1449 = do { var_ty <- lookupType nameTyConName
1450 ; go var_ty binds }
1451 where
1452 [elt_ty] = tcTyConAppArgs (exprType b)
1453 -- b :: Q a, so we can get the type 'a' by looking at the
1454 -- argument type. NB: this relies on Q being a data/newtype,
1455 -- not a type synonym
1456
1457 go _ [] = return body
1458 go var_ty ((name,id) : binds)
1459 = do { MkC body' <- go var_ty binds
1460 ; lit_str <- occNameLit name
1461 ; gensym_app <- repGensym lit_str
1462 ; repBindQ var_ty elt_ty
1463 gensym_app (MkC (Lam id body')) }
1464
1465 occNameLit :: Name -> DsM (Core String)
1466 occNameLit n = coreStringLit (occNameString (nameOccName n))
1467
1468
1469 -- %*********************************************************************
1470 -- %* *
1471 -- Constructing code
1472 -- %* *
1473 -- %*********************************************************************
1474
1475 -----------------------------------------------------------------------------
1476 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1477 -- we invent a new datatype which uses phantom types.
1478
1479 newtype Core a = MkC CoreExpr
1480 unC :: Core a -> CoreExpr
1481 unC (MkC x) = x
1482
1483 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1484 rep2 n xs = do { id <- dsLookupGlobalId n
1485 ; return (MkC (foldl App (Var id) xs)) }
1486
1487 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1488 dataCon' n args = do { id <- dsLookupDataCon n
1489 ; return $ MkC $ mkConApp id args }
1490
1491 dataCon :: Name -> DsM (Core a)
1492 dataCon n = dataCon' n []
1493
1494 -- Then we make "repConstructors" which use the phantom types for each of the
1495 -- smart constructors of the Meta.Meta datatypes.
1496
1497
1498 -- %*********************************************************************
1499 -- %* *
1500 -- The 'smart constructors'
1501 -- %* *
1502 -- %*********************************************************************
1503
1504 --------------- Patterns -----------------
1505 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1506 repPlit (MkC l) = rep2 litPName [l]
1507
1508 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1509 repPvar (MkC s) = rep2 varPName [s]
1510
1511 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1512 repPtup (MkC ps) = rep2 tupPName [ps]
1513
1514 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1515 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1516
1517 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1518 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1519
1520 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1521 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1522
1523 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1524 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1525
1526 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1527 repPtilde (MkC p) = rep2 tildePName [p]
1528
1529 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1530 repPbang (MkC p) = rep2 bangPName [p]
1531
1532 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1533 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1534
1535 repPwild :: DsM (Core TH.PatQ)
1536 repPwild = rep2 wildPName []
1537
1538 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1539 repPlist (MkC ps) = rep2 listPName [ps]
1540
1541 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1542 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1543
1544 --------------- Expressions -----------------
1545 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1546 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1547 | otherwise = repVar str
1548
1549 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1550 repVar (MkC s) = rep2 varEName [s]
1551
1552 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1553 repCon (MkC s) = rep2 conEName [s]
1554
1555 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1556 repLit (MkC c) = rep2 litEName [c]
1557
1558 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1559 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1560
1561 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1562 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1563
1564 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1565 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1566
1567 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1568 repTup (MkC es) = rep2 tupEName [es]
1569
1570 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1571 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1572
1573 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1574 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1575
1576 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1577 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1578
1579 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1580 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1581
1582 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1583 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1584
1585 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1586 repDoE (MkC ss) = rep2 doEName [ss]
1587
1588 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1589 repComp (MkC ss) = rep2 compEName [ss]
1590
1591 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1592 repListExp (MkC es) = rep2 listEName [es]
1593
1594 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1595 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1596
1597 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1598 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1599
1600 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1601 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1602
1603 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1604 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1605
1606 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1607 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1608
1609 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1610 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1611
1612 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1613 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1614
1615 ------------ Right hand sides (guarded expressions) ----
1616 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1617 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1618
1619 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1620 repNormal (MkC e) = rep2 normalBName [e]
1621
1622 ------------ Guards ----
1623 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1624 repLNormalGE g e = do g' <- repLE g
1625 e' <- repLE e
1626 repNormalGE g' e'
1627
1628 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1629 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1630
1631 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1632 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1633
1634 ------------- Stmts -------------------
1635 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1636 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1637
1638 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1639 repLetSt (MkC ds) = rep2 letSName [ds]
1640
1641 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1642 repNoBindSt (MkC e) = rep2 noBindSName [e]
1643
1644 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
1645 repParSt (MkC sss) = rep2 parSName [sss]
1646
1647 -------------- Range (Arithmetic sequences) -----------
1648 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1649 repFrom (MkC x) = rep2 fromEName [x]
1650
1651 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1652 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1653
1654 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1655 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1656
1657 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1658 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1659
1660 ------------ Match and Clause Tuples -----------
1661 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1662 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1663
1664 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1665 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1666
1667 -------------- Dec -----------------------------
1668 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1669 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1670
1671 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1672 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1673
1674 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1675 -> Maybe (Core [TH.TypeQ])
1676 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1677 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1678 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1679 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1680 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1681
1682 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1683 -> Maybe (Core [TH.TypeQ])
1684 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1685 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1686 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1687 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1688 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1689
1690 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1691 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1692 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
1693 = rep2 tySynDName [nm, tvs, rhs]
1694
1695 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1696 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1697
1698 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1699 -> Core [TH.FunDep] -> Core [TH.DecQ]
1700 -> DsM (Core TH.DecQ)
1701 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1702 = rep2 classDName [cxt, cls, tvs, fds, ds]
1703
1704 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
1705 -> Core TH.Phases -> DsM (Core TH.DecQ)
1706 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
1707 = rep2 pragInlDName [nm, inline, rm, phases]
1708
1709 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
1710 -> DsM (Core TH.DecQ)
1711 repPragSpec (MkC nm) (MkC ty) (MkC phases)
1712 = rep2 pragSpecDName [nm, ty, phases]
1713
1714 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
1715 -> Core TH.Phases -> DsM (Core TH.DecQ)
1716 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
1717 = rep2 pragSpecInlDName [nm, ty, inline, phases]
1718
1719 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
1720 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
1721
1722 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
1723 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
1724 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
1725 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
1726
1727 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1728 -> DsM (Core TH.DecQ)
1729 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1730 = rep2 familyNoKindDName [flav, nm, tvs]
1731
1732 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1733 -> Core TH.Kind
1734 -> DsM (Core TH.DecQ)
1735 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1736 = rep2 familyKindDName [flav, nm, tvs, ki]
1737
1738 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
1739 repTySynInst (MkC nm) (MkC eqn)
1740 = rep2 tySynInstDName [nm, eqn]
1741
1742 repClosedFamilyNoKind :: Core TH.Name
1743 -> Core [TH.TyVarBndr]
1744 -> Core [TH.TySynEqnQ]
1745 -> DsM (Core TH.DecQ)
1746 repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
1747 = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
1748
1749 repClosedFamilyKind :: Core TH.Name
1750 -> Core [TH.TyVarBndr]
1751 -> Core TH.Kind
1752 -> Core [TH.TySynEqnQ]
1753 -> DsM (Core TH.DecQ)
1754 repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
1755 = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
1756
1757 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
1758 repTySynEqn (MkC lhs) (MkC rhs)
1759 = rep2 tySynEqnName [lhs, rhs]
1760
1761 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
1762 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
1763
1764 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1765 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1766
1767 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1768 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1769
1770 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1771 repCtxt (MkC tys) = rep2 cxtName [tys]
1772
1773 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1774 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1775
1776 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1777 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1778
1779 repConstr :: Core TH.Name -> HsConDeclDetails Name
1780 -> DsM (Core TH.ConQ)
1781 repConstr con (PrefixCon ps)
1782 = do arg_tys <- repList strictTypeQTyConName repBangTy ps
1783 rep2 normalCName [unC con, unC arg_tys]
1784 repConstr con (RecCon ips)
1785 = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips
1786 ; rep2 recCName [unC con, unC arg_vtys] }
1787 where
1788 rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip)
1789 ; MkC ty <- repBangTy (cd_fld_type ip)
1790 ; rep2 varStrictTypeName [v,ty] }
1791
1792 repConstr con (InfixCon st1 st2)
1793 = do arg1 <- repBangTy st1
1794 arg2 <- repBangTy st2
1795 rep2 infixCName [unC arg1, unC con, unC arg2]
1796
1797 ------------ Types -------------------
1798
1799 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1800 -> DsM (Core TH.TypeQ)
1801 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1802 = rep2 forallTName [tvars, ctxt, ty]
1803
1804 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1805 repTvar (MkC s) = rep2 varTName [s]
1806
1807 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1808 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1809
1810 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1811 repTapps f [] = return f
1812 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1813
1814 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1815 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1816
1817 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1818 repTPromotedList [] = repPromotedNilTyCon
1819 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
1820 ; f <- repTapp tcon t
1821 ; t' <- repTPromotedList ts
1822 ; repTapp f t'
1823 }
1824
1825 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
1826 repTLit (MkC lit) = rep2 litTName [lit]
1827
1828 --------- Type constructors --------------
1829
1830 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1831 repNamedTyCon (MkC s) = rep2 conTName [s]
1832
1833 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1834 -- Note: not Core Int; it's easier to be direct here
1835 repTupleTyCon i = do dflags <- getDynFlags
1836 rep2 tupleTName [mkIntExprInt dflags i]
1837
1838 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1839 -- Note: not Core Int; it's easier to be direct here
1840 repUnboxedTupleTyCon i = do dflags <- getDynFlags
1841 rep2 unboxedTupleTName [mkIntExprInt dflags i]
1842
1843 repArrowTyCon :: DsM (Core TH.TypeQ)
1844 repArrowTyCon = rep2 arrowTName []
1845
1846 repListTyCon :: DsM (Core TH.TypeQ)
1847 repListTyCon = rep2 listTName []
1848
1849 repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1850 repPromotedTyCon (MkC s) = rep2 promotedTName [s]
1851
1852 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1853 repPromotedTupleTyCon i = do dflags <- getDynFlags
1854 rep2 promotedTupleTName [mkIntExprInt dflags i]
1855
1856 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
1857 repPromotedNilTyCon = rep2 promotedNilTName []
1858
1859 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
1860 repPromotedConsTyCon = rep2 promotedConsTName []
1861
1862 ------------ Kinds -------------------
1863
1864 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1865 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1866
1867 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1868 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1869
1870 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
1871 repKVar (MkC s) = rep2 varKName [s]
1872
1873 repKCon :: Core TH.Name -> DsM (Core TH.Kind)
1874 repKCon (MkC s) = rep2 conKName [s]
1875
1876 repKTuple :: Int -> DsM (Core TH.Kind)
1877 repKTuple i = do dflags <- getDynFlags
1878 rep2 tupleKName [mkIntExprInt dflags i]
1879
1880 repKArrow :: DsM (Core TH.Kind)
1881 repKArrow = rep2 arrowKName []
1882
1883 repKList :: DsM (Core TH.Kind)
1884 repKList = rep2 listKName []
1885
1886 repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1887 repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
1888
1889 repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
1890 repKApps f [] = return f
1891 repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
1892
1893 repKStar :: DsM (Core TH.Kind)
1894 repKStar = rep2 starKName []
1895
1896 repKConstraint :: DsM (Core TH.Kind)
1897 repKConstraint = rep2 constraintKName []
1898
1899 ----------------------------------------------------------
1900 -- Literals
1901
1902 repLiteral :: HsLit -> DsM (Core TH.Lit)
1903 repLiteral lit
1904 = do lit' <- case lit of
1905 HsIntPrim i -> mk_integer i
1906 HsWordPrim w -> mk_integer w
1907 HsInt i -> mk_integer i
1908 HsFloatPrim r -> mk_rational r
1909 HsDoublePrim r -> mk_rational r
1910 _ -> return lit
1911 lit_expr <- dsLit lit'
1912 case mb_lit_name of
1913 Just lit_name -> rep2 lit_name [lit_expr]
1914 Nothing -> notHandled "Exotic literal" (ppr lit)
1915 where
1916 mb_lit_name = case lit of
1917 HsInteger _ _ -> Just integerLName
1918 HsInt _ -> Just integerLName
1919 HsIntPrim _ -> Just intPrimLName
1920 HsWordPrim _ -> Just wordPrimLName
1921 HsFloatPrim _ -> Just floatPrimLName
1922 HsDoublePrim _ -> Just doublePrimLName
1923 HsChar _ -> Just charLName
1924 HsString _ -> Just stringLName
1925 HsRat _ _ -> Just rationalLName
1926 _ -> Nothing
1927
1928 mk_integer :: Integer -> DsM HsLit
1929 mk_integer i = do integer_ty <- lookupType integerTyConName
1930 return $ HsInteger i integer_ty
1931 mk_rational :: FractionalLit -> DsM HsLit
1932 mk_rational r = do rat_ty <- lookupType rationalTyConName
1933 return $ HsRat r rat_ty
1934 mk_string :: FastString -> DsM HsLit
1935 mk_string s = return $ HsString s
1936
1937 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1938 repOverloadedLiteral (OverLit { ol_val = val})
1939 = do { lit <- mk_lit val; repLiteral lit }
1940 -- The type Rational will be in the environment, because
1941 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1942 -- and rationalL is sucked in when any TH stuff is used
1943
1944 mk_lit :: OverLitVal -> DsM HsLit
1945 mk_lit (HsIntegral i) = mk_integer i
1946 mk_lit (HsFractional f) = mk_rational f
1947 mk_lit (HsIsString s) = mk_string s
1948
1949 --------------- Miscellaneous -------------------
1950
1951 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1952 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1953
1954 repBindQ :: Type -> Type -- a and b
1955 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1956 repBindQ ty_a ty_b (MkC x) (MkC y)
1957 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1958
1959 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1960 repSequenceQ ty_a (MkC list)
1961 = rep2 sequenceQName [Type ty_a, list]
1962
1963 ------------ Lists and Tuples -------------------
1964 -- turn a list of patterns into a single pattern matching a list
1965
1966 repList :: Name -> (a -> DsM (Core b))
1967 -> [a] -> DsM (Core [b])
1968 repList tc_name f args
1969 = do { args1 <- mapM f args
1970 ; coreList tc_name args1 }
1971
1972 coreList :: Name -- Of the TyCon of the element type
1973 -> [Core a] -> DsM (Core [a])
1974 coreList tc_name es
1975 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1976
1977 coreList' :: Type -- The element type
1978 -> [Core a] -> Core [a]
1979 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1980
1981 nonEmptyCoreList :: [Core a] -> Core [a]
1982 -- The list must be non-empty so we can get the element type
1983 -- Otherwise use coreList
1984 nonEmptyCoreList [] = panic "coreList: empty argument"
1985 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1986
1987 coreStringLit :: String -> DsM (Core String)
1988 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1989
1990 ------------ Literals & Variables -------------------
1991
1992 coreIntLit :: Int -> DsM (Core Int)
1993 coreIntLit i = do dflags <- getDynFlags
1994 return (MkC (mkIntExprInt dflags i))
1995
1996 coreVar :: Id -> Core TH.Name -- The Id has type Name
1997 coreVar id = MkC (Var id)
1998
1999 ----------------- Failure -----------------------
2000 notHandled :: String -> SDoc -> DsM a
2001 notHandled what doc = failWithDs msg
2002 where
2003 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
2004 2 doc
2005
2006
2007 -- %************************************************************************
2008 -- %* *
2009 -- The known-key names for Template Haskell
2010 -- %* *
2011 -- %************************************************************************
2012
2013 -- To add a name, do three things
2014 --
2015 -- 1) Allocate a key
2016 -- 2) Make a "Name"
2017 -- 3) Add the name to knownKeyNames
2018
2019 templateHaskellNames :: [Name]
2020 -- The names that are implicitly mentioned by ``bracket''
2021 -- Should stay in sync with the import list of DsMeta
2022
2023 templateHaskellNames = [
2024 returnQName, bindQName, sequenceQName, newNameName, liftName,
2025 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
2026 liftStringName,
2027 unTypeName,
2028 unTypeQName,
2029 unsafeTExpCoerceName,
2030
2031 -- Lit
2032 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
2033 floatPrimLName, doublePrimLName, rationalLName,
2034 -- Pat
2035 litPName, varPName, tupPName, unboxedTupPName,
2036 conPName, tildePName, bangPName, infixPName,
2037 asPName, wildPName, recPName, listPName, sigPName, viewPName,
2038 -- FieldPat
2039 fieldPatName,
2040 -- Match
2041 matchName,
2042 -- Clause
2043 clauseName,
2044 -- Exp
2045 varEName, conEName, litEName, appEName, infixEName,
2046 infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
2047 tupEName, unboxedTupEName,
2048 condEName, multiIfEName, letEName, caseEName, doEName, compEName,
2049 fromEName, fromThenEName, fromToEName, fromThenToEName,
2050 listEName, sigEName, recConEName, recUpdEName,
2051 -- FieldExp
2052 fieldExpName,
2053 -- Body
2054 guardedBName, normalBName,
2055 -- Guard
2056 normalGEName, patGEName,
2057 -- Stmt
2058 bindSName, letSName, noBindSName, parSName,
2059 -- Dec
2060 funDName, valDName, dataDName, newtypeDName, tySynDName,
2061 classDName, instanceDName, sigDName, forImpDName,
2062 pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
2063 pragRuleDName,
2064 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
2065 tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
2066 infixLDName, infixRDName, infixNDName,
2067 roleAnnotDName,
2068 -- Cxt
2069 cxtName,
2070 -- Pred
2071 classPName, equalPName,
2072 -- Strict
2073 isStrictName, notStrictName, unpackedName,
2074 -- Con
2075 normalCName, recCName, infixCName, forallCName,
2076 -- StrictType
2077 strictTypeName,
2078 -- VarStrictType
2079 varStrictTypeName,
2080 -- Type
2081 forallTName, varTName, conTName, appTName,
2082 tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
2083 promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
2084 -- TyLit
2085 numTyLitName, strTyLitName,
2086 -- TyVarBndr
2087 plainTVName, kindedTVName,
2088 -- Role
2089 nominalRName, representationalRName, phantomRName, inferRName,
2090 -- Kind
2091 varKName, conKName, tupleKName, arrowKName, listKName, appKName,
2092 starKName, constraintKName,
2093 -- Callconv
2094 cCallName, stdCallName,
2095 -- Safety
2096 unsafeName,
2097 safeName,
2098 interruptibleName,
2099 -- Inline
2100 noInlineDataConName, inlineDataConName, inlinableDataConName,
2101 -- RuleMatch
2102 conLikeDataConName, funLikeDataConName,
2103 -- Phases
2104 allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
2105 -- TExp
2106 tExpDataConName,
2107 -- RuleBndr
2108 ruleVarName, typedRuleVarName,
2109 -- FunDep
2110 funDepName,
2111 -- FamFlavour
2112 typeFamName, dataFamName,
2113 -- TySynEqn
2114 tySynEqnName,
2115
2116 -- And the tycons
2117 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
2118 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
2119 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
2120 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
2121 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
2122 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
2123 predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
2124 roleTyConName, tExpTyConName,
2125
2126 -- Quasiquoting
2127 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
2128
2129 thSyn, thLib, qqLib :: Module
2130 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
2131 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
2132 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
2133
2134 mkTHModule :: FastString -> Module
2135 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
2136
2137 libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name
2138 libFun = mk_known_key_name OccName.varName thLib
2139 libTc = mk_known_key_name OccName.tcName thLib
2140 thFun = mk_known_key_name OccName.varName thSyn
2141 thTc = mk_known_key_name OccName.tcName thSyn
2142 thCon = mk_known_key_name OccName.dataName thSyn
2143 qqFun = mk_known_key_name OccName.varName qqLib
2144
2145 -------------------- TH.Syntax -----------------------
2146 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
2147 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
2148 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
2149 predTyConName, tExpTyConName :: Name
2150 qTyConName = thTc (fsLit "Q") qTyConKey
2151 nameTyConName = thTc (fsLit "Name") nameTyConKey
2152 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
2153 patTyConName = thTc (fsLit "Pat") patTyConKey
2154 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
2155 expTyConName = thTc (fsLit "Exp") expTyConKey
2156 decTyConName = thTc (fsLit "Dec") decTyConKey
2157 typeTyConName = thTc (fsLit "Type") typeTyConKey
2158 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
2159 matchTyConName = thTc (fsLit "Match") matchTyConKey
2160 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
2161 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
2162 predTyConName = thTc (fsLit "Pred") predTyConKey
2163 tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
2164
2165 returnQName, bindQName, sequenceQName, newNameName, liftName,
2166 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
2167 mkNameLName, liftStringName, unTypeName, unTypeQName,
2168 unsafeTExpCoerceName :: Name
2169 returnQName = thFun (fsLit "returnQ") returnQIdKey
2170 bindQName = thFun (fsLit "bindQ") bindQIdKey
2171 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
2172 newNameName = thFun (fsLit "newName") newNameIdKey
2173 liftName = thFun (fsLit "lift") liftIdKey
2174 liftStringName = thFun (fsLit "liftString") liftStringIdKey
2175 mkNameName = thFun (fsLit "mkName") mkNameIdKey
2176 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
2177 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
2178 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
2179 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
2180 unTypeName = thFun (fsLit "unType") unTypeIdKey
2181 unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
2182 unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
2183
2184
2185 -------------------- TH.Lib -----------------------
2186 -- data Lit = ...
2187 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
2188 floatPrimLName, doublePrimLName, rationalLName :: Name
2189 charLName = libFun (fsLit "charL") charLIdKey
2190 stringLName = libFun (fsLit "stringL") stringLIdKey
2191 integerLName = libFun (fsLit "integerL") integerLIdKey
2192 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
2193 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
2194 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
2195 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
2196 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
2197
2198 -- data Pat = ...
2199 litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
2200 asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
2201 litPName = libFun (fsLit "litP") litPIdKey
2202 varPName = libFun (fsLit "varP") varPIdKey
2203 tupPName = libFun (fsLit "tupP") tupPIdKey
2204 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
2205 conPName = libFun (fsLit "conP") conPIdKey
2206 infixPName = libFun (fsLit "infixP") infixPIdKey
2207 tildePName = libFun (fsLit "tildeP") tildePIdKey
2208 bangPName = libFun (fsLit "bangP") bangPIdKey
2209 asPName = libFun (fsLit "asP") asPIdKey
2210 wildPName = libFun (fsLit "wildP") wildPIdKey
2211 recPName = libFun (fsLit "recP") recPIdKey
2212 listPName = libFun (fsLit "listP") listPIdKey
2213 sigPName = libFun (fsLit "sigP") sigPIdKey
2214 viewPName = libFun (fsLit "viewP") viewPIdKey
2215
2216 -- type FieldPat = ...
2217 fieldPatName :: Name
2218 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
2219
2220 -- data Match = ...
2221 matchName :: Name
2222 matchName = libFun (fsLit "match") matchIdKey
2223
2224 -- data Clause = ...
2225 clauseName :: Name
2226 clauseName = libFun (fsLit "clause") clauseIdKey
2227
2228 -- data Exp = ...
2229 varEName, conEName, litEName, appEName, infixEName, infixAppName,
2230 sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
2231 unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
2232 doEName, compEName :: Name
2233 varEName = libFun (fsLit "varE") varEIdKey
2234 conEName = libFun (fsLit "conE") conEIdKey
2235 litEName = libFun (fsLit "litE") litEIdKey
2236 appEName = libFun (fsLit "appE") appEIdKey
2237 infixEName = libFun (fsLit "infixE") infixEIdKey
2238 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
2239 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
2240 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
2241 lamEName = libFun (fsLit "lamE") lamEIdKey
2242 lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey
2243 tupEName = libFun (fsLit "tupE") tupEIdKey
2244 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
2245 condEName = libFun (fsLit "condE") condEIdKey
2246 multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey
2247 letEName = libFun (fsLit "letE") letEIdKey
2248 caseEName = libFun (fsLit "caseE") caseEIdKey
2249 doEName = libFun (fsLit "doE") doEIdKey
2250 compEName = libFun (fsLit "compE") compEIdKey
2251 -- ArithSeq skips a level
2252 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
2253 fromEName = libFun (fsLit "fromE") fromEIdKey
2254 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
2255 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
2256 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
2257 -- end ArithSeq
2258 listEName, sigEName, recConEName, recUpdEName :: Name
2259 listEName = libFun (fsLit "listE") listEIdKey
2260 sigEName = libFun (fsLit "sigE") sigEIdKey
2261 recConEName = libFun (fsLit "recConE") recConEIdKey
2262 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
2263
2264 -- type FieldExp = ...
2265 fieldExpName :: Name
2266 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
2267
2268 -- data Body = ...
2269 guardedBName, normalBName :: Name
2270 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
2271 normalBName = libFun (fsLit "normalB") normalBIdKey
2272
2273 -- data Guard = ...
2274 normalGEName, patGEName :: Name
2275 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
2276 patGEName = libFun (fsLit "patGE") patGEIdKey
2277
2278 -- data Stmt = ...
2279 bindSName, letSName, noBindSName, parSName :: Name
2280 bindSName = libFun (fsLit "bindS") bindSIdKey
2281 letSName = libFun (fsLit "letS") letSIdKey
2282 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
2283 parSName = libFun (fsLit "parS") parSIdKey
2284
2285 -- data Dec = ...
2286 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
2287 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
2288 pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName,
2289 familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
2290 closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
2291 infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
2292 funDName = libFun (fsLit "funD") funDIdKey
2293 valDName = libFun (fsLit "valD") valDIdKey
2294 dataDName = libFun (fsLit "dataD") dataDIdKey
2295 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
2296 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
2297 classDName = libFun (fsLit "classD") classDIdKey
2298 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
2299 sigDName = libFun (fsLit "sigD") sigDIdKey
2300 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
2301 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
2302 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
2303 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
2304 pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey
2305 pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey
2306 familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey
2307 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
2308 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
2309 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
2310 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
2311 closedTypeFamilyKindDName
2312 = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey
2313 closedTypeFamilyNoKindDName
2314 = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey
2315 infixLDName = libFun (fsLit "infixLD") infixLDIdKey
2316 infixRDName = libFun (fsLit "infixRD") infixRDIdKey
2317 infixNDName = libFun (fsLit "infixND") infixNDIdKey
2318 roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
2319
2320 -- type Ctxt = ...
2321 cxtName :: Name
2322 cxtName = libFun (fsLit "cxt") cxtIdKey
2323
2324 -- data Pred = ...
2325 classPName, equalPName :: Name
2326 classPName = libFun (fsLit "classP") classPIdKey
2327 equalPName = libFun (fsLit "equalP") equalPIdKey
2328
2329 -- data Strict = ...
2330 isStrictName, notStrictName, unpackedName :: Name
2331 isStrictName = libFun (fsLit "isStrict") isStrictKey
2332 notStrictName = libFun (fsLit "notStrict") notStrictKey
2333 unpackedName = libFun (fsLit "unpacked") unpackedKey
2334
2335 -- data Con = ...
2336 normalCName, recCName, infixCName, forallCName :: Name
2337 normalCName = libFun (fsLit "normalC") normalCIdKey
2338 recCName = libFun (fsLit "recC") recCIdKey
2339 infixCName = libFun (fsLit "infixC") infixCIdKey
2340 forallCName = libFun (fsLit "forallC") forallCIdKey
2341
2342 -- type StrictType = ...
2343 strictTypeName :: Name
2344 strictTypeName = libFun (fsLit "strictType") strictTKey
2345
2346 -- type VarStrictType = ...
2347 varStrictTypeName :: Name
2348 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
2349
2350 -- data Type = ...
2351 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
2352 listTName, appTName, sigTName, litTName,
2353 promotedTName, promotedTupleTName,
2354 promotedNilTName, promotedConsTName :: Name
2355 forallTName = libFun (fsLit "forallT") forallTIdKey
2356 varTName = libFun (fsLit "varT") varTIdKey
2357 conTName = libFun (fsLit "conT") conTIdKey
2358 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
2359 unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
2360 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
2361 listTName = libFun (fsLit "listT") listTIdKey
2362 appTName = libFun (fsLit "appT") appTIdKey
2363 sigTName = libFun (fsLit "sigT") sigTIdKey
2364 litTName = libFun (fsLit "litT") litTIdKey
2365 promotedTName = libFun (fsLit "promotedT") promotedTIdKey
2366 promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
2367 promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey
2368 promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey
2369
2370 -- data TyLit = ...
2371 numTyLitName, strTyLitName :: Name
2372 numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
2373 strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
2374
2375 -- data TyVarBndr = ...
2376 plainTVName, kindedTVName :: Name
2377 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
2378 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
2379
2380 -- data Role = ...
2381 nominalRName, representationalRName, phantomRName, inferRName :: Name
2382 nominalRName = libFun (fsLit "nominalR") nominalRIdKey
2383 representationalRName = libFun (fsLit "representationalR") representationalRIdKey
2384 phantomRName = libFun (fsLit "phantomR") phantomRIdKey
2385 inferRName = libFun (fsLit "inferR") inferRIdKey
2386
2387 -- data Kind = ...
2388 varKName, conKName, tupleKName, arrowKName, listKName, appKName,
2389 starKName, constraintKName :: Name
2390 varKName = libFun (fsLit "varK") varKIdKey
2391 conKName = libFun (fsLit "conK") conKIdKey
2392 tupleKName = libFun (fsLit "tupleK") tupleKIdKey
2393 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
2394 listKName = libFun (fsLit "listK") listKIdKey
2395 appKName = libFun (fsLit "appK") appKIdKey
2396 starKName = libFun (fsLit "starK") starKIdKey
2397 constraintKName = libFun (fsLit "constraintK") constraintKIdKey
2398
2399 -- data Callconv = ...
2400 cCallName, stdCallName :: Name
2401 cCallName = libFun (fsLit "cCall") cCallIdKey
2402 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
2403
2404 -- data Safety = ...
2405 unsafeName, safeName, interruptibleName :: Name
2406 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
2407 safeName = libFun (fsLit "safe") safeIdKey
2408 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
2409
2410 -- data Inline = ...
2411 noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
2412 noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey
2413 inlineDataConName = thCon (fsLit "Inline") inlineDataConKey
2414 inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
2415
2416 -- data RuleMatch = ...
2417 conLikeDataConName, funLikeDataConName :: Name
2418 conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
2419 funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
2420
2421 -- data Phases = ...
2422 allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
2423 allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey
2424 fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey
2425 beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
2426
2427 -- newtype TExp a = ...
2428 tExpDataConName :: Name
2429 tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
2430
2431 -- data RuleBndr = ...
2432 ruleVarName, typedRuleVarName :: Name
2433 ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
2434 typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
2435
2436 -- data FunDep = ...
2437 funDepName :: Name
2438 funDepName = libFun (fsLit "funDep") funDepIdKey
2439
2440 -- data FamFlavour = ...
2441 typeFamName, dataFamName :: Name
2442 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2443 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2444
2445 -- data TySynEqn = ...
2446 tySynEqnName :: Name
2447 tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
2448
2449 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2450 decQTyConName, conQTyConName, strictTypeQTyConName,
2451 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2452 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
2453 ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name
2454 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2455 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2456 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2457 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2458 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2459 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2460 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2461 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2462 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2463 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2464 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2465 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2466 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2467 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2468 ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
2469 tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
2470 roleTyConName = libTc (fsLit "Role") roleTyConKey
2471
2472 -- quasiquoting
2473 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2474 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2475 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2476 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2477 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2478
2479 -- TyConUniques available: 200-299
2480 -- Check in PrelNames if you want to change this
2481
2482 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2483 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2484 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2485 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2486 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2487 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2488 predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
2489 roleTyConKey, tExpTyConKey :: Unique
2490 expTyConKey = mkPreludeTyConUnique 200
2491 matchTyConKey = mkPreludeTyConUnique 201
2492 clauseTyConKey = mkPreludeTyConUnique 202
2493 qTyConKey = mkPreludeTyConUnique 203
2494 expQTyConKey = mkPreludeTyConUnique 204
2495 decQTyConKey = mkPreludeTyConUnique 205
2496 patTyConKey = mkPreludeTyConUnique 206
2497 matchQTyConKey = mkPreludeTyConUnique 207
2498 clauseQTyConKey = mkPreludeTyConUnique 208
2499 stmtQTyConKey = mkPreludeTyConUnique 209
2500 conQTyConKey = mkPreludeTyConUnique 210
2501 typeQTyConKey = mkPreludeTyConUnique 211
2502 typeTyConKey = mkPreludeTyConUnique 212
2503 decTyConKey = mkPreludeTyConUnique 213
2504 varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2505 strictTypeQTyConKey = mkPreludeTyConUnique 215
2506 fieldExpTyConKey = mkPreludeTyConUnique 216
2507 fieldPatTyConKey = mkPreludeTyConUnique 217
2508 nameTyConKey = mkPreludeTyConUnique 218
2509 patQTyConKey = mkPreludeTyConUnique 219
2510 fieldPatQTyConKey = mkPreludeTyConUnique 220
2511 fieldExpQTyConKey = mkPreludeTyConUnique 221
2512 funDepTyConKey = mkPreludeTyConUnique 222
2513 predTyConKey = mkPreludeTyConUnique 223
2514 predQTyConKey = mkPreludeTyConUnique 224
2515 tyVarBndrTyConKey = mkPreludeTyConUnique 225
2516 decsQTyConKey = mkPreludeTyConUnique 226
2517 ruleBndrQTyConKey = mkPreludeTyConUnique 227
2518 tySynEqnQTyConKey = mkPreludeTyConUnique 228
2519 roleTyConKey = mkPreludeTyConUnique 229
2520 tExpTyConKey = mkPreludeTyConUnique 230
2521
2522 -- IdUniques available: 200-499
2523 -- If you want to change this, make sure you check in PrelNames
2524
2525 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2526 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2527 mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique
2528 returnQIdKey = mkPreludeMiscIdUnique 200
2529 bindQIdKey = mkPreludeMiscIdUnique 201
2530 sequenceQIdKey = mkPreludeMiscIdUnique 202
2531 liftIdKey = mkPreludeMiscIdUnique 203
2532 newNameIdKey = mkPreludeMiscIdUnique 204
2533 mkNameIdKey = mkPreludeMiscIdUnique 205
2534 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2535 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2536 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2537 mkNameLIdKey = mkPreludeMiscIdUnique 209
2538 unTypeIdKey = mkPreludeMiscIdUnique 210
2539 unTypeQIdKey = mkPreludeMiscIdUnique 211
2540 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212
2541
2542
2543 -- data Lit = ...
2544 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2545 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2546 charLIdKey = mkPreludeMiscIdUnique 220
2547 stringLIdKey = mkPreludeMiscIdUnique 221
2548 integerLIdKey = mkPreludeMiscIdUnique 222
2549 intPrimLIdKey = mkPreludeMiscIdUnique 223
2550 wordPrimLIdKey = mkPreludeMiscIdUnique 224
2551 floatPrimLIdKey = mkPreludeMiscIdUnique 225
2552 doublePrimLIdKey = mkPreludeMiscIdUnique 226
2553 rationalLIdKey = mkPreludeMiscIdUnique 227
2554
2555 liftStringIdKey :: Unique
2556 liftStringIdKey = mkPreludeMiscIdUnique 228
2557
2558 -- data Pat = ...
2559 litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2560 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2561 litPIdKey = mkPreludeMiscIdUnique 240
2562 varPIdKey = mkPreludeMiscIdUnique 241
2563 tupPIdKey = mkPreludeMiscIdUnique 242
2564 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2565 conPIdKey = mkPreludeMiscIdUnique 244
2566 infixPIdKey = mkPreludeMiscIdUnique 245
2567 tildePIdKey = mkPreludeMiscIdUnique 246
2568 bangPIdKey = mkPreludeMiscIdUnique 247
2569 asPIdKey = mkPreludeMiscIdUnique 248
2570 wildPIdKey = mkPreludeMiscIdUnique 249
2571 recPIdKey = mkPreludeMiscIdUnique 250
2572 listPIdKey = mkPreludeMiscIdUnique 251
2573 sigPIdKey = mkPreludeMiscIdUnique 252
2574 viewPIdKey = mkPreludeMiscIdUnique 253
2575
2576 -- type FieldPat = ...
2577 fieldPatIdKey :: Unique
2578 fieldPatIdKey = mkPreludeMiscIdUnique 260
2579
2580 -- data Match = ...
2581 matchIdKey :: Unique
2582 matchIdKey = mkPreludeMiscIdUnique 261
2583
2584 -- data Clause = ...
2585 clauseIdKey :: Unique
2586 clauseIdKey = mkPreludeMiscIdUnique 262
2587
2588
2589 -- data Exp = ...
2590 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2591 sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,
2592 unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
2593 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2594 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2595 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2596 varEIdKey = mkPreludeMiscIdUnique 270
2597 conEIdKey = mkPreludeMiscIdUnique 271
2598 litEIdKey = mkPreludeMiscIdUnique 272
2599 appEIdKey = mkPreludeMiscIdUnique 273
2600 infixEIdKey = mkPreludeMiscIdUnique 274
2601 infixAppIdKey = mkPreludeMiscIdUnique 275
2602 sectionLIdKey = mkPreludeMiscIdUnique 276
2603 sectionRIdKey = mkPreludeMiscIdUnique 277
2604 lamEIdKey = mkPreludeMiscIdUnique 278
2605 lamCaseEIdKey = mkPreludeMiscIdUnique 279
2606 tupEIdKey = mkPreludeMiscIdUnique 280
2607 unboxedTupEIdKey = mkPreludeMiscIdUnique 281
2608 condEIdKey = mkPreludeMiscIdUnique 282
2609 multiIfEIdKey = mkPreludeMiscIdUnique 283
2610 letEIdKey = mkPreludeMiscIdUnique 284
2611 caseEIdKey = mkPreludeMiscIdUnique 285
2612 doEIdKey = mkPreludeMiscIdUnique 286
2613 compEIdKey = mkPreludeMiscIdUnique 287
2614 fromEIdKey = mkPreludeMiscIdUnique 288
2615 fromThenEIdKey = mkPreludeMiscIdUnique 289
2616 fromToEIdKey = mkPreludeMiscIdUnique 290
2617 fromThenToEIdKey = mkPreludeMiscIdUnique 291
2618 listEIdKey = mkPreludeMiscIdUnique 292
2619 sigEIdKey = mkPreludeMiscIdUnique 293
2620 recConEIdKey = mkPreludeMiscIdUnique 294
2621 recUpdEIdKey = mkPreludeMiscIdUnique 295
2622
2623 -- type FieldExp = ...
2624 fieldExpIdKey :: Unique
2625 fieldExpIdKey = mkPreludeMiscIdUnique 310
2626
2627 -- data Body = ...
2628 guardedBIdKey, normalBIdKey :: Unique
2629 guardedBIdKey = mkPreludeMiscIdUnique 311
2630 normalBIdKey = mkPreludeMiscIdUnique 312
2631
2632 -- data Guard = ...
2633 normalGEIdKey, patGEIdKey :: Unique
2634 normalGEIdKey = mkPreludeMiscIdUnique 313
2635 patGEIdKey = mkPreludeMiscIdUnique 314
2636
2637 -- data Stmt = ...
2638 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2639 bindSIdKey = mkPreludeMiscIdUnique 320
2640 letSIdKey = mkPreludeMiscIdUnique 321
2641 noBindSIdKey = mkPreludeMiscIdUnique 322
2642 parSIdKey = mkPreludeMiscIdUnique 323
2643
2644 -- data Dec = ...
2645 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2646 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2647 pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
2648 familyNoKindDIdKey, familyKindDIdKey,
2649 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
2650 closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
2651 infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique
2652 funDIdKey = mkPreludeMiscIdUnique 330
2653 valDIdKey = mkPreludeMiscIdUnique 331
2654 dataDIdKey = mkPreludeMiscIdUnique 332
2655 newtypeDIdKey = mkPreludeMiscIdUnique 333
2656 tySynDIdKey = mkPreludeMiscIdUnique 334
2657 classDIdKey = mkPreludeMiscIdUnique 335
2658 instanceDIdKey = mkPreludeMiscIdUnique 336
2659 sigDIdKey = mkPreludeMiscIdUnique 337
2660 forImpDIdKey = mkPreludeMiscIdUnique 338
2661 pragInlDIdKey = mkPreludeMiscIdUnique 339
2662 pragSpecDIdKey = mkPreludeMiscIdUnique 340
2663 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2664 pragSpecInstDIdKey = mkPreludeMiscIdUnique 417
2665 pragRuleDIdKey = mkPreludeMiscIdUnique 418
2666 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2667 familyKindDIdKey = mkPreludeMiscIdUnique 343
2668 dataInstDIdKey = mkPreludeMiscIdUnique 344
2669 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2670 tySynInstDIdKey = mkPreludeMiscIdUnique 346
2671 closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347
2672 closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348
2673 infixLDIdKey = mkPreludeMiscIdUnique 349
2674 infixRDIdKey = mkPreludeMiscIdUnique 350
2675 infixNDIdKey = mkPreludeMiscIdUnique 351
2676 roleAnnotDIdKey = mkPreludeMiscIdUnique 352
2677
2678 -- type Cxt = ...
2679 cxtIdKey :: Unique
2680 cxtIdKey = mkPreludeMiscIdUnique 360
2681
2682 -- data Pred = ...
2683 classPIdKey, equalPIdKey :: Unique
2684 classPIdKey = mkPreludeMiscIdUnique 361
2685 equalPIdKey = mkPreludeMiscIdUnique 362
2686
2687 -- data Strict = ...
2688 isStrictKey, notStrictKey, unpackedKey :: Unique
2689 isStrictKey = mkPreludeMiscIdUnique 363
2690 notStrictKey = mkPreludeMiscIdUnique 364
2691 unpackedKey = mkPreludeMiscIdUnique 365
2692
2693 -- data Con = ...
2694 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2695 normalCIdKey = mkPreludeMiscIdUnique 370
2696 recCIdKey = mkPreludeMiscIdUnique 371
2697 infixCIdKey = mkPreludeMiscIdUnique 372
2698 forallCIdKey = mkPreludeMiscIdUnique 373
2699
2700 -- type StrictType = ...
2701 strictTKey :: Unique
2702 strictTKey = mkPreludeMiscIdUnique 374
2703
2704 -- type VarStrictType = ...
2705 varStrictTKey :: Unique
2706 varStrictTKey = mkPreludeMiscIdUnique 375
2707
2708 -- data Type = ...
2709 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2710 listTIdKey, appTIdKey, sigTIdKey, litTIdKey,
2711 promotedTIdKey, promotedTupleTIdKey,
2712 promotedNilTIdKey, promotedConsTIdKey :: Unique
2713 forallTIdKey = mkPreludeMiscIdUnique 380
2714 varTIdKey = mkPreludeMiscIdUnique 381
2715 conTIdKey = mkPreludeMiscIdUnique 382
2716 tupleTIdKey = mkPreludeMiscIdUnique 383
2717 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2718 arrowTIdKey = mkPreludeMiscIdUnique 385
2719 listTIdKey = mkPreludeMiscIdUnique 386
2720 appTIdKey = mkPreludeMiscIdUnique 387
2721 sigTIdKey = mkPreludeMiscIdUnique 388
2722 litTIdKey = mkPreludeMiscIdUnique 389
2723 promotedTIdKey = mkPreludeMiscIdUnique 390
2724 promotedTupleTIdKey = mkPreludeMiscIdUnique 391
2725 promotedNilTIdKey = mkPreludeMiscIdUnique 392
2726 promotedConsTIdKey = mkPreludeMiscIdUnique 393
2727
2728 -- data TyLit = ...
2729 numTyLitIdKey, strTyLitIdKey :: Unique
2730 numTyLitIdKey = mkPreludeMiscIdUnique 394
2731 strTyLitIdKey = mkPreludeMiscIdUnique 395
2732
2733 -- data TyVarBndr = ...
2734 plainTVIdKey, kindedTVIdKey :: Unique
2735 plainTVIdKey = mkPreludeMiscIdUnique 396
2736 kindedTVIdKey = mkPreludeMiscIdUnique 397
2737
2738 -- data Role = ...
2739 nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
2740 nominalRIdKey = mkPreludeMiscIdUnique 400
2741 representationalRIdKey = mkPreludeMiscIdUnique 401
2742 phantomRIdKey = mkPreludeMiscIdUnique 402
2743 inferRIdKey = mkPreludeMiscIdUnique 403
2744
2745 -- data Kind = ...
2746 varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
2747 starKIdKey, constraintKIdKey :: Unique
2748 varKIdKey = mkPreludeMiscIdUnique 404
2749 conKIdKey = mkPreludeMiscIdUnique 405
2750 tupleKIdKey = mkPreludeMiscIdUnique 406
2751 arrowKIdKey = mkPreludeMiscIdUnique 407
2752 listKIdKey = mkPreludeMiscIdUnique 408
2753 appKIdKey = mkPreludeMiscIdUnique 409
2754 starKIdKey = mkPreludeMiscIdUnique 410
2755 constraintKIdKey = mkPreludeMiscIdUnique 411
2756
2757 -- data Callconv = ...
2758 cCallIdKey, stdCallIdKey :: Unique
2759 cCallIdKey = mkPreludeMiscIdUnique 412
2760 stdCallIdKey = mkPreludeMiscIdUnique 413
2761
2762 -- data Safety = ...
2763 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
2764 unsafeIdKey = mkPreludeMiscIdUnique 414
2765 safeIdKey = mkPreludeMiscIdUnique 415
2766 interruptibleIdKey = mkPreludeMiscIdUnique 416
2767
2768 -- data Inline = ...
2769 noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
2770 noInlineDataConKey = mkPreludeDataConUnique 40
2771 inlineDataConKey = mkPreludeDataConUnique 41
2772 inlinableDataConKey = mkPreludeDataConUnique 42
2773
2774 -- data RuleMatch = ...
2775 conLikeDataConKey, funLikeDataConKey :: Unique
2776 conLikeDataConKey = mkPreludeDataConUnique 43
2777 funLikeDataConKey = mkPreludeDataConUnique 44
2778
2779 -- data Phases = ...
2780 allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
2781 allPhasesDataConKey = mkPreludeDataConUnique 45
2782 fromPhaseDataConKey = mkPreludeDataConUnique 46
2783 beforePhaseDataConKey = mkPreludeDataConUnique 47
2784
2785 -- newtype TExp a = ...
2786 tExpDataConKey :: Unique
2787 tExpDataConKey = mkPreludeDataConUnique 48
2788
2789 -- data FunDep = ...
2790 funDepIdKey :: Unique
2791 funDepIdKey = mkPreludeMiscIdUnique 419
2792
2793 -- data FamFlavour = ...
2794 typeFamIdKey, dataFamIdKey :: Unique
2795 typeFamIdKey = mkPreludeMiscIdUnique 420
2796 dataFamIdKey = mkPreludeMiscIdUnique 421
2797
2798 -- data TySynEqn = ...
2799 tySynEqnIdKey :: Unique
2800 tySynEqnIdKey = mkPreludeMiscIdUnique 422
2801
2802 -- quasiquoting
2803 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2804 quoteExpKey = mkPreludeMiscIdUnique 423
2805 quotePatKey = mkPreludeMiscIdUnique 424
2806 quoteDecKey = mkPreludeMiscIdUnique 425
2807 quoteTypeKey = mkPreludeMiscIdUnique 426
2808
2809 -- data RuleBndr = ...
2810 ruleVarIdKey, typedRuleVarIdKey :: Unique
2811 ruleVarIdKey = mkPreludeMiscIdUnique 427
2812 typedRuleVarIdKey = mkPreludeMiscIdUnique 428