b9805ac58b03744894ab3d5ad955fcca1aa6a546
[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 _ _ tvs ctxt ty) =
851 addTyVarBinds tvs $ \bndrs -> do
852 ctxt1 <- repLContext ctxt
853 ty1 <- repLTy ty
854 repTForall bndrs ctxt1 ty1
855
856 repTy (HsTyVar n)
857 | isTvOcc occ = do tv1 <- lookupOcc n
858 repTvar tv1
859 | isDataOcc occ = do tc1 <- lookupOcc n
860 repPromotedTyCon tc1
861 | otherwise = do tc1 <- lookupOcc n
862 repNamedTyCon tc1
863 where
864 occ = nameOccName n
865
866 repTy (HsAppTy f a) = do
867 f1 <- repLTy f
868 a1 <- repLTy a
869 repTapp f1 a1
870 repTy (HsFunTy f a) = do
871 f1 <- repLTy f
872 a1 <- repLTy a
873 tcon <- repArrowTyCon
874 repTapps tcon [f1, a1]
875 repTy (HsListTy t) = do
876 t1 <- repLTy t
877 tcon <- repListTyCon
878 repTapp tcon t1
879 repTy (HsPArrTy t) = do
880 t1 <- repLTy t
881 tcon <- repTy (HsTyVar (tyConName parrTyCon))
882 repTapp tcon t1
883 repTy (HsTupleTy HsUnboxedTuple tys) = do
884 tys1 <- repLTys tys
885 tcon <- repUnboxedTupleTyCon (length tys)
886 repTapps tcon tys1
887 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
888 tcon <- repTupleTyCon (length tys)
889 repTapps tcon tys1
890 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
891 `nlHsAppTy` ty2)
892 repTy (HsParTy t) = repLTy t
893 repTy (HsEqTy t1 t2) = do
894 t1' <- repLTy t1
895 t2' <- repLTy t2
896 eq <- repTequality
897 repTapps eq [t1', t2']
898 repTy (HsKindSig t k) = do
899 t1 <- repLTy t
900 k1 <- repLKind k
901 repTSig t1 k1
902 repTy (HsSpliceTy splice _) = repSplice splice
903 repTy (HsExplicitListTy _ tys) = do
904 tys1 <- repLTys tys
905 repTPromotedList tys1
906 repTy (HsExplicitTupleTy _ tys) = do
907 tys1 <- repLTys tys
908 tcon <- repPromotedTupleTyCon (length tys)
909 repTapps tcon tys1
910 repTy (HsTyLit lit) = do
911 lit' <- repTyLit lit
912 repTLit lit'
913 repTy (HsWildCardTy wc) = do
914 let name = HsSyn.wildCardName wc
915 putSrcSpanDs (nameSrcSpan name) $
916 failWithDs $ text "Unexpected wild card:" <+>
917 quotes (ppr name)
918
919 repTy ty = notHandled "Exotic form of type" (ppr ty)
920
921 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
922 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
923 rep2 numTyLitName [iExpr]
924 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
925 ; rep2 strTyLitName [s']
926 }
927
928 -- represent a kind
929 --
930 repLKind :: LHsKind Name -> DsM (Core TH.Kind)
931 repLKind ki
932 = do { let (kis, ki') = splitHsFunType ki
933 ; kis_rep <- mapM repLKind kis
934 ; ki'_rep <- repNonArrowLKind ki'
935 ; kcon <- repKArrow
936 ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
937 ; foldrM f ki'_rep kis_rep
938 }
939
940 repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
941 repNonArrowLKind (L _ ki) = repNonArrowKind ki
942
943 repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
944 repNonArrowKind (HsTyVar name)
945 | name == liftedTypeKindTyConName = repKStar
946 | name == constraintKindTyConName = repKConstraint
947 | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
948 | otherwise = lookupOcc name >>= repKCon
949 repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f
950 ; a' <- repLKind a
951 ; repKApp f' a'
952 }
953 repNonArrowKind (HsListTy k) = do { k' <- repLKind k
954 ; kcon <- repKList
955 ; repKApp kcon k'
956 }
957 repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks
958 ; kcon <- repKTuple (length ks)
959 ; repKApps kcon ks'
960 }
961 repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)
962
963 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
964 repRole (L _ (Just Nominal)) = rep2 nominalRName []
965 repRole (L _ (Just Representational)) = rep2 representationalRName []
966 repRole (L _ (Just Phantom)) = rep2 phantomRName []
967 repRole (L _ Nothing) = rep2 inferRName []
968
969 -----------------------------------------------------------------------------
970 -- Splices
971 -----------------------------------------------------------------------------
972
973 repSplice :: HsSplice Name -> DsM (Core a)
974 -- See Note [How brackets and nested splices are handled] in TcSplice
975 -- We return a CoreExpr of any old type; the context should know
976 repSplice (HsTypedSplice n _) = rep_splice n
977 repSplice (HsUntypedSplice n _) = rep_splice n
978 repSplice (HsQuasiQuote n _ _ _) = rep_splice n
979
980 rep_splice :: Name -> DsM (Core a)
981 rep_splice splice_name
982 = do { mb_val <- dsLookupMetaEnv splice_name
983 ; case mb_val of
984 Just (DsSplice e) -> do { e' <- dsExpr e
985 ; return (MkC e') }
986 _ -> pprPanic "HsSplice" (ppr splice_name) }
987 -- Should not happen; statically checked
988
989 -----------------------------------------------------------------------------
990 -- Expressions
991 -----------------------------------------------------------------------------
992
993 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
994 repLEs es = repList expQTyConName repLE es
995
996 -- FIXME: some of these panics should be converted into proper error messages
997 -- unless we can make sure that constructs, which are plainly not
998 -- supported in TH already lead to error messages at an earlier stage
999 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
1000 repLE (L loc e) = putSrcSpanDs loc (repE e)
1001
1002 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
1003 repE (HsVar x) =
1004 do { mb_val <- dsLookupMetaEnv x
1005 ; case mb_val of
1006 Nothing -> do { str <- globalVar x
1007 ; repVarOrCon x str }
1008 Just (DsBound y) -> repVarOrCon x (coreVar y)
1009 Just (DsSplice e) -> do { e' <- dsExpr e
1010 ; return (MkC e') } }
1011 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
1012
1013 -- Remember, we're desugaring renamer output here, so
1014 -- HsOverlit can definitely occur
1015 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
1016 repE (HsLit l) = do { a <- repLiteral l; repLit a }
1017 repE (HsLam (MG { mg_alts = [m] })) = repLambda m
1018 repE (HsLamCase _ (MG { mg_alts = ms }))
1019 = do { ms' <- mapM repMatchTup ms
1020 ; core_ms <- coreList matchQTyConName ms'
1021 ; repLamCase core_ms }
1022 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1023
1024 repE (OpApp e1 op _ e2) =
1025 do { arg1 <- repLE e1;
1026 arg2 <- repLE e2;
1027 the_op <- repLE op ;
1028 repInfixApp arg1 the_op arg2 }
1029 repE (NegApp x _) = do
1030 a <- repLE x
1031 negateVar <- lookupOcc negateName >>= repVar
1032 negateVar `repApp` a
1033 repE (HsPar x) = repLE x
1034 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1035 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1036 repE (HsCase e (MG { mg_alts = ms }))
1037 = do { arg <- repLE e
1038 ; ms2 <- mapM repMatchTup ms
1039 ; core_ms2 <- coreList matchQTyConName ms2
1040 ; repCaseE arg core_ms2 }
1041 repE (HsIf _ x y z) = do
1042 a <- repLE x
1043 b <- repLE y
1044 c <- repLE z
1045 repCond a b c
1046 repE (HsMultiIf _ alts)
1047 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1048 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1049 ; wrapGenSyms (concat binds) expr' }
1050 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
1051 ; e2 <- addBinds ss (repLE e)
1052 ; z <- repLetE ds e2
1053 ; wrapGenSyms ss z }
1054
1055 -- FIXME: I haven't got the types here right yet
1056 repE e@(HsDo ctxt sts _)
1057 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1058 = do { (ss,zs) <- repLSts sts;
1059 e' <- repDoE (nonEmptyCoreList zs);
1060 wrapGenSyms ss e' }
1061
1062 | ListComp <- ctxt
1063 = do { (ss,zs) <- repLSts sts;
1064 e' <- repComp (nonEmptyCoreList zs);
1065 wrapGenSyms ss e' }
1066
1067 | otherwise
1068 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
1069
1070 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1071 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
1072 repE e@(ExplicitTuple es boxed)
1073 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1074 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
1075 | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
1076 ; repUnboxedTup xs }
1077
1078 repE (RecordCon c _ flds)
1079 = do { x <- lookupLOcc c;
1080 fs <- repFields flds;
1081 repRecCon x fs }
1082 repE (RecordUpd e flds _ _ _)
1083 = do { x <- repLE e;
1084 fs <- repFields flds;
1085 repRecUpd x fs }
1086
1087 repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
1088 repE (ArithSeq _ _ aseq) =
1089 case aseq of
1090 From e -> do { ds1 <- repLE e; repFrom ds1 }
1091 FromThen e1 e2 -> do
1092 ds1 <- repLE e1
1093 ds2 <- repLE e2
1094 repFromThen ds1 ds2
1095 FromTo e1 e2 -> do
1096 ds1 <- repLE e1
1097 ds2 <- repLE e2
1098 repFromTo ds1 ds2
1099 FromThenTo e1 e2 e3 -> do
1100 ds1 <- repLE e1
1101 ds2 <- repLE e2
1102 ds3 <- repLE e3
1103 repFromThenTo ds1 ds2 ds3
1104
1105 repE (HsSpliceE splice) = repSplice splice
1106 repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
1107 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1108 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1109 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1110 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1111 repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
1112 repE e = notHandled "Expression form" (ppr e)
1113
1114 -----------------------------------------------------------------------------
1115 -- Building representations of auxillary structures like Match, Clause, Stmt,
1116
1117 repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
1118 repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
1119 do { ss1 <- mkGenSyms (collectPatBinders p)
1120 ; addBinds ss1 $ do {
1121 ; p1 <- repLP p
1122 ; (ss2,ds) <- repBinds wheres
1123 ; addBinds ss2 $ do {
1124 ; gs <- repGuards guards
1125 ; match <- repMatch p1 gs ds
1126 ; wrapGenSyms (ss1++ss2) match }}}
1127 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1128
1129 repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
1130 repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =
1131 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1132 ; addBinds ss1 $ do {
1133 ps1 <- repLPs ps
1134 ; (ss2,ds) <- repBinds wheres
1135 ; addBinds ss2 $ do {
1136 gs <- repGuards guards
1137 ; clause <- repClause ps1 gs ds
1138 ; wrapGenSyms (ss1++ss2) clause }}}
1139
1140 repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)
1141 repGuards [L _ (GRHS [] e)]
1142 = do {a <- repLE e; repNormal a }
1143 repGuards other
1144 = do { zs <- mapM repLGRHS other
1145 ; let (xs, ys) = unzip zs
1146 ; gd <- repGuarded (nonEmptyCoreList ys)
1147 ; wrapGenSyms (concat xs) gd }
1148
1149 repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1150 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1151 = do { guarded <- repLNormalGE e1 e2
1152 ; return ([], guarded) }
1153 repLGRHS (L _ (GRHS ss rhs))
1154 = do { (gs, ss') <- repLSts ss
1155 ; rhs' <- addBinds gs $ repLE rhs
1156 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1157 ; return (gs, guarded) }
1158
1159 repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])
1160 repFields (HsRecFields { rec_flds = flds })
1161 = repList fieldExpQTyConName rep_fld flds
1162 where
1163 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)
1164 ; e <- repLE (hsRecFieldArg fld)
1165 ; repFieldExp fn e }
1166
1167
1168 -----------------------------------------------------------------------------
1169 -- Representing Stmt's is tricky, especially if bound variables
1170 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1171 -- First gensym new names for every variable in any of the patterns.
1172 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1173 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1174 -- and we could reuse the original names (x and x).
1175 --
1176 -- do { x'1 <- gensym "x"
1177 -- ; x'2 <- gensym "x"
1178 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1179 -- , BindSt (pvar x'2) [| f x |]
1180 -- , NoBindSt [| g x |]
1181 -- ]
1182 -- }
1183
1184 -- The strategy is to translate a whole list of do-bindings by building a
1185 -- bigger environment, and a bigger set of meta bindings
1186 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1187 -- of the expressions within the Do
1188
1189 -----------------------------------------------------------------------------
1190 -- The helper function repSts computes the translation of each sub expression
1191 -- and a bunch of prefix bindings denoting the dynamic renaming.
1192
1193 repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1194 repLSts stmts = repSts (map unLoc stmts)
1195
1196 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1197 repSts (BindStmt p e _ _ : ss) =
1198 do { e2 <- repLE e
1199 ; ss1 <- mkGenSyms (collectPatBinders p)
1200 ; addBinds ss1 $ do {
1201 ; p1 <- repLP p;
1202 ; (ss2,zs) <- repSts ss
1203 ; z <- repBindSt p1 e2
1204 ; return (ss1++ss2, z : zs) }}
1205 repSts (LetStmt bs : ss) =
1206 do { (ss1,ds) <- repBinds bs
1207 ; z <- repLetSt ds
1208 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1209 ; return (ss1++ss2, z : zs) }
1210 repSts (BodyStmt e _ _ _ : ss) =
1211 do { e2 <- repLE e
1212 ; z <- repNoBindSt e2
1213 ; (ss2,zs) <- repSts ss
1214 ; return (ss2, z : zs) }
1215 repSts (ParStmt stmt_blocks _ _ : ss) =
1216 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1217 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1218 ss1 = concat ss_s
1219 ; z <- repParSt stmt_blocks2
1220 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1221 ; return (ss1++ss2, z : zs) }
1222 where
1223 rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])
1224 rep_stmt_block (ParStmtBlock stmts _ _) =
1225 do { (ss1, zs) <- repSts (map unLoc stmts)
1226 ; zs1 <- coreList stmtQTyConName zs
1227 ; return (ss1, zs1) }
1228 repSts [LastStmt e _]
1229 = do { e2 <- repLE e
1230 ; z <- repNoBindSt e2
1231 ; return ([], [z]) }
1232 repSts [] = return ([],[])
1233 repSts other = notHandled "Exotic statement" (ppr other)
1234
1235
1236 -----------------------------------------------------------
1237 -- Bindings
1238 -----------------------------------------------------------
1239
1240 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
1241 repBinds EmptyLocalBinds
1242 = do { core_list <- coreList decQTyConName []
1243 ; return ([], core_list) }
1244
1245 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1246
1247 repBinds (HsValBinds decs)
1248 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1249 -- No need to worrry about detailed scopes within
1250 -- the binding group, because we are talking Names
1251 -- here, so we can safely treat it as a mutually
1252 -- recursive group
1253 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1254 ; ss <- mkGenSyms bndrs
1255 ; prs <- addBinds ss (rep_val_binds decs)
1256 ; core_list <- coreList decQTyConName
1257 (de_loc (sort_by_loc prs))
1258 ; return (ss, core_list) }
1259
1260 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1261 -- Assumes: all the binders of the binding are alrady in the meta-env
1262 rep_val_binds (ValBindsOut binds sigs)
1263 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1264 ; core2 <- rep_sigs' sigs
1265 ; return (core1 ++ core2) }
1266 rep_val_binds (ValBindsIn _ _)
1267 = panic "rep_val_binds: ValBindsIn"
1268
1269 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
1270 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1271 ; return (de_loc (sort_by_loc binds_w_locs)) }
1272
1273 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
1274 rep_binds' = mapM rep_bind . bagToList
1275
1276 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
1277 -- Assumes: all the binders of the binding are alrady in the meta-env
1278
1279 -- Note GHC treats declarations of a variable (not a pattern)
1280 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1281 -- with an empty list of patterns
1282 rep_bind (L loc (FunBind
1283 { fun_id = fn,
1284 fun_matches = MG { mg_alts = [L _ (Match _ [] _
1285 (GRHSs guards wheres))] } }))
1286 = do { (ss,wherecore) <- repBinds wheres
1287 ; guardcore <- addBinds ss (repGuards guards)
1288 ; fn' <- lookupLBinder fn
1289 ; p <- repPvar fn'
1290 ; ans <- repVal p guardcore wherecore
1291 ; ans' <- wrapGenSyms ss ans
1292 ; return (loc, ans') }
1293
1294 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
1295 = do { ms1 <- mapM repClauseTup ms
1296 ; fn' <- lookupLBinder fn
1297 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1298 ; return (loc, ans) }
1299
1300 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
1301 = do { patcore <- repLP pat
1302 ; (ss,wherecore) <- repBinds wheres
1303 ; guardcore <- addBinds ss (repGuards guards)
1304 ; ans <- repVal patcore guardcore wherecore
1305 ; ans' <- wrapGenSyms ss ans
1306 ; return (loc, ans') }
1307
1308 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1309 = do { v' <- lookupBinder v
1310 ; e2 <- repLE e
1311 ; x <- repNormal e2
1312 ; patcore <- repPvar v'
1313 ; empty_decls <- coreList decQTyConName []
1314 ; ans <- repVal patcore x empty_decls
1315 ; return (srcLocSpan (getSrcLoc v), ans) }
1316
1317 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1318 rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
1319 -----------------------------------------------------------------------------
1320 -- Since everything in a Bind is mutually recursive we need rename all
1321 -- all the variables simultaneously. For example:
1322 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1323 -- do { f'1 <- gensym "f"
1324 -- ; g'2 <- gensym "g"
1325 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1326 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1327 -- ]}
1328 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1329 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1330 -- together. As we do this we collect GenSymBinds's which represent the renamed
1331 -- variables bound by the Bindings. In order not to lose track of these
1332 -- representations we build a shadow datatype MB with the same structure as
1333 -- MonoBinds, but which has slots for the representations
1334
1335
1336 -----------------------------------------------------------------------------
1337 -- GHC allows a more general form of lambda abstraction than specified
1338 -- by Haskell 98. In particular it allows guarded lambda's like :
1339 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1340 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1341 -- (\ p1 .. pn -> exp) by causing an error.
1342
1343 repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
1344 repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
1345 = do { let bndrs = collectPatsBinders ps ;
1346 ; ss <- mkGenSyms bndrs
1347 ; lam <- addBinds ss (
1348 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1349 ; wrapGenSyms ss lam }
1350
1351 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)
1352
1353
1354 -----------------------------------------------------------------------------
1355 -- Patterns
1356 -- repP deals with patterns. It assumes that we have already
1357 -- walked over the pattern(s) once to collect the binders, and
1358 -- have extended the environment. So every pattern-bound
1359 -- variable should already appear in the environment.
1360
1361 -- Process a list of patterns
1362 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
1363 repLPs ps = repList patQTyConName repLP ps
1364
1365 repLP :: LPat Name -> DsM (Core TH.PatQ)
1366 repLP (L _ p) = repP p
1367
1368 repP :: Pat Name -> DsM (Core TH.PatQ)
1369 repP (WildPat _) = repPwild
1370 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1371 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
1372 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1373 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1374 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1375 repP (ParPat p) = repLP p
1376 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1377 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
1378 repP (TuplePat ps boxed _)
1379 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1380 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1381 repP (ConPatIn dc details)
1382 = do { con_str <- lookupLOcc dc
1383 ; case details of
1384 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1385 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1386 ; repPrec con_str fps }
1387 InfixCon p1 p2 -> do { p1' <- repLP p1;
1388 p2' <- repLP p2;
1389 repPinfix p1' con_str p2' }
1390 }
1391 where
1392 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)
1393 ; MkC p <- repLP (hsRecFieldArg fld)
1394 ; rep2 fieldPatName [v,p] }
1395
1396 repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1397 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1398 repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1399 repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)
1400 -- The problem is to do with scoped type variables.
1401 -- To implement them, we have to implement the scoping rules
1402 -- here in DsMeta, and I don't want to do that today!
1403 -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
1404 -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1405 -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1406
1407 repP (SplicePat splice) = repSplice splice
1408
1409 repP other = notHandled "Exotic pattern" (ppr other)
1410
1411 ----------------------------------------------------------
1412 -- Declaration ordering helpers
1413
1414 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1415 sort_by_loc xs = sortBy comp xs
1416 where comp x y = compare (fst x) (fst y)
1417
1418 de_loc :: [(a, b)] -> [b]
1419 de_loc = map snd
1420
1421 ----------------------------------------------------------
1422 -- The meta-environment
1423
1424 -- A name/identifier association for fresh names of locally bound entities
1425 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1426 -- I.e. (x, x_id) means
1427 -- let x_id = gensym "x" in ...
1428
1429 -- Generate a fresh name for a locally bound entity
1430
1431 mkGenSyms :: [Name] -> DsM [GenSymBind]
1432 -- We can use the existing name. For example:
1433 -- [| \x_77 -> x_77 + x_77 |]
1434 -- desugars to
1435 -- do { x_77 <- genSym "x"; .... }
1436 -- We use the same x_77 in the desugared program, but with the type Bndr
1437 -- instead of Int
1438 --
1439 -- We do make it an Internal name, though (hence localiseName)
1440 --
1441 -- Nevertheless, it's monadic because we have to generate nameTy
1442 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1443 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1444
1445
1446 addBinds :: [GenSymBind] -> DsM a -> DsM a
1447 -- Add a list of fresh names for locally bound entities to the
1448 -- meta environment (which is part of the state carried around
1449 -- by the desugarer monad)
1450 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1451
1452 dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
1453 dupBinder (new, old)
1454 = do { mb_val <- dsLookupMetaEnv old
1455 ; case mb_val of
1456 Just val -> return (new, val)
1457 Nothing -> pprPanic "dupBinder" (ppr old) }
1458
1459 -- Look up a locally bound name
1460 --
1461 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1462 lookupLBinder (L _ n) = lookupBinder n
1463
1464 lookupBinder :: Name -> DsM (Core TH.Name)
1465 lookupBinder = lookupOcc
1466 -- Binders are brought into scope before the pattern or what-not is
1467 -- desugared. Moreover, in instance declaration the binder of a method
1468 -- will be the selector Id and hence a global; so we need the
1469 -- globalVar case of lookupOcc
1470
1471 -- Look up a name that is either locally bound or a global name
1472 --
1473 -- * If it is a global name, generate the "original name" representation (ie,
1474 -- the <module>:<name> form) for the associated entity
1475 --
1476 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1477 -- Lookup an occurrence; it can't be a splice.
1478 -- Use the in-scope bindings if they exist
1479 lookupLOcc (L _ n) = lookupOcc n
1480
1481 lookupOcc :: Name -> DsM (Core TH.Name)
1482 lookupOcc n
1483 = do { mb_val <- dsLookupMetaEnv n ;
1484 case mb_val of
1485 Nothing -> globalVar n
1486 Just (DsBound x) -> return (coreVar x)
1487 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1488 }
1489
1490 globalVar :: Name -> DsM (Core TH.Name)
1491 -- Not bound by the meta-env
1492 -- Could be top-level; or could be local
1493 -- f x = $(g [| x |])
1494 -- Here the x will be local
1495 globalVar name
1496 | isExternalName name
1497 = do { MkC mod <- coreStringLit name_mod
1498 ; MkC pkg <- coreStringLit name_pkg
1499 ; MkC occ <- occNameLit name
1500 ; rep2 mk_varg [pkg,mod,occ] }
1501 | otherwise
1502 = do { MkC occ <- occNameLit name
1503 ; MkC uni <- coreIntLit (getKey (getUnique name))
1504 ; rep2 mkNameLName [occ,uni] }
1505 where
1506 mod = ASSERT( isExternalName name) nameModule name
1507 name_mod = moduleNameString (moduleName mod)
1508 name_pkg = packageKeyString (modulePackageKey mod)
1509 name_occ = nameOccName name
1510 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1511 | OccName.isVarOcc name_occ = mkNameG_vName
1512 | OccName.isTcOcc name_occ = mkNameG_tcName
1513 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1514
1515 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1516 -> DsM Type -- The type
1517 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1518 return (mkTyConApp tc []) }
1519
1520 wrapGenSyms :: [GenSymBind]
1521 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1522 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1523 -- --> bindQ (gensym nm1) (\ id1 ->
1524 -- bindQ (gensym nm2 (\ id2 ->
1525 -- y))
1526
1527 wrapGenSyms binds body@(MkC b)
1528 = do { var_ty <- lookupType nameTyConName
1529 ; go var_ty binds }
1530 where
1531 [elt_ty] = tcTyConAppArgs (exprType b)
1532 -- b :: Q a, so we can get the type 'a' by looking at the
1533 -- argument type. NB: this relies on Q being a data/newtype,
1534 -- not a type synonym
1535
1536 go _ [] = return body
1537 go var_ty ((name,id) : binds)
1538 = do { MkC body' <- go var_ty binds
1539 ; lit_str <- occNameLit name
1540 ; gensym_app <- repGensym lit_str
1541 ; repBindQ var_ty elt_ty
1542 gensym_app (MkC (Lam id body')) }
1543
1544 occNameLit :: Name -> DsM (Core String)
1545 occNameLit n = coreStringLit (occNameString (nameOccName n))
1546
1547
1548 -- %*********************************************************************
1549 -- %* *
1550 -- Constructing code
1551 -- %* *
1552 -- %*********************************************************************
1553
1554 -----------------------------------------------------------------------------
1555 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1556 -- we invent a new datatype which uses phantom types.
1557
1558 newtype Core a = MkC CoreExpr
1559 unC :: Core a -> CoreExpr
1560 unC (MkC x) = x
1561
1562 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1563 rep2 n xs = do { id <- dsLookupGlobalId n
1564 ; return (MkC (foldl App (Var id) xs)) }
1565
1566 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1567 dataCon' n args = do { id <- dsLookupDataCon n
1568 ; return $ MkC $ mkCoreConApps id args }
1569
1570 dataCon :: Name -> DsM (Core a)
1571 dataCon n = dataCon' n []
1572
1573 -- Then we make "repConstructors" which use the phantom types for each of the
1574 -- smart constructors of the Meta.Meta datatypes.
1575
1576
1577 -- %*********************************************************************
1578 -- %* *
1579 -- The 'smart constructors'
1580 -- %* *
1581 -- %*********************************************************************
1582
1583 --------------- Patterns -----------------
1584 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1585 repPlit (MkC l) = rep2 litPName [l]
1586
1587 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1588 repPvar (MkC s) = rep2 varPName [s]
1589
1590 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1591 repPtup (MkC ps) = rep2 tupPName [ps]
1592
1593 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1594 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1595
1596 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1597 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1598
1599 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1600 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1601
1602 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1603 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1604
1605 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1606 repPtilde (MkC p) = rep2 tildePName [p]
1607
1608 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1609 repPbang (MkC p) = rep2 bangPName [p]
1610
1611 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1612 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1613
1614 repPwild :: DsM (Core TH.PatQ)
1615 repPwild = rep2 wildPName []
1616
1617 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1618 repPlist (MkC ps) = rep2 listPName [ps]
1619
1620 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1621 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1622
1623 --------------- Expressions -----------------
1624 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1625 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1626 | otherwise = repVar str
1627
1628 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1629 repVar (MkC s) = rep2 varEName [s]
1630
1631 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1632 repCon (MkC s) = rep2 conEName [s]
1633
1634 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1635 repLit (MkC c) = rep2 litEName [c]
1636
1637 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1638 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1639
1640 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1641 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1642
1643 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1644 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1645
1646 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1647 repTup (MkC es) = rep2 tupEName [es]
1648
1649 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1650 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1651
1652 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1653 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1654
1655 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1656 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1657
1658 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1659 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1660
1661 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1662 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1663
1664 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1665 repDoE (MkC ss) = rep2 doEName [ss]
1666
1667 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1668 repComp (MkC ss) = rep2 compEName [ss]
1669
1670 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1671 repListExp (MkC es) = rep2 listEName [es]
1672
1673 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1674 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1675
1676 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1677 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1678
1679 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1680 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1681
1682 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1683 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1684
1685 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1686 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1687
1688 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1689 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1690
1691 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1692 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1693
1694 ------------ Right hand sides (guarded expressions) ----
1695 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1696 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1697
1698 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1699 repNormal (MkC e) = rep2 normalBName [e]
1700
1701 ------------ Guards ----
1702 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1703 repLNormalGE g e = do g' <- repLE g
1704 e' <- repLE e
1705 repNormalGE g' e'
1706
1707 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1708 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1709
1710 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1711 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1712
1713 ------------- Stmts -------------------
1714 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1715 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1716
1717 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1718 repLetSt (MkC ds) = rep2 letSName [ds]
1719
1720 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1721 repNoBindSt (MkC e) = rep2 noBindSName [e]
1722
1723 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
1724 repParSt (MkC sss) = rep2 parSName [sss]
1725
1726 -------------- Range (Arithmetic sequences) -----------
1727 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1728 repFrom (MkC x) = rep2 fromEName [x]
1729
1730 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1731 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1732
1733 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1734 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1735
1736 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1737 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1738
1739 ------------ Match and Clause Tuples -----------
1740 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1741 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1742
1743 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1744 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1745
1746 -------------- Dec -----------------------------
1747 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1748 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1749
1750 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1751 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1752
1753 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1754 -> Maybe (Core [TH.TypeQ])
1755 -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1756 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)
1757 = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1758 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)
1759 = rep2 dataInstDName [cxt, nm, tys, cons, derivs]
1760
1761 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1762 -> Maybe (Core [TH.TypeQ])
1763 -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1764 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)
1765 = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1766 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)
1767 = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]
1768
1769 repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]
1770 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1771 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
1772 = rep2 tySynDName [nm, tvs, rhs]
1773
1774 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1775 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1776
1777 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
1778 -> Core [TH.FunDep] -> Core [TH.DecQ]
1779 -> DsM (Core TH.DecQ)
1780 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
1781 = rep2 classDName [cxt, cls, tvs, fds, ds]
1782
1783 repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1784 repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]
1785
1786 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
1787 -> Core TH.Phases -> DsM (Core TH.DecQ)
1788 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
1789 = rep2 pragInlDName [nm, inline, rm, phases]
1790
1791 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
1792 -> DsM (Core TH.DecQ)
1793 repPragSpec (MkC nm) (MkC ty) (MkC phases)
1794 = rep2 pragSpecDName [nm, ty, phases]
1795
1796 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
1797 -> Core TH.Phases -> DsM (Core TH.DecQ)
1798 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
1799 = rep2 pragSpecInlDName [nm, ty, inline, phases]
1800
1801 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
1802 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
1803
1804 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
1805 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
1806 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
1807 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
1808
1809 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
1810 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
1811
1812 repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1813 -> DsM (Core TH.DecQ)
1814 repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)
1815 = rep2 familyNoKindDName [flav, nm, tvs]
1816
1817 repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]
1818 -> Core TH.Kind
1819 -> DsM (Core TH.DecQ)
1820 repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)
1821 = rep2 familyKindDName [flav, nm, tvs, ki]
1822
1823 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
1824 repTySynInst (MkC nm) (MkC eqn)
1825 = rep2 tySynInstDName [nm, eqn]
1826
1827 repClosedFamilyNoKind :: Core TH.Name
1828 -> Core [TH.TyVarBndr]
1829 -> Core [TH.TySynEqnQ]
1830 -> DsM (Core TH.DecQ)
1831 repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)
1832 = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]
1833
1834 repClosedFamilyKind :: Core TH.Name
1835 -> Core [TH.TyVarBndr]
1836 -> Core TH.Kind
1837 -> Core [TH.TySynEqnQ]
1838 -> DsM (Core TH.DecQ)
1839 repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)
1840 = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]
1841
1842 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
1843 repTySynEqn (MkC lhs) (MkC rhs)
1844 = rep2 tySynEqnName [lhs, rhs]
1845
1846 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
1847 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
1848
1849 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1850 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1851
1852 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1853 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
1854
1855 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
1856 repCtxt (MkC tys) = rep2 cxtName [tys]
1857
1858 repConstr :: Core TH.Name -> HsConDeclDetails Name
1859 -> DsM (Core TH.ConQ)
1860 repConstr con (PrefixCon ps)
1861 = do arg_tys <- repList strictTypeQTyConName repBangTy ps
1862 rep2 normalCName [unC con, unC arg_tys]
1863
1864 repConstr con (RecCon (L _ ips))
1865 = do { args <- concatMapM rep_ip ips
1866 ; arg_vtys <- coreList varStrictTypeQTyConName args
1867 ; rep2 recCName [unC con, unC arg_vtys] }
1868 where
1869 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
1870 rep_one_ip t n = do { MkC v <- lookupLOcc n
1871 ; MkC ty <- repBangTy t
1872 ; rep2 varStrictTypeName [v,ty] }
1873
1874 repConstr con (InfixCon st1 st2)
1875 = do arg1 <- repBangTy st1
1876 arg2 <- repBangTy st2
1877 rep2 infixCName [unC arg1, unC con, unC arg2]
1878
1879 ------------ Types -------------------
1880
1881 repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
1882 -> DsM (Core TH.TypeQ)
1883 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1884 = rep2 forallTName [tvars, ctxt, ty]
1885
1886 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1887 repTvar (MkC s) = rep2 varTName [s]
1888
1889 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1890 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
1891
1892 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1893 repTapps f [] = return f
1894 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1895
1896 repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)
1897 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
1898
1899 repTequality :: DsM (Core TH.TypeQ)
1900 repTequality = rep2 equalityTName []
1901
1902 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1903 repTPromotedList [] = repPromotedNilTyCon
1904 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
1905 ; f <- repTapp tcon t
1906 ; t' <- repTPromotedList ts
1907 ; repTapp f t'
1908 }
1909
1910 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
1911 repTLit (MkC lit) = rep2 litTName [lit]
1912
1913 --------- Type constructors --------------
1914
1915 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1916 repNamedTyCon (MkC s) = rep2 conTName [s]
1917
1918 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1919 -- Note: not Core Int; it's easier to be direct here
1920 repTupleTyCon i = do dflags <- getDynFlags
1921 rep2 tupleTName [mkIntExprInt dflags i]
1922
1923 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1924 -- Note: not Core Int; it's easier to be direct here
1925 repUnboxedTupleTyCon i = do dflags <- getDynFlags
1926 rep2 unboxedTupleTName [mkIntExprInt dflags i]
1927
1928 repArrowTyCon :: DsM (Core TH.TypeQ)
1929 repArrowTyCon = rep2 arrowTName []
1930
1931 repListTyCon :: DsM (Core TH.TypeQ)
1932 repListTyCon = rep2 listTName []
1933
1934 repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1935 repPromotedTyCon (MkC s) = rep2 promotedTName [s]
1936
1937 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1938 repPromotedTupleTyCon i = do dflags <- getDynFlags
1939 rep2 promotedTupleTName [mkIntExprInt dflags i]
1940
1941 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
1942 repPromotedNilTyCon = rep2 promotedNilTName []
1943
1944 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
1945 repPromotedConsTyCon = rep2 promotedConsTName []
1946
1947 ------------ Kinds -------------------
1948
1949 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)
1950 repPlainTV (MkC nm) = rep2 plainTVName [nm]
1951
1952 repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)
1953 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
1954
1955 repKVar :: Core TH.Name -> DsM (Core TH.Kind)
1956 repKVar (MkC s) = rep2 varKName [s]
1957
1958 repKCon :: Core TH.Name -> DsM (Core TH.Kind)
1959 repKCon (MkC s) = rep2 conKName [s]
1960
1961 repKTuple :: Int -> DsM (Core TH.Kind)
1962 repKTuple i = do dflags <- getDynFlags
1963 rep2 tupleKName [mkIntExprInt dflags i]
1964
1965 repKArrow :: DsM (Core TH.Kind)
1966 repKArrow = rep2 arrowKName []
1967
1968 repKList :: DsM (Core TH.Kind)
1969 repKList = rep2 listKName []
1970
1971 repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)
1972 repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]
1973
1974 repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)
1975 repKApps f [] = return f
1976 repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }
1977
1978 repKStar :: DsM (Core TH.Kind)
1979 repKStar = rep2 starKName []
1980
1981 repKConstraint :: DsM (Core TH.Kind)
1982 repKConstraint = rep2 constraintKName []
1983
1984 ----------------------------------------------------------
1985 -- Literals
1986
1987 repLiteral :: HsLit -> DsM (Core TH.Lit)
1988 repLiteral (HsStringPrim _ bs)
1989 = do dflags <- getDynFlags
1990 word8_ty <- lookupType word8TyConName
1991 let w8s = unpack bs
1992 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
1993 [mkWordLit dflags (toInteger w8)]) w8s
1994 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
1995 repLiteral lit
1996 = do lit' <- case lit of
1997 HsIntPrim _ i -> mk_integer i
1998 HsWordPrim _ w -> mk_integer w
1999 HsInt _ i -> mk_integer i
2000 HsFloatPrim r -> mk_rational r
2001 HsDoublePrim r -> mk_rational r
2002 HsCharPrim _ c -> mk_char c
2003 _ -> return lit
2004 lit_expr <- dsLit lit'
2005 case mb_lit_name of
2006 Just lit_name -> rep2 lit_name [lit_expr]
2007 Nothing -> notHandled "Exotic literal" (ppr lit)
2008 where
2009 mb_lit_name = case lit of
2010 HsInteger _ _ _ -> Just integerLName
2011 HsInt _ _ -> Just integerLName
2012 HsIntPrim _ _ -> Just intPrimLName
2013 HsWordPrim _ _ -> Just wordPrimLName
2014 HsFloatPrim _ -> Just floatPrimLName
2015 HsDoublePrim _ -> Just doublePrimLName
2016 HsChar _ _ -> Just charLName
2017 HsCharPrim _ _ -> Just charPrimLName
2018 HsString _ _ -> Just stringLName
2019 HsRat _ _ -> Just rationalLName
2020 _ -> Nothing
2021
2022 mk_integer :: Integer -> DsM HsLit
2023 mk_integer i = do integer_ty <- lookupType integerTyConName
2024 return $ HsInteger "" i integer_ty
2025 mk_rational :: FractionalLit -> DsM HsLit
2026 mk_rational r = do rat_ty <- lookupType rationalTyConName
2027 return $ HsRat r rat_ty
2028 mk_string :: FastString -> DsM HsLit
2029 mk_string s = return $ HsString "" s
2030
2031 mk_char :: Char -> DsM HsLit
2032 mk_char c = return $ HsChar "" c
2033
2034 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
2035 repOverloadedLiteral (OverLit { ol_val = val})
2036 = do { lit <- mk_lit val; repLiteral lit }
2037 -- The type Rational will be in the environment, because
2038 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2039 -- and rationalL is sucked in when any TH stuff is used
2040
2041 mk_lit :: OverLitVal -> DsM HsLit
2042 mk_lit (HsIntegral _ i) = mk_integer i
2043 mk_lit (HsFractional f) = mk_rational f
2044 mk_lit (HsIsString _ s) = mk_string s
2045
2046 --------------- Miscellaneous -------------------
2047
2048 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2049 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2050
2051 repBindQ :: Type -> Type -- a and b
2052 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2053 repBindQ ty_a ty_b (MkC x) (MkC y)
2054 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2055
2056 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2057 repSequenceQ ty_a (MkC list)
2058 = rep2 sequenceQName [Type ty_a, list]
2059
2060 ------------ Lists and Tuples -------------------
2061 -- turn a list of patterns into a single pattern matching a list
2062
2063 repList :: Name -> (a -> DsM (Core b))
2064 -> [a] -> DsM (Core [b])
2065 repList tc_name f args
2066 = do { args1 <- mapM f args
2067 ; coreList tc_name args1 }
2068
2069 coreList :: Name -- Of the TyCon of the element type
2070 -> [Core a] -> DsM (Core [a])
2071 coreList tc_name es
2072 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2073
2074 coreList' :: Type -- The element type
2075 -> [Core a] -> Core [a]
2076 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2077
2078 nonEmptyCoreList :: [Core a] -> Core [a]
2079 -- The list must be non-empty so we can get the element type
2080 -- Otherwise use coreList
2081 nonEmptyCoreList [] = panic "coreList: empty argument"
2082 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2083
2084 coreStringLit :: String -> DsM (Core String)
2085 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2086
2087 ------------ Literals & Variables -------------------
2088
2089 coreIntLit :: Int -> DsM (Core Int)
2090 coreIntLit i = do dflags <- getDynFlags
2091 return (MkC (mkIntExprInt dflags i))
2092
2093 coreVar :: Id -> Core TH.Name -- The Id has type Name
2094 coreVar id = MkC (Var id)
2095
2096 ----------------- Failure -----------------------
2097 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2098 notHandledL loc what doc
2099 | isGoodSrcSpan loc
2100 = putSrcSpanDs loc $ notHandled what doc
2101 | otherwise
2102 = notHandled what doc
2103
2104 notHandled :: String -> SDoc -> DsM a
2105 notHandled what doc = failWithDs msg
2106 where
2107 msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
2108 2 doc
2109
2110