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