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