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