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