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