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