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