Visible kind application
[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 ++ map hsLTyVarName 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 (map hsLTyVarName 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 :: HsType GhcRn -> DsM (Core TH.TypeQ)
1148 -- Arg of repForall is always HsForAllTy or HsQualTy
1149 repForall ty
1150 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
1151 = addHsTyVarBinds tvs $ \bndrs ->
1152 do { ctxt1 <- repLContext ctxt
1153 ; ty1 <- repLTy tau
1154 ; repTForall bndrs ctxt1 ty1 }
1155
1156 repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
1157 repTy ty@(HsForAllTy {}) = repForall ty
1158 repTy ty@(HsQualTy {}) = repForall ty
1159
1160 repTy (HsTyVar _ _ (dL->L _ n))
1161 | isLiftedTypeKindTyConName n = repTStar
1162 | n `hasKey` constraintKindTyConKey = repTConstraint
1163 | n `hasKey` funTyConKey = repArrowTyCon
1164 | isTvOcc occ = do tv1 <- lookupOcc n
1165 repTvar tv1
1166 | isDataOcc occ = do tc1 <- lookupOcc n
1167 repPromotedDataCon tc1
1168 | n == eqTyConName = repTequality
1169 | otherwise = do tc1 <- lookupOcc n
1170 repNamedTyCon tc1
1171 where
1172 occ = nameOccName n
1173
1174 repTy (HsAppTy _ f a) = do
1175 f1 <- repLTy f
1176 a1 <- repLTy a
1177 repTapp f1 a1
1178 repTy (HsAppKindTy _ ty ki) = do
1179 ty1 <- repLTy ty
1180 ki1 <- repLTy ki
1181 repTappKind ty1 ki1
1182 repTy (HsFunTy _ f a) = do
1183 f1 <- repLTy f
1184 a1 <- repLTy a
1185 tcon <- repArrowTyCon
1186 repTapps tcon [f1, a1]
1187 repTy (HsListTy _ t) = do
1188 t1 <- repLTy t
1189 tcon <- repListTyCon
1190 repTapp tcon t1
1191 repTy (HsTupleTy _ HsUnboxedTuple tys) = do
1192 tys1 <- repLTys tys
1193 tcon <- repUnboxedTupleTyCon (length tys)
1194 repTapps tcon tys1
1195 repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys
1196 tcon <- repTupleTyCon (length tys)
1197 repTapps tcon tys1
1198 repTy (HsSumTy _ tys) = do tys1 <- repLTys tys
1199 tcon <- repUnboxedSumTyCon (length tys)
1200 repTapps tcon tys1
1201 repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
1202 `nlHsAppTy` ty2)
1203 repTy (HsParTy _ t) = repLTy t
1204 repTy (HsStarTy _ _) = repTStar
1205 repTy (HsKindSig _ t k) = do
1206 t1 <- repLTy t
1207 k1 <- repLTy k
1208 repTSig t1 k1
1209 repTy (HsSpliceTy _ splice) = repSplice splice
1210 repTy (HsExplicitListTy _ _ tys) = do
1211 tys1 <- repLTys tys
1212 repTPromotedList tys1
1213 repTy (HsExplicitTupleTy _ tys) = do
1214 tys1 <- repLTys tys
1215 tcon <- repPromotedTupleTyCon (length tys)
1216 repTapps tcon tys1
1217 repTy (HsTyLit _ lit) = do
1218 lit' <- repTyLit lit
1219 repTLit lit'
1220 repTy (HsWildCardTy _) = repTWildCard
1221 repTy (HsIParamTy _ n t) = do
1222 n' <- rep_implicit_param_name (unLoc n)
1223 t' <- repLTy t
1224 repTImplicitParam n' t'
1225
1226 repTy ty = notHandled "Exotic form of type" (ppr ty)
1227
1228 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
1229 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
1230 rep2 numTyLitName [iExpr]
1231 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
1232 ; rep2 strTyLitName [s']
1233 }
1234
1235 -- | Represent a type wrapped in a Maybe
1236 repMaybeLTy :: Maybe (LHsKind GhcRn)
1237 -> DsM (Core (Maybe TH.TypeQ))
1238 repMaybeLTy = repMaybe kindQTyConName repLTy
1239
1240 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
1241 repRole (dL->L _ (Just Nominal)) = rep2 nominalRName []
1242 repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
1243 repRole (dL->L _ (Just Phantom)) = rep2 phantomRName []
1244 repRole (dL->L _ Nothing) = rep2 inferRName []
1245 repRole _ = panic "repRole: Impossible Match" -- due to #15884
1246
1247 -----------------------------------------------------------------------------
1248 -- Splices
1249 -----------------------------------------------------------------------------
1250
1251 repSplice :: HsSplice GhcRn -> DsM (Core a)
1252 -- See Note [How brackets and nested splices are handled] in TcSplice
1253 -- We return a CoreExpr of any old type; the context should know
1254 repSplice (HsTypedSplice _ _ n _) = rep_splice n
1255 repSplice (HsUntypedSplice _ _ n _) = rep_splice n
1256 repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n
1257 repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e)
1258 repSplice e@(XSplice {}) = pprPanic "repSplice" (ppr e)
1259
1260 rep_splice :: Name -> DsM (Core a)
1261 rep_splice splice_name
1262 = do { mb_val <- dsLookupMetaEnv splice_name
1263 ; case mb_val of
1264 Just (DsSplice e) -> do { e' <- dsExpr e
1265 ; return (MkC e') }
1266 _ -> pprPanic "HsSplice" (ppr splice_name) }
1267 -- Should not happen; statically checked
1268
1269 -----------------------------------------------------------------------------
1270 -- Expressions
1271 -----------------------------------------------------------------------------
1272
1273 repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
1274 repLEs es = repList expQTyConName repLE es
1275
1276 -- FIXME: some of these panics should be converted into proper error messages
1277 -- unless we can make sure that constructs, which are plainly not
1278 -- supported in TH already lead to error messages at an earlier stage
1279 repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
1280 repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
1281
1282 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
1283 repE (HsVar _ (dL->L _ x)) =
1284 do { mb_val <- dsLookupMetaEnv x
1285 ; case mb_val of
1286 Nothing -> do { str <- globalVar x
1287 ; repVarOrCon x str }
1288 Just (DsBound y) -> repVarOrCon x (coreVar y)
1289 Just (DsSplice e) -> do { e' <- dsExpr e
1290 ; return (MkC e') } }
1291 repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
1292 repE (HsOverLabel _ _ s) = repOverLabel s
1293
1294 repE e@(HsRecFld _ f) = case f of
1295 Unambiguous x _ -> repE (HsVar noExt (noLoc x))
1296 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
1297 XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
1298
1299 -- Remember, we're desugaring renamer output here, so
1300 -- HsOverlit can definitely occur
1301 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
1302 repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
1303 repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
1304 repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
1305 = do { ms' <- mapM repMatchTup ms
1306 ; core_ms <- coreList matchQTyConName ms'
1307 ; repLamCase core_ms }
1308 repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1309 repE (HsAppType _ e t) = do { a <- repLE e
1310 ; s <- repLTy (hswc_body t)
1311 ; repAppType a s }
1312
1313 repE (OpApp _ e1 op e2) =
1314 do { arg1 <- repLE e1;
1315 arg2 <- repLE e2;
1316 the_op <- repLE op ;
1317 repInfixApp arg1 the_op arg2 }
1318 repE (NegApp _ x _) = do
1319 a <- repLE x
1320 negateVar <- lookupOcc negateName >>= repVar
1321 negateVar `repApp` a
1322 repE (HsPar _ x) = repLE x
1323 repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1324 repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1325 repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
1326 = do { arg <- repLE e
1327 ; ms2 <- mapM repMatchTup ms
1328 ; core_ms2 <- coreList matchQTyConName ms2
1329 ; repCaseE arg core_ms2 }
1330 repE (HsIf _ _ x y z) = do
1331 a <- repLE x
1332 b <- repLE y
1333 c <- repLE z
1334 repCond a b c
1335 repE (HsMultiIf _ alts)
1336 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1337 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1338 ; wrapGenSyms (concat binds) expr' }
1339 repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs
1340 ; e2 <- addBinds ss (repLE e)
1341 ; z <- repLetE ds e2
1342 ; wrapGenSyms ss z }
1343
1344 -- FIXME: I haven't got the types here right yet
1345 repE e@(HsDo _ ctxt (dL->L _ sts))
1346 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1347 = do { (ss,zs) <- repLSts sts;
1348 e' <- repDoE (nonEmptyCoreList zs);
1349 wrapGenSyms ss e' }
1350
1351 | ListComp <- ctxt
1352 = do { (ss,zs) <- repLSts sts;
1353 e' <- repComp (nonEmptyCoreList zs);
1354 wrapGenSyms ss e' }
1355
1356 | MDoExpr <- ctxt
1357 = do { (ss,zs) <- repLSts sts;
1358 e' <- repMDoE (nonEmptyCoreList zs);
1359 wrapGenSyms ss e' }
1360
1361 | otherwise
1362 = notHandled "monad comprehension and [: :]" (ppr e)
1363
1364 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1365 repE e@(ExplicitTuple _ es boxed)
1366 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1367 | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
1368 ; repTup xs }
1369 | otherwise = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
1370 ; repUnboxedTup xs }
1371
1372 repE (ExplicitSum _ alt arity e)
1373 = do { e1 <- repLE e
1374 ; repUnboxedSum e1 alt arity }
1375
1376 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
1377 = do { x <- lookupLOcc c;
1378 fs <- repFields flds;
1379 repRecCon x fs }
1380 repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
1381 = do { x <- repLE e;
1382 fs <- repUpdFields flds;
1383 repRecUpd x fs }
1384
1385 repE (ExprWithTySig _ e ty)
1386 = do { e1 <- repLE e
1387 ; t1 <- repHsSigWcType ty
1388 ; repSigExp e1 t1 }
1389
1390 repE (ArithSeq _ _ aseq) =
1391 case aseq of
1392 From e -> do { ds1 <- repLE e; repFrom ds1 }
1393 FromThen e1 e2 -> do
1394 ds1 <- repLE e1
1395 ds2 <- repLE e2
1396 repFromThen ds1 ds2
1397 FromTo e1 e2 -> do
1398 ds1 <- repLE e1
1399 ds2 <- repLE e2
1400 repFromTo ds1 ds2
1401 FromThenTo e1 e2 e3 -> do
1402 ds1 <- repLE e1
1403 ds2 <- repLE e2
1404 ds3 <- repLE e3
1405 repFromThenTo ds1 ds2 ds3
1406
1407 repE (HsSpliceE _ splice) = repSplice splice
1408 repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
1409 repE (HsUnboundVar _ uv) = do
1410 occ <- occNameLit (unboundVarOcc uv)
1411 sname <- repNameS occ
1412 repUnboundVar sname
1413
1414 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1415 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1416 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1417 repE e = notHandled "Expression form" (ppr e)
1418
1419 -----------------------------------------------------------------------------
1420 -- Building representations of auxillary structures like Match, Clause, Stmt,
1421
1422 repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
1423 repMatchTup (dL->L _ (Match { m_pats = [p]
1424 , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
1425 do { ss1 <- mkGenSyms (collectPatBinders p)
1426 ; addBinds ss1 $ do {
1427 ; p1 <- repLP p
1428 ; (ss2,ds) <- repBinds wheres
1429 ; addBinds ss2 $ do {
1430 ; gs <- repGuards guards
1431 ; match <- repMatch p1 gs ds
1432 ; wrapGenSyms (ss1++ss2) match }}}
1433 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1434
1435 repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
1436 repClauseTup (dL->L _ (Match { m_pats = ps
1437 , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
1438 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1439 ; addBinds ss1 $ do {
1440 ps1 <- repLPs ps
1441 ; (ss2,ds) <- repBinds wheres
1442 ; addBinds ss2 $ do {
1443 gs <- repGuards guards
1444 ; clause <- repClause ps1 gs ds
1445 ; wrapGenSyms (ss1++ss2) clause }}}
1446 repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
1447 repClauseTup _ = panic "repClauseTup"
1448
1449 repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
1450 repGuards [dL->L _ (GRHS _ [] e)]
1451 = do {a <- repLE e; repNormal a }
1452 repGuards other
1453 = do { zs <- mapM repLGRHS other
1454 ; let (xs, ys) = unzip zs
1455 ; gd <- repGuarded (nonEmptyCoreList ys)
1456 ; wrapGenSyms (concat xs) gd }
1457
1458 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
1459 -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1460 repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
1461 = do { guarded <- repLNormalGE e1 e2
1462 ; return ([], guarded) }
1463 repLGRHS (dL->L _ (GRHS _ ss rhs))
1464 = do { (gs, ss') <- repLSts ss
1465 ; rhs' <- addBinds gs $ repLE rhs
1466 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1467 ; return (gs, guarded) }
1468 repLGRHS _ = panic "repLGRHS"
1469
1470 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
1471 repFields (HsRecFields { rec_flds = flds })
1472 = repList fieldExpQTyConName rep_fld flds
1473 where
1474 rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
1475 -> DsM (Core (TH.Q TH.FieldExp))
1476 rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
1477 ; e <- repLE (hsRecFieldArg fld)
1478 ; repFieldExp fn e }
1479
1480 repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
1481 repUpdFields = repList fieldExpQTyConName rep_fld
1482 where
1483 rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
1484 rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
1485 Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
1486 ; e <- repLE (hsRecFieldArg fld)
1487 ; repFieldExp fn e }
1488 _ -> notHandled "Ambiguous record updates" (ppr fld)
1489
1490
1491
1492 -----------------------------------------------------------------------------
1493 -- Representing Stmt's is tricky, especially if bound variables
1494 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1495 -- First gensym new names for every variable in any of the patterns.
1496 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1497 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1498 -- and we could reuse the original names (x and x).
1499 --
1500 -- do { x'1 <- gensym "x"
1501 -- ; x'2 <- gensym "x"
1502 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1503 -- , BindSt (pvar x'2) [| f x |]
1504 -- , NoBindSt [| g x |]
1505 -- ]
1506 -- }
1507
1508 -- The strategy is to translate a whole list of do-bindings by building a
1509 -- bigger environment, and a bigger set of meta bindings
1510 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1511 -- of the expressions within the Do
1512
1513 -----------------------------------------------------------------------------
1514 -- The helper function repSts computes the translation of each sub expression
1515 -- and a bunch of prefix bindings denoting the dynamic renaming.
1516
1517 repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1518 repLSts stmts = repSts (map unLoc stmts)
1519
1520 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1521 repSts (BindStmt _ p e _ _ : ss) =
1522 do { e2 <- repLE e
1523 ; ss1 <- mkGenSyms (collectPatBinders p)
1524 ; addBinds ss1 $ do {
1525 ; p1 <- repLP p;
1526 ; (ss2,zs) <- repSts ss
1527 ; z <- repBindSt p1 e2
1528 ; return (ss1++ss2, z : zs) }}
1529 repSts (LetStmt _ (dL->L _ bs) : ss) =
1530 do { (ss1,ds) <- repBinds bs
1531 ; z <- repLetSt ds
1532 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1533 ; return (ss1++ss2, z : zs) }
1534 repSts (BodyStmt _ e _ _ : ss) =
1535 do { e2 <- repLE e
1536 ; z <- repNoBindSt e2
1537 ; (ss2,zs) <- repSts ss
1538 ; return (ss2, z : zs) }
1539 repSts (ParStmt _ stmt_blocks _ _ : ss) =
1540 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1541 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1542 ss1 = concat ss_s
1543 ; z <- repParSt stmt_blocks2
1544 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1545 ; return (ss1++ss2, z : zs) }
1546 where
1547 rep_stmt_block :: ParStmtBlock GhcRn GhcRn
1548 -> DsM ([GenSymBind], Core [TH.StmtQ])
1549 rep_stmt_block (ParStmtBlock _ stmts _ _) =
1550 do { (ss1, zs) <- repSts (map unLoc stmts)
1551 ; zs1 <- coreList stmtQTyConName zs
1552 ; return (ss1, zs1) }
1553 rep_stmt_block (XParStmtBlock{}) = panic "repSts"
1554 repSts [LastStmt _ e _ _]
1555 = do { e2 <- repLE e
1556 ; z <- repNoBindSt e2
1557 ; return ([], [z]) }
1558 repSts (stmt@RecStmt{} : ss)
1559 = do { let binders = collectLStmtsBinders (recS_stmts stmt)
1560 ; ss1 <- mkGenSyms binders
1561 -- Bring all of binders in the recursive group into scope for the
1562 -- whole group.
1563 ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
1564 ; MASSERT(sort ss1 == sort ss1_other)
1565 ; z <- repRecSt (nonEmptyCoreList rss)
1566 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1567 ; return (ss1++ss2, z : zs) }
1568 repSts [] = return ([],[])
1569 repSts other = notHandled "Exotic statement" (ppr other)
1570
1571
1572 -----------------------------------------------------------
1573 -- Bindings
1574 -----------------------------------------------------------
1575
1576 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
1577 repBinds (EmptyLocalBinds _)
1578 = do { core_list <- coreList decQTyConName []
1579 ; return ([], core_list) }
1580
1581 repBinds (HsIPBinds _ (IPBinds _ decs))
1582 = do { ips <- mapM rep_implicit_param_bind decs
1583 ; core_list <- coreList decQTyConName
1584 (de_loc (sort_by_loc ips))
1585 ; return ([], core_list)
1586 }
1587
1588 repBinds b@(HsIPBinds _ XHsIPBinds {})
1589 = notHandled "Implicit parameter binds extension" (ppr b)
1590
1591 repBinds (HsValBinds _ decs)
1592 = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
1593 -- No need to worry about detailed scopes within
1594 -- the binding group, because we are talking Names
1595 -- here, so we can safely treat it as a mutually
1596 -- recursive group
1597 -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
1598 ; ss <- mkGenSyms bndrs
1599 ; prs <- addBinds ss (rep_val_binds decs)
1600 ; core_list <- coreList decQTyConName
1601 (de_loc (sort_by_loc prs))
1602 ; return (ss, core_list) }
1603 repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
1604
1605 rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1606 rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
1607 = do { name <- case ename of
1608 Left (dL->L _ n) -> rep_implicit_param_name n
1609 Right _ ->
1610 panic "rep_implicit_param_bind: post typechecking"
1611 ; rhs' <- repE rhs
1612 ; ipb <- repImplicitParamBind name rhs'
1613 ; return (loc, ipb) }
1614 rep_implicit_param_bind (dL->L _ b@(XIPBind _))
1615 = notHandled "Implicit parameter bind extension" (ppr b)
1616 rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
1617 -- due to #15884
1618
1619 rep_implicit_param_name :: HsIPName -> DsM (Core String)
1620 rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
1621
1622 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1623 -- Assumes: all the binders of the binding are already in the meta-env
1624 rep_val_binds (XValBindsLR (NValBinds binds sigs))
1625 = do { core1 <- rep_binds (unionManyBags (map snd binds))
1626 ; core2 <- rep_sigs sigs
1627 ; return (core1 ++ core2) }
1628 rep_val_binds (ValBinds _ _ _)
1629 = panic "rep_val_binds: ValBinds"
1630
1631 rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1632 rep_binds = mapM rep_bind . bagToList
1633
1634 rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1635 -- Assumes: all the binders of the binding are already in the meta-env
1636
1637 -- Note GHC treats declarations of a variable (not a pattern)
1638 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1639 -- with an empty list of patterns
1640 rep_bind (dL->L loc (FunBind
1641 { fun_id = fn,
1642 fun_matches = MG { mg_alts
1643 = (dL->L _ [dL->L _ (Match
1644 { m_pats = []
1645 , m_grhss = GRHSs _ guards
1646 (dL->L _ wheres) }
1647 )]) } }))
1648 = do { (ss,wherecore) <- repBinds wheres
1649 ; guardcore <- addBinds ss (repGuards guards)
1650 ; fn' <- lookupLBinder fn
1651 ; p <- repPvar fn'
1652 ; ans <- repVal p guardcore wherecore
1653 ; ans' <- wrapGenSyms ss ans
1654 ; return (loc, ans') }
1655
1656 rep_bind (dL->L loc (FunBind { fun_id = fn
1657 , fun_matches = MG { mg_alts = (dL->L _ ms) } }))
1658 = do { ms1 <- mapM repClauseTup ms
1659 ; fn' <- lookupLBinder fn
1660 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1661 ; return (loc, ans) }
1662
1663 rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
1664
1665 rep_bind (dL->L loc (PatBind { pat_lhs = pat
1666 , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))
1667 = do { patcore <- repLP pat
1668 ; (ss,wherecore) <- repBinds wheres
1669 ; guardcore <- addBinds ss (repGuards guards)
1670 ; ans <- repVal patcore guardcore wherecore
1671 ; ans' <- wrapGenSyms ss ans
1672 ; return (loc, ans') }
1673 rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
1674
1675 rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
1676 = do { v' <- lookupBinder v
1677 ; e2 <- repLE e
1678 ; x <- repNormal e2
1679 ; patcore <- repPvar v'
1680 ; empty_decls <- coreList decQTyConName []
1681 ; ans <- repVal patcore x empty_decls
1682 ; return (srcLocSpan (getSrcLoc v), ans) }
1683
1684 rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1685 rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn
1686 , psb_args = args
1687 , psb_def = pat
1688 , psb_dir = dir })))
1689 = do { syn' <- lookupLBinder syn
1690 ; dir' <- repPatSynDir dir
1691 ; ss <- mkGenArgSyms args
1692 ; patSynD' <- addBinds ss (
1693 do { args' <- repPatSynArgs args
1694 ; pat' <- repLP pat
1695 ; repPatSynD syn' args' dir' pat' })
1696 ; patSynD'' <- wrapGenArgSyms args ss patSynD'
1697 ; return (loc, patSynD'') }
1698 where
1699 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
1700 -- for Record Pattern Synonyms we want to conflate the selector
1701 -- and the pattern-only names in order to provide a nicer TH
1702 -- API. Whereas inside GHC, record pattern synonym selectors and
1703 -- their pattern-only bound right hand sides have different names,
1704 -- we want to treat them the same in TH. This is the reason why we
1705 -- need an adjusted mkGenArgSyms in the `RecCon` case below.
1706 mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
1707 mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
1708 mkGenArgSyms (RecCon fields)
1709 = do { let pats = map (unLoc . recordPatSynPatVar) fields
1710 sels = map (unLoc . recordPatSynSelectorId) fields
1711 ; ss <- mkGenSyms sels
1712 ; return $ replaceNames (zip sels pats) ss }
1713
1714 replaceNames selsPats genSyms
1715 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
1716 , sel == sel' ]
1717
1718 wrapGenArgSyms :: HsPatSynDetails (Located Name)
1719 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
1720 wrapGenArgSyms (RecCon _) _ dec = return dec
1721 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
1722
1723 rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))
1724 = panic "rep_bind: XPatSynBind"
1725 rep_bind (dL->L _ (XHsBindsLR {})) = panic "rep_bind: XHsBindsLR"
1726 rep_bind _ = panic "rep_bind: Impossible match!"
1727 -- due to #15884
1728
1729 repPatSynD :: Core TH.Name
1730 -> Core TH.PatSynArgsQ
1731 -> Core TH.PatSynDirQ
1732 -> Core TH.PatQ
1733 -> DsM (Core TH.DecQ)
1734 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
1735 = rep2 patSynDName [syn, args, dir, pat]
1736
1737 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
1738 repPatSynArgs (PrefixCon args)
1739 = do { args' <- repList nameTyConName lookupLOcc args
1740 ; repPrefixPatSynArgs args' }
1741 repPatSynArgs (InfixCon arg1 arg2)
1742 = do { arg1' <- lookupLOcc arg1
1743 ; arg2' <- lookupLOcc arg2
1744 ; repInfixPatSynArgs arg1' arg2' }
1745 repPatSynArgs (RecCon fields)
1746 = do { sels' <- repList nameTyConName lookupLOcc sels
1747 ; repRecordPatSynArgs sels' }
1748 where sels = map recordPatSynSelectorId fields
1749
1750 repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
1751 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
1752
1753 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
1754 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
1755
1756 repRecordPatSynArgs :: Core [TH.Name]
1757 -> DsM (Core TH.PatSynArgsQ)
1758 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
1759
1760 repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
1761 repPatSynDir Unidirectional = rep2 unidirPatSynName []
1762 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
1763 repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
1764 = do { clauses' <- mapM repClauseTup clauses
1765 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
1766 repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
1767
1768 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
1769 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
1770
1771
1772 -----------------------------------------------------------------------------
1773 -- Since everything in a Bind is mutually recursive we need rename all
1774 -- all the variables simultaneously. For example:
1775 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1776 -- do { f'1 <- gensym "f"
1777 -- ; g'2 <- gensym "g"
1778 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1779 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1780 -- ]}
1781 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1782 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1783 -- together. As we do this we collect GenSymBinds's which represent the renamed
1784 -- variables bound by the Bindings. In order not to lose track of these
1785 -- representations we build a shadow datatype MB with the same structure as
1786 -- MonoBinds, but which has slots for the representations
1787
1788
1789 -----------------------------------------------------------------------------
1790 -- GHC allows a more general form of lambda abstraction than specified
1791 -- by Haskell 98. In particular it allows guarded lambda's like :
1792 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1793 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1794 -- (\ p1 .. pn -> exp) by causing an error.
1795
1796 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
1797 repLambda (dL->L _ (Match { m_pats = ps
1798 , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
1799 (dL->L _ (EmptyLocalBinds _)) } ))
1800 = do { let bndrs = collectPatsBinders ps ;
1801 ; ss <- mkGenSyms bndrs
1802 ; lam <- addBinds ss (
1803 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1804 ; wrapGenSyms ss lam }
1805
1806 repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)
1807
1808
1809 -----------------------------------------------------------------------------
1810 -- Patterns
1811 -- repP deals with patterns. It assumes that we have already
1812 -- walked over the pattern(s) once to collect the binders, and
1813 -- have extended the environment. So every pattern-bound
1814 -- variable should already appear in the environment.
1815
1816 -- Process a list of patterns
1817 repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
1818 repLPs ps = repList patQTyConName repLP ps
1819
1820 repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
1821 repLP p = repP (unLoc p)
1822
1823 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
1824 repP (WildPat _) = repPwild
1825 repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 }
1826 repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' }
1827 repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 }
1828 repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 }
1829 repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p
1830 ; repPaspat x' p1 }
1831 repP (ParPat _ p) = repLP p
1832 repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs }
1833 repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
1834 ; e' <- repE (syn_expr e)
1835 ; repPview e' p}
1836 repP (TuplePat _ ps boxed)
1837 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1838 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1839 repP (SumPat _ p alt arity) = do { p1 <- repLP p
1840 ; repPunboxedSum p1 alt arity }
1841 repP (ConPatIn dc details)
1842 = do { con_str <- lookupLOcc dc
1843 ; case details of
1844 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1845 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1846 ; repPrec con_str fps }
1847 InfixCon p1 p2 -> do { p1' <- repLP p1;
1848 p2' <- repLP p2;
1849 repPinfix p1' con_str p2' }
1850 }
1851 where
1852 rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
1853 rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
1854 ; MkC p <- repLP (hsRecFieldArg fld)
1855 ; rep2 fieldPatName [v,p] }
1856
1857 repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l
1858 ; repPlit a }
1859 repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1860 repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
1861 repP (SigPat _ p t) = do { p' <- repLP p
1862 ; t' <- repLTy (hsSigWcType t)
1863 ; repPsig p' t' }
1864 repP (SplicePat _ splice) = repSplice splice
1865
1866 repP other = notHandled "Exotic pattern" (ppr other)
1867
1868 ----------------------------------------------------------
1869 -- Declaration ordering helpers
1870
1871 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1872 sort_by_loc xs = sortBy comp xs
1873 where comp x y = compare (fst x) (fst y)
1874
1875 de_loc :: [(a, b)] -> [b]
1876 de_loc = map snd
1877
1878 ----------------------------------------------------------
1879 -- The meta-environment
1880
1881 -- A name/identifier association for fresh names of locally bound entities
1882 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1883 -- I.e. (x, x_id) means
1884 -- let x_id = gensym "x" in ...
1885
1886 -- Generate a fresh name for a locally bound entity
1887
1888 mkGenSyms :: [Name] -> DsM [GenSymBind]
1889 -- We can use the existing name. For example:
1890 -- [| \x_77 -> x_77 + x_77 |]
1891 -- desugars to
1892 -- do { x_77 <- genSym "x"; .... }
1893 -- We use the same x_77 in the desugared program, but with the type Bndr
1894 -- instead of Int
1895 --
1896 -- We do make it an Internal name, though (hence localiseName)
1897 --
1898 -- Nevertheless, it's monadic because we have to generate nameTy
1899 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1900 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1901
1902
1903 addBinds :: [GenSymBind] -> DsM a -> DsM a
1904 -- Add a list of fresh names for locally bound entities to the
1905 -- meta environment (which is part of the state carried around
1906 -- by the desugarer monad)
1907 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1908
1909 -- Look up a locally bound name
1910 --
1911 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1912 lookupLBinder n = lookupBinder (unLoc n)
1913
1914 lookupBinder :: Name -> DsM (Core TH.Name)
1915 lookupBinder = lookupOcc
1916 -- Binders are brought into scope before the pattern or what-not is
1917 -- desugared. Moreover, in instance declaration the binder of a method
1918 -- will be the selector Id and hence a global; so we need the
1919 -- globalVar case of lookupOcc
1920
1921 -- Look up a name that is either locally bound or a global name
1922 --
1923 -- * If it is a global name, generate the "original name" representation (ie,
1924 -- the <module>:<name> form) for the associated entity
1925 --
1926 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1927 -- Lookup an occurrence; it can't be a splice.
1928 -- Use the in-scope bindings if they exist
1929 lookupLOcc n = lookupOcc (unLoc n)
1930
1931 lookupOcc :: Name -> DsM (Core TH.Name)
1932 lookupOcc n
1933 = do { mb_val <- dsLookupMetaEnv n ;
1934 case mb_val of
1935 Nothing -> globalVar n
1936 Just (DsBound x) -> return (coreVar x)
1937 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1938 }
1939
1940 globalVar :: Name -> DsM (Core TH.Name)
1941 -- Not bound by the meta-env
1942 -- Could be top-level; or could be local
1943 -- f x = $(g [| x |])
1944 -- Here the x will be local
1945 globalVar name
1946 | isExternalName name
1947 = do { MkC mod <- coreStringLit name_mod
1948 ; MkC pkg <- coreStringLit name_pkg
1949 ; MkC occ <- nameLit name
1950 ; rep2 mk_varg [pkg,mod,occ] }
1951 | otherwise
1952 = do { MkC occ <- nameLit name
1953 ; MkC uni <- coreIntLit (getKey (getUnique name))
1954 ; rep2 mkNameLName [occ,uni] }
1955 where
1956 mod = ASSERT( isExternalName name) nameModule name
1957 name_mod = moduleNameString (moduleName mod)
1958 name_pkg = unitIdString (moduleUnitId mod)
1959 name_occ = nameOccName name
1960 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1961 | OccName.isVarOcc name_occ = mkNameG_vName
1962 | OccName.isTcOcc name_occ = mkNameG_tcName
1963 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1964
1965 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1966 -> DsM Type -- The type
1967 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1968 return (mkTyConApp tc []) }
1969
1970 wrapGenSyms :: [GenSymBind]
1971 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1972 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1973 -- --> bindQ (gensym nm1) (\ id1 ->
1974 -- bindQ (gensym nm2 (\ id2 ->
1975 -- y))
1976
1977 wrapGenSyms binds body@(MkC b)
1978 = do { var_ty <- lookupType nameTyConName
1979 ; go var_ty binds }
1980 where
1981 [elt_ty] = tcTyConAppArgs (exprType b)
1982 -- b :: Q a, so we can get the type 'a' by looking at the
1983 -- argument type. NB: this relies on Q being a data/newtype,
1984 -- not a type synonym
1985
1986 go _ [] = return body
1987 go var_ty ((name,id) : binds)
1988 = do { MkC body' <- go var_ty binds
1989 ; lit_str <- nameLit name
1990 ; gensym_app <- repGensym lit_str
1991 ; repBindQ var_ty elt_ty
1992 gensym_app (MkC (Lam id body')) }
1993
1994 nameLit :: Name -> DsM (Core String)
1995 nameLit n = coreStringLit (occNameString (nameOccName n))
1996
1997 occNameLit :: OccName -> DsM (Core String)
1998 occNameLit name = coreStringLit (occNameString name)
1999
2000
2001 -- %*********************************************************************
2002 -- %* *
2003 -- Constructing code
2004 -- %* *
2005 -- %*********************************************************************
2006
2007 -----------------------------------------------------------------------------
2008 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
2009 -- we invent a new datatype which uses phantom types.
2010
2011 newtype Core a = MkC CoreExpr
2012 unC :: Core a -> CoreExpr
2013 unC (MkC x) = x
2014
2015 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
2016 rep2 n xs = do { id <- dsLookupGlobalId n
2017 ; return (MkC (foldl' App (Var id) xs)) }
2018
2019 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
2020 dataCon' n args = do { id <- dsLookupDataCon n
2021 ; return $ MkC $ mkCoreConApps id args }
2022
2023 dataCon :: Name -> DsM (Core a)
2024 dataCon n = dataCon' n []
2025
2026
2027 -- %*********************************************************************
2028 -- %* *
2029 -- The 'smart constructors'
2030 -- %* *
2031 -- %*********************************************************************
2032
2033 --------------- Patterns -----------------
2034 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
2035 repPlit (MkC l) = rep2 litPName [l]
2036
2037 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
2038 repPvar (MkC s) = rep2 varPName [s]
2039
2040 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
2041 repPtup (MkC ps) = rep2 tupPName [ps]
2042
2043 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
2044 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
2045
2046 repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
2047 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
2048 repPunboxedSum (MkC p) alt arity
2049 = do { dflags <- getDynFlags
2050 ; rep2 unboxedSumPName [ p
2051 , mkIntExprInt dflags alt
2052 , mkIntExprInt dflags arity ] }
2053
2054 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
2055 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
2056
2057 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
2058 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
2059
2060 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
2061 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
2062
2063 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
2064 repPtilde (MkC p) = rep2 tildePName [p]
2065
2066 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
2067 repPbang (MkC p) = rep2 bangPName [p]
2068
2069 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
2070 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
2071
2072 repPwild :: DsM (Core TH.PatQ)
2073 repPwild = rep2 wildPName []
2074
2075 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
2076 repPlist (MkC ps) = rep2 listPName [ps]
2077
2078 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
2079 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
2080
2081 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
2082 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
2083
2084 --------------- Expressions -----------------
2085 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
2086 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
2087 | otherwise = repVar str
2088
2089 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2090 repVar (MkC s) = rep2 varEName [s]
2091
2092 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
2093 repCon (MkC s) = rep2 conEName [s]
2094
2095 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
2096 repLit (MkC c) = rep2 litEName [c]
2097
2098 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2099 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
2100
2101 repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2102 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
2103
2104 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2105 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
2106
2107 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
2108 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
2109
2110 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2111 repTup (MkC es) = rep2 tupEName [es]
2112
2113 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2114 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
2115
2116 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
2117 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
2118 repUnboxedSum (MkC e) alt arity
2119 = do { dflags <- getDynFlags
2120 ; rep2 unboxedSumEName [ e
2121 , mkIntExprInt dflags alt
2122 , mkIntExprInt dflags arity ] }
2123
2124 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2125 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
2126
2127 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
2128 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
2129
2130 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2131 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
2132
2133 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
2134 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
2135
2136 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2137 repDoE (MkC ss) = rep2 doEName [ss]
2138
2139 repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2140 repMDoE (MkC ss) = rep2 mdoEName [ss]
2141
2142 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
2143 repComp (MkC ss) = rep2 compEName [ss]
2144
2145 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
2146 repListExp (MkC es) = rep2 listEName [es]
2147
2148 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
2149 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
2150
2151 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
2152 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
2153
2154 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
2155 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
2156
2157 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
2158 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
2159
2160 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2161 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
2162
2163 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2164 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
2165
2166 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2167 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
2168
2169 repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
2170 repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
2171
2172 ------------ Right hand sides (guarded expressions) ----
2173 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
2174 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
2175
2176 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
2177 repNormal (MkC e) = rep2 normalBName [e]
2178
2179 ------------ Guards ----
2180 repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
2181 -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2182 repLNormalGE g e = do g' <- repLE g
2183 e' <- repLE e
2184 repNormalGE g' e'
2185
2186 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2187 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
2188
2189 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
2190 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
2191
2192 ------------- Stmts -------------------
2193 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
2194 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
2195
2196 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
2197 repLetSt (MkC ds) = rep2 letSName [ds]
2198
2199 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
2200 repNoBindSt (MkC e) = rep2 noBindSName [e]
2201
2202 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
2203 repParSt (MkC sss) = rep2 parSName [sss]
2204
2205 repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
2206 repRecSt (MkC ss) = rep2 recSName [ss]
2207
2208 -------------- Range (Arithmetic sequences) -----------
2209 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
2210 repFrom (MkC x) = rep2 fromEName [x]
2211
2212 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2213 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
2214
2215 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2216 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
2217
2218 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
2219 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
2220
2221 ------------ Match and Clause Tuples -----------
2222 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
2223 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
2224
2225 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
2226 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
2227
2228 -------------- Dec -----------------------------
2229 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2230 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
2231
2232 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
2233 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
2234
2235 repData :: Core TH.CxtQ -> Core TH.Name
2236 -> Either (Core [TH.TyVarBndrQ])
2237 (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
2238 -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
2239 -> DsM (Core TH.DecQ)
2240 repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
2241 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
2242 repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
2243 (MkC derivs)
2244 = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
2245
2246 repNewtype :: Core TH.CxtQ -> Core TH.Name
2247 -> Either (Core [TH.TyVarBndrQ])
2248 (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
2249 -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
2250 -> DsM (Core TH.DecQ)
2251 repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
2252 (MkC derivs)
2253 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
2254 repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
2255 (MkC derivs)
2256 = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
2257
2258 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
2259 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2260 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
2261 = rep2 tySynDName [nm, tvs, rhs]
2262
2263 repInst :: Core (Maybe TH.Overlap) ->
2264 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2265 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
2266 [o, cxt, ty, ds]
2267
2268 repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
2269 -> DsM (Core (Maybe TH.DerivStrategyQ))
2270 repDerivStrategy mds =
2271 case mds of
2272 Nothing -> nothing
2273 Just ds ->
2274 case unLoc ds of
2275 StockStrategy -> just =<< repStockStrategy
2276 AnyclassStrategy -> just =<< repAnyclassStrategy
2277 NewtypeStrategy -> just =<< repNewtypeStrategy
2278 ViaStrategy ty -> do ty' <- repLTy (hsSigType ty)
2279 via_strat <- repViaStrategy ty'
2280 just via_strat
2281 where
2282 nothing = coreNothing derivStrategyQTyConName
2283 just = coreJust derivStrategyQTyConName
2284
2285 repStockStrategy :: DsM (Core TH.DerivStrategyQ)
2286 repStockStrategy = rep2 stockStrategyName []
2287
2288 repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
2289 repAnyclassStrategy = rep2 anyclassStrategyName []
2290
2291 repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
2292 repNewtypeStrategy = rep2 newtypeStrategyName []
2293
2294 repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
2295 repViaStrategy (MkC t) = rep2 viaStrategyName [t]
2296
2297 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
2298 repOverlap mb =
2299 case mb of
2300 Nothing -> nothing
2301 Just o ->
2302 case o of
2303 NoOverlap _ -> nothing
2304 Overlappable _ -> just =<< dataCon overlappableDataConName
2305 Overlapping _ -> just =<< dataCon overlappingDataConName
2306 Overlaps _ -> just =<< dataCon overlapsDataConName
2307 Incoherent _ -> just =<< dataCon incoherentDataConName
2308 where
2309 nothing = coreNothing overlapTyConName
2310 just = coreJust overlapTyConName
2311
2312
2313 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2314 -> Core [TH.FunDep] -> Core [TH.DecQ]
2315 -> DsM (Core TH.DecQ)
2316 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
2317 = rep2 classDName [cxt, cls, tvs, fds, ds]
2318
2319 repDeriv :: Core (Maybe TH.DerivStrategyQ)
2320 -> Core TH.CxtQ -> Core TH.TypeQ
2321 -> DsM (Core TH.DecQ)
2322 repDeriv (MkC ds) (MkC cxt) (MkC ty)
2323 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
2324
2325 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
2326 -> Core TH.Phases -> DsM (Core TH.DecQ)
2327 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
2328 = rep2 pragInlDName [nm, inline, rm, phases]
2329
2330 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
2331 -> DsM (Core TH.DecQ)
2332 repPragSpec (MkC nm) (MkC ty) (MkC phases)
2333 = rep2 pragSpecDName [nm, ty, phases]
2334
2335 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
2336 -> Core TH.Phases -> DsM (Core TH.DecQ)
2337 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
2338 = rep2 pragSpecInlDName [nm, ty, inline, phases]
2339
2340 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
2341 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
2342
2343 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
2344 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
2345
2346 repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
2347 -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
2348 -> Core TH.Phases -> DsM (Core TH.DecQ)
2349 repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
2350 = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
2351
2352 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2353 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
2354
2355 repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
2356 repTySynInst (MkC eqn)
2357 = rep2 tySynInstDName [eqn]
2358
2359 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
2360 -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
2361 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
2362 = rep2 dataFamilyDName [nm, tvs, kind]
2363
2364 repOpenFamilyD :: Core TH.Name
2365 -> Core [TH.TyVarBndrQ]
2366 -> Core TH.FamilyResultSigQ
2367 -> Core (Maybe TH.InjectivityAnn)
2368 -> DsM (Core TH.DecQ)
2369 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
2370 = rep2 openTypeFamilyDName [nm, tvs, result, inj]
2371
2372 repClosedFamilyD :: Core TH.Name
2373 -> Core [TH.TyVarBndrQ]
2374 -> Core TH.FamilyResultSigQ
2375 -> Core (Maybe TH.InjectivityAnn)
2376 -> Core [TH.TySynEqnQ]
2377 -> DsM (Core TH.DecQ)
2378 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
2379 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
2380
2381 repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
2382 Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
2383 repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
2384 = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
2385
2386 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
2387 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
2388
2389 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
2390 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
2391
2392 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2393 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
2394
2395 repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2396 repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
2397
2398 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
2399 repCtxt (MkC tys) = rep2 cxtName [tys]
2400
2401 repDataCon :: Located Name
2402 -> HsConDeclDetails GhcRn
2403 -> DsM (Core TH.ConQ)
2404 repDataCon con details
2405 = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
2406 repConstr details Nothing [con']
2407
2408 repGadtDataCons :: [Located Name]
2409 -> HsConDeclDetails GhcRn
2410 -> LHsType GhcRn
2411 -> DsM (Core TH.ConQ)
2412 repGadtDataCons cons details res_ty
2413 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
2414 repConstr details (Just res_ty) cons'
2415
2416 -- Invariant:
2417 -- * for plain H98 data constructors second argument is Nothing and third
2418 -- argument is a singleton list
2419 -- * for GADTs data constructors second argument is (Just return_type) and
2420 -- third argument is a non-empty list
2421 repConstr :: HsConDeclDetails GhcRn
2422 -> Maybe (LHsType GhcRn)
2423 -> [Core TH.Name]
2424 -> DsM (Core TH.ConQ)
2425 repConstr (PrefixCon ps) Nothing [con]
2426 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2427 rep2 normalCName [unC con, unC arg_tys]
2428
2429 repConstr (PrefixCon ps) (Just res_ty) cons
2430 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2431 res_ty' <- repLTy res_ty
2432 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
2433
2434 repConstr (RecCon ips) resTy cons
2435 = do args <- concatMapM rep_ip (unLoc ips)
2436 arg_vtys <- coreList varBangTypeQTyConName args
2437 case resTy of
2438 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
2439 Just res_ty -> do
2440 res_ty' <- repLTy res_ty
2441 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
2442 unC res_ty']
2443
2444 where
2445 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
2446
2447 rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
2448 rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n)
2449 ; MkC ty <- repBangTy t
2450 ; rep2 varBangTypeName [v,ty] }
2451
2452 repConstr (InfixCon st1 st2) Nothing [con]
2453 = do arg1 <- repBangTy st1
2454 arg2 <- repBangTy st2
2455 rep2 infixCName [unC arg1, unC con, unC arg2]
2456
2457 repConstr (InfixCon {}) (Just _) _ =
2458 panic "repConstr: infix GADT constructor should be in a PrefixCon"
2459 repConstr _ _ _ =
2460 panic "repConstr: invariant violated"
2461
2462 ------------ Types -------------------
2463
2464 repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
2465 -> DsM (Core TH.TypeQ)
2466 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
2467 = rep2 forallTName [tvars, ctxt, ty]
2468
2469 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
2470 repTvar (MkC s) = rep2 varTName [s]
2471
2472 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2473 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
2474
2475 repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
2476 repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
2477
2478 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2479 repTapps f [] = return f
2480 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
2481
2482 repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
2483 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
2484
2485 repTequality :: DsM (Core TH.TypeQ)
2486 repTequality = rep2 equalityTName []
2487
2488 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2489 repTPromotedList [] = repPromotedNilTyCon
2490 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
2491 ; f <- repTapp tcon t
2492 ; t' <- repTPromotedList ts
2493 ; repTapp f t'
2494 }
2495
2496 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
2497 repTLit (MkC lit) = rep2 litTName [lit]
2498
2499 repTWildCard :: DsM (Core TH.TypeQ)
2500 repTWildCard = rep2 wildCardTName []
2501
2502 repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2503 repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
2504
2505 repTStar :: DsM (Core TH.TypeQ)
2506 repTStar = rep2 starKName []
2507
2508 repTConstraint :: DsM (Core TH.TypeQ)
2509 repTConstraint = rep2 constraintKName []
2510
2511 --------- Type constructors --------------
2512
2513 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2514 repNamedTyCon (MkC s) = rep2 conTName [s]
2515
2516 repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
2517 -> DsM (Core TH.TypeQ)
2518 repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
2519
2520 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2521 -- Note: not Core Int; it's easier to be direct here
2522 repTupleTyCon i = do dflags <- getDynFlags
2523 rep2 tupleTName [mkIntExprInt dflags i]
2524
2525 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2526 -- Note: not Core Int; it's easier to be direct here
2527 repUnboxedTupleTyCon i = do dflags <- getDynFlags
2528 rep2 unboxedTupleTName [mkIntExprInt dflags i]
2529
2530 repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
2531 -- Note: not Core TH.SumArity; it's easier to be direct here
2532 repUnboxedSumTyCon arity = do dflags <- getDynFlags
2533 rep2 unboxedSumTName [mkIntExprInt dflags arity]
2534
2535 repArrowTyCon :: DsM (Core TH.TypeQ)
2536 repArrowTyCon = rep2 arrowTName []
2537
2538 repListTyCon :: DsM (Core TH.TypeQ)
2539 repListTyCon = rep2 listTName []
2540
2541 repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2542 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
2543
2544 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2545 repPromotedTupleTyCon i = do dflags <- getDynFlags
2546 rep2 promotedTupleTName [mkIntExprInt dflags i]
2547
2548 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
2549 repPromotedNilTyCon = rep2 promotedNilTName []
2550
2551 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
2552 repPromotedConsTyCon = rep2 promotedConsTName []
2553
2554 ------------ TyVarBndrs -------------------
2555
2556 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
2557 repPlainTV (MkC nm) = rep2 plainTVName [nm]
2558
2559 repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
2560 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
2561
2562 ----------------------------------------------------------
2563 -- Type family result signature
2564
2565 repNoSig :: DsM (Core TH.FamilyResultSigQ)
2566 repNoSig = rep2 noSigName []
2567
2568 repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
2569 repKindSig (MkC ki) = rep2 kindSigName [ki]
2570
2571 repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
2572 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
2573
2574 ----------------------------------------------------------
2575 -- Literals
2576
2577 repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
2578 repLiteral (HsStringPrim _ bs)
2579 = do dflags <- getDynFlags
2580 word8_ty <- lookupType word8TyConName
2581 let w8s = unpack bs
2582 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2583 [mkWordLit dflags (toInteger w8)]) w8s
2584 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2585 repLiteral lit
2586 = do lit' <- case lit of
2587 HsIntPrim _ i -> mk_integer i
2588 HsWordPrim _ w -> mk_integer w
2589 HsInt _ i -> mk_integer (il_value i)
2590 HsFloatPrim _ r -> mk_rational r
2591 HsDoublePrim _ r -> mk_rational r
2592 HsCharPrim _ c -> mk_char c
2593 _ -> return lit
2594 lit_expr <- dsLit lit'
2595 case mb_lit_name of
2596 Just lit_name -> rep2 lit_name [lit_expr]
2597 Nothing -> notHandled "Exotic literal" (ppr lit)
2598 where
2599 mb_lit_name = case lit of
2600 HsInteger _ _ _ -> Just integerLName
2601 HsInt _ _ -> Just integerLName
2602 HsIntPrim _ _ -> Just intPrimLName
2603 HsWordPrim _ _ -> Just wordPrimLName
2604 HsFloatPrim _ _ -> Just floatPrimLName
2605 HsDoublePrim _ _ -> Just doublePrimLName
2606 HsChar _ _ -> Just charLName
2607 HsCharPrim _ _ -> Just charPrimLName
2608 HsString _ _ -> Just stringLName
2609 HsRat _ _ _ -> Just rationalLName
2610 _ -> Nothing
2611
2612 mk_integer :: Integer -> DsM (HsLit GhcRn)
2613 mk_integer i = do integer_ty <- lookupType integerTyConName
2614 return $ HsInteger NoSourceText i integer_ty
2615
2616 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
2617 mk_rational r = do rat_ty <- lookupType rationalTyConName
2618 return $ HsRat noExt r rat_ty
2619 mk_string :: FastString -> DsM (HsLit GhcRn)
2620 mk_string s = return $ HsString NoSourceText s
2621
2622 mk_char :: Char -> DsM (HsLit GhcRn)
2623 mk_char c = return $ HsChar NoSourceText c
2624
2625 repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
2626 repOverloadedLiteral (OverLit { ol_val = val})
2627 = do { lit <- mk_lit val; repLiteral lit }
2628 -- The type Rational will be in the environment, because
2629 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2630 -- and rationalL is sucked in when any TH stuff is used
2631 repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
2632
2633 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
2634 mk_lit (HsIntegral i) = mk_integer (il_value i)
2635 mk_lit (HsFractional f) = mk_rational f
2636 mk_lit (HsIsString _ s) = mk_string s
2637
2638 repNameS :: Core String -> DsM (Core TH.Name)
2639 repNameS (MkC name) = rep2 mkNameSName [name]
2640
2641 --------------- Miscellaneous -------------------
2642
2643 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2644 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2645
2646 repBindQ :: Type -> Type -- a and b
2647 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2648 repBindQ ty_a ty_b (MkC x) (MkC y)
2649 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2650
2651 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2652 repSequenceQ ty_a (MkC list)
2653 = rep2 sequenceQName [Type ty_a, list]
2654
2655 repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2656 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
2657
2658 repOverLabel :: FastString -> DsM (Core TH.ExpQ)
2659 repOverLabel fs = do
2660 (MkC s) <- coreStringLit $ unpackFS fs
2661 rep2 labelEName [s]
2662
2663
2664 ------------ Lists -------------------
2665 -- turn a list of patterns into a single pattern matching a list
2666
2667 repList :: Name -> (a -> DsM (Core b))
2668 -> [a] -> DsM (Core [b])
2669 repList tc_name f args
2670 = do { args1 <- mapM f args
2671 ; coreList tc_name args1 }
2672
2673 coreList :: Name -- Of the TyCon of the element type
2674 -> [Core a] -> DsM (Core [a])
2675 coreList tc_name es
2676 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2677
2678 coreList' :: Type -- The element type
2679 -> [Core a] -> Core [a]
2680 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2681
2682 nonEmptyCoreList :: [Core a] -> Core [a]
2683 -- The list must be non-empty so we can get the element type
2684 -- Otherwise use coreList
2685 nonEmptyCoreList [] = panic "coreList: empty argument"
2686 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2687
2688 coreStringLit :: String -> DsM (Core String)
2689 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2690
2691 ------------------- Maybe ------------------
2692
2693 repMaybe :: Name -> (a -> DsM (Core b))
2694 -> Maybe a -> DsM (Core (Maybe b))
2695 repMaybe tc_name _ Nothing = coreNothing tc_name
2696 repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
2697
2698 -- | Construct Core expression for Nothing of a given type name
2699 coreNothing :: Name -- ^ Name of the TyCon of the element type
2700 -> DsM (Core (Maybe a))
2701 coreNothing tc_name =
2702 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
2703
2704 -- | Construct Core expression for Nothing of a given type
2705 coreNothing' :: Type -- ^ The element type
2706 -> Core (Maybe a)
2707 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
2708
2709 -- | Store given Core expression in a Just of a given type name
2710 coreJust :: Name -- ^ Name of the TyCon of the element type
2711 -> Core a -> DsM (Core (Maybe a))
2712 coreJust tc_name es
2713 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
2714
2715 -- | Store given Core expression in a Just of a given type
2716 coreJust' :: Type -- ^ The element type
2717 -> Core a -> Core (Maybe a)
2718 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
2719
2720 ------------------- Maybe Lists ------------------
2721
2722 repMaybeList :: Name -> (a -> DsM (Core b))
2723 -> Maybe [a] -> DsM (Core (Maybe [b]))
2724 repMaybeList tc_name _ Nothing = coreNothingList tc_name
2725 repMaybeList tc_name f (Just args)
2726 = do { elt_ty <- lookupType tc_name
2727 ; args1 <- mapM f args
2728 ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
2729
2730 coreNothingList :: Name -> DsM (Core (Maybe [a]))
2731 coreNothingList tc_name
2732 = do { elt_ty <- lookupType tc_name
2733 ; return $ coreNothing' (mkListTy elt_ty) }
2734
2735 coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
2736 coreJustList tc_name args
2737 = do { elt_ty <- lookupType tc_name
2738 ; return $ coreJust' (mkListTy elt_ty) args }
2739
2740 ------------ Literals & Variables -------------------
2741
2742 coreIntLit :: Int -> DsM (Core Int)
2743 coreIntLit i = do dflags <- getDynFlags
2744 return (MkC (mkIntExprInt dflags i))
2745
2746 coreVar :: Id -> Core TH.Name -- The Id has type Name
2747 coreVar id = MkC (Var id)
2748
2749 ----------------- Failure -----------------------
2750 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2751 notHandledL loc what doc
2752 | isGoodSrcSpan loc
2753 = putSrcSpanDs loc $ notHandled what doc
2754 | otherwise
2755 = notHandled what doc
2756
2757 notHandled :: String -> SDoc -> DsM a
2758 notHandled what doc = failWithDs msg
2759 where
2760 msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2761 2 doc