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