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