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