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