Support wild cards in TH splices
[ghc.git] / compiler / deSugar / DsMeta.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- (c) The University of Glasgow 2006
6 --
7 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
8 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
9 -- input HsExpr. We do this in the DsM monad, which supplies access to
10 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
11 --
12 -- It also defines a bunch of knownKeyNames, in the same way as is done
13 -- in prelude/PrelNames. It's much more convenient to do it here, because
14 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
15 -- a Royal Pain (triggers other recompilation).
16 -----------------------------------------------------------------------------
17
18 module DsMeta( dsBracket ) where
19
20 #include "HsVersions.h"
21
22 import {-# SOURCE #-} DsExpr ( dsExpr )
23
24 import MatchLit
25 import DsMonad
26
27 import qualified Language.Haskell.TH as TH
28
29 import HsSyn
30 import Class
31 import PrelNames
32 -- To avoid clashes with DsMeta.varName we must make a local alias for
33 -- OccName.varName we do this by removing varName from the import of
34 -- OccName above, making a qualified instance of OccName and using
35 -- OccNameAlias.varName where varName ws previously used in this file.
36 import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
37
38 import Module
39 import Id
40 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
41 import THNames
42 import NameEnv
43 import TcType
44 import TyCon
45 import TysWiredIn
46 import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
47 import CoreSyn
48 import MkCore
49 import CoreUtils
50 import SrcLoc
51 import Unique
52 import BasicTypes
53 import Outputable
54 import Bag
55 import DynFlags
56 import FastString
57 import ForeignCall
58 import Util
59 import MonadUtils
60
61 import Data.ByteString ( unpack )
62 import Data.Maybe
63 import Control.Monad
64 import Data.List
65
66 -----------------------------------------------------------------------------
67 dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
68 -- Returns a CoreExpr of type TH.ExpQ
69 -- The quoted thing is parameterised over Name, even though it has
70 -- been type checked. We don't want all those type decorations!
71
72 dsBracket brack splices
73 = dsExtendMetaEnv new_bit (do_brack brack)
74 where
75 new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
76
77 do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
78 do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
79 do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }
80 do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }
81 do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
82 do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"
83 do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 }
84
85 {- -------------- Examples --------------------
86
87 [| \x -> x |]
88 ====>
89 gensym (unpackString "x"#) `bindQ` \ x1::String ->
90 lam (pvar x1) (var x1)
91
92
93 [| \x -> $(f [| x |]) |]
94 ====>
95 gensym (unpackString "x"#) `bindQ` \ x1::String ->
96 lam (pvar x1) (f (var x1))
97 -}
98
99
100 -------------------------------------------------------
101 -- Declarations
102 -------------------------------------------------------
103
104 repTopP :: LPat Name -> DsM (Core TH.PatQ)
105 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
106 ; pat' <- addBinds ss (repLP pat)
107 ; wrapGenSyms ss pat' }
108
109 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110 repTopDs group@(HsGroup { hs_valds = valds
111 , hs_splcds = splcds
112 , hs_tyclds = tyclds
113 , hs_instds = instds
114 , hs_derivds = derivds
115 , hs_fixds = fixds
116 , hs_defds = defds
117 , hs_fords = fords
118 , hs_warnds = warnds
119 , hs_annds = annds
120 , hs_ruleds = ruleds
121 , hs_vects = vects
122 , hs_docs = docs })
123 = do { let { tv_bndrs = hsSigTvBinders valds
124 ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
125 ss <- mkGenSyms bndrs ;
126
127 -- Bind all the names mainly to avoid repeated use of explicit strings.
128 -- Thus we get
129 -- do { t :: String <- genSym "T" ;
130 -- return (Data t [] ...more t's... }
131 -- The other important reason is that the output must mention
132 -- only "T", not "Foo:T" where Foo is the current module
133
134 decls <- addBinds ss (
135 do { val_ds <- rep_val_binds valds
136 ; _ <- mapM no_splice splcds
137 ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)
138 ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
139 ; inst_ds <- mapM repInstD instds
140 ; deriv_ds <- mapM repStandaloneDerivD derivds
141 ; fix_ds <- mapM repFixD fixds
142 ; _ <- mapM no_default_decl defds
143 ; for_ds <- mapM repForD fords
144 ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)
145 warnds)
146 ; ann_ds <- mapM repAnnD annds
147 ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)
148 ruleds)
149 ; _ <- mapM no_vect vects
150 ; _ <- mapM no_doc docs
151
152 -- more needed
153 ; return (de_loc $ sort_by_loc $
154 val_ds ++ catMaybes tycl_ds ++ role_ds
155 ++ (concat fix_ds)
156 ++ inst_ds ++ rule_ds ++ for_ds
157 ++ ann_ds ++ deriv_ds) }) ;
158
159 decl_ty <- lookupType decQTyConName ;
160 let { core_list = coreList' decl_ty decls } ;
161
162 dec_ty <- lookupType decTyConName ;
163 q_decs <- repSequenceQ dec_ty core_list ;
164
165 wrapGenSyms ss q_decs
166 }
167 where
168 no_splice (L loc _)
169 = notHandledL loc "Splices within declaration brackets" empty
170 no_default_decl (L loc decl)
171 = notHandledL loc "Default declarations" (ppr decl)
172 no_warn (L loc (Warning thing _))
173 = notHandledL loc "WARNING and DEPRECATION pragmas" $
174 text "Pragma for declaration of" <+> ppr thing
175 no_vect (L loc decl)
176 = notHandledL loc "Vectorisation pragmas" (ppr decl)
177 no_doc (L loc _)
178 = notHandledL loc "Haddock documentation" empty
179
180 hsSigTvBinders :: HsValBinds Name -> [Name]
181 -- See Note [Scoped type variables in bindings]
182 hsSigTvBinders binds
183 = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
184 , tv <- hsQTvBndrs qtvs]
185 where
186 sigs = case binds of
187 ValBindsIn _ sigs -> sigs
188 ValBindsOut _ sigs -> sigs
189
190
191 {- Notes
192
193 Note [Scoped type variables in bindings]
194 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
195 Consider
196 f :: forall a. a -> a
197 f x = x::a
198 Here the 'forall a' brings 'a' into scope over the binding group.
199 To achieve this we
200
201 a) Gensym a binding for 'a' at the same time as we do one for 'f'
202 collecting the relevant binders with hsSigTvBinders
203
204 b) When processing the 'forall', don't gensym
205
206 The relevant places are signposted with references to this Note
207
208 Note [Binders and occurrences]
209 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
210 When we desugar [d| data T = MkT |]
211 we want to get
212 Data "T" [] [Con "MkT" []] []
213 and *not*
214 Data "Foo:T" [] [Con "Foo:MkT" []] []
215 That is, the new data decl should fit into whatever new module it is
216 asked to fit in. We do *not* clone, though; no need for this:
217 Data "T79" ....
218
219 But if we see this:
220 data T = MkT
221 foo = reifyDecl T
222
223 then we must desugar to
224 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
225
226 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
227 And we use lookupOcc, rather than lookupBinder
228 in repTyClD and repC.
229
230 -}
231
232 -- represent associated family instances
233 --
234 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
235
236 repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
237
238 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
239 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
240 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
241 repSynDecl tc1 bndrs rhs
242 ; return (Just (loc, dec)) }
243
244 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
245 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
246 ; tc_tvs <- mk_extra_tvs tc tvs defn
247 ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
248 repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn
249 ; return (Just (loc, dec)) }
250
251 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
252 tcdTyVars = tvs, tcdFDs = fds,
253 tcdSigs = sigs, tcdMeths = meth_binds,
254 tcdATs = ats, tcdATDefs = [] }))
255 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
256 ; dec <- addTyVarBinds tvs $ \bndrs ->
257 do { cxt1 <- repLContext cxt
258 ; sigs1 <- rep_sigs sigs
259 ; binds1 <- rep_binds meth_binds
260 ; fds1 <- repLFunDeps fds
261 ; ats1 <- repFamilyDecls ats
262 ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)
263 ; repClass cxt1 cls1 bndrs fds1 decls1
264 }
265 ; return $ Just (loc, dec)
266 }
267
268 -- Un-handled cases
269 repTyClD (L loc d) = putSrcSpanDs loc $
270 do { warnDs (hang ds_msg 4 (ppr d))
271 ; return Nothing }
272
273 -------------------------
274 repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
275 repRoleD (L loc (RoleAnnotDecl tycon roles))
276 = do { tycon1 <- lookupLOcc tycon
277 ; roles1 <- mapM repRole roles
278 ; roles2 <- coreList roleTyConName roles1
279 ; dec <- repRoleAnnotD tycon1 roles2
280 ; return (loc, dec) }
281
282 -------------------------
283 repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
284 -> Maybe (Core [TH.TypeQ])
285 -> [Name] -> HsDataDefn Name
286 -> DsM (Core TH.DecQ)
287 repDataDefn tc bndrs opt_tys tv_names
288 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
289 , dd_cons = cons, dd_derivs = mb_derivs })
290 = do { cxt1 <- repLContext cxt
291 ; derivs1 <- repDerivs mb_derivs
292 ; case new_or_data of
293 NewType -> do { con1 <- repC tv_names (head cons)
294 ; case con1 of
295 [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
296 _cs -> failWithDs (ptext
297 (sLit "Multiple constructors for newtype:")
298 <+> pprQuotedList
299 (con_names $ unLoc $ head cons))
300 }
301 DataType -> do { consL <- concatMapM (repC tv_names) cons
302 ; cons1 <- coreList conQTyConName consL
303 ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
304
305 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
306 -> LHsType Name
307 -> DsM (Core TH.DecQ)
308 repSynDecl tc bndrs ty
309 = do { ty1 <- repLTy ty
310 ; repTySyn tc bndrs ty1 }
311
312 repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
313 repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
314 fdLName = tc,
315 fdTyVars = tvs,
316 fdKindSig = opt_kind }))
317 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
318 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
319 case (opt_kind, info) of
320 (_ , ClosedTypeFamily Nothing) ->
321 notHandled "abstract closed type family" (ppr decl)
322 (Nothing, ClosedTypeFamily (Just eqns)) ->
323 do { eqns1 <- mapM repTyFamEqn eqns
324 ; eqns2 <- coreList tySynEqnQTyConName eqns1
325 ; repClosedFamilyNoKind tc1 bndrs eqns2 }
326 (Just ki, ClosedTypeFamily (Just eqns)) ->
327 do { eqns1 <- mapM repTyFamEqn eqns
328 ; eqns2 <- coreList tySynEqnQTyConName eqns1
329 ; ki1 <- repLKind ki
330 ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
331 (Nothing, _) ->
332 do { info' <- repFamilyInfo info
333 ; repFamilyNoKind info' tc1 bndrs }
334 (Just ki, _) ->
335 do { info' <- repFamilyInfo info
336 ; ki1 <- repLKind ki
337 ; repFamilyKind info' tc1 bndrs ki1 }
338 ; return (loc, dec)
339 }
340
341 repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
342 repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
343
344 -------------------------
345 mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
346 -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
347 -- If there is a kind signature it must be of form
348 -- k1 -> .. -> kn -> *
349 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
350 mk_extra_tvs tc tvs defn
351 | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
352 = do { extra_tvs <- go hs_kind
353 ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
354 | otherwise
355 = return tvs
356 where
357 go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
358 go (L loc (HsFunTy kind rest))
359 = do { uniq <- newUnique
360 ; let { occ = mkTyVarOccFS (fsLit "t")
361 ; nm = mkInternalName uniq occ loc
362 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
363 ; hs_tvs <- go rest
364 ; return (hs_tv : hs_tvs) }
365
366 go (L _ (HsTyVar n))
367 | n == liftedTypeKindTyConName
368 = return []
369
370 go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
371
372 -------------------------
373 -- represent fundeps
374 --
375 repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
376 repLFunDeps fds = repList funDepTyConName repLFunDep fds
377
378 repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
379 repLFunDep (L _ (xs, ys))
380 = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
381 ys' <- repList nameTyConName (lookupBinder . unLoc) ys
382 repFunDep xs' ys'
383
384 -- represent family declaration flavours
385 --
386 repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
387 repFamilyInfo OpenTypeFamily = rep2 typeFamName []
388 repFamilyInfo DataFamily = rep2 dataFamName []
389 repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
390
391 -- Represent instance declarations
392 --
393 repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
394 repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
395 = do { dec <- repTyFamInstD fi_decl
396 ; return (loc, dec) }
397 repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
398 = do { dec <- repDataFamInstD fi_decl
399 ; return (loc, dec) }
400 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
401 = do { dec <- repClsInstD cls_decl
402 ; return (loc, dec) }
403
404 repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
405 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
406 , cid_sigs = prags, cid_tyfam_insts = ats
407 , cid_datafam_insts = adts })
408 = addTyVarBinds tvs $ \_ ->
409 -- We must bring the type variables into scope, so their
410 -- occurrences don't fail, even though the binders don't
411 -- appear in the resulting data structure
412 --
413 -- But we do NOT bring the binders of 'binds' into scope
414 -- because they are properly regarded as occurrences
415 -- For example, the method names should be bound to
416 -- the selector Ids, not to fresh names (Trac #5410)
417 --
418 do { cxt1 <- repContext cxt
419 ; cls_tcon <- repTy (HsTyVar (unLoc cls))
420 ; cls_tys <- repLTys tys
421 ; inst_ty1 <- repTapps cls_tcon cls_tys
422 ; binds1 <- rep_binds binds
423 ; prags1 <- rep_sigs prags
424 ; ats1 <- mapM (repTyFamInstD . unLoc) ats
425 ; adts1 <- mapM (repDataFamInstD . unLoc) adts
426 ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
427 ; repInst cxt1 inst_ty1 decls }
428 where
429 Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
430
431 repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
432 repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
433 = do { dec <- addTyVarBinds tvs $ \_ ->
434 do { cxt' <- repContext cxt
435 ; cls_tcon <- repTy (HsTyVar (unLoc cls))
436 ; cls_tys <- repLTys tys
437 ; inst_ty <- repTapps cls_tcon cls_tys
438 ; repDeriv cxt' inst_ty }
439 ; return (loc, dec) }
440 where
441 Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
442
443 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
444 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
445 = do { let tc_name = tyFamInstDeclLName decl
446 ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
447 ; eqn1 <- repTyFamEqn eqn
448 ; repTySynInst tc eqn1 }
449
450 repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
451 repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
452 , hswb_kvs = kv_names
453 , hswb_tvs = tv_names }
454 , tfe_rhs = rhs }))
455 = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
456 , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
457 ; addTyClTyVarBinds hs_tvs $ \ _ ->
458 do { tys1 <- repLTys tys
459 ; tys2 <- coreList typeQTyConName tys1
460 ; rhs1 <- repLTy rhs
461 ; repTySynEqn tys2 rhs1 } }
462
463 repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
464 repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
465 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
466 , dfid_defn = defn })
467 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
468 ; let loc = getLoc tc_name
469 hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk
470 ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
471 do { tys1 <- repList typeQTyConName repLTy tys
472 ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
473
474 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
475 repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
476 = do MkC name' <- lookupLOcc name
477 MkC typ' <- repLTy typ
478 MkC cc' <- repCCallConv cc
479 MkC s' <- repSafety s
480 cis' <- conv_cimportspec cis
481 MkC str <- coreStringLit (static ++ chStr ++ cis')
482 dec <- rep2 forImpDName [cc', s', str, name', typ']
483 return (loc, dec)
484 where
485 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
486 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
487 conv_cimportspec (CFunction (StaticTarget _ fs _ True))
488 = return (unpackFS fs)
489 conv_cimportspec (CFunction (StaticTarget _ _ _ False))
490 = panic "conv_cimportspec: values not supported yet"
491 conv_cimportspec CWrapper = return "wrapper"
492 static = case cis of
493 CFunction (StaticTarget _ _ _ _) -> "static "
494 _ -> ""
495 chStr = case mch of
496 Nothing -> ""
497 Just (Header _ h) -> unpackFS h ++ " "
498 repForD decl = notHandled "Foreign declaration" (ppr decl)
499
500 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
501 repCCallConv CCallConv = rep2 cCallName []
502 repCCallConv StdCallConv = rep2 stdCallName []
503 repCCallConv CApiConv = rep2 cApiCallName []
504 repCCallConv PrimCallConv = rep2 primCallName []
505 repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
506
507 repSafety :: Safety -> DsM (Core TH.Safety)
508 repSafety PlayRisky = rep2 unsafeName []
509 repSafety PlayInterruptible = rep2 interruptibleName []
510 repSafety PlaySafe = rep2 safeName []
511
512 repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
513 repFixD (L loc (FixitySig names (Fixity prec dir)))
514 = do { MkC prec' <- coreIntLit prec
515 ; let rep_fn = case dir of
516 InfixL -> infixLDName
517 InfixR -> infixRDName
518 InfixN -> infixNDName
519 ; let do_one name
520 = do { MkC name' <- lookupLOcc name
521 ; dec <- rep2 rep_fn [prec', name']
522 ; return (loc,dec) }
523 ; mapM do_one names }
524
525 repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
526 repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
527 = do { let bndr_names = concatMap ruleBndrNames bndrs
528 ; ss <- mkGenSyms bndr_names
529 ; rule1 <- addBinds ss $
530 do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
531 ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
532 ; act' <- repPhases act
533 ; lhs' <- repLE lhs
534 ; rhs' <- repLE rhs
535 ; repPragRule n' bndrs' lhs' rhs' act' }
536 ; rule2 <- wrapGenSyms ss rule1
537 ; return (loc, rule2) }
538
539 ruleBndrNames :: LRuleBndr Name -> [Name]
540 ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
541 ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
542 = unLoc n : kvs ++ tvs
543
544 repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
545 repRuleBndr (L _ (RuleBndr n))
546 = do { MkC n' <- lookupLBinder n
547 ; rep2 ruleVarName [n'] }
548 repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
549 = do { MkC n' <- lookupLBinder n
550 ; MkC ty' <- repLTy ty
551 ; rep2 typedRuleVarName [n', ty'] }
552
553 repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
554 repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
555 = do { target <- repAnnProv ann_prov
556 ; exp' <- repE exp
557 ; dec <- repPragAnn target exp'
558 ; return (loc, dec) }
559
560 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
561 repAnnProv (ValueAnnProvenance (L _ n))
562 = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
563 ; rep2 valueAnnotationName [ n' ] }
564 repAnnProv (TypeAnnProvenance (L _ n))
565 = do { MkC n' <- globalVar n
566 ; rep2 typeAnnotationName [ n' ] }
567 repAnnProv ModuleAnnProvenance
568 = rep2 moduleAnnotationName []
569
570 ds_msg :: SDoc
571 ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
572
573 -------------------------------------------------------
574 -- Constructors
575 -------------------------------------------------------
576
577 repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
578 repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
579 , con_details = details, con_res = ResTyH98 }))
580 | null (hsQTvBndrs con_tvs)
581 = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences]
582 ; mapM (\c -> repConstr c details) con1 }
583
584 repC tvs (L _ (ConDecl { con_names = cons
585 , con_qvars = con_tvs, con_cxt = L _ ctxt
586 , con_details = details
587 , con_res = res_ty }))
588 = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
589 ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
590 , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }
591
592 ; binds <- mapM dupBinder con_tv_subst
593 ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
594 addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
595 do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
596 ; c' <- mapM (\c -> repConstr c details) cons1
597 ; ctxt' <- repContext (eq_ctxt ++ ctxt)
598 ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
599 ; return [b]
600 }
601
602 in_subst :: [(Name,Name)] -> Name -> Bool
603 in_subst [] _ = False
604 in_subst ((n',_):ns) n = n==n' || in_subst ns n
605
606 mkGadtCtxt :: [Name] -- Tyvars of the data type
607 -> ResType (LHsType Name)
608 -> DsM (HsContext Name, [(Name,Name)])
609 -- Given a data type in GADT syntax, figure out the equality
610 -- context, so that we can represent it with an explicit
611 -- equality context, because that is the only way to express
612 -- the GADT in TH syntax
613 --
614 -- Example:
615 -- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
616 -- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
617 -- returns
618 -- (b~[e], c~e), [d->a]
619 --
620 -- This function is fiddly, but not really hard
621 mkGadtCtxt _ ResTyH98
622 = return ([], [])
623 mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
624 | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
625 , data_tvs `equalLength` tys
626 = return (go [] [] (data_tvs `zip` tys))
627
628 | otherwise
629 = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
630 where
631 go cxt subst [] = (cxt, subst)
632 go cxt subst ((data_tv, ty) : rest)
633 | Just con_tv <- is_hs_tyvar ty
634 , isTyVarName con_tv
635 , not (in_subst subst con_tv)
636 = go cxt ((con_tv, data_tv) : subst) rest
637 | otherwise
638 = go (eq_pred : cxt) subst rest
639 where
640 loc = getLoc ty
641 eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
642
643 is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
644 is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
645 is_hs_tyvar _ = Nothing
646
647
648 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
649 repBangTy ty= do
650 MkC s <- rep2 str []
651 MkC t <- repLTy ty'
652 rep2 strictTypeName [s, t]
653 where
654 (str, ty') = case ty of
655 L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName, ty)
656 L _ (HsBangTy (HsSrcBang _ _ True) ty) -> (isStrictName, ty)
657 _ -> (notStrictName, ty)
658
659 -------------------------------------------------------
660 -- Deriving clause
661 -------------------------------------------------------
662
663 repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
664 repDerivs Nothing = coreList nameTyConName []
665 repDerivs (Just (L _ ctxt))
666 = repList nameTyConName rep_deriv ctxt
667 where
668 rep_deriv :: LHsType Name -> DsM (Core TH.Name)
669 -- Deriving clauses must have the simple H98 form
670 rep_deriv ty
671 | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
672 = lookupOcc cls
673 | otherwise
674 = notHandled "Non-H98 deriving clause" (ppr ty)
675
676
677 -------------------------------------------------------
678 -- Signatures in a class decl, or a group of bindings
679 -------------------------------------------------------
680
681 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
682 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
683 return $ de_loc $ sort_by_loc locs_cores
684
685 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
686 -- We silently ignore ones we don't recognise
687 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
688 return (concat sigs1) }
689
690 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
691 rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms
692 rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty
693 rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms
694 rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
695 rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
696 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
697 rep_sig (L loc (SpecSig nm tys ispec))
698 = concatMapM (\t -> rep_specialise nm t ispec loc) tys
699 rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
700 rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
701
702 rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
703 -> DsM (SrcSpan, Core TH.DecQ)
704 rep_ty_sig mk_sig loc (L _ ty) nm
705 = do { nm1 <- lookupLOcc nm
706 ; ty1 <- rep_ty ty
707 ; sig <- repProto mk_sig nm1 ty1
708 ; return (loc, sig) }
709 where
710 -- We must special-case the top-level explicit for-all of a TypeSig
711 -- See Note [Scoped type variables in bindings]
712 rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
713 = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
714 ; repTyVarBndrWithKind tv name }
715 ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
716 ; ctxt1 <- repLContext ctxt
717 ; ty1 <- repLTy ty
718 ; repTForall bndrs1 ctxt1 ty1 }
719
720 rep_ty ty = repTy ty
721
722 rep_inline :: Located Name
723 -> InlinePragma -- Never defaultInlinePragma
724 -> SrcSpan
725 -> DsM [(SrcSpan, Core TH.DecQ)]
726 rep_inline nm ispec loc
727 = do { nm1 <- lookupLOcc nm
728 ; inline <- repInline $ inl_inline ispec
729 ; rm <- repRuleMatch $ inl_rule ispec
730 ; phases <- repPhases $ inl_act ispec
731 ; pragma <- repPragInl nm1 inline rm phases
732 ; return [(loc, pragma)]
733 }
734
735 rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
736 -> DsM [(SrcSpan, Core TH.DecQ)]
737 rep_specialise nm ty ispec loc
738 = do { nm1 <- lookupLOcc nm
739 ; ty1 <- repLTy ty
740 ; phases <- repPhases $ inl_act ispec
741 ; let inline = inl_inline ispec
742 ; pragma <- if isEmptyInlineSpec inline
743 then -- SPECIALISE
744 repPragSpec nm1 ty1 phases
745 else -- SPECIALISE INLINE
746 do { inline1 <- repInline inline
747 ; repPragSpecInl nm1 ty1 inline1 phases }
748 ; return [(loc, pragma)]
749 }
750
751 rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
752 rep_specialiseInst ty loc
753 = do { ty1 <- repLTy ty
754 ; pragma <- repPragSpecInst ty1
755 ; return [(loc, pragma)] }
756
757 repInline :: InlineSpec -> DsM (Core TH.Inline)
758 repInline NoInline = dataCon noInlineDataConName
759 repInline Inline = dataCon inlineDataConName
760 repInline Inlinable = dataCon inlinableDataConName
761 repInline spec = notHandled "repInline" (ppr spec)
762
763 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
764 repRuleMatch ConLike = dataCon conLikeDataConName
765 repRuleMatch FunLike = dataCon funLikeDataConName
766
767 repPhases :: Activation -> DsM (Core TH.Phases)
768 repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
769 ; dataCon' beforePhaseDataConName [arg] }
770 repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i
771 ; dataCon' fromPhaseDataConName [arg] }
772 repPhases _ = dataCon allPhasesDataConName
773
774 -------------------------------------------------------
775 -- Types
776 -------------------------------------------------------
777
778 addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
779 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
780 -> DsM (Core (TH.Q a))
781 -- gensym a list of type variables and enter them into the meta environment;
782 -- the computations passed as the second argument is executed in that extended
783 -- meta environment and gets the *new* names on Core-level as an argument
784
785 addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
786 = do { fresh_kv_names <- mkGenSyms kvs
787 ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
788 ; let fresh_names = fresh_kv_names ++ fresh_tv_names
789 ; term <- addBinds fresh_names $
790 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
791 ; m kbs }
792 ; wrapGenSyms fresh_names term }
793 where
794 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
795
796 addTyClTyVarBinds :: LHsTyVarBndrs Name
797 -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
798 -> DsM (Core (TH.Q a))
799
800 -- Used for data/newtype declarations, and family instances,
801 -- so that the nested type variables work right
802 -- instance C (T a) where
803 -- type W (T a) = blah
804 -- The 'a' in the type instance is the one bound by the instance decl
805 addTyClTyVarBinds tvs m
806 = do { let tv_names = hsLKiTyVarNames tvs
807 ; env <- dsGetMetaEnv
808 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
809 -- Make fresh names for the ones that are not already in scope
810 -- This makes things work for family declarations
811
812 ; term <- addBinds freshNames $
813 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
814 ; m kbs }
815
816 ; wrapGenSyms freshNames term }
817 where
818 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
819 ; repTyVarBndrWithKind tv v }
820
821 -- Produce kinded binder constructors from the Haskell tyvar binders
822 --
823 repTyVarBndrWithKind :: LHsTyVarBndr Name
824 -> Core TH.Name -> DsM (Core TH.TyVarBndr)
825 repTyVarBndrWithKind (L _ (UserTyVar _)) nm
826 = repPlainTV nm
827 repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
828 = repLKind ki >>= repKindedTV nm
829
830 -- represent a type context
831 --
832 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
833 repLContext (L _ ctxt) = repContext ctxt
834
835 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
836 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
837 repCtxt preds
838
839 -- yield the representation of a list of types
840 --
841 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
842 repLTys tys = mapM repLTy tys
843
844 -- represent a type
845 --
846 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
847 repLTy (L _ ty) = repTy ty
848
849 repTy :: HsType Name -> DsM (Core TH.TypeQ)
850 repTy (HsForAllTy _ extra tvs ctxt ty) =
851 addTyVarBinds tvs $ \bndrs -> do
852 ctxt1 <- repLContext ctxt'
853 ty1 <- repLTy ty
854 repTForall bndrs ctxt1 ty1
855 where
856 -- If extra is not Nothing, an extra-constraints wild card was removed
857 -- (just) before renaming. It must be put back now, otherwise the
858 -- represented type won't include this extra-constraints wild card.
859 ctxt'
860 | Just loc <- extra
861 = let uniq = panic "addExtraCtsWC"
862 -- This unique will be discarded by repLContext, but is required
863 -- to make a Name
864 name = mkInternalName uniq (mkTyVarOcc "_") loc
865 in (++ [L loc (HsWildCardTy (AnonWildCard name))]) `fmap` ctxt
866 | otherwise
867 = ctxt
868
869
870
871 repTy (HsTyVar n)
872 | isTvOcc occ = do tv1 <- lookupOcc n
873 repTvar tv1
874 | isDataOcc occ = do tc1 <- lookupOcc n
875 repPromotedTyCon tc1
876 | otherwise = do tc1 <- lookupOcc n
877 repNamedTyCon tc1
878 where
879 occ = nameOccName n
880
881 repTy (HsAppTy f a) = do
882 f1 <- repLTy f
883 a1 <- repLTy a
884 repTapp f1 a1
885 repTy (HsFunTy f a) = do
886 f1 <- repLTy f
887 a1 <- repLTy a
888 tcon <- repArrowTyCon
889 repTapps tcon [f1, a1]
890 repTy (HsListTy t) = do
891 t1 <- repLTy t
892 tcon <- repListTyCon
893 repTapp tcon t1
894 repTy (HsPArrTy t) = do
895 t1 <- repLTy t
896 tcon <- repTy (HsTyVar (tyConName parrTyCon))
897 repTapp tcon t1
898 repTy (HsTupleTy HsUnboxedTuple tys) = do
899 tys1 <- repLTys tys
900 tcon <- repUnboxedTupleTyCon (length tys)
901 repTapps tcon tys1
902 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
903 tcon <- repTupleTyCon (length tys)
904 repTapps tcon tys1
905 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
906 `nlHsAppTy` ty2)
907 repTy (HsParTy t) = repLTy t
908 repTy (HsEqTy t1 t2) = do
909 t1' <- repLTy t1
910 t2' <- repLTy t2
911 eq <- repTequality
912 repTapps eq [t1', t2']
913 repTy (HsKindSig t k) = do
914 t1 <- repLTy t
915 k1 <- repLKind k
916 repTSig t1 k1
917 repTy (HsSpliceTy splice _) = repSplice splice
918 repTy (HsExplicitListTy _ tys) = do
919 tys1 <- repLTys tys
920 repTPromotedList tys1
921 repTy (HsExplicitTupleTy _ tys) = do
922 tys1 <- repLTys tys
923 tcon <- repPromotedTupleTyCon (length tys)
924 repTapps tcon tys1
925 repTy (HsTyLit lit) = do
926 lit' <- repTyLit lit
927 repTLit lit'
928 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
929 repTy (HsWildCardTy (NamedWildCard n)) = do
930 nwc <- lookupOcc n
931 repTNamedWildCard nwc
932
933 repTy ty = notHandled "Exotic form of type" (ppr ty)
934
935 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
936 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
937 rep2 numTyLitName [iExpr]
938 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
939 ; rep2 strTyLitName [s']
940 }
941
942 -- represent a kind
943 --
944 repLKind :: LHsKind Name -> DsM (Core TH.Kind)
945 repLKind ki
946 = do { let (kis, ki') = splitHsFunType ki
947 ; kis_rep <- mapM repLKind kis
948 ; ki'_rep <- repNonArrowLKind ki'
949 ; kcon <- repKArrow
950 ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
951 ; foldrM f ki'_rep kis_rep
952 }
953
954 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
955 repNonArrowLKind (L _ ki) = repNonArrowKind ki
956
957 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
958 repNonArrowKind (HsTyVar name)
959 | name == liftedTypeKindTyConName = repKStar
960 | name == constraintKindTyConName = repKConstraint
961 | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
962 | otherwise = lookupOcc name >>= repKCon
963 repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
964 ; a' <- repLKind a
965 ; repKApp f' a'
966 }
967 repNonArrowKind (HsListTy k) = do { k' <- repLKind k
968 ; kcon <- repKList
969 ; repKApp kcon k'
970 }
971 repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
972 ; kcon <- repKTuple (length ks)
973 ; repKApps kcon ks'
974 }
975 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
976
977 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
978 repRole (L _ (Just Nominal)) = rep2 nominalRName []
979 repRole (L _ (Just Representational)) = rep2 representationalRName []
980 repRole (L _ (Just Phantom)) = rep2 phantomRName []
981 repRole (L _ Nothing) = rep2 inferRName []
982
983 -----------------------------------------------------------------------------
984 -- Splices
985 -----------------------------------------------------------------------------
986
987 repSplice :: HsSplice Name -> DsM (Core a)
988 -- See Note [How brackets and nested splices are handled] in TcSplice
989 -- We return a CoreExpr of any old type; the context should know
990 repSplice (HsTypedSplice n _) = rep_splice n
991 repSplice (HsUntypedSplice n _) = rep_splice n
992 repSplice (HsQuasiQuote n _ _ _) = rep_splice n
993
994 rep_splice :: Name -> DsM (Core a)
995 rep_splice splice_name
996 = do { mb_val <- dsLookupMetaEnv splice_name
997 ; case mb_val of
998 Just (DsSplice e) -> do { e' <- dsExpr e
999 ; return (MkC e') }
1000 _ -> pprPanic "HsSplice" (ppr splice_name) }
1001 -- Should not happen; statically checked
1002
1003 -----------------------------------------------------------------------------
1004 -- Expressions
1005 -----------------------------------------------------------------------------
1006
1007 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
1008 repLEs es = repList expQTyConName repLE es
1009
1010 -- FIXME: some of these panics should be converted into proper error messages
1011 -- unless we can make sure that constructs, which are plainly not
1012 -- supported in TH already lead to error messages at an earlier stage
1013 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
1014 repLE (L loc e) = putSrcSpanDs loc (repE e)
1015
1016 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
1017 repE (HsVar x) =
1018 do { mb_val <- dsLookupMetaEnv x
1019 ; case mb_val of
1020 Nothing -> do { str <- globalVar x
1021 ; repVarOrCon x str }
1022 Just (DsBound y) -> repVarOrCon x (coreVar y)
1023 Just (DsSplice e) -> do { e' <- dsExpr e
1024 ; return (MkC e') } }
1025 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
1026
1027 -- Remember, we're desugaring renamer output here, so
1028 -- HsOverlit can definitely occur
1029 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
1030 repE (HsLit l) = do { a <- repLiteral l; repLit a }
1031 repE (HsLam (MG { mg_alts = [m] })) = repLambda m
1032 repE (HsLamCase _ (MG { mg_alts = ms }))
1033 = do { ms' <- mapM repMatchTup ms
1034 ; core_ms <- coreList matchQTyConName ms'
1035 ; repLamCase core_ms }
1036 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1037
1038 repE (OpApp e1 op _ e2) =
1039 do { arg1 <- repLE e1;
1040 arg2 <- repLE e2;
1041 the_op <- repLE op ;
1042 repInfixApp arg1 the_op arg2 }
1043 repE (NegApp x _) = do
1044 a <- repLE x
1045 negateVar <- lookupOcc negateName >>= repVar
1046 negateVar `repApp` a
1047 repE (HsPar x) = repLE x
1048 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1049 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1050 repE (HsCase e (MG { mg_alts = ms }))
1051 = do { arg <- repLE e
1052 ; ms2 <- mapM repMatchTup ms
1053 ; core_ms2 <- coreList matchQTyConName ms2
1054 ; repCaseE arg core_ms2 }
1055 repE (HsIf _ x y z) = do
1056 a <- repLE x
1057 b <- repLE y
1058 c <- repLE z
1059 repCond a b c
1060 repE (HsMultiIf _ alts)
1061 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1062 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1063 ; wrapGenSyms (concat binds) expr' }
1064 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
1065 ; e2 <- addBinds ss (repLE e)
1066 ; z <- repLetE ds e2
1067 ; wrapGenSyms ss z }
1068
1069 -- FIXME: I haven't got the types here right yet
1070 repE e@(HsDo ctxt sts _)
1071 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1072 = do { (ss,zs) <- repLSts sts;
1073 e' <- repDoE (nonEmptyCoreList zs);
1074 wrapGenSyms ss e' }
1075
1076 | ListComp <- ctxt
1077 = do { (ss,zs) <- repLSts sts;
1078 e' <- repComp (nonEmptyCoreList zs);
1079 wrapGenSyms ss e' }
1080
1081 | otherwise
1082 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
1083
1084 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1085 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
1086 repE e@(ExplicitTuple es boxed)
1087 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1088 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
1089 | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
1090 ; repUnboxedTup xs }
1091
1092 repE (RecordCon c _ flds)
1093 = do { x <- lookupLOcc c;
1094 fs <- repFields flds;
1095 repRecCon x fs }
1096 repE (RecordUpd e flds _ _ _)
1097 = do { x <- repLE e;
1098 fs <- repFields flds;
1099 repRecUpd x fs }
1100
1101 repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
1102 repE (ArithSeq _ _ aseq) =
1103 case aseq of
1104 From e -> do { ds1 <- repLE e; repFrom ds1 }
1105 FromThen e1 e2 -> do
1106 ds1 <- repLE e1
1107 ds2 <- repLE e2
1108 repFromThen ds1 ds2
1109 FromTo e1 e2 -> do
1110 ds1 <- repLE e1
1111 ds2 <- repLE e2
1112 repFromTo ds1 ds2
1113 FromThenTo e1 e2 e3 -> do
1114 ds1 <- repLE e1
1115 ds2 <- repLE e2
1116 ds3 <- repLE e3
1117 repFromThenTo ds1 ds2 ds3
1118
1119 repE (HsSpliceE splice) = repSplice splice
1120 repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
1121 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1122 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1123 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1124 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1125 repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
1126 repE e = notHandled "Expression form" (ppr e)
1127
1128 -----------------------------------------------------------------------------
1129 -- Building representations of auxillary structures like Match, Clause, Stmt,
1130
1131 repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
1132 repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
1133 do { ss1 <- mkGenSyms (collectPatBinders p)
1134 ; addBinds ss1 $ do {
1135 ; p1 <- repLP p
1136 ; (ss2,ds) <- repBinds wheres
1137 ; addBinds ss2 $ do {
1138 ; gs <- repGuards guards
1139 ; match <- repMatch p1 gs ds
1140 ; wrapGenSyms (ss1++ss2) match }}}
1141 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1142
1143 repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
1144 repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =
1145 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1146 ; addBinds ss1 $ do {
1147 ps1 <- repLPs ps
1148 ; (ss2,ds) <- repBinds wheres
1149 ; addBinds ss2 $ do {
1150 gs <- repGuards guards
1151 ; clause <- repClause ps1 gs ds
1152 ; wrapGenSyms (ss1++ss2) clause }}}
1153
1154 repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
1155 repGuards [L _ (GRHS [] e)]
1156 = do {a <- repLE e; repNormal a }
1157 repGuards other
1158 = do { zs <- mapM repLGRHS other
1159 ; let (xs, ys) = unzip zs
1160 ; gd <- repGuarded (nonEmptyCoreList ys)
1161 ; wrapGenSyms (concat xs) gd }
1162
1163 repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1164 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1165 = do { guarded <- repLNormalGE e1 e2
1166 ; return ([], guarded) }
1167 repLGRHS (L _ (GRHS ss rhs))
1168 = do { (gs, ss') <- repLSts ss
1169 ; rhs' <- addBinds gs $ repLE rhs
1170 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1171 ; return (gs, guarded) }
1172
1173 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
1174 repFields (HsRecFields { rec_flds = flds })
1175 = repList fieldExpQTyConName rep_fld flds
1176 where
1177 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)
1178 ; e <- repLE (hsRecFieldArg fld)
1179 ; repFieldExp fn e }
1180
1181
1182 -----------------------------------------------------------------------------
1183 -- Representing Stmt's is tricky, especially if bound variables
1184 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1185 -- First gensym new names for every variable in any of the patterns.
1186 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1187 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1188 -- and we could reuse the original names (x and x).
1189 --
1190 -- do { x'1 <- gensym "x"
1191 -- ; x'2 <- gensym "x"
1192 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1193 -- , BindSt (pvar x'2) [| f x |]
1194 -- , NoBindSt [| g x |]
1195 -- ]
1196 -- }
1197
1198 -- The strategy is to translate a whole list of do-bindings by building a
1199 -- bigger environment, and a bigger set of meta bindings
1200 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1201 -- of the expressions within the Do
1202
1203 -----------------------------------------------------------------------------
1204 -- The helper function repSts computes the translation of each sub expression
1205 -- and a bunch of prefix bindings denoting the dynamic renaming.
1206
1207 repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1208 repLSts stmts = repSts (map unLoc stmts)
1209
1210 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1211 repSts (BindStmt p e _ _ : ss) =
1212 do { e2 <- repLE e
1213 ; ss1 <- mkGenSyms (collectPatBinders p)
1214 ; addBinds ss1 $ do {
1215 ; p1 <- repLP p;
1216 ; (ss2,zs) <- repSts ss
1217 ; z <- repBindSt p1 e2
1218 ; return (ss1++ss2, z : zs) }}
1219 repSts (LetStmt bs : ss) =
1220 do { (ss1,ds) <- repBinds bs
1221 ; z <- repLetSt ds
1222 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1223 ; return (ss1++ss2, z : zs) }
1224 repSts (BodyStmt e _ _ _ : ss) =
1225 do { e2 <- repLE e
1226 ; z <- repNoBindSt e2
1227 ; (ss2,zs) <- repSts ss
1228 ; return (ss2, z : zs) }
1229 repSts (ParStmt stmt_blocks _ _ : ss) =
1230 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1231 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1232 ss1 = concat ss_s
1233 ; z <- repParSt stmt_blocks2
1234 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1235 ; return (ss1++ss2, z : zs) }
1236 where
1237 rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])
1238 rep_stmt_block (ParStmtBlock stmts _ _) =
1239 do { (ss1, zs) <- repSts (map unLoc stmts)
1240 ; zs1 <- coreList stmtQTyConName zs
1241 ; return (ss1, zs1) }
1242 repSts [LastStmt e _]
1243 = do { e2 <- repLE e
1244 ; z <- repNoBindSt e2
1245 ; return ([], [z]) }
1246 repSts [] = return ([],[])
1247 repSts other = notHandled "Exotic statement" (ppr other)
1248
1249
1250 -----------------------------------------------------------
1251 -- Bindings
1252 -----------------------------------------------------------
1253
1254 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1255 repBinds EmptyLocalBinds
1256 = do { core_list <- coreList decQTyConName []
1257 ; return ([], core_list) }
1258
1259 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1260
1261 repBinds (HsValBinds decs)
1262 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1263 -- No need to worrry about detailed scopes within
1264 -- the binding group, because we are talking Names
1265 -- here, so we can safely treat it as a mutually
1266 -- recursive group
1267 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1268 ; ss <- mkGenSyms bndrs
1269 ; prs <- addBinds ss (rep_val_binds decs)
1270 ; core_list <- coreList decQTyConName
1271 (de_loc (sort_by_loc prs))
1272 ; return (ss, core_list) }
1273
1274 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1275 -- Assumes: all the binders of the binding are alrady in the meta-env
1276 rep_val_binds (ValBindsOut binds sigs)
1277 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1278 ; core2 <- rep_sigs' sigs
1279 ; return (core1 ++ core2) }
1280 rep_val_binds (ValBindsIn _ _)
1281 = panic "rep_val_binds: ValBindsIn"
1282
1283 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1284 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1285 ; return (de_loc (sort_by_loc binds_w_locs)) }
1286
1287 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1288 rep_binds' = mapM rep_bind . bagToList
1289
1290 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1291 -- Assumes: all the binders of the binding are alrady in the meta-env
1292
1293 -- Note GHC treats declarations of a variable (not a pattern)
1294 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1295 -- with an empty list of patterns
1296 rep_bind (L loc (FunBind
1297 { fun_id = fn,
1298 fun_matches = MG { mg_alts = [L _ (Match _ [] _
1299 (GRHSs guards wheres))] } }))
1300 = do { (ss,wherecore) <- repBinds wheres
1301 ; guardcore <- addBinds ss (repGuards guards)
1302 ; fn' <- lookupLBinder fn
1303 ; p <- repPvar fn'
1304 ; ans <- repVal p guardcore wherecore
1305 ; ans' <- wrapGenSyms ss ans
1306 ; return (loc, ans') }
1307
1308 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
1309 = do { ms1 <- mapM repClauseTup ms
1310 ; fn' <- lookupLBinder fn
1311 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1312 ; return (loc, ans) }
1313
1314 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1315 = do { patcore <- repLP pat
1316 ; (ss,wherecore) <- repBinds wheres
1317 ; guardcore <- addBinds ss (repGuards guards)
1318 ; ans <- repVal patcore guardcore wherecore
1319 ; ans' <- wrapGenSyms ss ans
1320 ; return (loc, ans') }
1321
1322 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1323 = do { v' <- lookupBinder v
1324 ; e2 <- repLE e
1325 ; x <- repNormal e2
1326 ; patcore <- repPvar v'
1327 ; empty_decls <- coreList decQTyConName []
1328 ; ans <- repVal patcore x empty_decls
1329 ; return (srcLocSpan (getSrcLoc v), ans) }
1330
1331 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1332 rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
1333 -----------------------------------------------------------------------------
1334 -- Since everything in a Bind is mutually recursive we need rename all
1335 -- all the variables simultaneously. For example:
1336 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1337 -- do { f'1 <- gensym "f"
1338 -- ; g'2 <- gensym "g"
1339 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1340 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1341 -- ]}
1342 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1343 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1344 -- together. As we do this we collect GenSymBinds's which represent the renamed
1345 -- variables bound by the Bindings. In order not to lose track of these
1346 -- representations we build a shadow datatype MB with the same structure as
1347 -- MonoBinds, but which has slots for the representations
1348
1349
1350 -----------------------------------------------------------------------------
1351 -- GHC allows a more general form of lambda abstraction than specified
1352 -- by Haskell 98. In particular it allows guarded lambda's like :
1353 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1354 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1355 -- (\ p1 .. pn -> exp) by causing an error.
1356
1357 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
1358 repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1359 = do { let bndrs = collectPatsBinders ps ;
1360 ; ss <- mkGenSyms bndrs
1361 ; lam <- addBinds ss (
1362 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1363 ; wrapGenSyms ss lam }
1364
1365 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1366
1367
1368 -----------------------------------------------------------------------------
1369 -- Patterns
1370 -- repP deals with patterns. It assumes that we have already
1371 -- walked over the pattern(s) once to collect the binders, and
1372 -- have extended the environment. So every pattern-bound
1373 -- variable should already appear in the environment.
1374
1375 -- Process a list of patterns
1376 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1377 repLPs ps = repList patQTyConName repLP ps
1378
1379 repLP :: LPat Name -> DsM (Core TH.PatQ)
1380 repLP (L _ p) = repP p
1381
1382 repP :: Pat Name -> DsM (Core TH.PatQ)
1383 repP (WildPat _) = repPwild
1384 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1385 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1386 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1387 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1388 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1389 repP (ParPat p) = repLP p
1390 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1391 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
1392 repP (TuplePat ps boxed _)
1393 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1394 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1395 repP (ConPatIn dc details)
1396 = do { con_str <- lookupLOcc dc
1397 ; case details of
1398 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1399 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1400 ; repPrec con_str fps }
1401 InfixCon p1 p2 -> do { p1' <- repLP p1;
1402 p2' <- repLP p2;
1403 repPinfix p1' con_str p2' }
1404 }
1405 where
1406 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)
1407 ; MkC p <- repLP (hsRecFieldArg fld)
1408 ; rep2 fieldPatName [v,p] }
1409
1410 repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1411 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1412 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1413 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1414 -- The problem is to do with scoped type variables.
1415 -- To implement them, we have to implement the scoping rules
1416 -- here in DsMeta, and I don't want to do that today!
1417 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1418 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1419 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1420
1421 repP (SplicePat splice) = repSplice splice
1422
1423 repP other = notHandled "Exotic pattern" (ppr other)
1424
1425 ----------------------------------------------------------
1426 -- Declaration ordering helpers
1427
1428 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1429 sort_by_loc xs = sortBy comp xs
1430 where comp x y = compare (fst x) (fst y)
1431
1432 de_loc :: [(a, b)] -> [b]
1433 de_loc = map snd
1434
1435 ----------------------------------------------------------
1436 -- The meta-environment
1437
1438 -- A name/identifier association for fresh names of locally bound entities
1439 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1440 -- I.e. (x, x_id) means
1441 -- let x_id = gensym "x" in ...
1442
1443 -- Generate a fresh name for a locally bound entity
1444
1445 mkGenSyms :: [Name] -> DsM [GenSymBind]
1446 -- We can use the existing name. For example:
1447 -- [| \x_77 -> x_77 + x_77 |]
1448 -- desugars to
1449 -- do { x_77 <- genSym "x"; .... }
1450 -- We use the same x_77 in the desugared program, but with the type Bndr
1451 -- instead of Int
1452 --
1453 -- We do make it an Internal name, though (hence localiseName)
1454 --
1455 -- Nevertheless, it's monadic because we have to generate nameTy
1456 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1457 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1458
1459
1460 addBinds :: [GenSymBind] -> DsM a -> DsM a
1461 -- Add a list of fresh names for locally bound entities to the
1462 -- meta environment (which is part of the state carried around
1463 -- by the desugarer monad)
1464 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1465
1466 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1467 dupBinder (new, old)
1468 = do { mb_val <- dsLookupMetaEnv old
1469 ; case mb_val of
1470 Just val -> return (new, val)
1471 Nothing -> pprPanic "dupBinder" (ppr old) }
1472
1473 -- Look up a locally bound name
1474 --
1475 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1476 lookupLBinder (L _ n) = lookupBinder n
1477
1478 lookupBinder :: Name -> DsM (Core TH.Name)
1479 lookupBinder = lookupOcc
1480 -- Binders are brought into scope before the pattern or what-not is
1481 -- desugared. Moreover, in instance declaration the binder of a method
1482 -- will be the selector Id and hence a global; so we need the
1483 -- globalVar case of lookupOcc
1484
1485 -- Look up a name that is either locally bound or a global name
1486 --
1487 -- * If it is a global name, generate the "original name" representation (ie,
1488 -- the <module>:<name> form) for the associated entity
1489 --
1490 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1491 -- Lookup an occurrence; it can't be a splice.
1492 -- Use the in-scope bindings if they exist
1493 lookupLOcc (L _ n) = lookupOcc n
1494
1495 lookupOcc :: Name -> DsM (Core TH.Name)
1496 lookupOcc n
1497 = do { mb_val <- dsLookupMetaEnv n ;
1498 case mb_val of
1499 Nothing -> globalVar n
1500 Just (DsBound x) -> return (coreVar x)
1501 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1502 }
1503
1504 globalVar :: Name -> DsM (Core TH.Name)
1505 -- Not bound by the meta-env
1506 -- Could be top-level; or could be local
1507 -- f x = $(g [| x |])
1508 -- Here the x will be local
1509 globalVar name
1510 | isExternalName name
1511 = do { MkC mod <- coreStringLit name_mod
1512 ; MkC pkg <- coreStringLit name_pkg
1513 ; MkC occ <- occNameLit name
1514 ; rep2 mk_varg [pkg,mod,occ] }
1515 | otherwise
1516 = do { MkC occ <- occNameLit name
1517 ; MkC uni <- coreIntLit (getKey (getUnique name))
1518 ; rep2 mkNameLName [occ,uni] }
1519 where
1520 mod = ASSERT( isExternalName name) nameModule name
1521 name_mod = moduleNameString (moduleName mod)
1522 name_pkg = packageKeyString (modulePackageKey mod)
1523 name_occ = nameOccName name
1524 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1525 | OccName.isVarOcc name_occ = mkNameG_vName
1526 | OccName.isTcOcc name_occ = mkNameG_tcName
1527 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1528
1529 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1530 -> DsM Type -- The type
1531 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1532 return (mkTyConApp tc []) }
1533
1534 wrapGenSyms :: [GenSymBind]
1535 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1536 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1537 -- --> bindQ (gensym nm1) (\ id1 ->
1538 -- bindQ (gensym nm2 (\ id2 ->
1539 -- y))
1540
1541 wrapGenSyms binds body@(MkC b)
1542 = do { var_ty <- lookupType nameTyConName
1543 ; go var_ty binds }
1544 where
1545 [elt_ty] = tcTyConAppArgs (exprType b)
1546 -- b :: Q a, so we can get the type 'a' by looking at the
1547 -- argument type. NB: this relies on Q being a data/newtype,
1548 -- not a type synonym
1549
1550 go _ [] = return body
1551 go var_ty ((name,id) : binds)
1552 = do { MkC body' <- go var_ty binds
1553 ; lit_str <- occNameLit name
1554 ; gensym_app <- repGensym lit_str
1555 ; repBindQ var_ty elt_ty
1556 gensym_app (MkC (Lam id body')) }
1557
1558 occNameLit :: Name -> DsM (Core String)
1559 occNameLit n = coreStringLit (occNameString (nameOccName n))
1560
1561
1562 -- %*********************************************************************
1563 -- %* *
1564 -- Constructing code
1565 -- %* *
1566 -- %*********************************************************************
1567
1568 -----------------------------------------------------------------------------
1569 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1570 -- we invent a new datatype which uses phantom types.
1571
1572 newtype Core a = MkC CoreExpr
1573 unC :: Core a -> CoreExpr
1574 unC (MkC x) = x
1575
1576 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1577 rep2 n xs = do { id <- dsLookupGlobalId n
1578 ; return (MkC (foldl App (Var id) xs)) }
1579
1580 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1581 dataCon' n args = do { id <- dsLookupDataCon n
1582 ; return $ MkC $ mkCoreConApps id args }
1583
1584 dataCon :: Name -> DsM (Core a)
1585 dataCon n = dataCon' n []
1586
1587 -- Then we make "repConstructors" which use the phantom types for each of the
1588 -- smart constructors of the Meta.Meta datatypes.
1589
1590
1591 -- %*********************************************************************
1592 -- %* *
1593 -- The 'smart constructors'
1594 -- %* *
1595 -- %*********************************************************************
1596
1597 --------------- Patterns -----------------
1598 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1599 repPlit (MkC l) = rep2 litPName [l]
1600
1601 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1602 repPvar (MkC s) = rep2 varPName [s]
1603
1604 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1605 repPtup (MkC ps) = rep2 tupPName [ps]
1606
1607 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1608 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1609
1610 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1611 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1612
1613 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1614 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1615
1616 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1617 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1618
1619 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1620 repPtilde (MkC p) = rep2 tildePName [p]
1621
1622 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1623 repPbang (MkC p) = rep2 bangPName [p]
1624
1625 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1626 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1627
1628 repPwild :: DsM (Core TH.PatQ)
1629 repPwild = rep2 wildPName []
1630
1631 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1632 repPlist (MkC ps) = rep2 listPName [ps]
1633
1634 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1635 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1636
1637 --------------- Expressions -----------------
1638 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1639 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1640 | otherwise = repVar str
1641
1642 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1643 repVar (MkC s) = rep2 varEName [s]
1644
1645 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1646 repCon (MkC s) = rep2 conEName [s]
1647
1648 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1649 repLit (MkC c) = rep2 litEName [c]
1650
1651 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1652 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1653
1654 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1655 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1656
1657 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1658 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1659
1660 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1661 repTup (MkC es) = rep2 tupEName [es]
1662
1663 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1664 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1665
1666 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1667 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1668
1669 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1670 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1671
1672 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1673 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1674
1675 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1676 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1677
1678 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1679 repDoE (MkC ss) = rep2 doEName [ss]
1680
1681 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1682 repComp (MkC ss) = rep2 compEName [ss]
1683
1684 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1685 repListExp (MkC es) = rep2 listEName [es]
1686
1687 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1688 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1689
1690 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1691 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1692
1693 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1694 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1695
1696 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1697 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1698
1699 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1700 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1701
1702 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1703 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1704
1705 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1706 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1707
1708 ------------ Right hand sides (guarded expressions) ----
1709 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1710 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1711
1712 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1713 repNormal (MkC e) = rep2 normalBName [e]
1714
1715 ------------ Guards ----
1716 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1717 repLNormalGE g e = do g' <- repLE g
1718 e' <- repLE e
1719 repNormalGE g' e'
1720
1721 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1722 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1723
1724 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1725 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1726
1727 ------------- Stmts -------------------
1728 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1729 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1730
1731 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1732 repLetSt (MkC ds) = rep2 letSName [ds]
1733
1734 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1735 repNoBindSt (MkC e) = rep2 noBindSName [e]
1736
1737 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
1738 repParSt (MkC sss) = rep2 parSName [sss]
1739
1740 -------------- Range (Arithmetic sequences) -----------
1741 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1742 repFrom (MkC x) = rep2 fromEName [x]
1743
1744 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1745 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1746
1747 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1748 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1749
1750 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1751 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1752
1753 ------------ Match and Clause Tuples -----------
1754 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1755 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1756
1757 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1758 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1759
1760 -------------- Dec -----------------------------
1761 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1762 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1763
1764 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1765 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1766
1767 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1768 -> Maybe (Core [TH.TypeQ])
1769 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1770 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1771 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1772 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1773 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1774
1775 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1776 -> Maybe (Core [TH.TypeQ])
1777 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1778 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1779 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1780 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1781 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1782
1783 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1784 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1785 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
1786 = rep2 tySynDName [nm, tvs, rhs]
1787
1788 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1789 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1790
1791 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1792 -> Core [TH.FunDep] -> Core [TH.DecQ]
1793 -> DsM (Core TH.DecQ)
1794 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1795 = rep2 classDName [cxt, cls, tvs, fds, ds]
1796
1797 repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1798 repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]
1799
1800 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
1801 -> Core TH.Phases -> DsM (Core TH.DecQ)
1802 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
1803 = rep2 pragInlDName [nm, inline, rm, phases]
1804
1805 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
1806 -> DsM (Core TH.DecQ)
1807 repPragSpec (MkC nm) (MkC ty) (MkC phases)
1808 = rep2 pragSpecDName [nm, ty, phases]
1809
1810 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
1811 -> Core TH.Phases -> DsM (Core TH.DecQ)
1812 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
1813 = rep2 pragSpecInlDName [nm, ty, inline, phases]
1814
1815 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
1816 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
1817
1818 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
1819 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
1820 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
1821 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
1822
1823 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
1824 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
1825
1826 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1827 -> DsM (Core TH.DecQ)
1828 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1829 = rep2 familyNoKindDName [flav, nm, tvs]
1830
1831 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1832 -> Core TH.Kind
1833 -> DsM (Core TH.DecQ)
1834 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1835 = rep2 familyKindDName [flav, nm, tvs, ki]
1836
1837 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
1838 repTySynInst (MkC nm) (MkC eqn)
1839 = rep2 tySynInstDName [nm, eqn]
1840
1841 repClosedFamilyNoKind :: Core TH.Name
1842 -> Core [TH.TyVarBndr]
1843 -> Core [TH.TySynEqnQ]
1844 -> DsM (Core TH.DecQ)
1845 repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
1846 = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
1847
1848 repClosedFamilyKind :: Core TH.Name
1849 -> Core [TH.TyVarBndr]
1850 -> Core TH.Kind
1851 -> Core [TH.TySynEqnQ]
1852 -> DsM (Core TH.DecQ)
1853 repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
1854 = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
1855
1856 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
1857 repTySynEqn (MkC lhs) (MkC rhs)
1858 = rep2 tySynEqnName [lhs, rhs]
1859
1860 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
1861 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
1862
1863 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1864 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1865
1866 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1867 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
1868
1869 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1870 repCtxt (MkC tys) = rep2 cxtName [tys]
1871
1872 repConstr :: Core TH.Name -> HsConDeclDetails Name
1873 -> DsM (Core TH.ConQ)
1874 repConstr con (PrefixCon ps)
1875 = do arg_tys <- repList strictTypeQTyConName repBangTy ps
1876 rep2 normalCName [unC con, unC arg_tys]
1877
1878 repConstr con (RecCon (L _ ips))
1879 = do { args <- concatMapM rep_ip ips
1880 ; arg_vtys <- coreList varStrictTypeQTyConName args
1881 ; rep2 recCName [unC con, unC arg_vtys] }
1882 where
1883 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
1884 rep_one_ip t n = do { MkC v <- lookupLOcc n
1885 ; MkC ty <- repBangTy t
1886 ; rep2 varStrictTypeName [v,ty] }
1887
1888 repConstr con (InfixCon st1 st2)
1889 = do arg1 <- repBangTy st1
1890 arg2 <- repBangTy st2
1891 rep2 infixCName [unC arg1, unC con, unC arg2]
1892
1893 ------------ Types -------------------
1894
1895 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1896 -> DsM (Core TH.TypeQ)
1897 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1898 = rep2 forallTName [tvars, ctxt, ty]
1899
1900 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1901 repTvar (MkC s) = rep2 varTName [s]
1902
1903 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1904 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1905
1906 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1907 repTapps f [] = return f
1908 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1909
1910 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1911 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1912
1913 repTequality :: DsM (Core TH.TypeQ)
1914 repTequality = rep2 equalityTName []
1915
1916 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1917 repTPromotedList [] = repPromotedNilTyCon
1918 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
1919 ; f <- repTapp tcon t
1920 ; t' <- repTPromotedList ts
1921 ; repTapp f t'
1922 }
1923
1924 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
1925 repTLit (MkC lit) = rep2 litTName [lit]
1926
1927 repTWildCard :: DsM (Core TH.TypeQ)
1928 repTWildCard = rep2 wildCardTName []
1929
1930 repTNamedWildCard :: Core TH.Name -> DsM (Core TH.TypeQ)
1931 repTNamedWildCard (MkC s) = rep2 namedWildCardTName [s]
1932
1933
1934 --------- Type constructors --------------
1935
1936 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1937 repNamedTyCon (MkC s) = rep2 conTName [s]
1938
1939 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1940 -- Note: not Core Int; it's easier to be direct here
1941 repTupleTyCon i = do dflags <- getDynFlags
1942 rep2 tupleTName [mkIntExprInt dflags i]
1943
1944 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1945 -- Note: not Core Int; it's easier to be direct here
1946 repUnboxedTupleTyCon i = do dflags <- getDynFlags
1947 rep2 unboxedTupleTName [mkIntExprInt dflags i]
1948
1949 repArrowTyCon :: DsM (Core TH.TypeQ)
1950 repArrowTyCon = rep2 arrowTName []
1951
1952 repListTyCon :: DsM (Core TH.TypeQ)
1953 repListTyCon = rep2 listTName []
1954
1955 repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1956 repPromotedTyCon (MkC s) = rep2 promotedTName [s]
1957
1958 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1959 repPromotedTupleTyCon i = do dflags <- getDynFlags
1960 rep2 promotedTupleTName [mkIntExprInt dflags i]
1961
1962 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
1963 repPromotedNilTyCon = rep2 promotedNilTName []
1964
1965 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
1966 repPromotedConsTyCon = rep2 promotedConsTName []
1967
1968 ------------ Kinds -------------------
1969
1970 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1971 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1972
1973 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1974 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1975
1976 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
1977 repKVar (MkC s) = rep2 varKName [s]
1978
1979 repKCon :: Core TH.Name -> DsM (Core TH.Kind)
1980 repKCon (MkC s) = rep2 conKName [s]
1981
1982 repKTuple :: Int -> DsM (Core TH.Kind)
1983 repKTuple i = do dflags <- getDynFlags
1984 rep2 tupleKName [mkIntExprInt dflags i]
1985
1986 repKArrow :: DsM (Core TH.Kind)
1987 repKArrow = rep2 arrowKName []
1988
1989 repKList :: DsM (Core TH.Kind)
1990 repKList = rep2 listKName []
1991
1992 repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1993 repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
1994
1995 repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
1996 repKApps f [] = return f
1997 repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
1998
1999 repKStar :: DsM (Core TH.Kind)
2000 repKStar = rep2 starKName []
2001
2002 repKConstraint :: DsM (Core TH.Kind)
2003 repKConstraint = rep2 constraintKName []
2004
2005 ----------------------------------------------------------
2006 -- Literals
2007
2008 repLiteral :: HsLit -> DsM (Core TH.Lit)
2009 repLiteral (HsStringPrim _ bs)
2010 = do dflags <- getDynFlags
2011 word8_ty <- lookupType word8TyConName
2012 let w8s = unpack bs
2013 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2014 [mkWordLit dflags (toInteger w8)]) w8s
2015 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2016 repLiteral lit
2017 = do lit' <- case lit of
2018 HsIntPrim _ i -> mk_integer i
2019 HsWordPrim _ w -> mk_integer w
2020 HsInt _ i -> mk_integer i
2021 HsFloatPrim r -> mk_rational r
2022 HsDoublePrim r -> mk_rational r
2023 HsCharPrim _ c -> mk_char c
2024 _ -> return lit
2025 lit_expr <- dsLit lit'
2026 case mb_lit_name of
2027 Just lit_name -> rep2 lit_name [lit_expr]
2028 Nothing -> notHandled "Exotic literal" (ppr lit)
2029 where
2030 mb_lit_name = case lit of
2031 HsInteger _ _ _ -> Just integerLName
2032 HsInt _ _ -> Just integerLName
2033 HsIntPrim _ _ -> Just intPrimLName
2034 HsWordPrim _ _ -> Just wordPrimLName
2035 HsFloatPrim _ -> Just floatPrimLName
2036 HsDoublePrim _ -> Just doublePrimLName
2037 HsChar _ _ -> Just charLName
2038 HsCharPrim _ _ -> Just charPrimLName
2039 HsString _ _ -> Just stringLName
2040 HsRat _ _ -> Just rationalLName
2041 _ -> Nothing
2042
2043 mk_integer :: Integer -> DsM HsLit
2044 mk_integer i = do integer_ty <- lookupType integerTyConName
2045 return $ HsInteger "" i integer_ty
2046 mk_rational :: FractionalLit -> DsM HsLit
2047 mk_rational r = do rat_ty <- lookupType rationalTyConName
2048 return $ HsRat r rat_ty
2049 mk_string :: FastString -> DsM HsLit
2050 mk_string s = return $ HsString "" s
2051
2052 mk_char :: Char -> DsM HsLit
2053 mk_char c = return $ HsChar "" c
2054
2055 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
2056 repOverloadedLiteral (OverLit { ol_val = val})
2057 = do { lit <- mk_lit val; repLiteral lit }
2058 -- The type Rational will be in the environment, because
2059 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2060 -- and rationalL is sucked in when any TH stuff is used
2061
2062 mk_lit :: OverLitVal -> DsM HsLit
2063 mk_lit (HsIntegral _ i) = mk_integer i
2064 mk_lit (HsFractional f) = mk_rational f
2065 mk_lit (HsIsString _ s) = mk_string s
2066
2067 --------------- Miscellaneous -------------------
2068
2069 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2070 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2071
2072 repBindQ :: Type -> Type -- a and b
2073 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2074 repBindQ ty_a ty_b (MkC x) (MkC y)
2075 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2076
2077 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2078 repSequenceQ ty_a (MkC list)
2079 = rep2 sequenceQName [Type ty_a, list]
2080
2081 ------------ Lists and Tuples -------------------
2082 -- turn a list of patterns into a single pattern matching a list
2083
2084 repList :: Name -> (a -> DsM (Core b))
2085 -> [a] -> DsM (Core [b])
2086 repList tc_name f args
2087 = do { args1 <- mapM f args
2088 ; coreList tc_name args1 }
2089
2090 coreList :: Name -- Of the TyCon of the element type
2091 -> [Core a] -> DsM (Core [a])
2092 coreList tc_name es
2093 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2094
2095 coreList' :: Type -- The element type
2096 -> [Core a] -> Core [a]
2097 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2098
2099 nonEmptyCoreList :: [Core a] -> Core [a]
2100 -- The list must be non-empty so we can get the element type
2101 -- Otherwise use coreList
2102 nonEmptyCoreList [] = panic "coreList: empty argument"
2103 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2104
2105 coreStringLit :: String -> DsM (Core String)
2106 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2107
2108 ------------ Literals & Variables -------------------
2109
2110 coreIntLit :: Int -> DsM (Core Int)
2111 coreIntLit i = do dflags <- getDynFlags
2112 return (MkC (mkIntExprInt dflags i))
2113
2114 coreVar :: Id -> Core TH.Name -- The Id has type Name
2115 coreVar id = MkC (Var id)
2116
2117 ----------------- Failure -----------------------
2118 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2119 notHandledL loc what doc
2120 | isGoodSrcSpan loc
2121 = putSrcSpanDs loc $ notHandled what doc
2122 | otherwise
2123 = notHandled what doc
2124
2125 notHandled :: String -> SDoc -> DsM a
2126 notHandled what doc = failWithDs msg
2127 where
2128 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
2129 2 doc
2130
2131