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