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