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