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