Add tuple sections as a new feature
[ghc.git] / compiler / deSugar / DsMeta.hs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2006
4 --
5 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
6 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
7 -- input HsExpr. We do this in the DsM monad, which supplies access to
8 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
9 --
10 -- It also defines a bunch of knownKeyNames, in the same way as is done
11 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
12 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
13 -- a Royal Pain (triggers other recompilation).
14 -----------------------------------------------------------------------------
15
16 module DsMeta( dsBracket,
17 templateHaskellNames, qTyConName, nameTyConName,
18 liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
19 decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
20 quoteExpName, quotePatName
21 ) where
22
23 #include "HsVersions.h"
24
25 import {-# SOURCE #-} DsExpr ( dsExpr )
26
27 import MatchLit
28 import DsMonad
29
30 import qualified Language.Haskell.TH as TH
31
32 import HsSyn
33 import Class
34 import PrelNames
35 -- To avoid clashes with DsMeta.varName we must make a local alias for
36 -- OccName.varName we do this by removing varName from the import of
37 -- OccName above, making a qualified instance of OccName and using
38 -- OccNameAlias.varName where varName ws previously used in this file.
39 import qualified OccName
40
41 import Module
42 import Id
43 import Name
44 import NameEnv
45 import TcType
46 import TyCon
47 import TysWiredIn
48 import CoreSyn
49 import MkCore
50 import CoreUtils
51 import SrcLoc
52 import Unique
53 import BasicTypes
54 import Outputable
55 import Bag
56 import FastString
57 import ForeignCall
58 import MonadUtils
59
60 import Data.Maybe
61 import Control.Monad
62 import Data.List
63
64 -----------------------------------------------------------------------------
65 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
66 -- Returns a CoreExpr of type TH.ExpQ
67 -- The quoted thing is parameterised over Name, even though it has
68 -- been type checked. We don't want all those type decorations!
69
70 dsBracket brack splices
71 = dsExtendMetaEnv new_bit (do_brack brack)
72 where
73 new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
74
75 do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 }
76 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
77 do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 }
78 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
79 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
80
81 {- -------------- Examples --------------------
82
83 [| \x -> x |]
84 ====>
85 gensym (unpackString "x"#) `bindQ` \ x1::String ->
86 lam (pvar x1) (var x1)
87
88
89 [| \x -> $(f [| x |]) |]
90 ====>
91 gensym (unpackString "x"#) `bindQ` \ x1::String ->
92 lam (pvar x1) (f (var x1))
93 -}
94
95
96 -------------------------------------------------------
97 -- Declarations
98 -------------------------------------------------------
99
100 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
101 repTopDs group
102 = do { let { bndrs = map unLoc (groupBinders group) } ;
103 ss <- mkGenSyms bndrs ;
104
105 -- Bind all the names mainly to avoid repeated use of explicit strings.
106 -- Thus we get
107 -- do { t :: String <- genSym "T" ;
108 -- return (Data t [] ...more t's... }
109 -- The other important reason is that the output must mention
110 -- only "T", not "Foo:T" where Foo is the current module
111
112
113 decls <- addBinds ss (do {
114 val_ds <- rep_val_binds (hs_valds group) ;
115 tycl_ds <- mapM repTyClD (hs_tyclds group) ;
116 inst_ds <- mapM repInstD' (hs_instds group) ;
117 for_ds <- mapM repForD (hs_fords group) ;
118 -- more needed
119 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
120
121 decl_ty <- lookupType decQTyConName ;
122 let { core_list = coreList' decl_ty decls } ;
123
124 dec_ty <- lookupType decTyConName ;
125 q_decs <- repSequenceQ dec_ty core_list ;
126
127 wrapNongenSyms ss q_decs
128 -- Do *not* gensym top-level binders
129 }
130
131 groupBinders :: HsGroup Name -> [Located Name]
132 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
133 hs_instds = inst_decls, hs_fords = foreign_decls })
134 -- Collect the binders of a Group
135 = collectHsValBinders val_decls ++
136 [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
137 [n | L _ (ForeignImport n _ _) <- foreign_decls]
138 where
139 assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
140
141
142 {- Note [Binders and occurrences]
143 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
144 When we desugar [d| data T = MkT |]
145 we want to get
146 Data "T" [] [Con "MkT" []] []
147 and *not*
148 Data "Foo:T" [] [Con "Foo:MkT" []] []
149 That is, the new data decl should fit into whatever new module it is
150 asked to fit in. We do *not* clone, though; no need for this:
151 Data "T79" ....
152
153 But if we see this:
154 data T = MkT
155 foo = reifyDecl T
156
157 then we must desugar to
158 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
159
160 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
161 And we use lookupOcc, rather than lookupBinder
162 in repTyClD and repC.
163
164 -}
165
166 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
167
168 repTyClD tydecl@(L _ (TyFamily {}))
169 = repTyFamily tydecl addTyVarBinds
170
171 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
172 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
173 tcdCons = cons, tcdDerivs = mb_derivs }))
174 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
175 ; dec <- addTyVarBinds tvs $ \bndrs ->
176 do { cxt1 <- repLContext cxt
177 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
178 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
179 ; cons1 <- mapM repC cons
180 ; cons2 <- coreList conQTyConName cons1
181 ; derivs1 <- repDerivs mb_derivs
182 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
183 ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1
184 }
185 ; return $ Just (loc, dec)
186 }
187
188 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
189 tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
190 tcdCons = [con], tcdDerivs = mb_derivs }))
191 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
192 ; dec <- addTyVarBinds tvs $ \bndrs ->
193 do { cxt1 <- repLContext cxt
194 ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
195 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
196 ; con1 <- repC con
197 ; derivs1 <- repDerivs mb_derivs
198 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
199 ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
200 }
201 ; return $ Just (loc, dec)
202 }
203
204 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys,
205 tcdSynRhs = ty }))
206 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
207 ; dec <- addTyVarBinds tvs $ \bndrs ->
208 do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
209 ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
210 ; ty1 <- repLTy ty
211 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
212 ; repTySyn tc1 bndrs1 opt_tys2 ty1
213 }
214 ; return (Just (loc, dec))
215 }
216
217 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
218 tcdTyVars = tvs, tcdFDs = fds,
219 tcdSigs = sigs, tcdMeths = meth_binds,
220 tcdATs = ats }))
221 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
222 ; dec <- addTyVarBinds tvs $ \bndrs ->
223 do { cxt1 <- repLContext cxt
224 ; sigs1 <- rep_sigs sigs
225 ; binds1 <- rep_binds meth_binds
226 ; fds1 <- repLFunDeps fds
227 ; ats1 <- repLAssocFamilys ats
228 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
229 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
230 ; repClass cxt1 cls1 bndrs1 fds1 decls1
231 }
232 ; return $ Just (loc, dec)
233 }
234
235 -- Un-handled cases
236 repTyClD (L loc d) = putSrcSpanDs loc $
237 do { warnDs (hang ds_msg 4 (ppr d))
238 ; return Nothing }
239
240 -- The type variables in the head of families are treated differently when the
241 -- family declaration is associated. In that case, they are usage, not binding
242 -- occurences.
243 --
244 repTyFamily :: LTyClDecl Name
245 -> ProcessTyVarBinds TH.Dec
246 -> DsM (Maybe (SrcSpan, Core TH.DecQ))
247 repTyFamily (L loc (TyFamily { tcdFlavour = flavour,
248 tcdLName = tc, tcdTyVars = tvs,
249 tcdKind = opt_kind }))
250 tyVarBinds
251 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
252 ; dec <- tyVarBinds tvs $ \bndrs ->
253 do { flav <- repFamilyFlavour flavour
254 ; bndrs1 <- coreList tyVarBndrTyConName bndrs
255 ; case opt_kind of
256 Nothing -> repFamilyNoKind flav tc1 bndrs1
257 Just ki -> do { ki1 <- repKind ki
258 ; repFamilyKind flav tc1 bndrs1 ki1
259 }
260 }
261 ; return $ Just (loc, dec)
262 }
263 repTyFamily _ _ = panic "DsMeta.repTyFamily: internal error"
264
265 -- represent fundeps
266 --
267 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
268 repLFunDeps fds = do fds' <- mapM repLFunDep fds
269 fdList <- coreList funDepTyConName fds'
270 return fdList
271
272 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
273 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
274 ys' <- mapM lookupBinder ys
275 xs_list <- coreList nameTyConName xs'
276 ys_list <- coreList nameTyConName ys'
277 repFunDep xs_list ys_list
278
279 -- represent family declaration flavours
280 --
281 repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour)
282 repFamilyFlavour TypeFamily = rep2 typeFamName []
283 repFamilyFlavour DataFamily = rep2 dataFamName []
284
285 -- represent associated family declarations
286 --
287 repLAssocFamilys :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
288 repLAssocFamilys = mapM repLAssocFamily
289 where
290 repLAssocFamily tydecl@(L _ (TyFamily {}))
291 = liftM (snd . fromJust) $ repTyFamily tydecl lookupTyVarBinds
292 repLAssocFamily tydecl
293 = failWithDs msg
294 where
295 msg = ptext (sLit "Illegal associated declaration in class:") <+>
296 ppr tydecl
297
298 -- represent associated family instances
299 --
300 repLAssocFamInst :: [LTyClDecl Name] -> DsM [Core TH.DecQ]
301 repLAssocFamInst = liftM de_loc . mapMaybeM repTyClD
302
303 -- represent instance declarations
304 --
305 repInstD' :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
306 repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now
307 = do { i <- addTyVarBinds tvs $ \_ ->
308 -- We must bring the type variables into scope, so their
309 -- occurrences don't fail, even though the binders don't
310 -- appear in the resulting data structure
311 do { cxt1 <- repContext cxt
312 ; inst_ty1 <- repPredTy (HsClassP cls tys)
313 ; ss <- mkGenSyms (collectHsBindBinders binds)
314 ; binds1 <- addBinds ss (rep_binds binds)
315 ; ats1 <- repLAssocFamInst ats
316 ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
317 ; decls2 <- wrapNongenSyms ss decls1
318 -- wrapNongenSyms: do not clone the class op names!
319 -- They must be called 'op' etc, not 'op34'
320 ; repInst cxt1 inst_ty1 (decls2)
321 }
322 ; return (loc, i)}
323 where
324 (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
325
326 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
327 repForD (L loc (ForeignImport name typ (CImport cc s ch cis)))
328 = do MkC name' <- lookupLOcc name
329 MkC typ' <- repLTy typ
330 MkC cc' <- repCCallConv cc
331 MkC s' <- repSafety s
332 cis' <- conv_cimportspec cis
333 MkC str <- coreStringLit $ static
334 ++ unpackFS ch ++ " "
335 ++ cis'
336 dec <- rep2 forImpDName [cc', s', str, name', typ']
337 return (loc, dec)
338 where
339 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
340 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
341 conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
342 conv_cimportspec CWrapper = return "wrapper"
343 static = case cis of
344 CFunction (StaticTarget _) -> "static "
345 _ -> ""
346 repForD decl = notHandled "Foreign declaration" (ppr decl)
347
348 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
349 repCCallConv CCallConv = rep2 cCallName []
350 repCCallConv StdCallConv = rep2 stdCallName []
351 repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
352
353 repSafety :: Safety -> DsM (Core TH.Safety)
354 repSafety PlayRisky = rep2 unsafeName []
355 repSafety (PlaySafe False) = rep2 safeName []
356 repSafety (PlaySafe True) = rep2 threadsafeName []
357
358 ds_msg :: SDoc
359 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
360
361 -------------------------------------------------------
362 -- Constructors
363 -------------------------------------------------------
364
365 repC :: LConDecl Name -> DsM (Core TH.ConQ)
366 repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
367 , con_details = details, con_res = ResTyH98 }))
368 = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
369 ; repConstr con1 details
370 }
371 repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
372 = addTyVarBinds tvs $ \bndrs ->
373 do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
374 ; ctxt' <- repContext ctxt
375 ; bndrs' <- coreList tyVarBndrTyConName bndrs
376 ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
377 }
378 repC (L loc con_decl) -- GADTs
379 = putSrcSpanDs loc $
380 notHandled "GADT declaration" (ppr con_decl)
381
382 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
383 repBangTy ty= do
384 MkC s <- rep2 str []
385 MkC t <- repLTy ty'
386 rep2 strictTypeName [s, t]
387 where
388 (str, ty') = case ty of
389 L _ (HsBangTy _ ty) -> (isStrictName, ty)
390 _ -> (notStrictName, ty)
391
392 -------------------------------------------------------
393 -- Deriving clause
394 -------------------------------------------------------
395
396 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
397 repDerivs Nothing = coreList nameTyConName []
398 repDerivs (Just ctxt)
399 = do { strs <- mapM rep_deriv ctxt ;
400 coreList nameTyConName strs }
401 where
402 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
403 -- Deriving clauses must have the simple H98 form
404 rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
405 rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other)
406
407
408 -------------------------------------------------------
409 -- Signatures in a class decl, or a group of bindings
410 -------------------------------------------------------
411
412 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
413 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
414 return $ de_loc $ sort_by_loc locs_cores
415
416 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
417 -- We silently ignore ones we don't recognise
418 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
419 return (concat sigs1) }
420
421 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
422 -- Singleton => Ok
423 -- Empty => Too hard, signature ignored
424 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
425 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
426 rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
427 rep_sig _ = return []
428
429 rep_proto :: Located Name -> LHsType Name -> SrcSpan
430 -> DsM [(SrcSpan, Core TH.DecQ)]
431 rep_proto nm ty loc
432 = do { nm1 <- lookupLOcc nm
433 ; ty1 <- repLTy ty
434 ; sig <- repProto nm1 ty1
435 ; return [(loc, sig)]
436 }
437
438 rep_inline :: Located Name -> InlineSpec -> SrcSpan
439 -> DsM [(SrcSpan, Core TH.DecQ)]
440 rep_inline nm ispec loc
441 = do { nm1 <- lookupLOcc nm
442 ; (_, ispec1) <- rep_InlineSpec ispec
443 ; pragma <- repPragInl nm1 ispec1
444 ; return [(loc, pragma)]
445 }
446
447 rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan
448 -> DsM [(SrcSpan, Core TH.DecQ)]
449 rep_specialise nm ty ispec loc
450 = do { nm1 <- lookupLOcc nm
451 ; ty1 <- repLTy ty
452 ; (hasSpec, ispec1) <- rep_InlineSpec ispec
453 ; pragma <- if hasSpec
454 then repPragSpecInl nm1 ty1 ispec1
455 else repPragSpec nm1 ty1
456 ; return [(loc, pragma)]
457 }
458
459 -- extract all the information needed to build a TH.InlineSpec
460 --
461 rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
462 rep_InlineSpec (Inline (InlinePragma activation match) inline)
463 | Nothing <- activation1
464 = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
465 | Just (flag, phase) <- activation1
466 = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase
467 | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
468 where
469 match1 = coreBool (rep_RuleMatchInfo match)
470 activation1 = rep_Activation activation
471 inline1 = coreBool inline
472
473 rep_RuleMatchInfo FunLike = False
474 rep_RuleMatchInfo ConLike = True
475
476 rep_Activation NeverActive = Nothing
477 rep_Activation AlwaysActive = Nothing
478 rep_Activation (ActiveBefore phase) = Just (coreBool False,
479 MkC $ mkIntExprInt phase)
480 rep_Activation (ActiveAfter phase) = Just (coreBool True,
481 MkC $ mkIntExprInt phase)
482
483
484 -------------------------------------------------------
485 -- Types
486 -------------------------------------------------------
487
488 -- We process type variable bindings in two ways, either by generating fresh
489 -- names or looking up existing names. The difference is crucial for type
490 -- families, depending on whether they are associated or not.
491 --
492 type ProcessTyVarBinds a =
493 [LHsTyVarBndr Name] -- the binders to be added
494 -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
495 -> DsM (Core (TH.Q a))
496
497 -- gensym a list of type variables and enter them into the meta environment;
498 -- the computations passed as the second argument is executed in that extended
499 -- meta environment and gets the *new* names on Core-level as an argument
500 --
501 addTyVarBinds :: ProcessTyVarBinds a
502 addTyVarBinds tvs m =
503 do
504 let names = hsLTyVarNames tvs
505 mkWithKinds = map repTyVarBndrWithKind tvs
506 freshNames <- mkGenSyms names
507 term <- addBinds freshNames $ do
508 bndrs <- mapM lookupBinder names
509 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
510 m kindedBndrs
511 wrapGenSyns freshNames term
512
513 -- Look up a list of type variables; the computations passed as the second
514 -- argument gets the *new* names on Core-level as an argument
515 --
516 lookupTyVarBinds :: ProcessTyVarBinds a
517 lookupTyVarBinds tvs m =
518 do
519 let names = hsLTyVarNames tvs
520 mkWithKinds = map repTyVarBndrWithKind tvs
521 bndrs <- mapM lookupBinder names
522 kindedBndrs <- zipWithM ($) mkWithKinds bndrs
523 m kindedBndrs
524
525 -- Produce kinded binder constructors from the Haskell tyvar binders
526 --
527 repTyVarBndrWithKind :: LHsTyVarBndr Name
528 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
529 repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV
530 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) =
531 \nm -> repKind ki >>= repKindedTV nm
532
533 -- represent a type context
534 --
535 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
536 repLContext (L _ ctxt) = repContext ctxt
537
538 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
539 repContext ctxt = do
540 preds <- mapM repLPred ctxt
541 predList <- coreList predQTyConName preds
542 repCtxt predList
543
544 -- represent a type predicate
545 --
546 repLPred :: LHsPred Name -> DsM (Core TH.PredQ)
547 repLPred (L _ p) = repPred p
548
549 repPred :: HsPred Name -> DsM (Core TH.PredQ)
550 repPred (HsClassP cls tys)
551 = do
552 cls1 <- lookupOcc cls
553 tys1 <- repLTys tys
554 tys2 <- coreList typeQTyConName tys1
555 repClassP cls1 tys2
556 repPred (HsEqualP tyleft tyright)
557 = do
558 tyleft1 <- repLTy tyleft
559 tyright1 <- repLTy tyright
560 repEqualP tyleft1 tyright1
561 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
562
563 repPredTy :: HsPred Name -> DsM (Core TH.TypeQ)
564 repPredTy (HsClassP cls tys)
565 = do
566 tcon <- repTy (HsTyVar cls)
567 tys1 <- repLTys tys
568 repTapps tcon tys1
569 repPredTy _ = panic "DsMeta.repPredTy: unexpected equality: internal error"
570
571 -- yield the representation of a list of types
572 --
573 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
574 repLTys tys = mapM repLTy tys
575
576 -- represent a type
577 --
578 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
579 repLTy (L _ ty) = repTy ty
580
581 repTy :: HsType Name -> DsM (Core TH.TypeQ)
582 repTy (HsForAllTy _ tvs ctxt ty) =
583 addTyVarBinds tvs $ \bndrs -> do
584 ctxt1 <- repLContext ctxt
585 ty1 <- repLTy ty
586 bndrs1 <- coreList tyVarBndrTyConName bndrs
587 repTForall bndrs1 ctxt1 ty1
588
589 repTy (HsTyVar n)
590 | isTvOcc (nameOccName n) = do
591 tv1 <- lookupTvOcc n
592 repTvar tv1
593 | otherwise = do
594 tc1 <- lookupOcc n
595 repNamedTyCon tc1
596 repTy (HsAppTy f a) = do
597 f1 <- repLTy f
598 a1 <- repLTy a
599 repTapp f1 a1
600 repTy (HsFunTy f a) = do
601 f1 <- repLTy f
602 a1 <- repLTy a
603 tcon <- repArrowTyCon
604 repTapps tcon [f1, a1]
605 repTy (HsListTy t) = do
606 t1 <- repLTy t
607 tcon <- repListTyCon
608 repTapp tcon t1
609 repTy (HsPArrTy t) = do
610 t1 <- repLTy t
611 tcon <- repTy (HsTyVar (tyConName parrTyCon))
612 repTapp tcon t1
613 repTy (HsTupleTy _ tys) = do
614 tys1 <- repLTys tys
615 tcon <- repTupleTyCon (length tys)
616 repTapps tcon tys1
617 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
618 `nlHsAppTy` ty2)
619 repTy (HsParTy t) = repLTy t
620 repTy (HsPredTy pred) = repPredTy pred
621 repTy (HsKindSig t k) = do
622 t1 <- repLTy t
623 k1 <- repKind k
624 repTSig t1 k1
625 repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
626 repTy ty = notHandled "Exotic form of type" (ppr ty)
627
628 -- represent a kind
629 --
630 repKind :: Kind -> DsM (Core TH.Kind)
631 repKind ki
632 = do { let (kis, ki') = splitKindFunTys ki
633 ; kis_rep <- mapM repKind kis
634 ; ki'_rep <- repNonArrowKind ki'
635 ; foldlM repArrowK ki'_rep kis_rep
636 }
637 where
638 repNonArrowKind k | isLiftedTypeKind k = repStarK
639 | otherwise = notHandled "Exotic form of kind"
640 (ppr k)
641
642 -----------------------------------------------------------------------------
643 -- Expressions
644 -----------------------------------------------------------------------------
645
646 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
647 repLEs es = do { es' <- mapM repLE es ;
648 coreList expQTyConName es' }
649
650 -- FIXME: some of these panics should be converted into proper error messages
651 -- unless we can make sure that constructs, which are plainly not
652 -- supported in TH already lead to error messages at an earlier stage
653 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
654 repLE (L loc e) = putSrcSpanDs loc (repE e)
655
656 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
657 repE (HsVar x) =
658 do { mb_val <- dsLookupMetaEnv x
659 ; case mb_val of
660 Nothing -> do { str <- globalVar x
661 ; repVarOrCon x str }
662 Just (Bound y) -> repVarOrCon x (coreVar y)
663 Just (Splice e) -> do { e' <- dsExpr e
664 ; return (MkC e') } }
665 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
666
667 -- Remember, we're desugaring renamer output here, so
668 -- HsOverlit can definitely occur
669 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
670 repE (HsLit l) = do { a <- repLiteral l; repLit a }
671 repE (HsLam (MatchGroup [m] _)) = repLambda m
672 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
673
674 repE (OpApp e1 op _ e2) =
675 do { arg1 <- repLE e1;
676 arg2 <- repLE e2;
677 the_op <- repLE op ;
678 repInfixApp arg1 the_op arg2 }
679 repE (NegApp x _) = do
680 a <- repLE x
681 negateVar <- lookupOcc negateName >>= repVar
682 negateVar `repApp` a
683 repE (HsPar x) = repLE x
684 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
685 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
686 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
687 ; ms2 <- mapM repMatchTup ms
688 ; repCaseE arg (nonEmptyCoreList ms2) }
689 repE (HsIf x y z) = do
690 a <- repLE x
691 b <- repLE y
692 c <- repLE z
693 repCond a b c
694 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
695 ; e2 <- addBinds ss (repLE e)
696 ; z <- repLetE ds e2
697 ; wrapGenSyns ss z }
698 -- FIXME: I haven't got the types here right yet
699 repE (HsDo DoExpr sts body _)
700 = do { (ss,zs) <- repLSts sts;
701 body' <- addBinds ss $ repLE body;
702 ret <- repNoBindSt body';
703 e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
704 wrapGenSyns ss e }
705 repE (HsDo ListComp sts body _)
706 = do { (ss,zs) <- repLSts sts;
707 body' <- addBinds ss $ repLE body;
708 ret <- repNoBindSt body';
709 e <- repComp (nonEmptyCoreList (zs ++ [ret]));
710 wrapGenSyns ss e }
711 repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e)
712 repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
713 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
714 repE e@(ExplicitTuple es boxed)
715 | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e)
716 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
717 | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs }
718
719 repE (RecordCon c _ flds)
720 = do { x <- lookupLOcc c;
721 fs <- repFields flds;
722 repRecCon x fs }
723 repE (RecordUpd e flds _ _ _)
724 = do { x <- repLE e;
725 fs <- repFields flds;
726 repRecUpd x fs }
727
728 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
729 repE (ArithSeq _ aseq) =
730 case aseq of
731 From e -> do { ds1 <- repLE e; repFrom ds1 }
732 FromThen e1 e2 -> do
733 ds1 <- repLE e1
734 ds2 <- repLE e2
735 repFromThen ds1 ds2
736 FromTo e1 e2 -> do
737 ds1 <- repLE e1
738 ds2 <- repLE e2
739 repFromTo ds1 ds2
740 FromThenTo e1 e2 e3 -> do
741 ds1 <- repLE e1
742 ds2 <- repLE e2
743 ds3 <- repLE e3
744 repFromThenTo ds1 ds2 ds3
745 repE (HsSpliceE (HsSplice n _))
746 = do { mb_val <- dsLookupMetaEnv n
747 ; case mb_val of
748 Just (Splice e) -> do { e' <- dsExpr e
749 ; return (MkC e') }
750 _ -> pprPanic "HsSplice" (ppr n) }
751 -- Should not happen; statically checked
752
753 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
754 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
755 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
756 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
757 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
758 repE e = notHandled "Expression form" (ppr e)
759
760 -----------------------------------------------------------------------------
761 -- Building representations of auxillary structures like Match, Clause, Stmt,
762
763 repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ)
764 repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) =
765 do { ss1 <- mkGenSyms (collectPatBinders p)
766 ; addBinds ss1 $ do {
767 ; p1 <- repLP p
768 ; (ss2,ds) <- repBinds wheres
769 ; addBinds ss2 $ do {
770 ; gs <- repGuards guards
771 ; match <- repMatch p1 gs ds
772 ; wrapGenSyns (ss1++ss2) match }}}
773 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
774
775 repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ)
776 repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) =
777 do { ss1 <- mkGenSyms (collectPatsBinders ps)
778 ; addBinds ss1 $ do {
779 ps1 <- repLPs ps
780 ; (ss2,ds) <- repBinds wheres
781 ; addBinds ss2 $ do {
782 gs <- repGuards guards
783 ; clause <- repClause ps1 gs ds
784 ; wrapGenSyns (ss1++ss2) clause }}}
785
786 repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ)
787 repGuards [L _ (GRHS [] e)]
788 = do {a <- repLE e; repNormal a }
789 repGuards other
790 = do { zs <- mapM process other;
791 let {(xs, ys) = unzip zs};
792 gd <- repGuarded (nonEmptyCoreList ys);
793 wrapGenSyns (concat xs) gd }
794 where
795 process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
796 process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
797 = do { x <- repLNormalGE e1 e2;
798 return ([], x) }
799 process (L _ (GRHS ss rhs))
800 = do (gs, ss') <- repLSts ss
801 rhs' <- addBinds gs $ repLE rhs
802 g <- repPatGE (nonEmptyCoreList ss') rhs'
803 return (gs, g)
804
805 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
806 repFields (HsRecFields { rec_flds = flds })
807 = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
808 ; es <- mapM repLE (map hsRecFieldArg flds)
809 ; fs <- zipWithM repFieldExp fnames es
810 ; coreList fieldExpQTyConName fs }
811
812
813 -----------------------------------------------------------------------------
814 -- Representing Stmt's is tricky, especially if bound variables
815 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
816 -- First gensym new names for every variable in any of the patterns.
817 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
818 -- if variables didn't shaddow, the static gensym wouldn't be necessary
819 -- and we could reuse the original names (x and x).
820 --
821 -- do { x'1 <- gensym "x"
822 -- ; x'2 <- gensym "x"
823 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
824 -- , BindSt (pvar x'2) [| f x |]
825 -- , NoBindSt [| g x |]
826 -- ]
827 -- }
828
829 -- The strategy is to translate a whole list of do-bindings by building a
830 -- bigger environment, and a bigger set of meta bindings
831 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
832 -- of the expressions within the Do
833
834 -----------------------------------------------------------------------------
835 -- The helper function repSts computes the translation of each sub expression
836 -- and a bunch of prefix bindings denoting the dynamic renaming.
837
838 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
839 repLSts stmts = repSts (map unLoc stmts)
840
841 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
842 repSts (BindStmt p e _ _ : ss) =
843 do { e2 <- repLE e
844 ; ss1 <- mkGenSyms (collectPatBinders p)
845 ; addBinds ss1 $ do {
846 ; p1 <- repLP p;
847 ; (ss2,zs) <- repSts ss
848 ; z <- repBindSt p1 e2
849 ; return (ss1++ss2, z : zs) }}
850 repSts (LetStmt bs : ss) =
851 do { (ss1,ds) <- repBinds bs
852 ; z <- repLetSt ds
853 ; (ss2,zs) <- addBinds ss1 (repSts ss)
854 ; return (ss1++ss2, z : zs) }
855 repSts (ExprStmt e _ _ : ss) =
856 do { e2 <- repLE e
857 ; z <- repNoBindSt e2
858 ; (ss2,zs) <- repSts ss
859 ; return (ss2, z : zs) }
860 repSts [] = return ([],[])
861 repSts other = notHandled "Exotic statement" (ppr other)
862
863
864 -----------------------------------------------------------
865 -- Bindings
866 -----------------------------------------------------------
867
868 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
869 repBinds EmptyLocalBinds
870 = do { core_list <- coreList decQTyConName []
871 ; return ([], core_list) }
872
873 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
874
875 repBinds (HsValBinds decs)
876 = do { let { bndrs = map unLoc (collectHsValBinders decs) }
877 -- No need to worrry about detailed scopes within
878 -- the binding group, because we are talking Names
879 -- here, so we can safely treat it as a mutually
880 -- recursive group
881 ; ss <- mkGenSyms bndrs
882 ; prs <- addBinds ss (rep_val_binds decs)
883 ; core_list <- coreList decQTyConName
884 (de_loc (sort_by_loc prs))
885 ; return (ss, core_list) }
886
887 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
888 -- Assumes: all the binders of the binding are alrady in the meta-env
889 rep_val_binds (ValBindsOut binds sigs)
890 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
891 ; core2 <- rep_sigs' sigs
892 ; return (core1 ++ core2) }
893 rep_val_binds (ValBindsIn _ _)
894 = panic "rep_val_binds: ValBindsIn"
895
896 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
897 rep_binds binds = do { binds_w_locs <- rep_binds' binds
898 ; return (de_loc (sort_by_loc binds_w_locs)) }
899
900 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
901 rep_binds' binds = mapM rep_bind (bagToList binds)
902
903 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
904 -- Assumes: all the binders of the binding are alrady in the meta-env
905
906 -- Note GHC treats declarations of a variable (not a pattern)
907 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
908 -- with an empty list of patterns
909 rep_bind (L loc (FunBind { fun_id = fn,
910 fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
911 = do { (ss,wherecore) <- repBinds wheres
912 ; guardcore <- addBinds ss (repGuards guards)
913 ; fn' <- lookupLBinder fn
914 ; p <- repPvar fn'
915 ; ans <- repVal p guardcore wherecore
916 ; ans' <- wrapGenSyns ss ans
917 ; return (loc, ans') }
918
919 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
920 = do { ms1 <- mapM repClauseTup ms
921 ; fn' <- lookupLBinder fn
922 ; ans <- repFun fn' (nonEmptyCoreList ms1)
923 ; return (loc, ans) }
924
925 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
926 = do { patcore <- repLP pat
927 ; (ss,wherecore) <- repBinds wheres
928 ; guardcore <- addBinds ss (repGuards guards)
929 ; ans <- repVal patcore guardcore wherecore
930 ; ans' <- wrapGenSyns ss ans
931 ; return (loc, ans') }
932
933 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
934 = do { v' <- lookupBinder v
935 ; e2 <- repLE e
936 ; x <- repNormal e2
937 ; patcore <- repPvar v'
938 ; empty_decls <- coreList decQTyConName []
939 ; ans <- repVal patcore x empty_decls
940 ; return (srcLocSpan (getSrcLoc v), ans) }
941
942 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
943
944 -----------------------------------------------------------------------------
945 -- Since everything in a Bind is mutually recursive we need rename all
946 -- all the variables simultaneously. For example:
947 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
948 -- do { f'1 <- gensym "f"
949 -- ; g'2 <- gensym "g"
950 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
951 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
952 -- ]}
953 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
954 -- environment ( f |-> f'1 ) from each binding, and then unioning them
955 -- together. As we do this we collect GenSymBinds's which represent the renamed
956 -- variables bound by the Bindings. In order not to lose track of these
957 -- representations we build a shadow datatype MB with the same structure as
958 -- MonoBinds, but which has slots for the representations
959
960
961 -----------------------------------------------------------------------------
962 -- GHC allows a more general form of lambda abstraction than specified
963 -- by Haskell 98. In particular it allows guarded lambda's like :
964 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
965 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
966 -- (\ p1 .. pn -> exp) by causing an error.
967
968 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
969 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
970 = do { let bndrs = collectPatsBinders ps ;
971 ; ss <- mkGenSyms bndrs
972 ; lam <- addBinds ss (
973 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
974 ; wrapGenSyns ss lam }
975
976 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
977
978
979 -----------------------------------------------------------------------------
980 -- Patterns
981 -- repP deals with patterns. It assumes that we have already
982 -- walked over the pattern(s) once to collect the binders, and
983 -- have extended the environment. So every pattern-bound
984 -- variable should already appear in the environment.
985
986 -- Process a list of patterns
987 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
988 repLPs ps = do { ps' <- mapM repLP ps ;
989 coreList patQTyConName ps' }
990
991 repLP :: LPat Name -> DsM (Core TH.PatQ)
992 repLP (L _ p) = repP p
993
994 repP :: Pat Name -> DsM (Core TH.PatQ)
995 repP (WildPat _) = repPwild
996 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
997 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
998 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
999 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1000 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1001 repP (ParPat p) = repLP p
1002 repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
1003 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
1004 repP (ConPatIn dc details)
1005 = do { con_str <- lookupLOcc dc
1006 ; case details of
1007 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1008 RecCon rec -> do { let flds = rec_flds rec
1009 ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds)
1010 ; ps <- sequence $ map repLP (map hsRecFieldArg flds)
1011 ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
1012 ; fps' <- coreList fieldPatQTyConName fps
1013 ; repPrec con_str fps' }
1014 InfixCon p1 p2 -> do { p1' <- repLP p1;
1015 p2' <- repLP p2;
1016 repPinfix p1' con_str p2' }
1017 }
1018 repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1019 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1020 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1021 -- The problem is to do with scoped type variables.
1022 -- To implement them, we have to implement the scoping rules
1023 -- here in DsMeta, and I don't want to do that today!
1024 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1025 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1026 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1027
1028 repP other = notHandled "Exotic pattern" (ppr other)
1029
1030 ----------------------------------------------------------
1031 -- Declaration ordering helpers
1032
1033 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1034 sort_by_loc xs = sortBy comp xs
1035 where comp x y = compare (fst x) (fst y)
1036
1037 de_loc :: [(a, b)] -> [b]
1038 de_loc = map snd
1039
1040 ----------------------------------------------------------
1041 -- The meta-environment
1042
1043 -- A name/identifier association for fresh names of locally bound entities
1044 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1045 -- I.e. (x, x_id) means
1046 -- let x_id = gensym "x" in ...
1047
1048 -- Generate a fresh name for a locally bound entity
1049
1050 mkGenSyms :: [Name] -> DsM [GenSymBind]
1051 -- We can use the existing name. For example:
1052 -- [| \x_77 -> x_77 + x_77 |]
1053 -- desugars to
1054 -- do { x_77 <- genSym "x"; .... }
1055 -- We use the same x_77 in the desugared program, but with the type Bndr
1056 -- instead of Int
1057 --
1058 -- We do make it an Internal name, though (hence localiseName)
1059 --
1060 -- Nevertheless, it's monadic because we have to generate nameTy
1061 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1062 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1063
1064
1065 addBinds :: [GenSymBind] -> DsM a -> DsM a
1066 -- Add a list of fresh names for locally bound entities to the
1067 -- meta environment (which is part of the state carried around
1068 -- by the desugarer monad)
1069 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
1070
1071 -- Look up a locally bound name
1072 --
1073 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1074 lookupLBinder (L _ n) = lookupBinder n
1075
1076 lookupBinder :: Name -> DsM (Core TH.Name)
1077 lookupBinder n
1078 = do { mb_val <- dsLookupMetaEnv n;
1079 case mb_val of
1080 Just (Bound x) -> return (coreVar x)
1081 _ -> failWithDs msg }
1082 where
1083 msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
1084
1085 -- Look up a name that is either locally bound or a global name
1086 --
1087 -- * If it is a global name, generate the "original name" representation (ie,
1088 -- the <module>:<name> form) for the associated entity
1089 --
1090 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1091 -- Lookup an occurrence; it can't be a splice.
1092 -- Use the in-scope bindings if they exist
1093 lookupLOcc (L _ n) = lookupOcc n
1094
1095 lookupOcc :: Name -> DsM (Core TH.Name)
1096 lookupOcc n
1097 = do { mb_val <- dsLookupMetaEnv n ;
1098 case mb_val of
1099 Nothing -> globalVar n
1100 Just (Bound x) -> return (coreVar x)
1101 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
1102 }
1103
1104 lookupTvOcc :: Name -> DsM (Core TH.Name)
1105 -- Type variables can't be staged and are not lexically scoped in TH
1106 lookupTvOcc n
1107 = do { mb_val <- dsLookupMetaEnv n ;
1108 case mb_val of
1109 Just (Bound x) -> return (coreVar x)
1110 _ -> failWithDs msg
1111 }
1112 where
1113 msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n)
1114 , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ]
1115
1116 globalVar :: Name -> DsM (Core TH.Name)
1117 -- Not bound by the meta-env
1118 -- Could be top-level; or could be local
1119 -- f x = $(g [| x |])
1120 -- Here the x will be local
1121 globalVar name
1122 | isExternalName name
1123 = do { MkC mod <- coreStringLit name_mod
1124 ; MkC pkg <- coreStringLit name_pkg
1125 ; MkC occ <- occNameLit name
1126 ; rep2 mk_varg [pkg,mod,occ] }
1127 | otherwise
1128 = do { MkC occ <- occNameLit name
1129 ; MkC uni <- coreIntLit (getKey (getUnique name))
1130 ; rep2 mkNameLName [occ,uni] }
1131 where
1132 mod = ASSERT( isExternalName name) nameModule name
1133 name_mod = moduleNameString (moduleName mod)
1134 name_pkg = packageIdString (modulePackageId mod)
1135 name_occ = nameOccName name
1136 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1137 | OccName.isVarOcc name_occ = mkNameG_vName
1138 | OccName.isTcOcc name_occ = mkNameG_tcName
1139 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1140
1141 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1142 -> DsM Type -- The type
1143 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1144 return (mkTyConApp tc []) }
1145
1146 wrapGenSyns :: [GenSymBind]
1147 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1148 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
1149 -- --> bindQ (gensym nm1) (\ id1 ->
1150 -- bindQ (gensym nm2 (\ id2 ->
1151 -- y))
1152
1153 wrapGenSyns binds body@(MkC b)
1154 = do { var_ty <- lookupType nameTyConName
1155 ; go var_ty binds }
1156 where
1157 [elt_ty] = tcTyConAppArgs (exprType b)
1158 -- b :: Q a, so we can get the type 'a' by looking at the
1159 -- argument type. NB: this relies on Q being a data/newtype,
1160 -- not a type synonym
1161
1162 go _ [] = return body
1163 go var_ty ((name,id) : binds)
1164 = do { MkC body' <- go var_ty binds
1165 ; lit_str <- occNameLit name
1166 ; gensym_app <- repGensym lit_str
1167 ; repBindQ var_ty elt_ty
1168 gensym_app (MkC (Lam id body')) }
1169
1170 -- Just like wrapGenSym, but don't actually do the gensym
1171 -- Instead use the existing name:
1172 -- let x = "x" in ...
1173 -- Only used for [Decl], and for the class ops in class
1174 -- and instance decls
1175 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
1176 wrapNongenSyms binds (MkC body)
1177 = do { binds' <- mapM do_one binds ;
1178 return (MkC (mkLets binds' body)) }
1179 where
1180 do_one (name,id)
1181 = do { MkC lit_str <- occNameLit name
1182 ; MkC var <- rep2 mkNameName [lit_str]
1183 ; return (NonRec id var) }
1184
1185 occNameLit :: Name -> DsM (Core String)
1186 occNameLit n = coreStringLit (occNameString (nameOccName n))
1187
1188
1189 -- %*********************************************************************
1190 -- %* *
1191 -- Constructing code
1192 -- %* *
1193 -- %*********************************************************************
1194
1195 -----------------------------------------------------------------------------
1196 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1197 -- we invent a new datatype which uses phantom types.
1198
1199 newtype Core a = MkC CoreExpr
1200 unC :: Core a -> CoreExpr
1201 unC (MkC x) = x
1202
1203 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1204 rep2 n xs = do { id <- dsLookupGlobalId n
1205 ; return (MkC (foldl App (Var id) xs)) }
1206
1207 -- Then we make "repConstructors" which use the phantom types for each of the
1208 -- smart constructors of the Meta.Meta datatypes.
1209
1210
1211 -- %*********************************************************************
1212 -- %* *
1213 -- The 'smart constructors'
1214 -- %* *
1215 -- %*********************************************************************
1216
1217 --------------- Patterns -----------------
1218 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1219 repPlit (MkC l) = rep2 litPName [l]
1220
1221 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1222 repPvar (MkC s) = rep2 varPName [s]
1223
1224 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1225 repPtup (MkC ps) = rep2 tupPName [ps]
1226
1227 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1228 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1229
1230 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1231 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1232
1233 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1234 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1235
1236 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1237 repPtilde (MkC p) = rep2 tildePName [p]
1238
1239 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1240 repPbang (MkC p) = rep2 bangPName [p]
1241
1242 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1243 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1244
1245 repPwild :: DsM (Core TH.PatQ)
1246 repPwild = rep2 wildPName []
1247
1248 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1249 repPlist (MkC ps) = rep2 listPName [ps]
1250
1251 --------------- Expressions -----------------
1252 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1253 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1254 | otherwise = repVar str
1255
1256 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1257 repVar (MkC s) = rep2 varEName [s]
1258
1259 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1260 repCon (MkC s) = rep2 conEName [s]
1261
1262 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1263 repLit (MkC c) = rep2 litEName [c]
1264
1265 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1266 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1267
1268 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1269 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1270
1271 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1272 repTup (MkC es) = rep2 tupEName [es]
1273
1274 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1275 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1276
1277 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1278 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1279
1280 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1281 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1282
1283 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1284 repDoE (MkC ss) = rep2 doEName [ss]
1285
1286 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1287 repComp (MkC ss) = rep2 compEName [ss]
1288
1289 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1290 repListExp (MkC es) = rep2 listEName [es]
1291
1292 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1293 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1294
1295 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1296 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1297
1298 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1299 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1300
1301 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1302 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1303
1304 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1305 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1306
1307 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1308 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1309
1310 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1311 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1312
1313 ------------ Right hand sides (guarded expressions) ----
1314 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1315 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1316
1317 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1318 repNormal (MkC e) = rep2 normalBName [e]
1319
1320 ------------ Guards ----
1321 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1322 repLNormalGE g e = do g' <- repLE g
1323 e' <- repLE e
1324 repNormalGE g' e'
1325
1326 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1327 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1328
1329 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1330 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1331
1332 ------------- Stmts -------------------
1333 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1334 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1335
1336 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1337 repLetSt (MkC ds) = rep2 letSName [ds]
1338
1339 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1340 repNoBindSt (MkC e) = rep2 noBindSName [e]
1341
1342 -------------- Range (Arithmetic sequences) -----------
1343 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1344 repFrom (MkC x) = rep2 fromEName [x]
1345
1346 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1347 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1348
1349 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1350 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1351
1352 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1353 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1354
1355 ------------ Match and Clause Tuples -----------
1356 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1357 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1358
1359 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1360 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1361
1362 -------------- Dec -----------------------------
1363 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1364 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1365
1366 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1367 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1368
1369 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1370 -> Maybe (Core [TH.TypeQ])
1371 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1372 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1373 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1374 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1375 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1376
1377 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1378 -> Maybe (Core [TH.TypeQ])
1379 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1380 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1381 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1382 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1383 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1384
1385 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1386 -> Maybe (Core [TH.TypeQ])
1387 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1388 repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs)
1389 = rep2 tySynDName [nm, tvs, rhs]
1390 repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs)
1391 = rep2 tySynInstDName [nm, tys, rhs]
1392
1393 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1394 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1395
1396 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1397 -> Core [TH.FunDep] -> Core [TH.DecQ]
1398 -> DsM (Core TH.DecQ)
1399 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1400 = rep2 classDName [cxt, cls, tvs, fds, ds]
1401
1402 repPragInl :: Core TH.Name -> Core TH.InlineSpecQ -> DsM (Core TH.DecQ)
1403 repPragInl (MkC nm) (MkC ispec) = rep2 pragInlDName [nm, ispec]
1404
1405 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1406 repPragSpec (MkC nm) (MkC ty) = rep2 pragSpecDName [nm, ty]
1407
1408 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ
1409 -> DsM (Core TH.DecQ)
1410 repPragSpecInl (MkC nm) (MkC ty) (MkC ispec)
1411 = rep2 pragSpecInlDName [nm, ty, ispec]
1412
1413 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1414 -> DsM (Core TH.DecQ)
1415 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1416 = rep2 familyNoKindDName [flav, nm, tvs]
1417
1418 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1419 -> Core TH.Kind
1420 -> DsM (Core TH.DecQ)
1421 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1422 = rep2 familyKindDName [flav, nm, tvs, ki]
1423
1424 repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ)
1425 repInlineSpecNoPhase (MkC inline) (MkC conlike)
1426 = rep2 inlineSpecNoPhaseName [inline, conlike]
1427
1428 repInlineSpecPhase :: Core Bool -> Core Bool -> Core Bool -> Core Int
1429 -> DsM (Core TH.InlineSpecQ)
1430 repInlineSpecPhase (MkC inline) (MkC conlike) (MkC beforeFrom) (MkC phase)
1431 = rep2 inlineSpecPhaseName [inline, conlike, beforeFrom, phase]
1432
1433 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1434 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1435
1436 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1437 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1438
1439 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1440 repCtxt (MkC tys) = rep2 cxtName [tys]
1441
1442 repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ)
1443 repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys]
1444
1445 repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ)
1446 repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2]
1447
1448 repConstr :: Core TH.Name -> HsConDeclDetails Name
1449 -> DsM (Core TH.ConQ)
1450 repConstr con (PrefixCon ps)
1451 = do arg_tys <- mapM repBangTy ps
1452 arg_tys1 <- coreList strictTypeQTyConName arg_tys
1453 rep2 normalCName [unC con, unC arg_tys1]
1454 repConstr con (RecCon ips)
1455 = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips)
1456 arg_tys <- mapM repBangTy (map cd_fld_type ips)
1457 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1458 arg_vs arg_tys
1459 arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1460 rep2 recCName [unC con, unC arg_vtys']
1461 repConstr con (InfixCon st1 st2)
1462 = do arg1 <- repBangTy st1
1463 arg2 <- repBangTy st2
1464 rep2 infixCName [unC arg1, unC con, unC arg2]
1465
1466 ------------ Types -------------------
1467
1468 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1469 -> DsM (Core TH.TypeQ)
1470 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1471 = rep2 forallTName [tvars, ctxt, ty]
1472
1473 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1474 repTvar (MkC s) = rep2 varTName [s]
1475
1476 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1477 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1478
1479 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1480 repTapps f [] = return f
1481 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1482
1483 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1484 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1485
1486 --------- Type constructors --------------
1487
1488 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1489 repNamedTyCon (MkC s) = rep2 conTName [s]
1490
1491 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1492 -- Note: not Core Int; it's easier to be direct here
1493 repTupleTyCon i = rep2 tupleTName [mkIntExprInt i]
1494
1495 repArrowTyCon :: DsM (Core TH.TypeQ)
1496 repArrowTyCon = rep2 arrowTName []
1497
1498 repListTyCon :: DsM (Core TH.TypeQ)
1499 repListTyCon = rep2 listTName []
1500
1501 ------------ Kinds -------------------
1502
1503 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1504 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1505
1506 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1507 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1508
1509 repStarK :: DsM (Core TH.Kind)
1510 repStarK = rep2 starKName []
1511
1512 repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1513 repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2]
1514
1515 ----------------------------------------------------------
1516 -- Literals
1517
1518 repLiteral :: HsLit -> DsM (Core TH.Lit)
1519 repLiteral lit
1520 = do lit' <- case lit of
1521 HsIntPrim i -> mk_integer i
1522 HsWordPrim w -> mk_integer w
1523 HsInt i -> mk_integer i
1524 HsFloatPrim r -> mk_rational r
1525 HsDoublePrim r -> mk_rational r
1526 _ -> return lit
1527 lit_expr <- dsLit lit'
1528 case mb_lit_name of
1529 Just lit_name -> rep2 lit_name [lit_expr]
1530 Nothing -> notHandled "Exotic literal" (ppr lit)
1531 where
1532 mb_lit_name = case lit of
1533 HsInteger _ _ -> Just integerLName
1534 HsInt _ -> Just integerLName
1535 HsIntPrim _ -> Just intPrimLName
1536 HsWordPrim _ -> Just wordPrimLName
1537 HsFloatPrim _ -> Just floatPrimLName
1538 HsDoublePrim _ -> Just doublePrimLName
1539 HsChar _ -> Just charLName
1540 HsString _ -> Just stringLName
1541 HsRat _ _ -> Just rationalLName
1542 _ -> Nothing
1543
1544 mk_integer :: Integer -> DsM HsLit
1545 mk_integer i = do integer_ty <- lookupType integerTyConName
1546 return $ HsInteger i integer_ty
1547 mk_rational :: Rational -> DsM HsLit
1548 mk_rational r = do rat_ty <- lookupType rationalTyConName
1549 return $ HsRat r rat_ty
1550 mk_string :: FastString -> DsM HsLit
1551 mk_string s = return $ HsString s
1552
1553 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1554 repOverloadedLiteral (OverLit { ol_val = val})
1555 = do { lit <- mk_lit val; repLiteral lit }
1556 -- The type Rational will be in the environment, becuase
1557 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1558 -- and rationalL is sucked in when any TH stuff is used
1559
1560 mk_lit :: OverLitVal -> DsM HsLit
1561 mk_lit (HsIntegral i) = mk_integer i
1562 mk_lit (HsFractional f) = mk_rational f
1563 mk_lit (HsIsString s) = mk_string s
1564
1565 --------------- Miscellaneous -------------------
1566
1567 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1568 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1569
1570 repBindQ :: Type -> Type -- a and b
1571 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1572 repBindQ ty_a ty_b (MkC x) (MkC y)
1573 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1574
1575 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1576 repSequenceQ ty_a (MkC list)
1577 = rep2 sequenceQName [Type ty_a, list]
1578
1579 ------------ Lists and Tuples -------------------
1580 -- turn a list of patterns into a single pattern matching a list
1581
1582 coreList :: Name -- Of the TyCon of the element type
1583 -> [Core a] -> DsM (Core [a])
1584 coreList tc_name es
1585 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1586
1587 coreList' :: Type -- The element type
1588 -> [Core a] -> Core [a]
1589 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1590
1591 nonEmptyCoreList :: [Core a] -> Core [a]
1592 -- The list must be non-empty so we can get the element type
1593 -- Otherwise use coreList
1594 nonEmptyCoreList [] = panic "coreList: empty argument"
1595 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1596
1597 coreStringLit :: String -> DsM (Core String)
1598 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1599
1600 ------------ Bool, Literals & Variables -------------------
1601
1602 coreBool :: Bool -> Core Bool
1603 coreBool False = MkC $ mkConApp falseDataCon []
1604 coreBool True = MkC $ mkConApp trueDataCon []
1605
1606 coreIntLit :: Int -> DsM (Core Int)
1607 coreIntLit i = return (MkC (mkIntExprInt i))
1608
1609 coreVar :: Id -> Core TH.Name -- The Id has type Name
1610 coreVar id = MkC (Var id)
1611
1612 ----------------- Failure -----------------------
1613 notHandled :: String -> SDoc -> DsM a
1614 notHandled what doc = failWithDs msg
1615 where
1616 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
1617 2 doc
1618
1619
1620 -- %************************************************************************
1621 -- %* *
1622 -- The known-key names for Template Haskell
1623 -- %* *
1624 -- %************************************************************************
1625
1626 -- To add a name, do three things
1627 --
1628 -- 1) Allocate a key
1629 -- 2) Make a "Name"
1630 -- 3) Add the name to knownKeyNames
1631
1632 templateHaskellNames :: [Name]
1633 -- The names that are implicitly mentioned by ``bracket''
1634 -- Should stay in sync with the import list of DsMeta
1635
1636 templateHaskellNames = [
1637 returnQName, bindQName, sequenceQName, newNameName, liftName,
1638 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1639
1640 -- Lit
1641 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1642 floatPrimLName, doublePrimLName, rationalLName,
1643 -- Pat
1644 litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName,
1645 asPName, wildPName, recPName, listPName, sigPName,
1646 -- FieldPat
1647 fieldPatName,
1648 -- Match
1649 matchName,
1650 -- Clause
1651 clauseName,
1652 -- Exp
1653 varEName, conEName, litEName, appEName, infixEName,
1654 infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1655 condEName, letEName, caseEName, doEName, compEName,
1656 fromEName, fromThenEName, fromToEName, fromThenToEName,
1657 listEName, sigEName, recConEName, recUpdEName,
1658 -- FieldExp
1659 fieldExpName,
1660 -- Body
1661 guardedBName, normalBName,
1662 -- Guard
1663 normalGEName, patGEName,
1664 -- Stmt
1665 bindSName, letSName, noBindSName, parSName,
1666 -- Dec
1667 funDName, valDName, dataDName, newtypeDName, tySynDName,
1668 classDName, instanceDName, sigDName, forImpDName,
1669 pragInlDName, pragSpecDName, pragSpecInlDName,
1670 familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
1671 tySynInstDName,
1672 -- Cxt
1673 cxtName,
1674 -- Pred
1675 classPName, equalPName,
1676 -- Strict
1677 isStrictName, notStrictName,
1678 -- Con
1679 normalCName, recCName, infixCName, forallCName,
1680 -- StrictType
1681 strictTypeName,
1682 -- VarStrictType
1683 varStrictTypeName,
1684 -- Type
1685 forallTName, varTName, conTName, appTName,
1686 tupleTName, arrowTName, listTName, sigTName,
1687 -- TyVarBndr
1688 plainTVName, kindedTVName,
1689 -- Kind
1690 starKName, arrowKName,
1691 -- Callconv
1692 cCallName, stdCallName,
1693 -- Safety
1694 unsafeName,
1695 safeName,
1696 threadsafeName,
1697 -- InlineSpec
1698 inlineSpecNoPhaseName, inlineSpecPhaseName,
1699 -- FunDep
1700 funDepName,
1701 -- FamFlavour
1702 typeFamName, dataFamName,
1703
1704 -- And the tycons
1705 qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1706 clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
1707 stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
1708 varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1709 typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
1710 patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
1711 predQTyConName,
1712
1713 -- Quasiquoting
1714 quoteExpName, quotePatName]
1715
1716 thSyn, thLib, qqLib :: Module
1717 thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
1718 thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
1719 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
1720
1721 mkTHModule :: FastString -> Module
1722 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
1723
1724 libFun, libTc, thFun, thTc, qqFun :: FastString -> Unique -> Name
1725 libFun = mk_known_key_name OccName.varName thLib
1726 libTc = mk_known_key_name OccName.tcName thLib
1727 thFun = mk_known_key_name OccName.varName thSyn
1728 thTc = mk_known_key_name OccName.tcName thSyn
1729 qqFun = mk_known_key_name OccName.varName qqLib
1730
1731 -------------------- TH.Syntax -----------------------
1732 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
1733 fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
1734 tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,
1735 predTyConName :: Name
1736 qTyConName = thTc (fsLit "Q") qTyConKey
1737 nameTyConName = thTc (fsLit "Name") nameTyConKey
1738 fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
1739 patTyConName = thTc (fsLit "Pat") patTyConKey
1740 fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
1741 expTyConName = thTc (fsLit "Exp") expTyConKey
1742 decTyConName = thTc (fsLit "Dec") decTyConKey
1743 typeTyConName = thTc (fsLit "Type") typeTyConKey
1744 tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey
1745 matchTyConName = thTc (fsLit "Match") matchTyConKey
1746 clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
1747 funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
1748 predTyConName = thTc (fsLit "Pred") predTyConKey
1749
1750 returnQName, bindQName, sequenceQName, newNameName, liftName,
1751 mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
1752 mkNameLName, liftStringName :: Name
1753 returnQName = thFun (fsLit "returnQ") returnQIdKey
1754 bindQName = thFun (fsLit "bindQ") bindQIdKey
1755 sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
1756 newNameName = thFun (fsLit "newName") newNameIdKey
1757 liftName = thFun (fsLit "lift") liftIdKey
1758 liftStringName = thFun (fsLit "liftString") liftStringIdKey
1759 mkNameName = thFun (fsLit "mkName") mkNameIdKey
1760 mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey
1761 mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
1762 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
1763 mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
1764
1765
1766 -------------------- TH.Lib -----------------------
1767 -- data Lit = ...
1768 charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
1769 floatPrimLName, doublePrimLName, rationalLName :: Name
1770 charLName = libFun (fsLit "charL") charLIdKey
1771 stringLName = libFun (fsLit "stringL") stringLIdKey
1772 integerLName = libFun (fsLit "integerL") integerLIdKey
1773 intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey
1774 wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey
1775 floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey
1776 doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
1777 rationalLName = libFun (fsLit "rationalL") rationalLIdKey
1778
1779 -- data Pat = ...
1780 litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName,
1781 asPName, wildPName, recPName, listPName, sigPName :: Name
1782 litPName = libFun (fsLit "litP") litPIdKey
1783 varPName = libFun (fsLit "varP") varPIdKey
1784 tupPName = libFun (fsLit "tupP") tupPIdKey
1785 conPName = libFun (fsLit "conP") conPIdKey
1786 infixPName = libFun (fsLit "infixP") infixPIdKey
1787 tildePName = libFun (fsLit "tildeP") tildePIdKey
1788 bangPName = libFun (fsLit "bangP") bangPIdKey
1789 asPName = libFun (fsLit "asP") asPIdKey
1790 wildPName = libFun (fsLit "wildP") wildPIdKey
1791 recPName = libFun (fsLit "recP") recPIdKey
1792 listPName = libFun (fsLit "listP") listPIdKey
1793 sigPName = libFun (fsLit "sigP") sigPIdKey
1794
1795 -- type FieldPat = ...
1796 fieldPatName :: Name
1797 fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
1798
1799 -- data Match = ...
1800 matchName :: Name
1801 matchName = libFun (fsLit "match") matchIdKey
1802
1803 -- data Clause = ...
1804 clauseName :: Name
1805 clauseName = libFun (fsLit "clause") clauseIdKey
1806
1807 -- data Exp = ...
1808 varEName, conEName, litEName, appEName, infixEName, infixAppName,
1809 sectionLName, sectionRName, lamEName, tupEName, condEName,
1810 letEName, caseEName, doEName, compEName :: Name
1811 varEName = libFun (fsLit "varE") varEIdKey
1812 conEName = libFun (fsLit "conE") conEIdKey
1813 litEName = libFun (fsLit "litE") litEIdKey
1814 appEName = libFun (fsLit "appE") appEIdKey
1815 infixEName = libFun (fsLit "infixE") infixEIdKey
1816 infixAppName = libFun (fsLit "infixApp") infixAppIdKey
1817 sectionLName = libFun (fsLit "sectionL") sectionLIdKey
1818 sectionRName = libFun (fsLit "sectionR") sectionRIdKey
1819 lamEName = libFun (fsLit "lamE") lamEIdKey
1820 tupEName = libFun (fsLit "tupE") tupEIdKey
1821 condEName = libFun (fsLit "condE") condEIdKey
1822 letEName = libFun (fsLit "letE") letEIdKey
1823 caseEName = libFun (fsLit "caseE") caseEIdKey
1824 doEName = libFun (fsLit "doE") doEIdKey
1825 compEName = libFun (fsLit "compE") compEIdKey
1826 -- ArithSeq skips a level
1827 fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
1828 fromEName = libFun (fsLit "fromE") fromEIdKey
1829 fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey
1830 fromToEName = libFun (fsLit "fromToE") fromToEIdKey
1831 fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey
1832 -- end ArithSeq
1833 listEName, sigEName, recConEName, recUpdEName :: Name
1834 listEName = libFun (fsLit "listE") listEIdKey
1835 sigEName = libFun (fsLit "sigE") sigEIdKey
1836 recConEName = libFun (fsLit "recConE") recConEIdKey
1837 recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
1838
1839 -- type FieldExp = ...
1840 fieldExpName :: Name
1841 fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
1842
1843 -- data Body = ...
1844 guardedBName, normalBName :: Name
1845 guardedBName = libFun (fsLit "guardedB") guardedBIdKey
1846 normalBName = libFun (fsLit "normalB") normalBIdKey
1847
1848 -- data Guard = ...
1849 normalGEName, patGEName :: Name
1850 normalGEName = libFun (fsLit "normalGE") normalGEIdKey
1851 patGEName = libFun (fsLit "patGE") patGEIdKey
1852
1853 -- data Stmt = ...
1854 bindSName, letSName, noBindSName, parSName :: Name
1855 bindSName = libFun (fsLit "bindS") bindSIdKey
1856 letSName = libFun (fsLit "letS") letSIdKey
1857 noBindSName = libFun (fsLit "noBindS") noBindSIdKey
1858 parSName = libFun (fsLit "parS") parSIdKey
1859
1860 -- data Dec = ...
1861 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
1862 instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
1863 pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName,
1864 newtypeInstDName, tySynInstDName :: Name
1865 funDName = libFun (fsLit "funD") funDIdKey
1866 valDName = libFun (fsLit "valD") valDIdKey
1867 dataDName = libFun (fsLit "dataD") dataDIdKey
1868 newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey
1869 tySynDName = libFun (fsLit "tySynD") tySynDIdKey
1870 classDName = libFun (fsLit "classD") classDIdKey
1871 instanceDName = libFun (fsLit "instanceD") instanceDIdKey
1872 sigDName = libFun (fsLit "sigD") sigDIdKey
1873 forImpDName = libFun (fsLit "forImpD") forImpDIdKey
1874 pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
1875 pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey
1876 pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey
1877 familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey
1878 familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey
1879 dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey
1880 newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey
1881 tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey
1882
1883 -- type Ctxt = ...
1884 cxtName :: Name
1885 cxtName = libFun (fsLit "cxt") cxtIdKey
1886
1887 -- data Pred = ...
1888 classPName, equalPName :: Name
1889 classPName = libFun (fsLit "classP") classPIdKey
1890 equalPName = libFun (fsLit "equalP") equalPIdKey
1891
1892 -- data Strict = ...
1893 isStrictName, notStrictName :: Name
1894 isStrictName = libFun (fsLit "isStrict") isStrictKey
1895 notStrictName = libFun (fsLit "notStrict") notStrictKey
1896
1897 -- data Con = ...
1898 normalCName, recCName, infixCName, forallCName :: Name
1899 normalCName = libFun (fsLit "normalC") normalCIdKey
1900 recCName = libFun (fsLit "recC") recCIdKey
1901 infixCName = libFun (fsLit "infixC") infixCIdKey
1902 forallCName = libFun (fsLit "forallC") forallCIdKey
1903
1904 -- type StrictType = ...
1905 strictTypeName :: Name
1906 strictTypeName = libFun (fsLit "strictType") strictTKey
1907
1908 -- type VarStrictType = ...
1909 varStrictTypeName :: Name
1910 varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey
1911
1912 -- data Type = ...
1913 forallTName, varTName, conTName, tupleTName, arrowTName,
1914 listTName, appTName, sigTName :: Name
1915 forallTName = libFun (fsLit "forallT") forallTIdKey
1916 varTName = libFun (fsLit "varT") varTIdKey
1917 conTName = libFun (fsLit "conT") conTIdKey
1918 tupleTName = libFun (fsLit "tupleT") tupleTIdKey
1919 arrowTName = libFun (fsLit "arrowT") arrowTIdKey
1920 listTName = libFun (fsLit "listT") listTIdKey
1921 appTName = libFun (fsLit "appT") appTIdKey
1922 sigTName = libFun (fsLit "sigT") sigTIdKey
1923
1924 -- data TyVarBndr = ...
1925 plainTVName, kindedTVName :: Name
1926 plainTVName = libFun (fsLit "plainTV") plainTVIdKey
1927 kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
1928
1929 -- data Kind = ...
1930 starKName, arrowKName :: Name
1931 starKName = libFun (fsLit "starK") starKIdKey
1932 arrowKName = libFun (fsLit "arrowK") arrowKIdKey
1933
1934 -- data Callconv = ...
1935 cCallName, stdCallName :: Name
1936 cCallName = libFun (fsLit "cCall") cCallIdKey
1937 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
1938
1939 -- data Safety = ...
1940 unsafeName, safeName, threadsafeName :: Name
1941 unsafeName = libFun (fsLit "unsafe") unsafeIdKey
1942 safeName = libFun (fsLit "safe") safeIdKey
1943 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
1944
1945 -- data InlineSpec = ...
1946 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
1947 inlineSpecNoPhaseName = libFun (fsLit "inlineSpecNoPhase") inlineSpecNoPhaseIdKey
1948 inlineSpecPhaseName = libFun (fsLit "inlineSpecPhase") inlineSpecPhaseIdKey
1949
1950 -- data FunDep = ...
1951 funDepName :: Name
1952 funDepName = libFun (fsLit "funDep") funDepIdKey
1953
1954 -- data FamFlavour = ...
1955 typeFamName, dataFamName :: Name
1956 typeFamName = libFun (fsLit "typeFam") typeFamIdKey
1957 dataFamName = libFun (fsLit "dataFam") dataFamIdKey
1958
1959 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
1960 decQTyConName, conQTyConName, strictTypeQTyConName,
1961 varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
1962 patQTyConName, fieldPatQTyConName, predQTyConName :: Name
1963 matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
1964 clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
1965 expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
1966 stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
1967 decQTyConName = libTc (fsLit "DecQ") decQTyConKey
1968 conQTyConName = libTc (fsLit "ConQ") conQTyConKey
1969 strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey
1970 varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
1971 typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
1972 fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
1973 patQTyConName = libTc (fsLit "PatQ") patQTyConKey
1974 fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
1975 predQTyConName = libTc (fsLit "PredQ") predQTyConKey
1976
1977 -- quasiquoting
1978 quoteExpName, quotePatName :: Name
1979 quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey
1980 quotePatName = qqFun (fsLit "quotePat") quotePatKey
1981
1982 -- TyConUniques available: 100-129
1983 -- Check in PrelNames if you want to change this
1984
1985 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
1986 decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
1987 stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
1988 decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
1989 fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
1990 fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
1991 predQTyConKey :: Unique
1992 expTyConKey = mkPreludeTyConUnique 100
1993 matchTyConKey = mkPreludeTyConUnique 101
1994 clauseTyConKey = mkPreludeTyConUnique 102
1995 qTyConKey = mkPreludeTyConUnique 103
1996 expQTyConKey = mkPreludeTyConUnique 104
1997 decQTyConKey = mkPreludeTyConUnique 105
1998 patTyConKey = mkPreludeTyConUnique 106
1999 matchQTyConKey = mkPreludeTyConUnique 107
2000 clauseQTyConKey = mkPreludeTyConUnique 108
2001 stmtQTyConKey = mkPreludeTyConUnique 109
2002 conQTyConKey = mkPreludeTyConUnique 110
2003 typeQTyConKey = mkPreludeTyConUnique 111
2004 typeTyConKey = mkPreludeTyConUnique 112
2005 tyVarBndrTyConKey = mkPreludeTyConUnique 125
2006 decTyConKey = mkPreludeTyConUnique 113
2007 varStrictTypeQTyConKey = mkPreludeTyConUnique 114
2008 strictTypeQTyConKey = mkPreludeTyConUnique 115
2009 fieldExpTyConKey = mkPreludeTyConUnique 116
2010 fieldPatTyConKey = mkPreludeTyConUnique 117
2011 nameTyConKey = mkPreludeTyConUnique 118
2012 patQTyConKey = mkPreludeTyConUnique 119
2013 fieldPatQTyConKey = mkPreludeTyConUnique 120
2014 fieldExpQTyConKey = mkPreludeTyConUnique 121
2015 funDepTyConKey = mkPreludeTyConUnique 122
2016 predTyConKey = mkPreludeTyConUnique 123
2017 predQTyConKey = mkPreludeTyConUnique 124
2018
2019 -- IdUniques available: 200-399
2020 -- If you want to change this, make sure you check in PrelNames
2021
2022 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
2023 mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
2024 mkNameLIdKey :: Unique
2025 returnQIdKey = mkPreludeMiscIdUnique 200
2026 bindQIdKey = mkPreludeMiscIdUnique 201
2027 sequenceQIdKey = mkPreludeMiscIdUnique 202
2028 liftIdKey = mkPreludeMiscIdUnique 203
2029 newNameIdKey = mkPreludeMiscIdUnique 204
2030 mkNameIdKey = mkPreludeMiscIdUnique 205
2031 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
2032 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
2033 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
2034 mkNameLIdKey = mkPreludeMiscIdUnique 209
2035
2036
2037 -- data Lit = ...
2038 charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
2039 floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique
2040 charLIdKey = mkPreludeMiscIdUnique 210
2041 stringLIdKey = mkPreludeMiscIdUnique 211
2042 integerLIdKey = mkPreludeMiscIdUnique 212
2043 intPrimLIdKey = mkPreludeMiscIdUnique 213
2044 wordPrimLIdKey = mkPreludeMiscIdUnique 214
2045 floatPrimLIdKey = mkPreludeMiscIdUnique 215
2046 doublePrimLIdKey = mkPreludeMiscIdUnique 216
2047 rationalLIdKey = mkPreludeMiscIdUnique 217
2048
2049 liftStringIdKey :: Unique
2050 liftStringIdKey = mkPreludeMiscIdUnique 218
2051
2052 -- data Pat = ...
2053 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
2054 asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
2055 litPIdKey = mkPreludeMiscIdUnique 220
2056 varPIdKey = mkPreludeMiscIdUnique 221
2057 tupPIdKey = mkPreludeMiscIdUnique 222
2058 conPIdKey = mkPreludeMiscIdUnique 223
2059 infixPIdKey = mkPreludeMiscIdUnique 312
2060 tildePIdKey = mkPreludeMiscIdUnique 224
2061 bangPIdKey = mkPreludeMiscIdUnique 359
2062 asPIdKey = mkPreludeMiscIdUnique 225
2063 wildPIdKey = mkPreludeMiscIdUnique 226
2064 recPIdKey = mkPreludeMiscIdUnique 227
2065 listPIdKey = mkPreludeMiscIdUnique 228
2066 sigPIdKey = mkPreludeMiscIdUnique 229
2067
2068 -- type FieldPat = ...
2069 fieldPatIdKey :: Unique
2070 fieldPatIdKey = mkPreludeMiscIdUnique 230
2071
2072 -- data Match = ...
2073 matchIdKey :: Unique
2074 matchIdKey = mkPreludeMiscIdUnique 231
2075
2076 -- data Clause = ...
2077 clauseIdKey :: Unique
2078 clauseIdKey = mkPreludeMiscIdUnique 232
2079
2080
2081 -- data Exp = ...
2082 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
2083 sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,
2084 letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
2085 fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
2086 listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
2087 varEIdKey = mkPreludeMiscIdUnique 240
2088 conEIdKey = mkPreludeMiscIdUnique 241
2089 litEIdKey = mkPreludeMiscIdUnique 242
2090 appEIdKey = mkPreludeMiscIdUnique 243
2091 infixEIdKey = mkPreludeMiscIdUnique 244
2092 infixAppIdKey = mkPreludeMiscIdUnique 245
2093 sectionLIdKey = mkPreludeMiscIdUnique 246
2094 sectionRIdKey = mkPreludeMiscIdUnique 247
2095 lamEIdKey = mkPreludeMiscIdUnique 248
2096 tupEIdKey = mkPreludeMiscIdUnique 249
2097 condEIdKey = mkPreludeMiscIdUnique 250
2098 letEIdKey = mkPreludeMiscIdUnique 251
2099 caseEIdKey = mkPreludeMiscIdUnique 252
2100 doEIdKey = mkPreludeMiscIdUnique 253
2101 compEIdKey = mkPreludeMiscIdUnique 254
2102 fromEIdKey = mkPreludeMiscIdUnique 255
2103 fromThenEIdKey = mkPreludeMiscIdUnique 256
2104 fromToEIdKey = mkPreludeMiscIdUnique 257
2105 fromThenToEIdKey = mkPreludeMiscIdUnique 258
2106 listEIdKey = mkPreludeMiscIdUnique 259
2107 sigEIdKey = mkPreludeMiscIdUnique 260
2108 recConEIdKey = mkPreludeMiscIdUnique 261
2109 recUpdEIdKey = mkPreludeMiscIdUnique 262
2110
2111 -- type FieldExp = ...
2112 fieldExpIdKey :: Unique
2113 fieldExpIdKey = mkPreludeMiscIdUnique 265
2114
2115 -- data Body = ...
2116 guardedBIdKey, normalBIdKey :: Unique
2117 guardedBIdKey = mkPreludeMiscIdUnique 266
2118 normalBIdKey = mkPreludeMiscIdUnique 267
2119
2120 -- data Guard = ...
2121 normalGEIdKey, patGEIdKey :: Unique
2122 normalGEIdKey = mkPreludeMiscIdUnique 310
2123 patGEIdKey = mkPreludeMiscIdUnique 311
2124
2125 -- data Stmt = ...
2126 bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique
2127 bindSIdKey = mkPreludeMiscIdUnique 268
2128 letSIdKey = mkPreludeMiscIdUnique 269
2129 noBindSIdKey = mkPreludeMiscIdUnique 270
2130 parSIdKey = mkPreludeMiscIdUnique 271
2131
2132 -- data Dec = ...
2133 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
2134 classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
2135 pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey,
2136 dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique
2137 funDIdKey = mkPreludeMiscIdUnique 272
2138 valDIdKey = mkPreludeMiscIdUnique 273
2139 dataDIdKey = mkPreludeMiscIdUnique 274
2140 newtypeDIdKey = mkPreludeMiscIdUnique 275
2141 tySynDIdKey = mkPreludeMiscIdUnique 276
2142 classDIdKey = mkPreludeMiscIdUnique 277
2143 instanceDIdKey = mkPreludeMiscIdUnique 278
2144 sigDIdKey = mkPreludeMiscIdUnique 279
2145 forImpDIdKey = mkPreludeMiscIdUnique 297
2146 pragInlDIdKey = mkPreludeMiscIdUnique 348
2147 pragSpecDIdKey = mkPreludeMiscIdUnique 349
2148 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352
2149 familyNoKindDIdKey= mkPreludeMiscIdUnique 340
2150 familyKindDIdKey = mkPreludeMiscIdUnique 353
2151 dataInstDIdKey = mkPreludeMiscIdUnique 341
2152 newtypeInstDIdKey = mkPreludeMiscIdUnique 342
2153 tySynInstDIdKey = mkPreludeMiscIdUnique 343
2154
2155 -- type Cxt = ...
2156 cxtIdKey :: Unique
2157 cxtIdKey = mkPreludeMiscIdUnique 280
2158
2159 -- data Pred = ...
2160 classPIdKey, equalPIdKey :: Unique
2161 classPIdKey = mkPreludeMiscIdUnique 346
2162 equalPIdKey = mkPreludeMiscIdUnique 347
2163
2164 -- data Strict = ...
2165 isStrictKey, notStrictKey :: Unique
2166 isStrictKey = mkPreludeMiscIdUnique 281
2167 notStrictKey = mkPreludeMiscIdUnique 282
2168
2169 -- data Con = ...
2170 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
2171 normalCIdKey = mkPreludeMiscIdUnique 283
2172 recCIdKey = mkPreludeMiscIdUnique 284
2173 infixCIdKey = mkPreludeMiscIdUnique 285
2174 forallCIdKey = mkPreludeMiscIdUnique 288
2175
2176 -- type StrictType = ...
2177 strictTKey :: Unique
2178 strictTKey = mkPreludeMiscIdUnique 286
2179
2180 -- type VarStrictType = ...
2181 varStrictTKey :: Unique
2182 varStrictTKey = mkPreludeMiscIdUnique 287
2183
2184 -- data Type = ...
2185 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey,
2186 listTIdKey, appTIdKey, sigTIdKey :: Unique
2187 forallTIdKey = mkPreludeMiscIdUnique 290
2188 varTIdKey = mkPreludeMiscIdUnique 291
2189 conTIdKey = mkPreludeMiscIdUnique 292
2190 tupleTIdKey = mkPreludeMiscIdUnique 294
2191 arrowTIdKey = mkPreludeMiscIdUnique 295
2192 listTIdKey = mkPreludeMiscIdUnique 296
2193 appTIdKey = mkPreludeMiscIdUnique 293
2194 sigTIdKey = mkPreludeMiscIdUnique 358
2195
2196 -- data TyVarBndr = ...
2197 plainTVIdKey, kindedTVIdKey :: Unique
2198 plainTVIdKey = mkPreludeMiscIdUnique 354
2199 kindedTVIdKey = mkPreludeMiscIdUnique 355
2200
2201 -- data Kind = ...
2202 starKIdKey, arrowKIdKey :: Unique
2203 starKIdKey = mkPreludeMiscIdUnique 356
2204 arrowKIdKey = mkPreludeMiscIdUnique 357
2205
2206 -- data Callconv = ...
2207 cCallIdKey, stdCallIdKey :: Unique
2208 cCallIdKey = mkPreludeMiscIdUnique 300
2209 stdCallIdKey = mkPreludeMiscIdUnique 301
2210
2211 -- data Safety = ...
2212 unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
2213 unsafeIdKey = mkPreludeMiscIdUnique 305
2214 safeIdKey = mkPreludeMiscIdUnique 306
2215 threadsafeIdKey = mkPreludeMiscIdUnique 307
2216
2217 -- data InlineSpec =
2218 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
2219 inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350
2220 inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351
2221
2222 -- data FunDep = ...
2223 funDepIdKey :: Unique
2224 funDepIdKey = mkPreludeMiscIdUnique 320
2225
2226 -- data FamFlavour = ...
2227 typeFamIdKey, dataFamIdKey :: Unique
2228 typeFamIdKey = mkPreludeMiscIdUnique 344
2229 dataFamIdKey = mkPreludeMiscIdUnique 345
2230
2231 -- quasiquoting
2232 quoteExpKey, quotePatKey :: Unique
2233 quoteExpKey = mkPreludeMiscIdUnique 321
2234 quotePatKey = mkPreludeMiscIdUnique 322