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