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