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