Merge branch 'master' of http://darcs.haskell.org//ghc
[ghc.git] / compiler / deSugar / DsMeta.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2006
4 --
5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
7 -- input HsExpr. We do this in the DsM monad, which supplies access to
8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
9 --
10 -- It also defines a bunch of knownKeyNames, in the same way as is done
11 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
15
16 {-# OPTIONS -fno-warn-tabs #-}
17 -- The above warning supression flag is a temporary kludge.
18 -- While working on this module you are encouraged to remove it and
19 -- detab the module (please do the detabbing in a separate patch). See
20 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
21 -- for details
22
23 module DsMeta( dsBracket,
24 templateHaskellNames, qTyConName, nameTyConName,
25 liftName, liftStringName, expQTyConName, patQTyConName,
26 decQTyConName, decsQTyConName, typeQTyConName,
27 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
28 quoteExpName, quotePatName, quoteDecName, quoteTypeName
29 ) where
30
31 #include "HsVersions.h"
32
33 import {-# SOURCE #-} DsExpr ( dsExpr )
34
35 import MatchLit
36 import DsMonad
37
38 import qualified Language.Haskell.TH as TH
39
40 import HsSyn
41 import Class
42 import PrelNames
43 -- To avoid clashes with DsMeta.varName we must make a local alias for
44 -- OccName.varName we do this by removing varName from the import of
45 -- OccName above, making a qualified instance of OccName and using
46 -- OccNameAlias.varName where varName ws previously used in this file.
47 import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
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 )
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 <- repKind 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 = repKind 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 (nameOccName n) = do
723 tv1 <- lookupOcc n
724 repTvar tv1
725 | otherwise = do
726 tc1 <- lookupOcc n
727 repNamedTyCon tc1
728 repTy (HsAppTy f a) = do
729 f1 <- repLTy f
730 a1 <- repLTy a
731 repTapp f1 a1
732 repTy (HsFunTy f a) = do
733 f1 <- repLTy f
734 a1 <- repLTy a
735 tcon <- repArrowTyCon
736 repTapps tcon [f1, a1]
737 repTy (HsListTy t) = do
738 t1 <- repLTy t
739 tcon <- repListTyCon
740 repTapp tcon t1
741 repTy (HsPArrTy t) = do
742 t1 <- repLTy t
743 tcon <- repTy (HsTyVar (tyConName parrTyCon))
744 repTapp tcon t1
745 repTy (HsTupleTy HsUnboxedTuple tys) = do
746 tys1 <- repLTys tys
747 tcon <- repUnboxedTupleTyCon (length tys)
748 repTapps tcon tys1
749 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
750 tcon <- repTupleTyCon (length tys)
751 repTapps tcon tys1
752 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
753 `nlHsAppTy` ty2)
754 repTy (HsParTy t) = repLTy t
755 repTy (HsKindSig t k) = do
756 t1 <- repLTy t
757 k1 <- repKind k
758 repTSig t1 k1
759 repTy (HsSpliceTy splice _ _) = repSplice splice
760 repTy ty = notHandled "Exotic form of type" (ppr ty)
761
762 -- represent a kind
763 --
764 repKind :: LHsKind Name -> DsM (Core TH.Kind)
765 repKind ki
766 = do { let (kis, ki') = splitHsFunType ki
767 ; kis_rep <- mapM repKind kis
768 ; ki'_rep <- repNonArrowKind ki'
769 ; foldrM repArrowK ki'_rep kis_rep
770 }
771 where
772 repNonArrowKind (L _ (HsTyVar name)) | name == liftedTypeKindTyConName = repStarK
773 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
774
775 -----------------------------------------------------------------------------
776 -- Splices
777 -----------------------------------------------------------------------------
778
779 repSplice :: HsSplice Name -> DsM (Core a)
780 -- See Note [How brackets and nested splices are handled] in TcSplice
781 -- We return a CoreExpr of any old type; the context should know
782 repSplice (HsSplice n _)
783 = do { mb_val <- dsLookupMetaEnv n
784 ; case mb_val of
785 Just (Splice e) -> do { e' <- dsExpr e
786 ; return (MkC e') }
787 _ -> pprPanic "HsSplice" (ppr n) }
788 -- Should not happen; statically checked
789
790 -----------------------------------------------------------------------------
791 -- Expressions
792 -----------------------------------------------------------------------------
793
794 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
795 repLEs es = do { es' <- mapM repLE es ;
796 coreList expQTyConName es' }
797
798 -- FIXME: some of these panics should be converted into proper error messages
799 -- unless we can make sure that constructs, which are plainly not
800 -- supported in TH already lead to error messages at an earlier stage
801 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
802 repLE (L loc e) = putSrcSpanDs loc (repE e)
803
804 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
805 repE (HsVar x) =
806 do { mb_val <- dsLookupMetaEnv x
807 ; case mb_val of
808 Nothing -> do { str <- globalVar x
809 ; repVarOrCon x str }
810 Just (Bound y) -> repVarOrCon x (coreVar y)
811 Just (Splice e) -> do { e' <- dsExpr e
812 ; return (MkC e') } }
813 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
814
815 -- Remember, we're desugaring renamer output here, so
816 -- HsOverlit can definitely occur
817 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
818 repE (HsLit l) = do { a <- repLiteral l; repLit a }
819 repE (HsLam (MatchGroup [m] _)) = repLambda m
820 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
821
822 repE (OpApp e1 op _ e2) =
823 do { arg1 <- repLE e1;
824 arg2 <- repLE e2;
825 the_op <- repLE op ;
826 repInfixApp arg1 the_op arg2 }
827 repE (NegApp x _) = do
828 a <- repLE x
829 negateVar <- lookupOcc negateName >>= repVar
830 negateVar `repApp` a
831 repE (HsPar x) = repLE x
832 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
833 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
834 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
835 ; ms2 <- mapM repMatchTup ms
836 ; repCaseE arg (nonEmptyCoreList ms2) }
837 repE (HsIf _ x y z) = do
838 a <- repLE x
839 b <- repLE y
840 c <- repLE z
841 repCond a b c
842 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
843 ; e2 <- addBinds ss (repLE e)
844 ; z <- repLetE ds e2
845 ; wrapGenSyms ss z }
846
847 -- FIXME: I haven't got the types here right yet
848 repE e@(HsDo ctxt sts _)
849 | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
850 = do { (ss,zs) <- repLSts sts;
851 e' <- repDoE (nonEmptyCoreList zs);
852 wrapGenSyms ss e' }
853
854 | ListComp <- ctxt
855 = do { (ss,zs) <- repLSts sts;
856 e' <- repComp (nonEmptyCoreList zs);
857 wrapGenSyms ss e' }
858
859 | otherwise
860 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
861
862 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
863 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
864 repE e@(ExplicitTuple es boxed)
865 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
866 | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs }
867 | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs }
868
869 repE (RecordCon c _ flds)
870 = do { x <- lookupLOcc c;
871 fs <- repFields flds;
872 repRecCon x fs }
873 repE (RecordUpd e flds _ _ _)
874 = do { x <- repLE e;
875 fs <- repFields flds;
876 repRecUpd x fs }
877
878 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
879 repE (ArithSeq _ aseq) =
880 case aseq of
881 From e -> do { ds1 <- repLE e; repFrom ds1 }
882 FromThen e1 e2 -> do
883 ds1 <- repLE e1
884 ds2 <- repLE e2
885 repFromThen ds1 ds2
886 FromTo e1 e2 -> do
887 ds1 <- repLE e1
888 ds2 <- repLE e2
889 repFromTo ds1 ds2
890 FromThenTo e1 e2 e3 -> do
891 ds1 <- repLE e1
892 ds2 <- repLE e2
893 ds3 <- repLE e3
894 repFromThenTo ds1 ds2 ds3
895
896 repE (HsSpliceE splice) = repSplice splice
897 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
898 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
899 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
900 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
901 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
902 repE e = notHandled "Expression form" (ppr e)
903
904 -----------------------------------------------------------------------------
905 -- Building representations of auxillary structures like Match, Clause, Stmt,
906
907 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
908 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
909 do { ss1 <- mkGenSyms (collectPatBinders p)
910 ; addBinds ss1 $ do {
911 ; p1 <- repLP p
912 ; (ss2,ds) <- repBinds wheres
913 ; addBinds ss2 $ do {
914 ; gs <- repGuards guards
915 ; match <- repMatch p1 gs ds
916 ; wrapGenSyms (ss1++ss2) match }}}
917 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
918
919 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
920 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
921 do { ss1 <- mkGenSyms (collectPatsBinders ps)
922 ; addBinds ss1 $ do {
923 ps1 <- repLPs ps
924 ; (ss2,ds) <- repBinds wheres
925 ; addBinds ss2 $ do {
926 gs <- repGuards guards
927 ; clause <- repClause ps1 gs ds
928 ; wrapGenSyms (ss1++ss2) clause }}}
929
930 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
931 repGuards [L _ (GRHS [] e)]
932 = do {a <- repLE e; repNormal a }
933 repGuards other
934 = do { zs <- mapM process other;
935 let {(xs, ys) = unzip zs};
936 gd <- repGuarded (nonEmptyCoreList ys);
937 wrapGenSyms (concat xs) gd }
938 where
939 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
940 process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
941 = do { x <- repLNormalGE e1 e2;
942 return ([], x) }
943 process (L _ (GRHS ss rhs))
944 = do (gs, ss') <- repLSts ss
945 rhs' <- addBinds gs $ repLE rhs
946 g <- repPatGE (nonEmptyCoreList ss') rhs'
947 return (gs, g)
948
949 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
950 repFields (HsRecFields { rec_flds = flds })
951 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
952 ; es <- mapM repLE (map hsRecFieldArg flds)
953 ; fs <- zipWithM repFieldExp fnames es
954 ; coreList fieldExpQTyConName fs }
955
956
957 -----------------------------------------------------------------------------
958 -- Representing Stmt's is tricky, especially if bound variables
959 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
960 -- First gensym new names for every variable in any of the patterns.
961 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
962 -- if variables didn't shaddow, the static gensym wouldn't be necessary
963 -- and we could reuse the original names (x and x).
964 --
965 -- do { x'1 <- gensym "x"
966 -- ; x'2 <- gensym "x"
967 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
968 -- , BindSt (pvar x'2) [| f x |]
969 -- , NoBindSt [| g x |]
970 -- ]
971 -- }
972
973 -- The strategy is to translate a whole list of do-bindings by building a
974 -- bigger environment, and a bigger set of meta bindings
975 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
976 -- of the expressions within the Do
977
978 -----------------------------------------------------------------------------
979 -- The helper function repSts computes the translation of each sub expression
980 -- and a bunch of prefix bindings denoting the dynamic renaming.
981
982 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
983 repLSts stmts = repSts (map unLoc stmts)
984
985 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
986 repSts (BindStmt p e _ _ : ss) =
987 do { e2 <- repLE e
988 ; ss1 <- mkGenSyms (collectPatBinders p)
989 ; addBinds ss1 $ do {
990 ; p1 <- repLP p;
991 ; (ss2,zs) <- repSts ss
992 ; z <- repBindSt p1 e2
993 ; return (ss1++ss2, z : zs) }}
994 repSts (LetStmt bs : ss) =
995 do { (ss1,ds) <- repBinds bs
996 ; z <- repLetSt ds
997 ; (ss2,zs) <- addBinds ss1 (repSts ss)
998 ; return (ss1++ss2, z : zs) }
999 repSts (ExprStmt e _ _ _ : ss) =
1000 do { e2 <- repLE e
1001 ; z <- repNoBindSt e2
1002 ; (ss2,zs) <- repSts ss
1003 ; return (ss2, z : zs) }
1004 repSts [LastStmt e _]
1005 = do { e2 <- repLE e
1006 ; z <- repNoBindSt e2
1007 ; return ([], [z]) }
1008 repSts [] = return ([],[])
1009 repSts other = notHandled "Exotic statement" (ppr other)
1010
1011
1012 -----------------------------------------------------------
1013 -- Bindings
1014 -----------------------------------------------------------
1015
1016 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1017 repBinds EmptyLocalBinds
1018 = do { core_list <- coreList decQTyConName []
1019 ; return ([], core_list) }
1020
1021 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1022
1023 repBinds (HsValBinds decs)
1024 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1025 -- No need to worrry about detailed scopes within
1026 -- the binding group, because we are talking Names
1027 -- here, so we can safely treat it as a mutually
1028 -- recursive group
1029 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1030 ; ss <- mkGenSyms bndrs
1031 ; prs <- addBinds ss (rep_val_binds decs)
1032 ; core_list <- coreList decQTyConName
1033 (de_loc (sort_by_loc prs))
1034 ; return (ss, core_list) }
1035
1036 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1037 -- Assumes: all the binders of the binding are alrady in the meta-env
1038 rep_val_binds (ValBindsOut binds sigs)
1039 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1040 ; core2 <- rep_sigs' sigs
1041 ; return (core1 ++ core2) }
1042 rep_val_binds (ValBindsIn _ _)
1043 = panic "rep_val_binds: ValBindsIn"
1044
1045 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1046 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1047 ; return (de_loc (sort_by_loc binds_w_locs)) }
1048
1049 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1050 rep_binds' binds = mapM rep_bind (bagToList binds)
1051
1052 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1053 -- Assumes: all the binders of the binding are alrady in the meta-env
1054
1055 -- Note GHC treats declarations of a variable (not a pattern)
1056 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1057 -- with an empty list of patterns
1058 rep_bind (L loc (FunBind { fun_id = fn,
1059 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
1060 = do { (ss,wherecore) <- repBinds wheres
1061 ; guardcore <- addBinds ss (repGuards guards)
1062 ; fn' <- lookupLBinder fn
1063 ; p <- repPvar fn'
1064 ; ans <- repVal p guardcore wherecore
1065 ; ans' <- wrapGenSyms ss ans
1066 ; return (loc, ans') }
1067
1068 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
1069 = do { ms1 <- mapM repClauseTup ms
1070 ; fn' <- lookupLBinder fn
1071 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1072 ; return (loc, ans) }
1073
1074 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1075 = do { patcore <- repLP pat
1076 ; (ss,wherecore) <- repBinds wheres
1077 ; guardcore <- addBinds ss (repGuards guards)
1078 ; ans <- repVal patcore guardcore wherecore
1079 ; ans' <- wrapGenSyms ss ans
1080 ; return (loc, ans') }
1081
1082 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1083 = do { v' <- lookupBinder v
1084 ; e2 <- repLE e
1085 ; x <- repNormal e2
1086 ; patcore <- repPvar v'
1087 ; empty_decls <- coreList decQTyConName []
1088 ; ans <- repVal patcore x empty_decls
1089 ; return (srcLocSpan (getSrcLoc v), ans) }
1090
1091 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1092
1093 -----------------------------------------------------------------------------
1094 -- Since everything in a Bind is mutually recursive we need rename all
1095 -- all the variables simultaneously. For example:
1096 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1097 -- do { f'1 <- gensym "f"
1098 -- ; g'2 <- gensym "g"
1099 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1100 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1101 -- ]}
1102 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1103 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1104 -- together. As we do this we collect GenSymBinds's which represent the renamed
1105 -- variables bound by the Bindings. In order not to lose track of these
1106 -- representations we build a shadow datatype MB with the same structure as
1107 -- MonoBinds, but which has slots for the representations
1108
1109
1110 -----------------------------------------------------------------------------
1111 -- GHC allows a more general form of lambda abstraction than specified
1112 -- by Haskell 98. In particular it allows guarded lambda's like :
1113 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1114 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1115 -- (\ p1 .. pn -> exp) by causing an error.
1116
1117 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
1118 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1119 = do { let bndrs = collectPatsBinders ps ;
1120 ; ss <- mkGenSyms bndrs
1121 ; lam <- addBinds ss (
1122 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1123 ; wrapGenSyms ss lam }
1124
1125 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1126
1127
1128 -----------------------------------------------------------------------------
1129 -- Patterns
1130 -- repP deals with patterns. It assumes that we have already
1131 -- walked over the pattern(s) once to collect the binders, and
1132 -- have extended the environment. So every pattern-bound
1133 -- variable should already appear in the environment.
1134
1135 -- Process a list of patterns
1136 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1137 repLPs ps = do { ps' <- mapM repLP ps ;
1138 coreList patQTyConName ps' }
1139
1140 repLP :: LPat Name -> DsM (Core TH.PatQ)
1141 repLP (L _ p) = repP p
1142
1143 repP :: Pat Name -> DsM (Core TH.PatQ)
1144 repP (WildPat _) = repPwild
1145 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1146 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1147 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1148 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1149 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1150 repP (ParPat p) = repLP p
1151 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1152 repP (TuplePat ps boxed _)
1153 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1154 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1155 repP (ConPatIn dc details)
1156 = do { con_str <- lookupLOcc dc
1157 ; case details of
1158 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1159 RecCon rec -> do { let flds = rec_flds rec
1160 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1161 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1162 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1163 ; fps' <- coreList fieldPatQTyConName fps
1164 ; repPrec con_str fps' }
1165 InfixCon p1 p2 -> do { p1' <- repLP p1;
1166 p2' <- repLP p2;
1167 repPinfix p1' con_str p2' }
1168 }
1169 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1170 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1171 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1172 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1173 -- The problem is to do with scoped type variables.
1174 -- To implement them, we have to implement the scoping rules
1175 -- here in DsMeta, and I don't want to do that today!
1176 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1177 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1178 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1179
1180 repP other = notHandled "Exotic pattern" (ppr other)
1181
1182 ----------------------------------------------------------
1183 -- Declaration ordering helpers
1184
1185 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1186 sort_by_loc xs = sortBy comp xs
1187 where comp x y = compare (fst x) (fst y)
1188
1189 de_loc :: [(a, b)] -> [b]
1190 de_loc = map snd
1191
1192 ----------------------------------------------------------
1193 -- The meta-environment
1194
1195 -- A name/identifier association for fresh names of locally bound entities
1196 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1197 -- I.e. (x, x_id) means
1198 -- let x_id = gensym "x" in ...
1199
1200 -- Generate a fresh name for a locally bound entity
1201
1202 mkGenSyms :: [Name] -> DsM [GenSymBind]
1203 -- We can use the existing name. For example:
1204 -- [| \x_77 -> x_77 + x_77 |]
1205 -- desugars to
1206 -- do { x_77 <- genSym "x"; .... }
1207 -- We use the same x_77 in the desugared program, but with the type Bndr
1208 -- instead of Int
1209 --
1210 -- We do make it an Internal name, though (hence localiseName)
1211 --
1212 -- Nevertheless, it's monadic because we have to generate nameTy
1213 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1214 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1215
1216
1217 addBinds :: [GenSymBind] -> DsM a -> DsM a
1218 -- Add a list of fresh names for locally bound entities to the
1219 -- meta environment (which is part of the state carried around
1220 -- by the desugarer monad)
1221 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1222
1223 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1224 dupBinder (new, old)
1225 = do { mb_val <- dsLookupMetaEnv old
1226 ; case mb_val of
1227 Just val -> return (new, val)
1228 Nothing -> pprPanic "dupBinder" (ppr old) }
1229
1230 -- Look up a locally bound name
1231 --
1232 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1233 lookupLBinder (L _ n) = lookupBinder n
1234
1235 lookupBinder :: Name -> DsM (Core TH.Name)
1236 lookupBinder = lookupOcc
1237 -- Binders are brought into scope before the pattern or what-not is
1238 -- desugared. Moreover, in instance declaration the binder of a method
1239 -- will be the selector Id and hence a global; so we need the
1240 -- globalVar case of lookupOcc
1241
1242 -- Look up a name that is either locally bound or a global name
1243 --
1244 -- * If it is a global name, generate the "original name" representation (ie,
1245 -- the <module>:<name> form) for the associated entity
1246 --
1247 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1248 -- Lookup an occurrence; it can't be a splice.
1249 -- Use the in-scope bindings if they exist
1250 lookupLOcc (L _ n) = lookupOcc n
1251
1252 lookupOcc :: Name -> DsM (Core TH.Name)
1253 lookupOcc n
1254 = do { mb_val <- dsLookupMetaEnv n ;
1255 case mb_val of
1256 Nothing -> globalVar n
1257 Just (Bound x) -> return (coreVar x)
1258 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1259 }
1260
1261 globalVar :: Name -> DsM (Core TH.Name)
1262 -- Not bound by the meta-env
1263 -- Could be top-level; or could be local
1264 -- f x = $(g [| x |])
1265 -- Here the x will be local
1266 globalVar name
1267 | isExternalName name
1268 = do { MkC mod <- coreStringLit name_mod
1269 ; MkC pkg <- coreStringLit name_pkg
1270 ; MkC occ <- occNameLit name
1271 ; rep2 mk_varg [pkg,mod,occ] }
1272 | otherwise
1273 = do { MkC occ <- occNameLit name
1274 ; MkC uni <- coreIntLit (getKey (getUnique name))
1275 ; rep2 mkNameLName [occ,uni] }
1276 where
1277 mod = ASSERT( isExternalName name) nameModule name
1278 name_mod = moduleNameString (moduleName mod)
1279 name_pkg = packageIdString (modulePackageId mod)
1280 name_occ = nameOccName name
1281 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1282 | OccName.isVarOcc name_occ = mkNameG_vName
1283 | OccName.isTcOcc name_occ = mkNameG_tcName
1284 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1285
1286 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1287 -> DsM Type -- The type
1288 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1289 return (mkTyConApp tc []) }
1290
1291 wrapGenSyms :: [GenSymBind]
1292 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1293 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1294 -- --> bindQ (gensym nm1) (\ id1 ->
1295 -- bindQ (gensym nm2 (\ id2 ->
1296 -- y))
1297
1298 wrapGenSyms binds body@(MkC b)
1299 = do { var_ty <- lookupType nameTyConName
1300 ; go var_ty binds }
1301 where
1302 [elt_ty] = tcTyConAppArgs (exprType b)
1303 -- b :: Q a, so we can get the type 'a' by looking at the
1304 -- argument type. NB: this relies on Q being a data/newtype,
1305 -- not a type synonym
1306
1307 go _ [] = return body
1308 go var_ty ((name,id) : binds)
1309 = do { MkC body' <- go var_ty binds
1310 ; lit_str <- occNameLit name
1311 ; gensym_app <- repGensym lit_str
1312 ; repBindQ var_ty elt_ty
1313 gensym_app (MkC (Lam id body')) }
1314
1315 occNameLit :: Name -> DsM (Core String)
1316 occNameLit n = coreStringLit (occNameString (nameOccName n))
1317
1318
1319 -- %*********************************************************************
1320 -- %* *
1321 -- Constructing code
1322 -- %* *
1323 -- %*********************************************************************
1324
1325 -----------------------------------------------------------------------------
1326 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1327 -- we invent a new datatype which uses phantom types.
1328
1329 newtype Core a = MkC CoreExpr
1330 unC :: Core a -> CoreExpr
1331 unC (MkC x) = x
1332
1333 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1334 rep2 n xs = do { id <- dsLookupGlobalId n
1335 ; return (MkC (foldl App (Var id) xs)) }
1336
1337 -- Then we make "repConstructors" which use the phantom types for each of the
1338 -- smart constructors of the Meta.Meta datatypes.
1339
1340
1341 -- %*********************************************************************
1342 -- %* *
1343 -- The 'smart constructors'
1344 -- %* *
1345 -- %*********************************************************************
1346
1347 --------------- Patterns -----------------
1348 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1349 repPlit (MkC l) = rep2 litPName [l]
1350
1351 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1352 repPvar (MkC s) = rep2 varPName [s]
1353
1354 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1355 repPtup (MkC ps) = rep2 tupPName [ps]
1356
1357 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1358 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1359
1360 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1361 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1362
1363 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1364 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1365
1366 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1367 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1368
1369 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1370 repPtilde (MkC p) = rep2 tildePName [p]
1371
1372 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1373 repPbang (MkC p) = rep2 bangPName [p]
1374
1375 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1376 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1377
1378 repPwild :: DsM (Core TH.PatQ)
1379 repPwild = rep2 wildPName []
1380
1381 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1382 repPlist (MkC ps) = rep2 listPName [ps]
1383
1384 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1385 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1386
1387 --------------- Expressions -----------------
1388 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1389 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1390 | otherwise = repVar str
1391
1392 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1393 repVar (MkC s) = rep2 varEName [s]
1394
1395 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1396 repCon (MkC s) = rep2 conEName [s]
1397
1398 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1399 repLit (MkC c) = rep2 litEName [c]
1400
1401 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1402 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1403
1404 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1405 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1406
1407 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1408 repTup (MkC es) = rep2 tupEName [es]
1409
1410 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1411 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1412
1413 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1414 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1415
1416 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1417 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1418
1419 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1420 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1421
1422 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1423 repDoE (MkC ss) = rep2 doEName [ss]
1424
1425 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1426 repComp (MkC ss) = rep2 compEName [ss]
1427
1428 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1429 repListExp (MkC es) = rep2 listEName [es]
1430
1431 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1432 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1433
1434 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1435 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1436
1437 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1438 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1439
1440 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1441 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1442
1443 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1444 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1445
1446 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1447 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1448
1449 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1450 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1451
1452 ------------ Right hand sides (guarded expressions) ----
1453 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1454 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1455
1456 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1457 repNormal (MkC e) = rep2 normalBName [e]
1458
1459 ------------ Guards ----
1460 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1461 repLNormalGE g e = do g' <- repLE g
1462 e' <- repLE e
1463 repNormalGE g' e'
1464
1465 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1466 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1467
1468 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1469 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1470
1471 ------------- Stmts -------------------
1472 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1473 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1474
1475 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1476 repLetSt (MkC ds) = rep2 letSName [ds]
1477
1478 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1479 repNoBindSt (MkC e) = rep2 noBindSName [e]
1480
1481 -------------- Range (Arithmetic sequences) -----------
1482 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1483 repFrom (MkC x) = rep2 fromEName [x]
1484
1485 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1486 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1487
1488 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1489 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1490
1491 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1492 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1493
1494 ------------ Match and Clause Tuples -----------
1495 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1496 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1497
1498 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1499 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1500
1501 -------------- Dec -----------------------------
1502 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1503 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1504
1505 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1506 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1507
1508 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1509 -> Maybe (Core [TH.TypeQ])
1510 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1511 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1512 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1513 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1514 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1515
1516 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1517 -> Maybe (Core [TH.TypeQ])
1518 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1519 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1520 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1521 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1522 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1523
1524 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1525 -> Maybe (Core [TH.TypeQ])
1526 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1527 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1528 = rep2 tySynDName [nm, tvs, rhs]
1529 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1530 = rep2 tySynInstDName [nm, tys, rhs]
1531
1532 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1533 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1534
1535 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1536 -> Core [TH.FunDep] -> Core [TH.DecQ]
1537 -> DsM (Core TH.DecQ)
1538 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1539 = rep2 classDName [cxt, cls, tvs, fds, ds]
1540
1541 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1542 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1543
1544 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1545 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1546
1547 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1548 -> DsM (Core TH.DecQ)
1549 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1550 = rep2 pragSpecInlDName [nm, ty, ispec]
1551
1552 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1553 -> DsM (Core TH.DecQ)
1554 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1555 = rep2 familyNoKindDName [flav, nm, tvs]
1556
1557 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1558 -> Core TH.Kind
1559 -> DsM (Core TH.DecQ)
1560 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1561 = rep2 familyKindDName [flav, nm, tvs, ki]
1562
1563 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1564 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1565 = rep2 inlineSpecNoPhaseName [inline, conlike]
1566
1567 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1568 -> DsM (Core TH.InlineSpecQ)
1569 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1570 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1571
1572 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1573 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1574
1575 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1576 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1577
1578 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1579 repCtxt (MkC tys) = rep2 cxtName [tys]
1580
1581 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1582 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1583
1584 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1585 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1586
1587 repConstr :: Core TH.Name -> HsConDeclDetails Name
1588 -> DsM (Core TH.ConQ)
1589 repConstr con (PrefixCon ps)
1590 = do arg_tys <- mapM repBangTy ps
1591 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1592 rep2 normalCName [unC con, unC arg_tys1]
1593 repConstr con (RecCon ips)
1594 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1595 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1596 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1597 arg_vs arg_tys
1598 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1599 rep2 recCName [unC con, unC arg_vtys']
1600 repConstr con (InfixCon st1 st2)
1601 = do arg1 <- repBangTy st1
1602 arg2 <- repBangTy st2
1603 rep2 infixCName [unC arg1, unC con, unC arg2]
1604
1605 ------------ Types -------------------
1606
1607 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1608 -> DsM (Core TH.TypeQ)
1609 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1610 = rep2 forallTName [tvars, ctxt, ty]
1611
1612 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1613 repTvar (MkC s) = rep2 varTName [s]
1614
1615 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1616 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1617
1618 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1619 repTapps f [] = return f
1620 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1621
1622 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1623 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1624
1625 --------- Type constructors --------------
1626
1627 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1628 repNamedTyCon (MkC s) = rep2 conTName [s]
1629
1630 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1631 -- Note: not Core Int; it's easier to be direct here
1632 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1633
1634 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1635 -- Note: not Core Int; it's easier to be direct here
1636 repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i]
1637
1638 repArrowTyCon :: DsM (Core TH.TypeQ)
1639 repArrowTyCon = rep2 arrowTName []
1640
1641 repListTyCon :: DsM (Core TH.TypeQ)
1642 repListTyCon = rep2 listTName []
1643
1644 ------------ Kinds -------------------
1645
1646 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1647 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1648
1649 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1650 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1651
1652 repStarK :: DsM (Core TH.Kind)
1653 repStarK = rep2 starKName []
1654
1655 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1656 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1657
1658 ----------------------------------------------------------
1659 -- Literals
1660
1661 repLiteral :: HsLit -> DsM (Core TH.Lit)
1662 repLiteral lit
1663 = do lit' <- case lit of
1664 HsIntPrim i -> mk_integer i
1665 HsWordPrim w -> mk_integer w
1666 HsInt i -> mk_integer i
1667 HsFloatPrim r -> mk_rational r
1668 HsDoublePrim r -> mk_rational r
1669 _ -> return lit
1670 lit_expr <- dsLit lit'
1671 case mb_lit_name of
1672 Just lit_name -> rep2 lit_name [lit_expr]
1673 Nothing -> notHandled "Exotic literal" (ppr lit)
1674 where
1675 mb_lit_name = case lit of
1676 HsInteger _ _ -> Just integerLName
1677 HsInt _ -> Just integerLName
1678 HsIntPrim _ -> Just intPrimLName
1679 HsWordPrim _ -> Just wordPrimLName
1680 HsFloatPrim _ -> Just floatPrimLName
1681 HsDoublePrim _ -> Just doublePrimLName
1682 HsChar _ -> Just charLName
1683 HsString _ -> Just stringLName
1684 HsRat _ _ -> Just rationalLName
1685 _ -> Nothing
1686
1687 mk_integer :: Integer -> DsM HsLit
1688 mk_integer i = do integer_ty <- lookupType integerTyConName
1689 return $ HsInteger i integer_ty
1690 mk_rational :: FractionalLit -> DsM HsLit
1691 mk_rational r = do rat_ty <- lookupType rationalTyConName
1692 return $ HsRat r rat_ty
1693 mk_string :: FastString -> DsM HsLit
1694 mk_string s = return $ HsString s
1695
1696 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1697 repOverloadedLiteral (OverLit { ol_val = val})
1698 = do { lit <- mk_lit val; repLiteral lit }
1699 -- The type Rational will be in the environment, becuase
1700 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1701 -- and rationalL is sucked in when any TH stuff is used
1702
1703 mk_lit :: OverLitVal -> DsM HsLit
1704 mk_lit (HsIntegral i) = mk_integer i
1705 mk_lit (HsFractional f) = mk_rational f
1706 mk_lit (HsIsString s) = mk_string s
1707
1708 --------------- Miscellaneous -------------------
1709
1710 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1711 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1712
1713 repBindQ :: Type -> Type -- a and b
1714 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1715 repBindQ ty_a ty_b (MkC x) (MkC y)
1716 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1717
1718 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1719 repSequenceQ ty_a (MkC list)
1720 = rep2 sequenceQName [Type ty_a, list]
1721
1722 ------------ Lists and Tuples -------------------
1723 -- turn a list of patterns into a single pattern matching a list
1724
1725 coreList :: Name -- Of the TyCon of the element type
1726 -> [Core a] -> DsM (Core [a])
1727 coreList tc_name es
1728 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1729
1730 coreList' :: Type -- The element type
1731 -> [Core a] -> Core [a]
1732 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1733
1734 nonEmptyCoreList :: [Core a] -> Core [a]
1735 -- The list must be non-empty so we can get the element type
1736 -- Otherwise use coreList
1737 nonEmptyCoreList [] = panic "coreList: empty argument"
1738 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1739
1740 coreStringLit :: String -> DsM (Core String)
1741 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1742
1743 ------------ Bool, Literals & Variables -------------------
1744
1745 coreBool :: Bool -> Core Bool
1746 coreBool False = MkC $ mkConApp falseDataCon []
1747 coreBool True = MkC $ mkConApp trueDataCon []
1748
1749 coreIntLit :: Int -> DsM (Core Int)
1750 coreIntLit i = return (MkC (mkIntExprInt i))
1751
1752 coreVar :: Id -> Core TH.Name -- The Id has type Name
1753 coreVar id = MkC (Var id)
1754
1755 ----------------- Failure -----------------------
1756 notHandled :: String -> SDoc -> DsM a
1757 notHandled what doc = failWithDs msg
1758 where
1759 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1760 2 doc
1761
1762
1763 -- %************************************************************************
1764 -- %* *
1765 -- The known-key names for Template Haskell
1766 -- %* *
1767 -- %************************************************************************
1768
1769 -- To add a name, do three things
1770 --
1771 -- 1) Allocate a key
1772 -- 2) Make a "Name"
1773 -- 3) Add the name to knownKeyNames
1774
1775 templateHaskellNames :: [Name]
1776 -- The names that are implicitly mentioned by ``bracket''
1777 -- Should stay in sync with the import list of DsMeta
1778
1779 templateHaskellNames = [
1780 returnQName, bindQName, sequenceQName, newNameName, liftName,
1781 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1782 liftStringName,
1783
1784 -- Lit
1785 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1786 floatPrimLName, doublePrimLName, rationalLName,
1787 -- Pat
1788 litPName, varPName, tupPName, unboxedTupPName,
1789 conPName, tildePName, bangPName, infixPName,
1790 asPName, wildPName, recPName, listPName, sigPName, viewPName,
1791 -- FieldPat
1792 fieldPatName,
1793 -- Match
1794 matchName,
1795 -- Clause
1796 clauseName,
1797 -- Exp
1798 varEName, conEName, litEName, appEName, infixEName,
1799 infixAppName, sectionLName, sectionRName, lamEName,
1800 tupEName, unboxedTupEName,
1801 condEName, letEName, caseEName, doEName, compEName,
1802 fromEName, fromThenEName, fromToEName, fromThenToEName,
1803 listEName, sigEName, recConEName, recUpdEName,
1804 -- FieldExp
1805 fieldExpName,
1806 -- Body
1807 guardedBName, normalBName,
1808 -- Guard
1809 normalGEName, patGEName,
1810 -- Stmt
1811 bindSName, letSName, noBindSName, parSName,
1812 -- Dec
1813 funDName, valDName, dataDName, newtypeDName, tySynDName,
1814 classDName, instanceDName, sigDName, forImpDName,
1815 pragInlDName, pragSpecDName, pragSpecInlDName,
1816 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1817 tySynInstDName, infixLDName, infixRDName, infixNDName,
1818 -- Cxt
1819 cxtName,
1820 -- Pred
1821 classPName, equalPName,
1822 -- Strict
1823 isStrictName, notStrictName, unpackedName,
1824 -- Con
1825 normalCName, recCName, infixCName, forallCName,
1826 -- StrictType
1827 strictTypeName,
1828 -- VarStrictType
1829 varStrictTypeName,
1830 -- Type
1831 forallTName, varTName, conTName, appTName,
1832 tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName,
1833 -- TyVarBndr
1834 plainTVName, kindedTVName,
1835 -- Kind
1836 starKName, arrowKName,
1837 -- Callconv
1838 cCallName, stdCallName,
1839 -- Safety
1840 unsafeName,
1841 safeName,
1842 interruptibleName,
1843 -- InlineSpec
1844 inlineSpecNoPhaseName, inlineSpecPhaseName,
1845 -- FunDep
1846 funDepName,
1847 -- FamFlavour
1848 typeFamName, dataFamName,
1849
1850 -- And the tycons
1851 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1852 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1853 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1854 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1855 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1856 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1857 predQTyConName, decsQTyConName,
1858
1859 -- Quasiquoting
1860 quoteDecName, quoteTypeName, quoteExpName, quotePatName]
1861
1862 thSyn, thLib, qqLib :: Module
1863 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1864 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1865 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1866
1867 mkTHModule :: FastString -> Module
1868 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1869
1870 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1871 libFun = mk_known_key_name OccName.varName thLib
1872 libTc = mk_known_key_name OccName.tcName thLib
1873 thFun = mk_known_key_name OccName.varName thSyn
1874 thTc = mk_known_key_name OccName.tcName thSyn
1875 qqFun = mk_known_key_name OccName.varName qqLib
1876
1877 -------------------- TH.Syntax -----------------------
1878 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1879 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1880 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1881 predTyConName :: Name
1882 qTyConName = thTc (fsLit "Q") qTyConKey
1883 nameTyConName = thTc (fsLit "Name") nameTyConKey
1884 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1885 patTyConName = thTc (fsLit "Pat") patTyConKey
1886 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1887 expTyConName = thTc (fsLit "Exp") expTyConKey
1888 decTyConName = thTc (fsLit "Dec") decTyConKey
1889 typeTyConName = thTc (fsLit "Type") typeTyConKey
1890 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1891 matchTyConName = thTc (fsLit "Match") matchTyConKey
1892 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1893 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1894 predTyConName = thTc (fsLit "Pred") predTyConKey
1895
1896 returnQName, bindQName, sequenceQName, newNameName, liftName,
1897 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1898 mkNameLName, liftStringName :: Name
1899 returnQName = thFun (fsLit "returnQ") returnQIdKey
1900 bindQName = thFun (fsLit "bindQ") bindQIdKey
1901 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1902 newNameName = thFun (fsLit "newName") newNameIdKey
1903 liftName = thFun (fsLit "lift") liftIdKey
1904 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1905 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1906 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1907 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1908 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1909 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1910
1911
1912 -------------------- TH.Lib -----------------------
1913 -- data Lit = ...
1914 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1915 floatPrimLName, doublePrimLName, rationalLName :: Name
1916 charLName = libFun (fsLit "charL") charLIdKey
1917 stringLName = libFun (fsLit "stringL") stringLIdKey
1918 integerLName = libFun (fsLit "integerL") integerLIdKey
1919 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1920 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1921 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1922 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1923 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1924
1925 -- data Pat = ...
1926 litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,
1927 asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name
1928 litPName = libFun (fsLit "litP") litPIdKey
1929 varPName = libFun (fsLit "varP") varPIdKey
1930 tupPName = libFun (fsLit "tupP") tupPIdKey
1931 unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
1932 conPName = libFun (fsLit "conP") conPIdKey
1933 infixPName = libFun (fsLit "infixP") infixPIdKey
1934 tildePName = libFun (fsLit "tildeP") tildePIdKey
1935 bangPName = libFun (fsLit "bangP") bangPIdKey
1936 asPName = libFun (fsLit "asP") asPIdKey
1937 wildPName = libFun (fsLit "wildP") wildPIdKey
1938 recPName = libFun (fsLit "recP") recPIdKey
1939 listPName = libFun (fsLit "listP") listPIdKey
1940 sigPName = libFun (fsLit "sigP") sigPIdKey
1941 viewPName = libFun (fsLit "viewP") viewPIdKey
1942
1943 -- type FieldPat = ...
1944 fieldPatName :: Name
1945 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1946
1947 -- data Match = ...
1948 matchName :: Name
1949 matchName = libFun (fsLit "match") matchIdKey
1950
1951 -- data Clause = ...
1952 clauseName :: Name
1953 clauseName = libFun (fsLit "clause") clauseIdKey
1954
1955 -- data Exp = ...
1956 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1957 sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName,
1958 letEName, caseEName, doEName, compEName :: Name
1959 varEName = libFun (fsLit "varE") varEIdKey
1960 conEName = libFun (fsLit "conE") conEIdKey
1961 litEName = libFun (fsLit "litE") litEIdKey
1962 appEName = libFun (fsLit "appE") appEIdKey
1963 infixEName = libFun (fsLit "infixE") infixEIdKey
1964 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1965 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1966 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1967 lamEName = libFun (fsLit "lamE") lamEIdKey
1968 tupEName = libFun (fsLit "tupE") tupEIdKey
1969 unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey
1970 condEName = libFun (fsLit "condE") condEIdKey
1971 letEName = libFun (fsLit "letE") letEIdKey
1972 caseEName = libFun (fsLit "caseE") caseEIdKey
1973 doEName = libFun (fsLit "doE") doEIdKey
1974 compEName = libFun (fsLit "compE") compEIdKey
1975 -- ArithSeq skips a level
1976 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1977 fromEName = libFun (fsLit "fromE") fromEIdKey
1978 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1979 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1980 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1981 -- end ArithSeq
1982 listEName, sigEName, recConEName, recUpdEName :: Name
1983 listEName = libFun (fsLit "listE") listEIdKey
1984 sigEName = libFun (fsLit "sigE") sigEIdKey
1985 recConEName = libFun (fsLit "recConE") recConEIdKey
1986 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1987
1988 -- type FieldExp = ...
1989 fieldExpName :: Name
1990 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1991
1992 -- data Body = ...
1993 guardedBName, normalBName :: Name
1994 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1995 normalBName = libFun (fsLit "normalB") normalBIdKey
1996
1997 -- data Guard = ...
1998 normalGEName, patGEName :: Name
1999 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
2000 patGEName = libFun (fsLit "patGE") patGEIdKey
2001
2002 -- data Stmt = ...
2003 bindSName, letSName, noBindSName, parSName :: Name
2004 bindSName = libFun (fsLit "bindS") bindSIdKey
2005 letSName = libFun (fsLit "letS") letSIdKey
2006 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
2007 parSName = libFun (fsLit "parS") parSIdKey
2008
2009 -- data Dec = ...
2010 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
2011 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
2012 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
2013 newtypeInstDName, tySynInstDName,
2014 infixLDName, infixRDName, infixNDName :: Name
2015 funDName = libFun (fsLit "funD") funDIdKey
2016 valDName = libFun (fsLit "valD") valDIdKey
2017 dataDName = libFun (fsLit "dataD") dataDIdKey
2018 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
2019 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
2020 classDName = libFun (fsLit "classD") classDIdKey
2021 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
2022 sigDName = libFun (fsLit "sigD") sigDIdKey
2023 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
2024 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
2025 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
2026 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
2027 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
2028 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
2029 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
2030 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
2031 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
2032 infixLDName = libFun (fsLit "infixLD") infixLDIdKey
2033 infixRDName = libFun (fsLit "infixRD") infixRDIdKey
2034 infixNDName = libFun (fsLit "infixND") infixNDIdKey
2035
2036 -- type Ctxt = ...
2037 cxtName :: Name
2038 cxtName = libFun (fsLit "cxt") cxtIdKey
2039
2040 -- data Pred = ...
2041 classPName, equalPName :: Name
2042 classPName = libFun (fsLit "classP") classPIdKey
2043 equalPName = libFun (fsLit "equalP") equalPIdKey
2044
2045 -- data Strict = ...
2046 isStrictName, notStrictName, unpackedName :: Name
2047 isStrictName = libFun (fsLit "isStrict") isStrictKey
2048 notStrictName = libFun (fsLit "notStrict") notStrictKey
2049 unpackedName = libFun (fsLit "unpacked") unpackedKey
2050
2051 -- data Con = ...
2052 normalCName, recCName, infixCName, forallCName :: Name
2053 normalCName = libFun (fsLit "normalC") normalCIdKey
2054 recCName = libFun (fsLit "recC") recCIdKey
2055 infixCName = libFun (fsLit "infixC") infixCIdKey
2056 forallCName = libFun (fsLit "forallC") forallCIdKey
2057
2058 -- type StrictType = ...
2059 strictTypeName :: Name
2060 strictTypeName = libFun (fsLit "strictType") strictTKey
2061
2062 -- type VarStrictType = ...
2063 varStrictTypeName :: Name
2064 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
2065
2066 -- data Type = ...
2067 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
2068 listTName, appTName, sigTName :: Name
2069 forallTName = libFun (fsLit "forallT") forallTIdKey
2070 varTName = libFun (fsLit "varT") varTIdKey
2071 conTName = libFun (fsLit "conT") conTIdKey
2072 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
2073 unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
2074 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
2075 listTName = libFun (fsLit "listT") listTIdKey
2076 appTName = libFun (fsLit "appT") appTIdKey
2077 sigTName = libFun (fsLit "sigT") sigTIdKey
2078
2079 -- data TyVarBndr = ...
2080 plainTVName, kindedTVName :: Name
2081 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
2082 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
2083
2084 -- data Kind = ...
2085 starKName, arrowKName :: Name
2086 starKName = libFun (fsLit "starK") starKIdKey
2087 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
2088
2089 -- data Callconv = ...
2090 cCallName, stdCallName :: Name
2091 cCallName = libFun (fsLit "cCall") cCallIdKey
2092 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
2093
2094 -- data Safety = ...
2095 unsafeName, safeName, interruptibleName :: Name
2096 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
2097 safeName = libFun (fsLit "safe") safeIdKey
2098 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
2099
2100 -- data InlineSpec = ...
2101 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
2102 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
2103 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
2104
2105 -- data FunDep = ...
2106 funDepName :: Name
2107 funDepName = libFun (fsLit "funDep") funDepIdKey
2108
2109 -- data FamFlavour = ...
2110 typeFamName, dataFamName :: Name
2111 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
2112 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
2113
2114 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
2115 decQTyConName, conQTyConName, strictTypeQTyConName,
2116 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
2117 patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name
2118 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
2119 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
2120 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
2121 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
2122 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
2123 decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
2124 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
2125 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
2126 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
2127 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
2128 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
2129 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
2130 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
2131 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
2132
2133 -- quasiquoting
2134 quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
2135 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
2136 quotePatName = qqFun (fsLit "quotePat") quotePatKey
2137 quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey
2138 quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey
2139
2140 -- TyConUniques available: 200-299
2141 -- Check in PrelNames if you want to change this
2142
2143 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
2144 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
2145 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
2146 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
2147 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
2148 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
2149 predQTyConKey, decsQTyConKey :: Unique
2150 expTyConKey = mkPreludeTyConUnique 200
2151 matchTyConKey = mkPreludeTyConUnique 201
2152 clauseTyConKey = mkPreludeTyConUnique 202
2153 qTyConKey = mkPreludeTyConUnique 203
2154 expQTyConKey = mkPreludeTyConUnique 204
2155 decQTyConKey = mkPreludeTyConUnique 205
2156 patTyConKey = mkPreludeTyConUnique 206
2157 matchQTyConKey = mkPreludeTyConUnique 207
2158 clauseQTyConKey = mkPreludeTyConUnique 208
2159 stmtQTyConKey = mkPreludeTyConUnique 209
2160 conQTyConKey = mkPreludeTyConUnique 210
2161 typeQTyConKey = mkPreludeTyConUnique 211
2162 typeTyConKey = mkPreludeTyConUnique 212
2163 decTyConKey = mkPreludeTyConUnique 213
2164 varStrictTypeQTyConKey = mkPreludeTyConUnique 214
2165 strictTypeQTyConKey = mkPreludeTyConUnique 215
2166 fieldExpTyConKey = mkPreludeTyConUnique 216
2167 fieldPatTyConKey = mkPreludeTyConUnique 217
2168 nameTyConKey = mkPreludeTyConUnique 218
2169 patQTyConKey = mkPreludeTyConUnique 219
2170 fieldPatQTyConKey = mkPreludeTyConUnique 220
2171 fieldExpQTyConKey = mkPreludeTyConUnique 221
2172 funDepTyConKey = mkPreludeTyConUnique 222
2173 predTyConKey = mkPreludeTyConUnique 223
2174 predQTyConKey = mkPreludeTyConUnique 224
2175 tyVarBndrTyConKey = mkPreludeTyConUnique 225
2176 decsQTyConKey = mkPreludeTyConUnique 226
2177
2178 -- IdUniques available: 200-399
2179 -- If you want to change this, make sure you check in PrelNames
2180
2181 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2182 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2183 mkNameLIdKey :: Unique
2184 returnQIdKey = mkPreludeMiscIdUnique 200
2185 bindQIdKey = mkPreludeMiscIdUnique 201
2186 sequenceQIdKey = mkPreludeMiscIdUnique 202
2187 liftIdKey = mkPreludeMiscIdUnique 203
2188 newNameIdKey = mkPreludeMiscIdUnique 204
2189 mkNameIdKey = mkPreludeMiscIdUnique 205
2190 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2191 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2192 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2193 mkNameLIdKey = mkPreludeMiscIdUnique 209
2194
2195
2196 -- data Lit = ...
2197 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2198 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2199 charLIdKey = mkPreludeMiscIdUnique 220
2200 stringLIdKey = mkPreludeMiscIdUnique 221
2201 integerLIdKey = mkPreludeMiscIdUnique 222
2202 intPrimLIdKey = mkPreludeMiscIdUnique 223
2203 wordPrimLIdKey = mkPreludeMiscIdUnique 224
2204 floatPrimLIdKey = mkPreludeMiscIdUnique 225
2205 doublePrimLIdKey = mkPreludeMiscIdUnique 226
2206 rationalLIdKey = mkPreludeMiscIdUnique 227
2207
2208 liftStringIdKey :: Unique
2209 liftStringIdKey = mkPreludeMiscIdUnique 228
2210
2211 -- data Pat = ...
2212 litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2213 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique
2214 litPIdKey = mkPreludeMiscIdUnique 240
2215 varPIdKey = mkPreludeMiscIdUnique 241
2216 tupPIdKey = mkPreludeMiscIdUnique 242
2217 unboxedTupPIdKey = mkPreludeMiscIdUnique 243
2218 conPIdKey = mkPreludeMiscIdUnique 244
2219 infixPIdKey = mkPreludeMiscIdUnique 245
2220 tildePIdKey = mkPreludeMiscIdUnique 246
2221 bangPIdKey = mkPreludeMiscIdUnique 247
2222 asPIdKey = mkPreludeMiscIdUnique 248
2223 wildPIdKey = mkPreludeMiscIdUnique 249
2224 recPIdKey = mkPreludeMiscIdUnique 250
2225 listPIdKey = mkPreludeMiscIdUnique 251
2226 sigPIdKey = mkPreludeMiscIdUnique 252
2227 viewPIdKey = mkPreludeMiscIdUnique 253
2228
2229 -- type FieldPat = ...
2230 fieldPatIdKey :: Unique
2231 fieldPatIdKey = mkPreludeMiscIdUnique 260
2232
2233 -- data Match = ...
2234 matchIdKey :: Unique
2235 matchIdKey = mkPreludeMiscIdUnique 261
2236
2237 -- data Clause = ...
2238 clauseIdKey :: Unique
2239 clauseIdKey = mkPreludeMiscIdUnique 262
2240
2241
2242 -- data Exp = ...
2243 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2244 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey,
2245 condEIdKey,
2246 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2247 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2248 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2249 varEIdKey = mkPreludeMiscIdUnique 270
2250 conEIdKey = mkPreludeMiscIdUnique 271
2251 litEIdKey = mkPreludeMiscIdUnique 272
2252 appEIdKey = mkPreludeMiscIdUnique 273
2253 infixEIdKey = mkPreludeMiscIdUnique 274
2254 infixAppIdKey = mkPreludeMiscIdUnique 275
2255 sectionLIdKey = mkPreludeMiscIdUnique 276
2256 sectionRIdKey = mkPreludeMiscIdUnique 277
2257 lamEIdKey = mkPreludeMiscIdUnique 278
2258 tupEIdKey = mkPreludeMiscIdUnique 279
2259 unboxedTupEIdKey = mkPreludeMiscIdUnique 280
2260 condEIdKey = mkPreludeMiscIdUnique 281
2261 letEIdKey = mkPreludeMiscIdUnique 282
2262 caseEIdKey = mkPreludeMiscIdUnique 283
2263 doEIdKey = mkPreludeMiscIdUnique 284
2264 compEIdKey = mkPreludeMiscIdUnique 285
2265 fromEIdKey = mkPreludeMiscIdUnique 286
2266 fromThenEIdKey = mkPreludeMiscIdUnique 287
2267 fromToEIdKey = mkPreludeMiscIdUnique 288
2268 fromThenToEIdKey = mkPreludeMiscIdUnique 289
2269 listEIdKey = mkPreludeMiscIdUnique 290
2270 sigEIdKey = mkPreludeMiscIdUnique 291
2271 recConEIdKey = mkPreludeMiscIdUnique 292
2272 recUpdEIdKey = mkPreludeMiscIdUnique 293
2273
2274 -- type FieldExp = ...
2275 fieldExpIdKey :: Unique
2276 fieldExpIdKey = mkPreludeMiscIdUnique 310
2277
2278 -- data Body = ...
2279 guardedBIdKey, normalBIdKey :: Unique
2280 guardedBIdKey = mkPreludeMiscIdUnique 311
2281 normalBIdKey = mkPreludeMiscIdUnique 312
2282
2283 -- data Guard = ...
2284 normalGEIdKey, patGEIdKey :: Unique
2285 normalGEIdKey = mkPreludeMiscIdUnique 313
2286 patGEIdKey = mkPreludeMiscIdUnique 314
2287
2288 -- data Stmt = ...
2289 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2290 bindSIdKey = mkPreludeMiscIdUnique 320
2291 letSIdKey = mkPreludeMiscIdUnique 321
2292 noBindSIdKey = mkPreludeMiscIdUnique 322
2293 parSIdKey = mkPreludeMiscIdUnique 323
2294
2295 -- data Dec = ...
2296 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2297 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2298 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2299 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
2300 infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique
2301 funDIdKey = mkPreludeMiscIdUnique 330
2302 valDIdKey = mkPreludeMiscIdUnique 331
2303 dataDIdKey = mkPreludeMiscIdUnique 332
2304 newtypeDIdKey = mkPreludeMiscIdUnique 333
2305 tySynDIdKey = mkPreludeMiscIdUnique 334
2306 classDIdKey = mkPreludeMiscIdUnique 335
2307 instanceDIdKey = mkPreludeMiscIdUnique 336
2308 sigDIdKey = mkPreludeMiscIdUnique 337
2309 forImpDIdKey = mkPreludeMiscIdUnique 338
2310 pragInlDIdKey = mkPreludeMiscIdUnique 339
2311 pragSpecDIdKey = mkPreludeMiscIdUnique 340
2312 pragSpecInlDIdKey = mkPreludeMiscIdUnique 341
2313 familyNoKindDIdKey = mkPreludeMiscIdUnique 342
2314 familyKindDIdKey = mkPreludeMiscIdUnique 343
2315 dataInstDIdKey = mkPreludeMiscIdUnique 344
2316 newtypeInstDIdKey = mkPreludeMiscIdUnique 345
2317 tySynInstDIdKey = mkPreludeMiscIdUnique 346
2318 infixLDIdKey = mkPreludeMiscIdUnique 347
2319 infixRDIdKey = mkPreludeMiscIdUnique 348
2320 infixNDIdKey = mkPreludeMiscIdUnique 349
2321
2322 -- type Cxt = ...
2323 cxtIdKey :: Unique
2324 cxtIdKey = mkPreludeMiscIdUnique 360
2325
2326 -- data Pred = ...
2327 classPIdKey, equalPIdKey :: Unique
2328 classPIdKey = mkPreludeMiscIdUnique 361
2329 equalPIdKey = mkPreludeMiscIdUnique 362
2330
2331 -- data Strict = ...
2332 isStrictKey, notStrictKey, unpackedKey :: Unique
2333 isStrictKey = mkPreludeMiscIdUnique 363
2334 notStrictKey = mkPreludeMiscIdUnique 364
2335 unpackedKey = mkPreludeMiscIdUnique 365
2336
2337 -- data Con = ...
2338 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2339 normalCIdKey = mkPreludeMiscIdUnique 370
2340 recCIdKey = mkPreludeMiscIdUnique 371
2341 infixCIdKey = mkPreludeMiscIdUnique 372
2342 forallCIdKey = mkPreludeMiscIdUnique 373
2343
2344 -- type StrictType = ...
2345 strictTKey :: Unique
2346 strictTKey = mkPreludeMiscIdUnique 374
2347
2348 -- type VarStrictType = ...
2349 varStrictTKey :: Unique
2350 varStrictTKey = mkPreludeMiscIdUnique 375
2351
2352 -- data Type = ...
2353 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
2354 listTIdKey, appTIdKey, sigTIdKey :: Unique
2355 forallTIdKey = mkPreludeMiscIdUnique 380
2356 varTIdKey = mkPreludeMiscIdUnique 381
2357 conTIdKey = mkPreludeMiscIdUnique 382
2358 tupleTIdKey = mkPreludeMiscIdUnique 383
2359 unboxedTupleTIdKey = mkPreludeMiscIdUnique 384
2360 arrowTIdKey = mkPreludeMiscIdUnique 385
2361 listTIdKey = mkPreludeMiscIdUnique 386
2362 appTIdKey = mkPreludeMiscIdUnique 387
2363 sigTIdKey = mkPreludeMiscIdUnique 388
2364
2365 -- data TyVarBndr = ...
2366 plainTVIdKey, kindedTVIdKey :: Unique
2367 plainTVIdKey = mkPreludeMiscIdUnique 390
2368 kindedTVIdKey = mkPreludeMiscIdUnique 391
2369
2370 -- data Kind = ...
2371 starKIdKey, arrowKIdKey :: Unique
2372 starKIdKey = mkPreludeMiscIdUnique 392
2373 arrowKIdKey = mkPreludeMiscIdUnique 393
2374
2375 -- data Callconv = ...
2376 cCallIdKey, stdCallIdKey :: Unique
2377 cCallIdKey = mkPreludeMiscIdUnique 394
2378 stdCallIdKey = mkPreludeMiscIdUnique 395
2379
2380 -- data Safety = ...
2381 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
2382 unsafeIdKey = mkPreludeMiscIdUnique 400
2383 safeIdKey = mkPreludeMiscIdUnique 401
2384 interruptibleIdKey = mkPreludeMiscIdUnique 403
2385
2386 -- data InlineSpec =
2387 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2388 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404
2389 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405
2390
2391 -- data FunDep = ...
2392 funDepIdKey :: Unique
2393 funDepIdKey = mkPreludeMiscIdUnique 406
2394
2395 -- data FamFlavour = ...
2396 typeFamIdKey, dataFamIdKey :: Unique
2397 typeFamIdKey = mkPreludeMiscIdUnique 407
2398 dataFamIdKey = mkPreludeMiscIdUnique 408
2399
2400 -- quasiquoting
2401 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
2402 quoteExpKey = mkPreludeMiscIdUnique 410
2403 quotePatKey = mkPreludeMiscIdUnique 411
2404 quoteDecKey = mkPreludeMiscIdUnique 412
2405 quoteTypeKey = mkPreludeMiscIdUnique 413