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