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