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