More explicit foralls (GHC Proposal 0007)
[ghc.git] / compiler / deSugar / DsMeta.hs
1 {-# LANGUAGE CPP, TypeFamilies #-}
2 {-# LANGUAGE FlexibleContexts #-}
3
4 -----------------------------------------------------------------------------
5 --
6 -- (c) The University of Glasgow 2006
7 --
8 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
9 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
10 -- input HsExpr. We do this in the DsM monad, which supplies access to
11 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
12 --
13 -- It also defines a bunch of knownKeyNames, in the same way as is done
14 -- in prelude/PrelNames. It's much more convenient to do it here, because
15 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
16 -- a Royal Pain (triggers other recompilation).
17 -----------------------------------------------------------------------------
18
19 module DsMeta( dsBracket ) where
20
21 #include "HsVersions.h"
22
23 import GhcPrelude
24
25 import {-# SOURCE #-} DsExpr ( dsExpr )
26
27 import MatchLit
28 import DsMonad
29
30 import qualified Language.Haskell.TH as TH
31
32 import HsSyn
33 import PrelNames
34 -- To avoid clashes with DsMeta.varName we must make a local alias for
35 -- OccName.varName we do this by removing varName from the import of
36 -- OccName above, making a qualified instance of OccName and using
37 -- OccNameAlias.varName where varName ws previously used in this file.
38 import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
39
40 import Module
41 import Id
42 import Name hiding( isVarOcc, isTcOcc, varName, tcName )
43 import THNames
44 import NameEnv
45 import NameSet
46 import TcType
47 import TyCon
48 import TysWiredIn
49 import CoreSyn
50 import MkCore
51 import CoreUtils
52 import SrcLoc
53 import Unique
54 import BasicTypes
55 import Outputable
56 import Bag
57 import DynFlags
58 import FastString
59 import ForeignCall
60 import Util
61 import Maybes
62 import MonadUtils
63
64 import Data.ByteString ( unpack )
65 import Control.Monad
66 import Data.List
67
68 -----------------------------------------------------------------------------
69 dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
70 -- Returns a CoreExpr of type TH.ExpQ
71 -- The quoted thing is parameterised over Name, even though it has
72 -- been type checked. We don't want all those type decorations!
73
74 dsBracket brack splices
75 = dsExtendMetaEnv new_bit (do_brack brack)
76 where
77 new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
78
79 do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
80 do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
81 do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 }
82 do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 }
83 do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
84 do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL"
85 do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 }
86 do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
87
88 {- -------------- Examples --------------------
89
90 [| \x -> x |]
91 ====>
92 gensym (unpackString "x"#) `bindQ` \ x1::String ->
93 lam (pvar x1) (var x1)
94
95
96 [| \x -> $(f [| x |]) |]
97 ====>
98 gensym (unpackString "x"#) `bindQ` \ x1::String ->
99 lam (pvar x1) (f (var x1))
100 -}
101
102
103 -------------------------------------------------------
104 -- Declarations
105 -------------------------------------------------------
106
107 repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
108 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
109 ; pat' <- addBinds ss (repLP pat)
110 ; wrapGenSyms ss pat' }
111
112 repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
113 repTopDs group@(HsGroup { hs_valds = valds
114 , hs_splcds = splcds
115 , hs_tyclds = tyclds
116 , hs_derivds = derivds
117 , hs_fixds = fixds
118 , hs_defds = defds
119 , hs_fords = fords
120 , hs_warnds = warnds
121 , hs_annds = annds
122 , hs_ruleds = ruleds
123 , hs_docs = docs })
124 = do { let { bndrs = hsScopedTvBinders valds
125 ++ hsGroupBinders group
126 ++ hsPatSynSelectors valds
127 ; instds = tyclds >>= group_instds } ;
128 ss <- mkGenSyms bndrs ;
129
130 -- Bind all the names mainly to avoid repeated use of explicit strings.
131 -- Thus we get
132 -- do { t :: String <- genSym "T" ;
133 -- return (Data t [] ...more t's... }
134 -- The other important reason is that the output must mention
135 -- only "T", not "Foo:T" where Foo is the current module
136
137 decls <- addBinds ss (
138 do { val_ds <- rep_val_binds valds
139 ; _ <- mapM no_splice splcds
140 ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds)
141 ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
142 ; inst_ds <- mapM repInstD instds
143 ; deriv_ds <- mapM repStandaloneDerivD derivds
144 ; fix_ds <- mapM repFixD fixds
145 ; _ <- mapM no_default_decl defds
146 ; for_ds <- mapM repForD fords
147 ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)
148 warnds)
149 ; ann_ds <- mapM repAnnD annds
150 ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)
151 ruleds)
152 ; _ <- mapM no_doc docs
153
154 -- more needed
155 ; return (de_loc $ sort_by_loc $
156 val_ds ++ catMaybes tycl_ds ++ role_ds
157 ++ (concat fix_ds)
158 ++ inst_ds ++ rule_ds ++ for_ds
159 ++ ann_ds ++ deriv_ds) }) ;
160
161 decl_ty <- lookupType decQTyConName ;
162 let { core_list = coreList' decl_ty decls } ;
163
164 dec_ty <- lookupType decTyConName ;
165 q_decs <- repSequenceQ dec_ty core_list ;
166
167 wrapGenSyms ss q_decs
168 }
169 where
170 no_splice (L loc _)
171 = notHandledL loc "Splices within declaration brackets" empty
172 no_default_decl (L loc decl)
173 = notHandledL loc "Default declarations" (ppr decl)
174 no_warn (L loc (Warning _ thing _))
175 = notHandledL loc "WARNING and DEPRECATION pragmas" $
176 text "Pragma for declaration of" <+> ppr thing
177 no_warn (L _ (XWarnDecl _)) = panic "repTopDs"
178 no_doc (L loc _)
179 = notHandledL loc "Haddock documentation" empty
180 repTopDs (XHsGroup _) = panic "repTopDs"
181
182 hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
183 -- See Note [Scoped type variables in bindings]
184 hsScopedTvBinders binds
185 = concatMap get_scoped_tvs sigs
186 where
187 sigs = case binds of
188 ValBinds _ _ sigs -> sigs
189 XValBindsLR (NValBinds _ sigs) -> sigs
190
191 get_scoped_tvs :: LSig GhcRn -> [Name]
192 get_scoped_tvs (L _ signature)
193 | TypeSig _ _ sig <- signature
194 = get_scoped_tvs_from_sig (hswc_body sig)
195 | ClassOpSig _ _ _ sig <- signature
196 = get_scoped_tvs_from_sig sig
197 | PatSynSig _ _ sig <- signature
198 = get_scoped_tvs_from_sig sig
199 | otherwise
200 = []
201 where
202 get_scoped_tvs_from_sig sig
203 -- Both implicit and explicit quantified variables
204 -- We need the implicit ones for f :: forall (a::k). blah
205 -- here 'k' scopes too
206 | HsIB { hsib_ext = implicit_vars
207 , hsib_body = hs_ty } <- sig
208 , (explicit_vars, _) <- splitLHsForAllTy hs_ty
209 = implicit_vars ++ map hsLTyVarName explicit_vars
210 get_scoped_tvs_from_sig (XHsImplicitBndrs _)
211 = panic "get_scoped_tvs_from_sig"
212
213 {- Notes
214
215 Note [Scoped type variables in bindings]
216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217 Consider
218 f :: forall a. a -> a
219 f x = x::a
220 Here the 'forall a' brings 'a' into scope over the binding group.
221 To achieve this we
222
223 a) Gensym a binding for 'a' at the same time as we do one for 'f'
224 collecting the relevant binders with hsScopedTvBinders
225
226 b) When processing the 'forall', don't gensym
227
228 The relevant places are signposted with references to this Note
229
230 Note [Scoped type variables in class and instance declarations]
231 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
232 Scoped type variables may occur in default methods and default
233 signatures. We need to bring the type variables in 'foralls'
234 into the scope of the method bindings.
235
236 Consider
237 class Foo a where
238 foo :: forall (b :: k). a -> Proxy b -> Proxy b
239 foo _ x = (x :: Proxy b)
240
241 We want to ensure that the 'b' in the type signature and the default
242 implementation are the same, so we do the following:
243
244 a) Before desugaring the signature and binding of 'foo', use
245 get_scoped_tvs to collect type variables in 'forall' and
246 create symbols for them.
247 b) Use 'addBinds' to bring these symbols into the scope of the type
248 signatures and bindings.
249 c) Use these symbols to generate Core for the class/instance declaration.
250
251 Note that when desugaring the signatures, we lookup the type variables
252 from the scope rather than recreate symbols for them. See more details
253 in "rep_ty_sig" and in Trac#14885.
254
255 Note [Binders and occurrences]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 When we desugar [d| data T = MkT |]
258 we want to get
259 Data "T" [] [Con "MkT" []] []
260 and *not*
261 Data "Foo:T" [] [Con "Foo:MkT" []] []
262 That is, the new data decl should fit into whatever new module it is
263 asked to fit in. We do *not* clone, though; no need for this:
264 Data "T79" ....
265
266 But if we see this:
267 data T = MkT
268 foo = reifyDecl T
269
270 then we must desugar to
271 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
272
273 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
274 And we use lookupOcc, rather than lookupBinder
275 in repTyClD and repC.
276
277 Note [Don't quantify implicit type variables in quotes]
278 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
279 If you're not careful, it's suprisingly easy to take this quoted declaration:
280
281 [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
282 idProxy x = x
283 |]
284
285 and have Template Haskell turn it into this:
286
287 idProxy :: forall k proxy (b :: k). proxy b -> proxy b
288 idProxy x = x
289
290 Notice that we explicitly quantified the variable `k`! The latter declaration
291 isn't what the user wrote in the first place.
292
293 Usually, the culprit behind these bugs is taking implicitly quantified type
294 variables (often from the hsib_vars field of HsImplicitBinders) and putting
295 them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
296 -}
297
298 -- represent associated family instances
299 --
300 repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
301
302 repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)
303
304 repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
305 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
306 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
307 repSynDecl tc1 bndrs rhs
308 ; return (Just (loc, dec)) }
309
310 repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
311 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
312 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
313 repDataDefn tc1 (Left bndrs) defn
314 ; return (Just (loc, dec)) }
315
316 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
317 tcdTyVars = tvs, tcdFDs = fds,
318 tcdSigs = sigs, tcdMeths = meth_binds,
319 tcdATs = ats, tcdATDefs = atds }))
320 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]
321 ; dec <- addTyVarBinds tvs $ \bndrs ->
322 do { cxt1 <- repLContext cxt
323 -- See Note [Scoped type variables in class and instance declarations]
324 ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
325 ; fds1 <- repLFunDeps fds
326 ; ats1 <- repFamilyDecls ats
327 ; atds1 <- repAssocTyFamDefaults atds
328 ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
329 ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
330 ; wrapGenSyms ss decls2 }
331 ; return $ Just (loc, dec)
332 }
333
334 repTyClD (L _ (XTyClDecl _)) = panic "repTyClD"
335
336 -------------------------
337 repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
338 repRoleD (L loc (RoleAnnotDecl _ tycon roles))
339 = do { tycon1 <- lookupLOcc tycon
340 ; roles1 <- mapM repRole roles
341 ; roles2 <- coreList roleTyConName roles1
342 ; dec <- repRoleAnnotD tycon1 roles2
343 ; return (loc, dec) }
344 repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
345
346 -------------------------
347 repDataDefn :: Core TH.Name
348 -> Either (Core [TH.TyVarBndrQ])
349 -- the repTyClD case
350 (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
351 -- the repDataFamInstD case
352 -> HsDataDefn GhcRn
353 -> DsM (Core TH.DecQ)
354 repDataDefn tc opts
355 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
356 , dd_cons = cons, dd_derivs = mb_derivs })
357 = do { cxt1 <- repLContext cxt
358 ; derivs1 <- repDerivs mb_derivs
359 ; case (new_or_data, cons) of
360 (NewType, [con]) -> do { con' <- repC con
361 ; ksig' <- repMaybeLTy ksig
362 ; repNewtype cxt1 tc opts ksig' con'
363 derivs1 }
364 (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
365 <+> pprQuotedList
366 (getConNames $ unLoc $ head cons))
367 (DataType, _) -> do { ksig' <- repMaybeLTy ksig
368 ; consL <- mapM repC cons
369 ; cons1 <- coreList conQTyConName consL
370 ; repData cxt1 tc opts ksig' cons1
371 derivs1 }
372 }
373 repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
374
375 repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
376 -> LHsType GhcRn
377 -> DsM (Core TH.DecQ)
378 repSynDecl tc bndrs ty
379 = do { ty1 <- repLTy ty
380 ; repTySyn tc bndrs ty1 }
381
382 repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
383 repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
384 fdLName = tc,
385 fdTyVars = tvs,
386 fdResultSig = L _ resultSig,
387 fdInjectivityAnn = injectivity }))
388 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
389 ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
390 mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
391 { hsq_implicit = []
392 , hsq_dependent = emptyNameSet }
393 , hsq_explicit = tvs }
394 resTyVar = case resultSig of
395 TyVarSig _ bndr -> mkHsQTvs [bndr]
396 _ -> mkHsQTvs []
397 ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
398 addTyClTyVarBinds resTyVar $ \_ ->
399 case info of
400 ClosedTypeFamily Nothing ->
401 notHandled "abstract closed type family" (ppr decl)
402 ClosedTypeFamily (Just eqns) ->
403 do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns
404 ; eqns2 <- coreList tySynEqnQTyConName eqns1
405 ; result <- repFamilyResultSig resultSig
406 ; inj <- repInjectivityAnn injectivity
407 ; repClosedFamilyD tc1 bndrs result inj eqns2 }
408 OpenTypeFamily ->
409 do { result <- repFamilyResultSig resultSig
410 ; inj <- repInjectivityAnn injectivity
411 ; repOpenFamilyD tc1 bndrs result inj }
412 DataFamily ->
413 do { kind <- repFamilyResultSigToMaybeKind resultSig
414 ; repDataFamilyD tc1 bndrs kind }
415 ; return (loc, dec)
416 }
417 repFamilyDecl (L _ (XFamilyDecl _)) = panic "repFamilyDecl"
418
419 -- | Represent result signature of a type family
420 repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
421 repFamilyResultSig (NoSig _) = repNoSig
422 repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki
423 ; repKindSig ki' }
424 repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
425 ; repTyVarSig bndr' }
426 repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
427
428 -- | Represent result signature using a Maybe Kind. Used with data families,
429 -- where the result signature can be either missing or a kind but never a named
430 -- result variable.
431 repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
432 -> DsM (Core (Maybe TH.KindQ))
433 repFamilyResultSigToMaybeKind (NoSig _) =
434 do { coreNothing kindQTyConName }
435 repFamilyResultSigToMaybeKind (KindSig _ ki) =
436 do { ki' <- repLTy ki
437 ; coreJust kindQTyConName ki' }
438 repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
439
440 -- | Represent injectivity annotation of a type family
441 repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
442 -> DsM (Core (Maybe TH.InjectivityAnn))
443 repInjectivityAnn Nothing =
444 do { coreNothing injAnnTyConName }
445 repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
446 do { lhs' <- lookupBinder (unLoc lhs)
447 ; rhs1 <- mapM (lookupBinder . unLoc) rhs
448 ; rhs2 <- coreList nameTyConName rhs1
449 ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
450 ; coreJust injAnnTyConName injAnn }
451
452 repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
453 repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
454
455 repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
456 repAssocTyFamDefaults = mapM rep_deflt
457 where
458 -- very like repTyFamEqn, but different in the details
459 rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
460 rep_deflt (L _ (FamEqn { feqn_tycon = tc
461 , feqn_bndrs = bndrs
462 , feqn_pats = tys
463 , feqn_rhs = rhs }))
464 = addTyClTyVarBinds tys $ \ _ ->
465 do { tc1 <- lookupLOcc tc
466 ; no_bndrs <- ASSERT( isNothing bndrs )
467 coreNothingList tyVarBndrQTyConName
468 ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
469 ; tys2 <- coreList typeQTyConName tys1
470 ; rhs1 <- repLTy rhs
471 ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
472 ; repTySynInst tc1 eqn1 }
473 rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
474
475 -------------------------
476 -- represent fundeps
477 --
478 repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
479 repLFunDeps fds = repList funDepTyConName repLFunDep fds
480
481 repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
482 repLFunDep (L _ (xs, ys))
483 = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
484 ys' <- repList nameTyConName (lookupBinder . unLoc) ys
485 repFunDep xs' ys'
486
487 -- Represent instance declarations
488 --
489 repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
490 repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
491 = do { dec <- repTyFamInstD fi_decl
492 ; return (loc, dec) }
493 repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
494 = do { dec <- repDataFamInstD fi_decl
495 ; return (loc, dec) }
496 repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
497 = do { dec <- repClsInstD cls_decl
498 ; return (loc, dec) }
499 repInstD (L _ (XInstDecl _)) = panic "repInstD"
500
501 repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
502 repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
503 , cid_sigs = sigs, cid_tyfam_insts = ats
504 , cid_datafam_insts = adts
505 , cid_overlap_mode = overlap
506 })
507 = addSimpleTyVarBinds tvs $
508 -- We must bring the type variables into scope, so their
509 -- occurrences don't fail, even though the binders don't
510 -- appear in the resulting data structure
511 --
512 -- But we do NOT bring the binders of 'binds' into scope
513 -- because they are properly regarded as occurrences
514 -- For example, the method names should be bound to
515 -- the selector Ids, not to fresh names (Trac #5410)
516 --
517 do { cxt1 <- repLContext cxt
518 ; inst_ty1 <- repLTy inst_ty
519 -- See Note [Scoped type variables in class and instance declarations]
520 ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
521 ; ats1 <- mapM (repTyFamInstD . unLoc) ats
522 ; adts1 <- mapM (repDataFamInstD . unLoc) adts
523 ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
524 ; rOver <- repOverlap (fmap unLoc overlap)
525 ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
526 ; wrapGenSyms ss decls2 }
527 where
528 (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
529 repClsInstD (XClsInstDecl _) = panic "repClsInstD"
530
531 repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
532 repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
533 , deriv_type = ty }))
534 = do { dec <- addSimpleTyVarBinds tvs $
535 do { cxt' <- repLContext cxt
536 ; strat' <- repDerivStrategy strat
537 ; inst_ty' <- repLTy inst_ty
538 ; repDeriv strat' cxt' inst_ty' }
539 ; return (loc, dec) }
540 where
541 (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
542 repStandaloneDerivD (L _ (XDerivDecl _)) = panic "repStandaloneDerivD"
543
544 repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
545 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
546 = do { let tc_name = tyFamInstDeclLName decl
547 ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
548 ; eqn1 <- repTyFamEqn eqn
549 ; repTySynInst tc eqn1 }
550
551 repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
552 repTyFamEqn (HsIB { hsib_ext = var_names
553 , hsib_body = FamEqn { feqn_bndrs = mb_bndrs
554 , feqn_pats = tys
555 , feqn_rhs = rhs }})
556 = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
557 { hsq_implicit = var_names
558 , hsq_dependent = emptyNameSet } -- Yuk
559 , hsq_explicit = fromMaybe [] mb_bndrs }
560 ; addTyClTyVarBinds hs_tvs $ \ _ ->
561 do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
562 repTyVarBndr
563 mb_bndrs
564 ; tys1 <- repLTys tys
565 ; tys2 <- coreList typeQTyConName tys1
566 ; rhs1 <- repLTy rhs
567 ; repTySynEqn mb_bndrs1 tys2 rhs1 } }
568 repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
569 repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
570
571 repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
572 repDataFamInstD (DataFamInstDecl { dfid_eqn =
573 (HsIB { hsib_ext = var_names
574 , hsib_body = FamEqn { feqn_tycon = tc_name
575 , feqn_bndrs = mb_bndrs
576 , feqn_pats = tys
577 , feqn_rhs = defn }})})
578 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
579 ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
580 { hsq_implicit = var_names
581 , hsq_dependent = emptyNameSet } -- Yuk
582 , hsq_explicit = fromMaybe [] mb_bndrs }
583 ; addTyClTyVarBinds hs_tvs $ \ _ ->
584 do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
585 repTyVarBndr
586 mb_bndrs
587 ; tys1 <- repList typeQTyConName repLTy tys
588 ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
589 repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
590 = panic "repDataFamInstD"
591 repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
592 = panic "repDataFamInstD"
593
594 repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
595 repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
596 , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
597 = do MkC name' <- lookupLOcc name
598 MkC typ' <- repHsSigType typ
599 MkC cc' <- repCCallConv cc
600 MkC s' <- repSafety s
601 cis' <- conv_cimportspec cis
602 MkC str <- coreStringLit (static ++ chStr ++ cis')
603 dec <- rep2 forImpDName [cc', s', str, name', typ']
604 return (loc, dec)
605 where
606 conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
607 conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
608 conv_cimportspec (CFunction (StaticTarget _ fs _ True))
609 = return (unpackFS fs)
610 conv_cimportspec (CFunction (StaticTarget _ _ _ False))
611 = panic "conv_cimportspec: values not supported yet"
612 conv_cimportspec CWrapper = return "wrapper"
613 -- these calling conventions do not support headers and the static keyword
614 raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
615 static = case cis of
616 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
617 _ -> ""
618 chStr = case mch of
619 Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
620 _ -> ""
621 repForD decl = notHandled "Foreign declaration" (ppr decl)
622
623 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
624 repCCallConv CCallConv = rep2 cCallName []
625 repCCallConv StdCallConv = rep2 stdCallName []
626 repCCallConv CApiConv = rep2 cApiCallName []
627 repCCallConv PrimCallConv = rep2 primCallName []
628 repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
629
630 repSafety :: Safety -> DsM (Core TH.Safety)
631 repSafety PlayRisky = rep2 unsafeName []
632 repSafety PlayInterruptible = rep2 interruptibleName []
633 repSafety PlaySafe = rep2 safeName []
634
635 repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
636 repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
637 = do { MkC prec' <- coreIntLit prec
638 ; let rep_fn = case dir of
639 InfixL -> infixLDName
640 InfixR -> infixRDName
641 InfixN -> infixNDName
642 ; let do_one name
643 = do { MkC name' <- lookupLOcc name
644 ; dec <- rep2 rep_fn [prec', name']
645 ; return (loc,dec) }
646 ; mapM do_one names }
647 repFixD (L _ (XFixitySig _)) = panic "repFixD"
648
649 repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
650 repRuleD (L loc (HsRule { rd_name = n
651 , rd_act = act
652 , rd_tyvs = ty_bndrs
653 , rd_tmvs = tm_bndrs
654 , rd_lhs = lhs
655 , rd_rhs = rhs }))
656 = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
657 do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
658 ; ss <- mkGenSyms tm_bndr_names
659 ; rule <- addBinds ss $
660 do { ty_bndrs' <- case ty_bndrs of
661 Nothing -> coreNothingList tyVarBndrQTyConName
662 Just _ -> coreJustList tyVarBndrQTyConName ex_bndrs
663 ; tm_bndrs' <- repList ruleBndrQTyConName
664 repRuleBndr
665 tm_bndrs
666 ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
667 ; act' <- repPhases act
668 ; lhs' <- repLE lhs
669 ; rhs' <- repLE rhs
670 ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
671 ; wrapGenSyms ss rule }
672 ; return (loc, rule) }
673 repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
674
675 ruleBndrNames :: LRuleBndr GhcRn -> [Name]
676 ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n]
677 ruleBndrNames (L _ (RuleBndrSig _ n sig))
678 | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
679 = unLoc n : vars
680 ruleBndrNames (L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
681 = panic "ruleBndrNames"
682 ruleBndrNames (L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
683 = panic "ruleBndrNames"
684 ruleBndrNames (L _ (XRuleBndr _)) = panic "ruleBndrNames"
685
686 repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
687 repRuleBndr (L _ (RuleBndr _ n))
688 = do { MkC n' <- lookupLBinder n
689 ; rep2 ruleVarName [n'] }
690 repRuleBndr (L _ (RuleBndrSig _ n sig))
691 = do { MkC n' <- lookupLBinder n
692 ; MkC ty' <- repLTy (hsSigWcType sig)
693 ; rep2 typedRuleVarName [n', ty'] }
694 repRuleBndr (L _ (XRuleBndr _)) = panic "repRuleBndr"
695
696 repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
697 repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))
698 = do { target <- repAnnProv ann_prov
699 ; exp' <- repE exp
700 ; dec <- repPragAnn target exp'
701 ; return (loc, dec) }
702 repAnnD (L _ (XAnnDecl _)) = panic "repAnnD"
703
704 repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
705 repAnnProv (ValueAnnProvenance (L _ n))
706 = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level
707 ; rep2 valueAnnotationName [ n' ] }
708 repAnnProv (TypeAnnProvenance (L _ n))
709 = do { MkC n' <- globalVar n
710 ; rep2 typeAnnotationName [ n' ] }
711 repAnnProv ModuleAnnProvenance
712 = rep2 moduleAnnotationName []
713
714 -------------------------------------------------------
715 -- Constructors
716 -------------------------------------------------------
717
718 repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
719 repC (L _ (ConDeclH98 { con_name = con
720 , con_forall = L _ False
721 , con_mb_cxt = Nothing
722 , con_args = args }))
723 = repDataCon con args
724
725 repC (L _ (ConDeclH98 { con_name = con
726 , con_forall = L _ is_existential
727 , con_ex_tvs = con_tvs
728 , con_mb_cxt = mcxt
729 , con_args = args }))
730 = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
731 do { c' <- repDataCon con args
732 ; ctxt' <- repMbContext mcxt
733 ; if not is_existential && isNothing mcxt
734 then return c'
735 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
736 }
737 }
738
739 repC (L _ (ConDeclGADT { con_names = cons
740 , con_qvars = qtvs, con_mb_cxt = mcxt
741 , con_args = args, con_res_ty = res_ty }))
742 | isEmptyLHsQTvs qtvs -- No implicit or explicit variables
743 , Nothing <- mcxt -- No context
744 -- ==> no need for a forall
745 = repGadtDataCons cons args res_ty
746
747 | otherwise
748 = addTyVarBinds qtvs $ \ ex_bndrs ->
749 -- See Note [Don't quantify implicit type variables in quotes]
750 do { c' <- repGadtDataCons cons args res_ty
751 ; ctxt' <- repMbContext mcxt
752 ; if null (hsQTvExplicit qtvs) && isNothing mcxt
753 then return c'
754 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
755
756 repC (L _ (XConDecl _)) = panic "repC"
757
758
759 repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
760 repMbContext Nothing = repContext []
761 repMbContext (Just (L _ cxt)) = repContext cxt
762
763 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
764 repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
765 repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName []
766 repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
767
768 repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
769 repSrcStrictness SrcLazy = rep2 sourceLazyName []
770 repSrcStrictness SrcStrict = rep2 sourceStrictName []
771 repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
772
773 repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
774 repBangTy ty = do
775 MkC u <- repSrcUnpackedness su'
776 MkC s <- repSrcStrictness ss'
777 MkC b <- rep2 bangName [u, s]
778 MkC t <- repLTy ty'
779 rep2 bangTypeName [b, t]
780 where
781 (su', ss', ty') = case ty of
782 L _ (HsBangTy _ (HsSrcBang _ su ss) ty) -> (su, ss, ty)
783 _ -> (NoSrcUnpack, NoSrcStrict, ty)
784
785 -------------------------------------------------------
786 -- Deriving clauses
787 -------------------------------------------------------
788
789 repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
790 repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
791
792 repDerivClause :: LHsDerivingClause GhcRn
793 -> DsM (Core TH.DerivClauseQ)
794 repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
795 , deriv_clause_tys = L _ dct }))
796 = do MkC dcs' <- repDerivStrategy dcs
797 MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
798 rep2 derivClauseName [dcs',dct']
799 where
800 rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
801 rep_deriv_ty (L _ ty) = repTy ty
802 repDerivClause (L _ (XHsDerivingClause _)) = panic "repDerivClause"
803
804 rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
805 -> DsM ([GenSymBind], [Core TH.DecQ])
806 -- Represent signatures and methods in class/instance declarations.
807 -- See Note [Scoped type variables in class and instance declarations]
808 --
809 -- Why not use 'repBinds': we have already created symbols for methods in
810 -- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
811 -- these fun_id via 'collectHsValBinders decs', which would lead to the
812 -- instance declarations failing in TH.
813 rep_sigs_binds sigs binds
814 = do { let tvs = concatMap get_scoped_tvs sigs
815 ; ss <- mkGenSyms tvs
816 ; sigs1 <- addBinds ss $ rep_sigs sigs
817 ; binds1 <- addBinds ss $ rep_binds binds
818 ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
819
820 -------------------------------------------------------
821 -- Signatures in a class decl, or a group of bindings
822 -------------------------------------------------------
823
824 rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
825 -- We silently ignore ones we don't recognise
826 rep_sigs = concatMapM rep_sig
827
828 rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
829 rep_sig (L loc (TypeSig _ nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
830 rep_sig (L loc (PatSynSig _ nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
831 rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
832 | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
833 | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
834 rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
835 rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
836 rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
837 rep_sig (L loc (SpecSig _ nm tys ispec))
838 = concatMapM (\t -> rep_specialise nm t ispec loc) tys
839 rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc
840 rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
841 rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
842 rep_sig (L loc (CompleteMatchSig _ _st cls mty)) = rep_complete_sig cls mty loc
843 rep_sig (L _ (XSig _)) = panic "rep_sig"
844
845 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
846 -> DsM (SrcSpan, Core TH.DecQ)
847 -- Don't create the implicit and explicit variables when desugaring signatures,
848 -- see Note [Scoped type variables in class and instance declarations].
849 -- and Note [Don't quantify implicit type variables in quotes]
850 rep_ty_sig mk_sig loc sig_ty nm
851 | HsIB { hsib_body = hs_ty } <- sig_ty
852 , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
853 = do { nm1 <- lookupLOcc nm
854 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
855 ; repTyVarBndrWithKind tv name }
856 ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
857 explicit_tvs
858
859 -- NB: Don't pass any implicit type variables to repList above
860 -- See Note [Don't quantify implicit type variables in quotes]
861
862 ; th_ctxt <- repLContext ctxt
863 ; th_ty <- repLTy ty
864 ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
865 then return th_ty
866 else repTForall th_explicit_tvs th_ctxt th_ty
867 ; sig <- repProto mk_sig nm1 ty1
868 ; return (loc, sig) }
869 rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
870
871 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
872 -> DsM (SrcSpan, Core TH.DecQ)
873 -- represents a pattern synonym type signature;
874 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
875 --
876 -- Don't create the implicit and explicit variables when desugaring signatures,
877 -- see Note [Scoped type variables in class and instance declarations]
878 -- and Note [Don't quantify implicit type variables in quotes]
879 rep_patsyn_ty_sig loc sig_ty nm
880 | HsIB { hsib_body = hs_ty } <- sig_ty
881 , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
882 = do { nm1 <- lookupLOcc nm
883 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
884 ; repTyVarBndrWithKind tv name }
885 ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
886 ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis
887
888 -- NB: Don't pass any implicit type variables to repList above
889 -- See Note [Don't quantify implicit type variables in quotes]
890
891 ; th_reqs <- repLContext reqs
892 ; th_provs <- repLContext provs
893 ; th_ty <- repLTy ty
894 ; ty1 <- repTForall th_univs th_reqs =<<
895 repTForall th_exis th_provs th_ty
896 ; sig <- repProto patSynSigDName nm1 ty1
897 ; return (loc, sig) }
898 rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
899
900 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
901 -> DsM (SrcSpan, Core TH.DecQ)
902 rep_wc_ty_sig mk_sig loc sig_ty nm
903 = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
904
905 rep_inline :: Located Name
906 -> InlinePragma -- Never defaultInlinePragma
907 -> SrcSpan
908 -> DsM [(SrcSpan, Core TH.DecQ)]
909 rep_inline nm ispec loc
910 = do { nm1 <- lookupLOcc nm
911 ; inline <- repInline $ inl_inline ispec
912 ; rm <- repRuleMatch $ inl_rule ispec
913 ; phases <- repPhases $ inl_act ispec
914 ; pragma <- repPragInl nm1 inline rm phases
915 ; return [(loc, pragma)]
916 }
917
918 rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
919 -> SrcSpan
920 -> DsM [(SrcSpan, Core TH.DecQ)]
921 rep_specialise nm ty ispec loc
922 = do { nm1 <- lookupLOcc nm
923 ; ty1 <- repHsSigType ty
924 ; phases <- repPhases $ inl_act ispec
925 ; let inline = inl_inline ispec
926 ; pragma <- if noUserInlineSpec inline
927 then -- SPECIALISE
928 repPragSpec nm1 ty1 phases
929 else -- SPECIALISE INLINE
930 do { inline1 <- repInline inline
931 ; repPragSpecInl nm1 ty1 inline1 phases }
932 ; return [(loc, pragma)]
933 }
934
935 rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
936 -> DsM [(SrcSpan, Core TH.DecQ)]
937 rep_specialiseInst ty loc
938 = do { ty1 <- repHsSigType ty
939 ; pragma <- repPragSpecInst ty1
940 ; return [(loc, pragma)] }
941
942 repInline :: InlineSpec -> DsM (Core TH.Inline)
943 repInline NoInline = dataCon noInlineDataConName
944 repInline Inline = dataCon inlineDataConName
945 repInline Inlinable = dataCon inlinableDataConName
946 repInline spec = notHandled "repInline" (ppr spec)
947
948 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
949 repRuleMatch ConLike = dataCon conLikeDataConName
950 repRuleMatch FunLike = dataCon funLikeDataConName
951
952 repPhases :: Activation -> DsM (Core TH.Phases)
953 repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
954 ; dataCon' beforePhaseDataConName [arg] }
955 repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
956 ; dataCon' fromPhaseDataConName [arg] }
957 repPhases _ = dataCon allPhasesDataConName
958
959 rep_complete_sig :: Located [Located Name]
960 -> Maybe (Located Name)
961 -> SrcSpan
962 -> DsM [(SrcSpan, Core TH.DecQ)]
963 rep_complete_sig (L _ cls) mty loc
964 = do { mty' <- repMaybe nameTyConName lookupLOcc mty
965 ; cls' <- repList nameTyConName lookupLOcc cls
966 ; sig <- repPragComplete cls' mty'
967 ; return [(loc, sig)] }
968
969 -------------------------------------------------------
970 -- Types
971 -------------------------------------------------------
972
973 addSimpleTyVarBinds :: [Name] -- the binders to be added
974 -> DsM (Core (TH.Q a)) -- action in the ext env
975 -> DsM (Core (TH.Q a))
976 addSimpleTyVarBinds names thing_inside
977 = do { fresh_names <- mkGenSyms names
978 ; term <- addBinds fresh_names thing_inside
979 ; wrapGenSyms fresh_names term }
980
981 addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
982 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
983 -> DsM (Core (TH.Q a))
984 addHsTyVarBinds exp_tvs thing_inside
985 = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
986 ; term <- addBinds fresh_exp_names $
987 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
988 (exp_tvs `zip` fresh_exp_names)
989 ; thing_inside kbs }
990 ; wrapGenSyms fresh_exp_names term }
991 where
992 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
993
994 addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
995 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
996 -> DsM (Core (TH.Q a))
997 -- gensym a list of type variables and enter them into the meta environment;
998 -- the computations passed as the second argument is executed in that extended
999 -- meta environment and gets the *new* names on Core-level as an argument
1000 addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
1001 , hsq_explicit = exp_tvs })
1002 thing_inside
1003 = addSimpleTyVarBinds imp_tvs $
1004 addHsTyVarBinds exp_tvs $
1005 thing_inside
1006 addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
1007
1008 addTyClTyVarBinds :: LHsQTyVars GhcRn
1009 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
1010 -> DsM (Core (TH.Q a))
1011
1012 -- Used for data/newtype declarations, and family instances,
1013 -- so that the nested type variables work right
1014 -- instance C (T a) where
1015 -- type W (T a) = blah
1016 -- The 'a' in the type instance is the one bound by the instance decl
1017 addTyClTyVarBinds tvs m
1018 = do { let tv_names = hsAllLTyVarNames tvs
1019 ; env <- dsGetMetaEnv
1020 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
1021 -- Make fresh names for the ones that are not already in scope
1022 -- This makes things work for family declarations
1023
1024 ; term <- addBinds freshNames $
1025 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
1026 (hsQTvExplicit tvs)
1027 ; m kbs }
1028
1029 ; wrapGenSyms freshNames term }
1030 where
1031 mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
1032 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
1033 ; repTyVarBndrWithKind tv v }
1034
1035 -- Produce kinded binder constructors from the Haskell tyvar binders
1036 --
1037 repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
1038 -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
1039 repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm
1040 = repPlainTV nm
1041 repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm
1042 = repLTy ki >>= repKindedTV nm
1043 repTyVarBndrWithKind (L _ (XTyVarBndr{})) _ = panic "repTyVarBndrWithKind"
1044
1045 -- | Represent a type variable binder
1046 repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
1047 repTyVarBndr (L _ (UserTyVar _ (L _ nm)) )= do { nm' <- lookupBinder nm
1048 ; repPlainTV nm' }
1049 repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) = do { nm' <- lookupBinder nm
1050 ; ki' <- repLTy ki
1051 ; repKindedTV nm' ki' }
1052 repTyVarBndr (L _ (XTyVarBndr{})) = panic "repTyVarBndr"
1053
1054 -- represent a type context
1055 --
1056 repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
1057 repLContext (L _ ctxt) = repContext ctxt
1058
1059 repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
1060 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
1061 repCtxt preds
1062
1063 repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
1064 repHsSigType (HsIB { hsib_ext = implicit_tvs
1065 , hsib_body = body })
1066 | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
1067 = addSimpleTyVarBinds implicit_tvs $
1068 -- See Note [Don't quantify implicit type variables in quotes]
1069 addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
1070 do { th_ctxt <- repLContext ctxt
1071 ; th_ty <- repLTy ty
1072 ; if null explicit_tvs && null (unLoc ctxt)
1073 then return th_ty
1074 else repTForall th_explicit_tvs th_ctxt th_ty }
1075 repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
1076
1077 repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
1078 repHsSigWcType (HsWC { hswc_body = sig1 })
1079 = repHsSigType sig1
1080 repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
1081
1082 -- yield the representation of a list of types
1083 repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
1084 repLTys tys = mapM repLTy tys
1085
1086 -- represent a type
1087 repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
1088 repLTy (L _ ty) = repTy ty
1089
1090 repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
1091 -- Arg of repForall is always HsForAllTy or HsQualTy
1092 repForall ty
1093 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
1094 = addHsTyVarBinds tvs $ \bndrs ->
1095 do { ctxt1 <- repLContext ctxt
1096 ; ty1 <- repLTy tau
1097 ; repTForall bndrs ctxt1 ty1 }
1098
1099 repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
1100 repTy ty@(HsForAllTy {}) = repForall ty
1101 repTy ty@(HsQualTy {}) = repForall ty
1102
1103 repTy (HsTyVar _ _ (L _ n))
1104 | isLiftedTypeKindTyConName n = repTStar
1105 | n `hasKey` constraintKindTyConKey = repTConstraint
1106 | n `hasKey` funTyConKey = repArrowTyCon
1107 | isTvOcc occ = do tv1 <- lookupOcc n
1108 repTvar tv1
1109 | isDataOcc occ = do tc1 <- lookupOcc n
1110 repPromotedDataCon tc1
1111 | n == eqTyConName = repTequality
1112 | otherwise = do tc1 <- lookupOcc n
1113 repNamedTyCon tc1
1114 where
1115 occ = nameOccName n
1116
1117 repTy (HsAppTy _ f a) = do
1118 f1 <- repLTy f
1119 a1 <- repLTy a
1120 repTapp f1 a1
1121 repTy (HsFunTy _ f a) = do
1122 f1 <- repLTy f
1123 a1 <- repLTy a
1124 tcon <- repArrowTyCon
1125 repTapps tcon [f1, a1]
1126 repTy (HsListTy _ t) = do
1127 t1 <- repLTy t
1128 tcon <- repListTyCon
1129 repTapp tcon t1
1130 repTy (HsTupleTy _ HsUnboxedTuple tys) = do
1131 tys1 <- repLTys tys
1132 tcon <- repUnboxedTupleTyCon (length tys)
1133 repTapps tcon tys1
1134 repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
1135 tcon <- repTupleTyCon (length tys)
1136 repTapps tcon tys1
1137 repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
1138 tcon <- repUnboxedSumTyCon (length tys)
1139 repTapps tcon tys1
1140 repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
1141 `nlHsAppTy` ty2)
1142 repTy (HsParTy _ t) = repLTy t
1143 repTy (HsStarTy _ _) = repTStar
1144 repTy (HsKindSig _ t k) = do
1145 t1 <- repLTy t
1146 k1 <- repLTy k
1147 repTSig t1 k1
1148 repTy (HsSpliceTy _ splice) = repSplice splice
1149 repTy (HsExplicitListTy _ _ tys) = do
1150 tys1 <- repLTys tys
1151 repTPromotedList tys1
1152 repTy (HsExplicitTupleTy _ tys) = do
1153 tys1 <- repLTys tys
1154 tcon <- repPromotedTupleTyCon (length tys)
1155 repTapps tcon tys1
1156 repTy (HsTyLit _ lit) = do
1157 lit' <- repTyLit lit
1158 repTLit lit'
1159 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
1160 repTy (HsIParamTy _ n t) = do
1161 n' <- rep_implicit_param_name (unLoc n)
1162 t' <- repLTy t
1163 repTImplicitParam n' t'
1164
1165 repTy ty = notHandled "Exotic form of type" (ppr ty)
1166
1167 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
1168 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
1169 rep2 numTyLitName [iExpr]
1170 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
1171 ; rep2 strTyLitName [s']
1172 }
1173
1174 -- | Represent a type wrapped in a Maybe
1175 repMaybeLTy :: Maybe (LHsKind GhcRn)
1176 -> DsM (Core (Maybe TH.TypeQ))
1177 repMaybeLTy = repMaybe kindQTyConName repLTy
1178
1179 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
1180 repRole (L _ (Just Nominal)) = rep2 nominalRName []
1181 repRole (L _ (Just Representational)) = rep2 representationalRName []
1182 repRole (L _ (Just Phantom)) = rep2 phantomRName []
1183 repRole (L _ Nothing) = rep2 inferRName []
1184
1185 -----------------------------------------------------------------------------
1186 -- Splices
1187 -----------------------------------------------------------------------------
1188
1189 repSplice :: HsSplice GhcRn -> DsM (Core a)
1190 -- See Note [How brackets and nested splices are handled] in TcSplice
1191 -- We return a CoreExpr of any old type; the context should know
1192 repSplice (HsTypedSplice _ _ n _) = rep_splice n
1193 repSplice (HsUntypedSplice _ _ n _) = rep_splice n
1194 repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
1195 repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
1196 repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
1197
1198 rep_splice :: Name -> DsM (Core a)
1199 rep_splice splice_name
1200 = do { mb_val <- dsLookupMetaEnv splice_name
1201 ; case mb_val of
1202 Just (DsSplice e) -> do { e' <- dsExpr e
1203 ; return (MkC e') }
1204 _ -> pprPanic "HsSplice" (ppr splice_name) }
1205 -- Should not happen; statically checked
1206
1207 -----------------------------------------------------------------------------
1208 -- Expressions
1209 -----------------------------------------------------------------------------
1210
1211 repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
1212 repLEs es = repList expQTyConName repLE es
1213
1214 -- FIXME: some of these panics should be converted into proper error messages
1215 -- unless we can make sure that constructs, which are plainly not
1216 -- supported in TH already lead to error messages at an earlier stage
1217 repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
1218 repLE (L loc e) = putSrcSpanDs loc (repE e)
1219
1220 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
1221 repE (HsVar _ (L _ x)) =
1222 do { mb_val <- dsLookupMetaEnv x
1223 ; case mb_val of
1224 Nothing -> do { str <- globalVar x
1225 ; repVarOrCon x str }
1226 Just (DsBound y) -> repVarOrCon x (coreVar y)
1227 Just (DsSplice e) -> do { e' <- dsExpr e
1228 ; return (MkC e') } }
1229 repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
1230 repE (HsOverLabel _ _ s) = repOverLabel s
1231
1232 repE e@(HsRecFld _ f) = case f of
1233 Unambiguous x _ -> repE (HsVar noExt (noLoc x))
1234 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
1235 XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
1236
1237 -- Remember, we're desugaring renamer output here, so
1238 -- HsOverlit can definitely occur
1239 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
1240 repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
1241 repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
1242 repE (HsLamCase _ (MG { mg_alts = L _ ms }))
1243 = do { ms' <- mapM repMatchTup ms
1244 ; core_ms <- coreList matchQTyConName ms'
1245 ; repLamCase core_ms }
1246 repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1247 repE (HsAppType _ e t) = do { a <- repLE e
1248 ; s <- repLTy (hswc_body t)
1249 ; repAppType a s }
1250
1251 repE (OpApp _ e1 op e2) =
1252 do { arg1 <- repLE e1;
1253 arg2 <- repLE e2;
1254 the_op <- repLE op ;
1255 repInfixApp arg1 the_op arg2 }
1256 repE (NegApp _ x _) = do
1257 a <- repLE x
1258 negateVar <- lookupOcc negateName >>= repVar
1259 negateVar `repApp` a
1260 repE (HsPar _ x) = repLE x
1261 repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1262 repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1263 repE (HsCase _ e (MG { mg_alts = L _ ms }))
1264 = do { arg <- repLE e
1265 ; ms2 <- mapM repMatchTup ms
1266 ; core_ms2 <- coreList matchQTyConName ms2
1267 ; repCaseE arg core_ms2 }
1268 repE (HsIf _ _ x y z) = do
1269 a <- repLE x
1270 b <- repLE y
1271 c <- repLE z
1272 repCond a b c
1273 repE (HsMultiIf _ alts)
1274 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1275 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1276 ; wrapGenSyms (concat binds) expr' }
1277 repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
1278 ; e2 <- addBinds ss (repLE e)
1279 ; z <- repLetE ds e2
1280 ; wrapGenSyms ss z }
1281
1282 -- FIXME: I haven't got the types here right yet
1283 repE e@(HsDo _ ctxt (L _ sts))
1284 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1285 = do { (ss,zs) <- repLSts sts;
1286 e' <- repDoE (nonEmptyCoreList zs);
1287 wrapGenSyms ss e' }
1288
1289 | ListComp <- ctxt
1290 = do { (ss,zs) <- repLSts sts;
1291 e' <- repComp (nonEmptyCoreList zs);
1292 wrapGenSyms ss e' }
1293
1294 | MDoExpr <- ctxt
1295 = do { (ss,zs) <- repLSts sts;
1296 e' <- repMDoE (nonEmptyCoreList zs);
1297 wrapGenSyms ss e' }
1298
1299 | otherwise
1300 = notHandled "monad comprehension and [: :]" (ppr e)
1301
1302 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1303 repE e@(ExplicitTuple _ es boxed)
1304 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1305 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present _ e) <- es]; repTup xs }
1306 | otherwise = do { xs <- repLEs [e | L _ (Present _ e) <- es]
1307 ; repUnboxedTup xs }
1308
1309 repE (ExplicitSum _ alt arity e)
1310 = do { e1 <- repLE e
1311 ; repUnboxedSum e1 alt arity }
1312
1313 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
1314 = do { x <- lookupLOcc c;
1315 fs <- repFields flds;
1316 repRecCon x fs }
1317 repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
1318 = do { x <- repLE e;
1319 fs <- repUpdFields flds;
1320 repRecUpd x fs }
1321
1322 repE (ExprWithTySig _ e ty)
1323 = do { e1 <- repLE e
1324 ; t1 <- repHsSigWcType ty
1325 ; repSigExp e1 t1 }
1326
1327 repE (ArithSeq _ _ aseq) =
1328 case aseq of
1329 From e -> do { ds1 <- repLE e; repFrom ds1 }
1330 FromThen e1 e2 -> do
1331 ds1 <- repLE e1
1332 ds2 <- repLE e2
1333 repFromThen ds1 ds2
1334 FromTo e1 e2 -> do
1335 ds1 <- repLE e1
1336 ds2 <- repLE e2
1337 repFromTo ds1 ds2
1338 FromThenTo e1 e2 e3 -> do
1339 ds1 <- repLE e1
1340 ds2 <- repLE e2
1341 ds3 <- repLE e3
1342 repFromThenTo ds1 ds2 ds3
1343
1344 repE (HsSpliceE _ splice) = repSplice splice
1345 repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
1346 repE (HsUnboundVar _ uv) = do
1347 occ <- occNameLit (unboundVarOcc uv)
1348 sname <- repNameS occ
1349 repUnboundVar sname
1350
1351 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1352 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1353 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1354 repE e = notHandled "Expression form" (ppr e)
1355
1356 -----------------------------------------------------------------------------
1357 -- Building representations of auxillary structures like Match, Clause, Stmt,
1358
1359 repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
1360 repMatchTup (L _ (Match { m_pats = [p]
1361 , m_grhss = GRHSs _ guards (L _ wheres) })) =
1362 do { ss1 <- mkGenSyms (collectPatBinders p)
1363 ; addBinds ss1 $ do {
1364 ; p1 <- repLP p
1365 ; (ss2,ds) <- repBinds wheres
1366 ; addBinds ss2 $ do {
1367 ; gs <- repGuards guards
1368 ; match <- repMatch p1 gs ds
1369 ; wrapGenSyms (ss1++ss2) match }}}
1370 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1371
1372 repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
1373 repClauseTup (L _ (Match { m_pats = ps
1374 , m_grhss = GRHSs _ guards (L _ wheres) })) =
1375 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1376 ; addBinds ss1 $ do {
1377 ps1 <- repLPs ps
1378 ; (ss2,ds) <- repBinds wheres
1379 ; addBinds ss2 $ do {
1380 gs <- repGuards guards
1381 ; clause <- repClause ps1 gs ds
1382 ; wrapGenSyms (ss1++ss2) clause }}}
1383 repClauseTup (L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
1384 repClauseTup (L _ (XMatch _)) = panic "repClauseTup"
1385
1386 repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
1387 repGuards [L _ (GRHS _ [] e)]
1388 = do {a <- repLE e; repNormal a }
1389 repGuards other
1390 = do { zs <- mapM repLGRHS other
1391 ; let (xs, ys) = unzip zs
1392 ; gd <- repGuarded (nonEmptyCoreList ys)
1393 ; wrapGenSyms (concat xs) gd }
1394
1395 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
1396 -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1397 repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
1398 = do { guarded <- repLNormalGE e1 e2
1399 ; return ([], guarded) }
1400 repLGRHS (L _ (GRHS _ ss rhs))
1401 = do { (gs, ss') <- repLSts ss
1402 ; rhs' <- addBinds gs $ repLE rhs
1403 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1404 ; return (gs, guarded) }
1405 repLGRHS (L _ (XGRHS _)) = panic "repLGRHS"
1406
1407 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
1408 repFields (HsRecFields { rec_flds = flds })
1409 = repList fieldExpQTyConName rep_fld flds
1410 where
1411 rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
1412 -> DsM (Core (TH.Q TH.FieldExp))
1413 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
1414 ; e <- repLE (hsRecFieldArg fld)
1415 ; repFieldExp fn e }
1416
1417 repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
1418 repUpdFields = repList fieldExpQTyConName rep_fld
1419 where
1420 rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
1421 rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
1422 Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
1423 ; e <- repLE (hsRecFieldArg fld)
1424 ; repFieldExp fn e }
1425 _ -> notHandled "Ambiguous record updates" (ppr fld)
1426
1427
1428
1429 -----------------------------------------------------------------------------
1430 -- Representing Stmt's is tricky, especially if bound variables
1431 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1432 -- First gensym new names for every variable in any of the patterns.
1433 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1434 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1435 -- and we could reuse the original names (x and x).
1436 --
1437 -- do { x'1 <- gensym "x"
1438 -- ; x'2 <- gensym "x"
1439 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1440 -- , BindSt (pvar x'2) [| f x |]
1441 -- , NoBindSt [| g x |]
1442 -- ]
1443 -- }
1444
1445 -- The strategy is to translate a whole list of do-bindings by building a
1446 -- bigger environment, and a bigger set of meta bindings
1447 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1448 -- of the expressions within the Do
1449
1450 -----------------------------------------------------------------------------
1451 -- The helper function repSts computes the translation of each sub expression
1452 -- and a bunch of prefix bindings denoting the dynamic renaming.
1453
1454 repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1455 repLSts stmts = repSts (map unLoc stmts)
1456
1457 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1458 repSts (BindStmt _ p e _ _ : ss) =
1459 do { e2 <- repLE e
1460 ; ss1 <- mkGenSyms (collectPatBinders p)
1461 ; addBinds ss1 $ do {
1462 ; p1 <- repLP p;
1463 ; (ss2,zs) <- repSts ss
1464 ; z <- repBindSt p1 e2
1465 ; return (ss1++ss2, z : zs) }}
1466 repSts (LetStmt _ (L _ bs) : ss) =
1467 do { (ss1,ds) <- repBinds bs
1468 ; z <- repLetSt ds
1469 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1470 ; return (ss1++ss2, z : zs) }
1471 repSts (BodyStmt _ e _ _ : ss) =
1472 do { e2 <- repLE e
1473 ; z <- repNoBindSt e2
1474 ; (ss2,zs) <- repSts ss
1475 ; return (ss2, z : zs) }
1476 repSts (ParStmt _ stmt_blocks _ _ : ss) =
1477 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1478 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1479 ss1 = concat ss_s
1480 ; z <- repParSt stmt_blocks2
1481 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1482 ; return (ss1++ss2, z : zs) }
1483 where
1484 rep_stmt_block :: ParStmtBlock GhcRn GhcRn
1485 -> DsM ([GenSymBind], Core [TH.StmtQ])
1486 rep_stmt_block (ParStmtBlock _ stmts _ _) =
1487 do { (ss1, zs) <- repSts (map unLoc stmts)
1488 ; zs1 <- coreList stmtQTyConName zs
1489 ; return (ss1, zs1) }
1490 rep_stmt_block (XParStmtBlock{}) = panic "repSts"
1491 repSts [LastStmt _ e _ _]
1492 = do { e2 <- repLE e
1493 ; z <- repNoBindSt e2
1494 ; return ([], [z]) }
1495 repSts (stmt@RecStmt{} : ss)
1496 = do { let binders = collectLStmtsBinders (recS_stmts stmt)
1497 ; ss1 <- mkGenSyms binders
1498 -- Bring all of binders in the recursive group into scope for the
1499 -- whole group.
1500 ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
1501 ; MASSERT(sort ss1 == sort ss1_other)
1502 ; z <- repRecSt (nonEmptyCoreList rss)
1503 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1504 ; return (ss1++ss2, z : zs) }
1505 repSts [] = return ([],[])
1506 repSts other = notHandled "Exotic statement" (ppr other)
1507
1508
1509 -----------------------------------------------------------
1510 -- Bindings
1511 -----------------------------------------------------------
1512
1513 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
1514 repBinds (EmptyLocalBinds _)
1515 = do { core_list <- coreList decQTyConName []
1516 ; return ([], core_list) }
1517
1518 repBinds (HsIPBinds _ (IPBinds _ decs))
1519 = do { ips <- mapM rep_implicit_param_bind decs
1520 ; core_list <- coreList decQTyConName
1521 (de_loc (sort_by_loc ips))
1522 ; return ([], core_list)
1523 }
1524
1525 repBinds b@(HsIPBinds _ XHsIPBinds {})
1526 = notHandled "Implicit parameter binds extension" (ppr b)
1527
1528 repBinds (HsValBinds _ decs)
1529 = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
1530 -- No need to worry about detailed scopes within
1531 -- the binding group, because we are talking Names
1532 -- here, so we can safely treat it as a mutually
1533 -- recursive group
1534 -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
1535 ; ss <- mkGenSyms bndrs
1536 ; prs <- addBinds ss (rep_val_binds decs)
1537 ; core_list <- coreList decQTyConName
1538 (de_loc (sort_by_loc prs))
1539 ; return (ss, core_list) }
1540 repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
1541
1542 rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1543 rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
1544 = do { name <- case ename of
1545 Left (L _ n) -> rep_implicit_param_name n
1546 Right _ ->
1547 panic "rep_implicit_param_bind: post typechecking"
1548 ; rhs' <- repE rhs
1549 ; ipb <- repImplicitParamBind name rhs'
1550 ; return (loc, ipb) }
1551 rep_implicit_param_bind (L _ b@(XIPBind _))
1552 = notHandled "Implicit parameter bind extension" (ppr b)
1553
1554 rep_implicit_param_name :: HsIPName -> DsM (Core String)
1555 rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
1556
1557 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1558 -- Assumes: all the binders of the binding are already in the meta-env
1559 rep_val_binds (XValBindsLR (NValBinds binds sigs))
1560 = do { core1 <- rep_binds (unionManyBags (map snd binds))
1561 ; core2 <- rep_sigs sigs
1562 ; return (core1 ++ core2) }
1563 rep_val_binds (ValBinds _ _ _)
1564 = panic "rep_val_binds: ValBinds"
1565
1566 rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1567 rep_binds = mapM rep_bind . bagToList
1568
1569 rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1570 -- Assumes: all the binders of the binding are already in the meta-env
1571
1572 -- Note GHC treats declarations of a variable (not a pattern)
1573 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1574 -- with an empty list of patterns
1575 rep_bind (L loc (FunBind
1576 { fun_id = fn,
1577 fun_matches = MG { mg_alts
1578 = L _ [L _ (Match
1579 { m_pats = []
1580 , m_grhss = GRHSs _ guards (L _ wheres) }
1581 )] } }))
1582 = do { (ss,wherecore) <- repBinds wheres
1583 ; guardcore <- addBinds ss (repGuards guards)
1584 ; fn' <- lookupLBinder fn
1585 ; p <- repPvar fn'
1586 ; ans <- repVal p guardcore wherecore
1587 ; ans' <- wrapGenSyms ss ans
1588 ; return (loc, ans') }
1589
1590 rep_bind (L loc (FunBind { fun_id = fn
1591 , fun_matches = MG { mg_alts = L _ ms } }))
1592 = do { ms1 <- mapM repClauseTup ms
1593 ; fn' <- lookupLBinder fn
1594 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1595 ; return (loc, ans) }
1596
1597 rep_bind (L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
1598
1599 rep_bind (L loc (PatBind { pat_lhs = pat
1600 , pat_rhs = GRHSs _ guards (L _ wheres) }))
1601 = do { patcore <- repLP pat
1602 ; (ss,wherecore) <- repBinds wheres
1603 ; guardcore <- addBinds ss (repGuards guards)
1604 ; ans <- repVal patcore guardcore wherecore
1605 ; ans' <- wrapGenSyms ss ans
1606 ; return (loc, ans') }
1607 rep_bind (L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
1608
1609 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1610 = do { v' <- lookupBinder v
1611 ; e2 <- repLE e
1612 ; x <- repNormal e2
1613 ; patcore <- repPvar v'
1614 ; empty_decls <- coreList decQTyConName []
1615 ; ans <- repVal patcore x empty_decls
1616 ; return (srcLocSpan (getSrcLoc v), ans) }
1617
1618 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1619 rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn
1620 , psb_args = args
1621 , psb_def = pat
1622 , psb_dir = dir })))
1623 = do { syn' <- lookupLBinder syn
1624 ; dir' <- repPatSynDir dir
1625 ; ss <- mkGenArgSyms args
1626 ; patSynD' <- addBinds ss (
1627 do { args' <- repPatSynArgs args
1628 ; pat' <- repLP pat
1629 ; repPatSynD syn' args' dir' pat' })
1630 ; patSynD'' <- wrapGenArgSyms args ss patSynD'
1631 ; return (loc, patSynD'') }
1632 where
1633 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
1634 -- for Record Pattern Synonyms we want to conflate the selector
1635 -- and the pattern-only names in order to provide a nicer TH
1636 -- API. Whereas inside GHC, record pattern synonym selectors and
1637 -- their pattern-only bound right hand sides have different names,
1638 -- we want to treat them the same in TH. This is the reason why we
1639 -- need an adjusted mkGenArgSyms in the `RecCon` case below.
1640 mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
1641 mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
1642 mkGenArgSyms (RecCon fields)
1643 = do { let pats = map (unLoc . recordPatSynPatVar) fields
1644 sels = map (unLoc . recordPatSynSelectorId) fields
1645 ; ss <- mkGenSyms sels
1646 ; return $ replaceNames (zip sels pats) ss }
1647
1648 replaceNames selsPats genSyms
1649 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
1650 , sel == sel' ]
1651
1652 wrapGenArgSyms :: HsPatSynDetails (Located Name)
1653 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
1654 wrapGenArgSyms (RecCon _) _ dec = return dec
1655 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
1656
1657 rep_bind (L _ (PatSynBind _ (XPatSynBind _))) = panic "rep_bind: XPatSynBind"
1658 rep_bind (L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
1659
1660 repPatSynD :: Core TH.Name
1661 -> Core TH.PatSynArgsQ
1662 -> Core TH.PatSynDirQ
1663 -> Core TH.PatQ
1664 -> DsM (Core TH.DecQ)
1665 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
1666 = rep2 patSynDName [syn, args, dir, pat]
1667
1668 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
1669 repPatSynArgs (PrefixCon args)
1670 = do { args' <- repList nameTyConName lookupLOcc args
1671 ; repPrefixPatSynArgs args' }
1672 repPatSynArgs (InfixCon arg1 arg2)
1673 = do { arg1' <- lookupLOcc arg1
1674 ; arg2' <- lookupLOcc arg2
1675 ; repInfixPatSynArgs arg1' arg2' }
1676 repPatSynArgs (RecCon fields)
1677 = do { sels' <- repList nameTyConName lookupLOcc sels
1678 ; repRecordPatSynArgs sels' }
1679 where sels = map recordPatSynSelectorId fields
1680
1681 repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
1682 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
1683
1684 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
1685 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
1686
1687 repRecordPatSynArgs :: Core [TH.Name]
1688 -> DsM (Core TH.PatSynArgsQ)
1689 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
1690
1691 repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
1692 repPatSynDir Unidirectional = rep2 unidirPatSynName []
1693 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
1694 repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
1695 = do { clauses' <- mapM repClauseTup clauses
1696 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
1697 repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
1698
1699 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
1700 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
1701
1702
1703 -----------------------------------------------------------------------------
1704 -- Since everything in a Bind is mutually recursive we need rename all
1705 -- all the variables simultaneously. For example:
1706 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1707 -- do { f'1 <- gensym "f"
1708 -- ; g'2 <- gensym "g"
1709 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1710 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1711 -- ]}
1712 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1713 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1714 -- together. As we do this we collect GenSymBinds's which represent the renamed
1715 -- variables bound by the Bindings. In order not to lose track of these
1716 -- representations we build a shadow datatype MB with the same structure as
1717 -- MonoBinds, but which has slots for the representations
1718
1719
1720 -----------------------------------------------------------------------------
1721 -- GHC allows a more general form of lambda abstraction than specified
1722 -- by Haskell 98. In particular it allows guarded lambda's like :
1723 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1724 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1725 -- (\ p1 .. pn -> exp) by causing an error.
1726
1727 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
1728 repLambda (L _ (Match { m_pats = ps
1729 , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
1730 (L _ (EmptyLocalBinds _)) } ))
1731 = do { let bndrs = collectPatsBinders ps ;
1732 ; ss <- mkGenSyms bndrs
1733 ; lam <- addBinds ss (
1734 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1735 ; wrapGenSyms ss lam }
1736
1737 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
1738
1739
1740 -----------------------------------------------------------------------------
1741 -- Patterns
1742 -- repP deals with patterns. It assumes that we have already
1743 -- walked over the pattern(s) once to collect the binders, and
1744 -- have extended the environment. So every pattern-bound
1745 -- variable should already appear in the environment.
1746
1747 -- Process a list of patterns
1748 repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
1749 repLPs ps = repList patQTyConName repLP ps
1750
1751 repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
1752 repLP (L _ p) = repP p
1753
1754 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
1755 repP (WildPat _) = repPwild
1756 repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
1757 repP (VarPat _ (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
1758 repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
1759 repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
1760 repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
1761 ; repPaspat x' p1 }
1762 repP (ParPat _ p) = repLP p
1763 repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
1764 repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
1765 ; e' <- repE (syn_expr e)
1766 ; repPview e' p}
1767 repP (TuplePat _ ps boxed)
1768 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1769 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1770 repP (SumPat _ p alt arity) = do { p1 <- repLP p
1771 ; repPunboxedSum p1 alt arity }
1772 repP (ConPatIn dc details)
1773 = do { con_str <- lookupLOcc dc
1774 ; case details of
1775 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1776 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1777 ; repPrec con_str fps }
1778 InfixCon p1 p2 -> do { p1' <- repLP p1;
1779 p2' <- repLP p2;
1780 repPinfix p1' con_str p2' }
1781 }
1782 where
1783 rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
1784 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
1785 ; MkC p <- repLP (hsRecFieldArg fld)
1786 ; rep2 fieldPatName [v,p] }
1787
1788 repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
1789 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1790 repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1791 repP (SigPat _ p t) = do { p' <- repLP p
1792 ; t' <- repLTy (hsSigWcType t)
1793 ; repPsig p' t' }
1794 repP (SplicePat _ splice) = repSplice splice
1795
1796 repP other = notHandled "Exotic pattern" (ppr other)
1797
1798 ----------------------------------------------------------
1799 -- Declaration ordering helpers
1800
1801 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1802 sort_by_loc xs = sortBy comp xs
1803 where comp x y = compare (fst x) (fst y)
1804
1805 de_loc :: [(a, b)] -> [b]
1806 de_loc = map snd
1807
1808 ----------------------------------------------------------
1809 -- The meta-environment
1810
1811 -- A name/identifier association for fresh names of locally bound entities
1812 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1813 -- I.e. (x, x_id) means
1814 -- let x_id = gensym "x" in ...
1815
1816 -- Generate a fresh name for a locally bound entity
1817
1818 mkGenSyms :: [Name] -> DsM [GenSymBind]
1819 -- We can use the existing name. For example:
1820 -- [| \x_77 -> x_77 + x_77 |]
1821 -- desugars to
1822 -- do { x_77 <- genSym "x"; .... }
1823 -- We use the same x_77 in the desugared program, but with the type Bndr
1824 -- instead of Int
1825 --
1826 -- We do make it an Internal name, though (hence localiseName)
1827 --
1828 -- Nevertheless, it's monadic because we have to generate nameTy
1829 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1830 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1831
1832
1833 addBinds :: [GenSymBind] -> DsM a -> DsM a
1834 -- Add a list of fresh names for locally bound entities to the
1835 -- meta environment (which is part of the state carried around
1836 -- by the desugarer monad)
1837 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1838
1839 -- Look up a locally bound name
1840 --
1841 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1842 lookupLBinder (L _ n) = lookupBinder n
1843
1844 lookupBinder :: Name -> DsM (Core TH.Name)
1845 lookupBinder = lookupOcc
1846 -- Binders are brought into scope before the pattern or what-not is
1847 -- desugared. Moreover, in instance declaration the binder of a method
1848 -- will be the selector Id and hence a global; so we need the
1849 -- globalVar case of lookupOcc
1850
1851 -- Look up a name that is either locally bound or a global name
1852 --
1853 -- * If it is a global name, generate the "original name" representation (ie,
1854 -- the <module>:<name> form) for the associated entity
1855 --
1856 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1857 -- Lookup an occurrence; it can't be a splice.
1858 -- Use the in-scope bindings if they exist
1859 lookupLOcc (L _ n) = lookupOcc n
1860
1861 lookupOcc :: Name -> DsM (Core TH.Name)
1862 lookupOcc n
1863 = do { mb_val <- dsLookupMetaEnv n ;
1864 case mb_val of
1865 Nothing -> globalVar n
1866 Just (DsBound x) -> return (coreVar x)
1867 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1868 }
1869
1870 globalVar :: Name -> DsM (Core TH.Name)
1871 -- Not bound by the meta-env
1872 -- Could be top-level; or could be local
1873 -- f x = $(g [| x |])
1874 -- Here the x will be local
1875 globalVar name
1876 | isExternalName name
1877 = do { MkC mod <- coreStringLit name_mod
1878 ; MkC pkg <- coreStringLit name_pkg
1879 ; MkC occ <- nameLit name
1880 ; rep2 mk_varg [pkg,mod,occ] }
1881 | otherwise
1882 = do { MkC occ <- nameLit name
1883 ; MkC uni <- coreIntLit (getKey (getUnique name))
1884 ; rep2 mkNameLName [occ,uni] }
1885 where
1886 mod = ASSERT( isExternalName name) nameModule name
1887 name_mod = moduleNameString (moduleName mod)
1888 name_pkg = unitIdString (moduleUnitId mod)
1889 name_occ = nameOccName name
1890 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1891 | OccName.isVarOcc name_occ = mkNameG_vName
1892 | OccName.isTcOcc name_occ = mkNameG_tcName
1893 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1894
1895 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1896 -> DsM Type -- The type
1897 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1898 return (mkTyConApp tc []) }
1899
1900 wrapGenSyms :: [GenSymBind]
1901 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1902 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1903 -- --> bindQ (gensym nm1) (\ id1 ->
1904 -- bindQ (gensym nm2 (\ id2 ->
1905 -- y))
1906
1907 wrapGenSyms binds body@(MkC b)
1908 = do { var_ty <- lookupType nameTyConName
1909 ; go var_ty binds }
1910 where
1911 [elt_ty] = tcTyConAppArgs (exprType b)
1912 -- b :: Q a, so we can get the type 'a' by looking at the
1913 -- argument type. NB: this relies on Q being a data/newtype,
1914 -- not a type synonym
1915
1916 go _ [] = return body
1917 go var_ty ((name,id) : binds)
1918 = do { MkC body' <- go var_ty binds
1919 ; lit_str <- nameLit name
1920 ; gensym_app <- repGensym lit_str
1921 ; repBindQ var_ty elt_ty
1922 gensym_app (MkC (Lam id body')) }
1923
1924 nameLit :: Name -> DsM (Core String)
1925 nameLit n = coreStringLit (occNameString (nameOccName n))
1926
1927 occNameLit :: OccName -> DsM (Core String)
1928 occNameLit name = coreStringLit (occNameString name)
1929
1930
1931 -- %*********************************************************************
1932 -- %* *
1933 -- Constructing code
1934 -- %* *
1935 -- %*********************************************************************
1936
1937 -----------------------------------------------------------------------------
1938 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1939 -- we invent a new datatype which uses phantom types.
1940
1941 newtype Core a = MkC CoreExpr
1942 unC :: Core a -> CoreExpr
1943 unC (MkC x) = x
1944
1945 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1946 rep2 n xs = do { id <- dsLookupGlobalId n
1947 ; return (MkC (foldl' App (Var id) xs)) }
1948
1949 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1950 dataCon' n args = do { id <- dsLookupDataCon n
1951 ; return $ MkC $ mkCoreConApps id args }
1952
1953 dataCon :: Name -> DsM (Core a)
1954 dataCon n = dataCon' n []
1955
1956
1957 -- %*********************************************************************
1958 -- %* *
1959 -- The 'smart constructors'
1960 -- %* *
1961 -- %*********************************************************************
1962
1963 --------------- Patterns -----------------
1964 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1965 repPlit (MkC l) = rep2 litPName [l]
1966
1967 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1968 repPvar (MkC s) = rep2 varPName [s]
1969
1970 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1971 repPtup (MkC ps) = rep2 tupPName [ps]
1972
1973 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1974 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1975
1976 repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
1977 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1978 repPunboxedSum (MkC p) alt arity
1979 = do { dflags <- getDynFlags
1980 ; rep2 unboxedSumPName [ p
1981 , mkIntExprInt dflags alt
1982 , mkIntExprInt dflags arity ] }
1983
1984 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1985 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1986
1987 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1988 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1989
1990 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1991 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1992
1993 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1994 repPtilde (MkC p) = rep2 tildePName [p]
1995
1996 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1997 repPbang (MkC p) = rep2 bangPName [p]
1998
1999 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
2000 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
2001
2002 repPwild :: DsM (Core TH.PatQ)
2003 repPwild = rep2 wildPName []
2004
2005 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
2006 repPlist (MkC ps) = rep2 listPName [ps]
2007
2008 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
2009 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
2010
2011 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
2012 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
2013
2014 --------------- Expressions -----------------
2015 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
2016 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
2017 | otherwise = repVar str
2018
2019 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2020 repVar (MkC s) = rep2 varEName [s]
2021
2022 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
2023 repCon (MkC s) = rep2 conEName [s]
2024
2025 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
2026 repLit (MkC c) = rep2 litEName [c]
2027
2028 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2029 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
2030
2031 repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2032 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
2033
2034 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2035 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
2036
2037 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
2038 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
2039
2040 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2041 repTup (MkC es) = rep2 tupEName [es]
2042
2043 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2044 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
2045
2046 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
2047 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
2048 repUnboxedSum (MkC e) alt arity
2049 = do { dflags <- getDynFlags
2050 ; rep2 unboxedSumEName [ e
2051 , mkIntExprInt dflags alt
2052 , mkIntExprInt dflags arity ] }
2053
2054 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2055 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
2056
2057 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
2058 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
2059
2060 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2061 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
2062
2063 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
2064 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
2065
2066 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2067 repDoE (MkC ss) = rep2 doEName [ss]
2068
2069 repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2070 repMDoE (MkC ss) = rep2 mdoEName [ss]
2071
2072 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2073 repComp (MkC ss) = rep2 compEName [ss]
2074
2075 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2076 repListExp (MkC es) = rep2 listEName [es]
2077
2078 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2079 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
2080
2081 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
2082 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
2083
2084 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
2085 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
2086
2087 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
2088 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
2089
2090 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2091 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
2092
2093 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2094 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
2095
2096 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2097 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
2098
2099 repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
2100 repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
2101
2102 ------------ Right hand sides (guarded expressions) ----
2103 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
2104 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
2105
2106 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
2107 repNormal (MkC e) = rep2 normalBName [e]
2108
2109 ------------ Guards ----
2110 repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
2111 -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2112 repLNormalGE g e = do g' <- repLE g
2113 e' <- repLE e
2114 repNormalGE g' e'
2115
2116 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2117 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
2118
2119 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2120 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
2121
2122 ------------- Stmts -------------------
2123 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
2124 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
2125
2126 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
2127 repLetSt (MkC ds) = rep2 letSName [ds]
2128
2129 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
2130 repNoBindSt (MkC e) = rep2 noBindSName [e]
2131
2132 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
2133 repParSt (MkC sss) = rep2 parSName [sss]
2134
2135 repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
2136 repRecSt (MkC ss) = rep2 recSName [ss]
2137
2138 -------------- Range (Arithmetic sequences) -----------
2139 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
2140 repFrom (MkC x) = rep2 fromEName [x]
2141
2142 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2143 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
2144
2145 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2146 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
2147
2148 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2149 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
2150
2151 ------------ Match and Clause Tuples -----------
2152 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
2153 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
2154
2155 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
2156 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
2157
2158 -------------- Dec -----------------------------
2159 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2160 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
2161
2162 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
2163 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
2164
2165 repData :: Core TH.CxtQ -> Core TH.Name
2166 -> Either (Core [TH.TyVarBndrQ])
2167 (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
2168 -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
2169 -> DsM (Core TH.DecQ)
2170 repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
2171 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
2172 repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
2173 (MkC cons) (MkC derivs)
2174 = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
2175
2176 repNewtype :: Core TH.CxtQ -> Core TH.Name
2177 -> Either (Core [TH.TyVarBndrQ])
2178 (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
2179 -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
2180 -> DsM (Core TH.DecQ)
2181 repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
2182 (MkC derivs)
2183 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
2184 repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
2185 (MkC con) (MkC derivs)
2186 = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
2187
2188 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
2189 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2190 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
2191 = rep2 tySynDName [nm, tvs, rhs]
2192
2193 repInst :: Core (Maybe TH.Overlap) ->
2194 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2195 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
2196 [o, cxt, ty, ds]
2197
2198 repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
2199 -> DsM (Core (Maybe TH.DerivStrategyQ))
2200 repDerivStrategy mds =
2201 case mds of
2202 Nothing -> nothing
2203 Just (L _ ds) ->
2204 case ds of
2205 StockStrategy -> just =<< repStockStrategy
2206 AnyclassStrategy -> just =<< repAnyclassStrategy
2207 NewtypeStrategy -> just =<< repNewtypeStrategy
2208 ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
2209 via_strat <- repViaStrategy ty'
2210 just via_strat
2211 where
2212 nothing = coreNothing derivStrategyQTyConName
2213 just = coreJust derivStrategyQTyConName
2214
2215 repStockStrategy :: DsM (Core TH.DerivStrategyQ)
2216 repStockStrategy = rep2 stockStrategyName []
2217
2218 repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
2219 repAnyclassStrategy = rep2 anyclassStrategyName []
2220
2221 repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
2222 repNewtypeStrategy = rep2 newtypeStrategyName []
2223
2224 repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
2225 repViaStrategy (MkC t) = rep2 viaStrategyName [t]
2226
2227 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
2228 repOverlap mb =
2229 case mb of
2230 Nothing -> nothing
2231 Just o ->
2232 case o of
2233 NoOverlap _ -> nothing
2234 Overlappable _ -> just =<< dataCon overlappableDataConName
2235 Overlapping _ -> just =<< dataCon overlappingDataConName
2236 Overlaps _ -> just =<< dataCon overlapsDataConName
2237 Incoherent _ -> just =<< dataCon incoherentDataConName
2238 where
2239 nothing = coreNothing overlapTyConName
2240 just = coreJust overlapTyConName
2241
2242
2243 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2244 -> Core [TH.FunDep] -> Core [TH.DecQ]
2245 -> DsM (Core TH.DecQ)
2246 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
2247 = rep2 classDName [cxt, cls, tvs, fds, ds]
2248
2249 repDeriv :: Core (Maybe TH.DerivStrategyQ)
2250 -> Core TH.CxtQ -> Core TH.TypeQ
2251 -> DsM (Core TH.DecQ)
2252 repDeriv (MkC ds) (MkC cxt) (MkC ty)
2253 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
2254
2255 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
2256 -> Core TH.Phases -> DsM (Core TH.DecQ)
2257 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
2258 = rep2 pragInlDName [nm, inline, rm, phases]
2259
2260 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
2261 -> DsM (Core TH.DecQ)
2262 repPragSpec (MkC nm) (MkC ty) (MkC phases)
2263 = rep2 pragSpecDName [nm, ty, phases]
2264
2265 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
2266 -> Core TH.Phases -> DsM (Core TH.DecQ)
2267 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
2268 = rep2 pragSpecInlDName [nm, ty, inline, phases]
2269
2270 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
2271 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
2272
2273 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
2274 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
2275
2276 repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
2277 -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
2278 -> Core TH.Phases -> DsM (Core TH.DecQ)
2279 repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
2280 = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
2281
2282 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2283 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
2284
2285 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
2286 repTySynInst (MkC nm) (MkC eqn)
2287 = rep2 tySynInstDName [nm, eqn]
2288
2289 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
2290 -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
2291 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
2292 = rep2 dataFamilyDName [nm, tvs, kind]
2293
2294 repOpenFamilyD :: Core TH.Name
2295 -> Core [TH.TyVarBndrQ]
2296 -> Core TH.FamilyResultSigQ
2297 -> Core (Maybe TH.InjectivityAnn)
2298 -> DsM (Core TH.DecQ)
2299 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
2300 = rep2 openTypeFamilyDName [nm, tvs, result, inj]
2301
2302 repClosedFamilyD :: Core TH.Name
2303 -> Core [TH.TyVarBndrQ]
2304 -> Core TH.FamilyResultSigQ
2305 -> Core (Maybe TH.InjectivityAnn)
2306 -> Core [TH.TySynEqnQ]
2307 -> DsM (Core TH.DecQ)
2308 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
2309 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
2310
2311 repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
2312 Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
2313 repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
2314 = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
2315
2316 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
2317 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
2318
2319 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
2320 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
2321
2322 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2323 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
2324
2325 repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2326 repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
2327
2328 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
2329 repCtxt (MkC tys) = rep2 cxtName [tys]
2330
2331 repDataCon :: Located Name
2332 -> HsConDeclDetails GhcRn
2333 -> DsM (Core TH.ConQ)
2334 repDataCon con details
2335 = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
2336 repConstr details Nothing [con']
2337
2338 repGadtDataCons :: [Located Name]
2339 -> HsConDeclDetails GhcRn
2340 -> LHsType GhcRn
2341 -> DsM (Core TH.ConQ)
2342 repGadtDataCons cons details res_ty
2343 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
2344 repConstr details (Just res_ty) cons'
2345
2346 -- Invariant:
2347 -- * for plain H98 data constructors second argument is Nothing and third
2348 -- argument is a singleton list
2349 -- * for GADTs data constructors second argument is (Just return_type) and
2350 -- third argument is a non-empty list
2351 repConstr :: HsConDeclDetails GhcRn
2352 -> Maybe (LHsType GhcRn)
2353 -> [Core TH.Name]
2354 -> DsM (Core TH.ConQ)
2355 repConstr (PrefixCon ps) Nothing [con]
2356 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2357 rep2 normalCName [unC con, unC arg_tys]
2358
2359 repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
2360 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2361 res_ty' <- repTy res_ty
2362 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
2363
2364 repConstr (RecCon (L _ ips)) resTy cons
2365 = do args <- concatMapM rep_ip ips
2366 arg_vtys <- coreList varBangTypeQTyConName args
2367 case resTy of
2368 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
2369 Just (L _ res_ty) -> do
2370 res_ty' <- repTy res_ty
2371 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
2372 unC res_ty']
2373
2374 where
2375 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
2376
2377 rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
2378 rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
2379 ; MkC ty <- repBangTy t
2380 ; rep2 varBangTypeName [v,ty] }
2381
2382 repConstr (InfixCon st1 st2) Nothing [con]
2383 = do arg1 <- repBangTy st1
2384 arg2 <- repBangTy st2
2385 rep2 infixCName [unC arg1, unC con, unC arg2]
2386
2387 repConstr (InfixCon {}) (Just _) _ =
2388 panic "repConstr: infix GADT constructor should be in a PrefixCon"
2389 repConstr _ _ _ =
2390 panic "repConstr: invariant violated"
2391
2392 ------------ Types -------------------
2393
2394 repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
2395 -> DsM (Core TH.TypeQ)
2396 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
2397 = rep2 forallTName [tvars, ctxt, ty]
2398
2399 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
2400 repTvar (MkC s) = rep2 varTName [s]
2401
2402 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2403 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
2404
2405 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2406 repTapps f [] = return f
2407 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
2408
2409 repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
2410 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
2411
2412 repTequality :: DsM (Core TH.TypeQ)
2413 repTequality = rep2 equalityTName []
2414
2415 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2416 repTPromotedList [] = repPromotedNilTyCon
2417 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
2418 ; f <- repTapp tcon t
2419 ; t' <- repTPromotedList ts
2420 ; repTapp f t'
2421 }
2422
2423 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
2424 repTLit (MkC lit) = rep2 litTName [lit]
2425
2426 repTWildCard :: DsM (Core TH.TypeQ)
2427 repTWildCard = rep2 wildCardTName []
2428
2429 repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2430 repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
2431
2432 repTStar :: DsM (Core TH.TypeQ)
2433 repTStar = rep2 starKName []
2434
2435 repTConstraint :: DsM (Core TH.TypeQ)
2436 repTConstraint = rep2 constraintKName []
2437
2438 --------- Type constructors --------------
2439
2440 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2441 repNamedTyCon (MkC s) = rep2 conTName [s]
2442
2443 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2444 -- Note: not Core Int; it's easier to be direct here
2445 repTupleTyCon i = do dflags <- getDynFlags
2446 rep2 tupleTName [mkIntExprInt dflags i]
2447
2448 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2449 -- Note: not Core Int; it's easier to be direct here
2450 repUnboxedTupleTyCon i = do dflags <- getDynFlags
2451 rep2 unboxedTupleTName [mkIntExprInt dflags i]
2452
2453 repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
2454 -- Note: not Core TH.SumArity; it's easier to be direct here
2455 repUnboxedSumTyCon arity = do dflags <- getDynFlags
2456 rep2 unboxedSumTName [mkIntExprInt dflags arity]
2457
2458 repArrowTyCon :: DsM (Core TH.TypeQ)
2459 repArrowTyCon = rep2 arrowTName []
2460
2461 repListTyCon :: DsM (Core TH.TypeQ)
2462 repListTyCon = rep2 listTName []
2463
2464 repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2465 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
2466
2467 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2468 repPromotedTupleTyCon i = do dflags <- getDynFlags
2469 rep2 promotedTupleTName [mkIntExprInt dflags i]
2470
2471 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
2472 repPromotedNilTyCon = rep2 promotedNilTName []
2473
2474 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
2475 repPromotedConsTyCon = rep2 promotedConsTName []
2476
2477 ------------ TyVarBndrs -------------------
2478
2479 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
2480 repPlainTV (MkC nm) = rep2 plainTVName [nm]
2481
2482 repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
2483 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
2484
2485 ----------------------------------------------------------
2486 -- Type family result signature
2487
2488 repNoSig :: DsM (Core TH.FamilyResultSigQ)
2489 repNoSig = rep2 noSigName []
2490
2491 repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
2492 repKindSig (MkC ki) = rep2 kindSigName [ki]
2493
2494 repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
2495 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
2496
2497 ----------------------------------------------------------
2498 -- Literals
2499
2500 repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
2501 repLiteral (HsStringPrim _ bs)
2502 = do dflags <- getDynFlags
2503 word8_ty <- lookupType word8TyConName
2504 let w8s = unpack bs
2505 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2506 [mkWordLit dflags (toInteger w8)]) w8s
2507 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2508 repLiteral lit
2509 = do lit' <- case lit of
2510 HsIntPrim _ i -> mk_integer i
2511 HsWordPrim _ w -> mk_integer w
2512 HsInt _ i -> mk_integer (il_value i)
2513 HsFloatPrim _ r -> mk_rational r
2514 HsDoublePrim _ r -> mk_rational r
2515 HsCharPrim _ c -> mk_char c
2516 _ -> return lit
2517 lit_expr <- dsLit lit'
2518 case mb_lit_name of
2519 Just lit_name -> rep2 lit_name [lit_expr]
2520 Nothing -> notHandled "Exotic literal" (ppr lit)
2521 where
2522 mb_lit_name = case lit of
2523 HsInteger _ _ _ -> Just integerLName
2524 HsInt _ _ -> Just integerLName
2525 HsIntPrim _ _ -> Just intPrimLName
2526 HsWordPrim _ _ -> Just wordPrimLName
2527 HsFloatPrim _ _ -> Just floatPrimLName
2528 HsDoublePrim _ _ -> Just doublePrimLName
2529 HsChar _ _ -> Just charLName
2530 HsCharPrim _ _ -> Just charPrimLName
2531 HsString _ _ -> Just stringLName
2532 HsRat _ _ _ -> Just rationalLName
2533 _ -> Nothing
2534
2535 mk_integer :: Integer -> DsM (HsLit GhcRn)
2536 mk_integer i = do integer_ty <- lookupType integerTyConName
2537 return $ HsInteger NoSourceText i integer_ty
2538
2539 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
2540 mk_rational r = do rat_ty <- lookupType rationalTyConName
2541 return $ HsRat noExt r rat_ty
2542 mk_string :: FastString -> DsM (HsLit GhcRn)
2543 mk_string s = return $ HsString NoSourceText s
2544
2545 mk_char :: Char -> DsM (HsLit GhcRn)
2546 mk_char c = return $ HsChar NoSourceText c
2547
2548 repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
2549 repOverloadedLiteral (OverLit { ol_val = val})
2550 = do { lit <- mk_lit val; repLiteral lit }
2551 -- The type Rational will be in the environment, because
2552 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2553 -- and rationalL is sucked in when any TH stuff is used
2554 repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
2555
2556 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
2557 mk_lit (HsIntegral i) = mk_integer (il_value i)
2558 mk_lit (HsFractional f) = mk_rational f
2559 mk_lit (HsIsString _ s) = mk_string s
2560
2561 repNameS :: Core String -> DsM (Core TH.Name)
2562 repNameS (MkC name) = rep2 mkNameSName [name]
2563
2564 --------------- Miscellaneous -------------------
2565
2566 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2567 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2568
2569 repBindQ :: Type -> Type -- a and b
2570 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2571 repBindQ ty_a ty_b (MkC x) (MkC y)
2572 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2573
2574 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2575 repSequenceQ ty_a (MkC list)
2576 = rep2 sequenceQName [Type ty_a, list]
2577
2578 repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2579 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
2580
2581 repOverLabel :: FastString -> DsM (Core TH.ExpQ)
2582 repOverLabel fs = do
2583 (MkC s) <- coreStringLit $ unpackFS fs
2584 rep2 labelEName [s]
2585
2586
2587 ------------ Lists -------------------
2588 -- turn a list of patterns into a single pattern matching a list
2589
2590 repList :: Name -> (a -> DsM (Core b))
2591 -> [a] -> DsM (Core [b])
2592 repList tc_name f args
2593 = do { args1 <- mapM f args
2594 ; coreList tc_name args1 }
2595
2596 coreList :: Name -- Of the TyCon of the element type
2597 -> [Core a] -> DsM (Core [a])
2598 coreList tc_name es
2599 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2600
2601 coreList' :: Type -- The element type
2602 -> [Core a] -> Core [a]
2603 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2604
2605 nonEmptyCoreList :: [Core a] -> Core [a]
2606 -- The list must be non-empty so we can get the element type
2607 -- Otherwise use coreList
2608 nonEmptyCoreList [] = panic "coreList: empty argument"
2609 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2610
2611 coreStringLit :: String -> DsM (Core String)
2612 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2613
2614 ------------------- Maybe ------------------
2615
2616 repMaybe :: Name -> (a -> DsM (Core b))
2617 -> Maybe a -> DsM (Core (Maybe b))
2618 repMaybe tc_name _ Nothing = coreNothing tc_name
2619 repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
2620
2621 -- | Construct Core expression for Nothing of a given type name
2622 coreNothing :: Name -- ^ Name of the TyCon of the element type
2623 -> DsM (Core (Maybe a))
2624 coreNothing tc_name =
2625 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
2626
2627 -- | Construct Core expression for Nothing of a given type
2628 coreNothing' :: Type -- ^ The element type
2629 -> Core (Maybe a)
2630 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
2631
2632 -- | Store given Core expression in a Just of a given type name
2633 coreJust :: Name -- ^ Name of the TyCon of the element type
2634 -> Core a -> DsM (Core (Maybe a))
2635 coreJust tc_name es
2636 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
2637
2638 -- | Store given Core expression in a Just of a given type
2639 coreJust' :: Type -- ^ The element type
2640 -> Core a -> Core (Maybe a)
2641 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
2642
2643 ------------------- Maybe Lists ------------------
2644
2645 repMaybeList :: Name -> (a -> DsM (Core b))
2646 -> Maybe [a] -> DsM (Core (Maybe [b]))
2647 repMaybeList tc_name _ Nothing = coreNothingList tc_name
2648 repMaybeList tc_name f (Just args)
2649 = do { elt_ty <- lookupType tc_name
2650 ; args1 <- mapM f args
2651 ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
2652
2653 coreNothingList :: Name -> DsM (Core (Maybe [a]))
2654 coreNothingList tc_name
2655 = do { elt_ty <- lookupType tc_name
2656 ; return $ coreNothing' (mkListTy elt_ty) }
2657
2658 coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
2659 coreJustList tc_name args
2660 = do { elt_ty <- lookupType tc_name
2661 ; return $ coreJust' (mkListTy elt_ty) args }
2662
2663 ------------ Literals & Variables -------------------
2664
2665 coreIntLit :: Int -> DsM (Core Int)
2666 coreIntLit i = do dflags <- getDynFlags
2667 return (MkC (mkIntExprInt dflags i))
2668
2669 coreVar :: Id -> Core TH.Name -- The Id has type Name
2670 coreVar id = MkC (Var id)
2671
2672 ----------------- Failure -----------------------
2673 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2674 notHandledL loc what doc
2675 | isGoodSrcSpan loc
2676 = putSrcSpanDs loc $ notHandled what doc
2677 | otherwise
2678 = notHandled what doc
2679
2680 notHandled :: String -> SDoc -> DsM a
2681 notHandled what doc = failWithDs msg
2682 where
2683 msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2684 2 doc