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