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