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