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