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