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