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