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