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