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