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