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