Simplify HsPatSynDetails
[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 ValBindsIn _ sigs -> sigs
202 ValBindsOut _ 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_forall = False
634 , con_mb_cxt = Nothing
635 , con_args = args }))
636 = repDataCon con args
637
638 repC (L _ (ConDeclH98 { con_name = con
639 , con_forall = is_existential
640 , con_ex_tvs = con_tvs
641 , con_mb_cxt = mcxt
642 , con_args = args }))
643 = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
644 do { c' <- repDataCon con args
645 ; ctxt' <- repMbContext mcxt
646 ; if not is_existential && isNothing mcxt
647 then return c'
648 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
649 }
650 }
651
652 repC (L _ (ConDeclGADT { con_names = cons
653 , con_qvars = qtvs, con_mb_cxt = mcxt
654 , con_args = args, con_res_ty = res_ty }))
655 | isEmptyLHsQTvs qtvs -- No implicit or explicit variables
656 , Nothing <- mcxt -- No context
657 -- ==> no need for a forall
658 = repGadtDataCons cons args res_ty
659
660 | otherwise
661 = addTyVarBinds qtvs $ \ ex_bndrs ->
662 -- See Note [Don't quantify implicit type variables in quotes]
663 do { c' <- repGadtDataCons cons args res_ty
664 ; ctxt' <- repMbContext mcxt
665 ; if null (hsQTvExplicit qtvs) && isNothing mcxt
666 then return c'
667 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
668
669 repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
670 repMbContext Nothing = repContext []
671 repMbContext (Just (L _ cxt)) = repContext cxt
672
673 repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
674 repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName []
675 repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName []
676 repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
677
678 repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
679 repSrcStrictness SrcLazy = rep2 sourceLazyName []
680 repSrcStrictness SrcStrict = rep2 sourceStrictName []
681 repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
682
683 repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
684 repBangTy ty = do
685 MkC u <- repSrcUnpackedness su'
686 MkC s <- repSrcStrictness ss'
687 MkC b <- rep2 bangName [u, s]
688 MkC t <- repLTy ty'
689 rep2 bangTypeName [b, t]
690 where
691 (su', ss', ty') = case ty of
692 L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
693 _ -> (NoSrcUnpack, NoSrcStrict, ty)
694
695 -------------------------------------------------------
696 -- Deriving clauses
697 -------------------------------------------------------
698
699 repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
700 repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses
701
702 repDerivClause :: LHsDerivingClause GhcRn
703 -> DsM (Core TH.DerivClauseQ)
704 repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
705 , deriv_clause_tys = L _ dct }))
706 = do MkC dcs' <- repDerivStrategy dcs
707 MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
708 rep2 derivClauseName [dcs',dct']
709 where
710 rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
711 rep_deriv_ty (L _ ty) = repTy ty
712
713 -------------------------------------------------------
714 -- Signatures in a class decl, or a group of bindings
715 -------------------------------------------------------
716
717 rep_sigs :: [LSig GhcRn] -> DsM [Core TH.DecQ]
718 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
719 return $ de_loc $ sort_by_loc locs_cores
720
721 rep_sigs' :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
722 -- We silently ignore ones we don't recognise
723 rep_sigs' = concatMapM rep_sig
724
725 rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
726 rep_sig (L loc (TypeSig nms ty)) = mapM (rep_wc_ty_sig sigDName loc ty) nms
727 rep_sig (L loc (PatSynSig nms ty)) = mapM (rep_patsyn_ty_sig loc ty) nms
728 rep_sig (L loc (ClassOpSig is_deflt nms ty))
729 | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms
730 | otherwise = mapM (rep_ty_sig sigDName loc ty) nms
731 rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)
732 rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level
733 rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
734 rep_sig (L loc (SpecSig nm tys ispec))
735 = concatMapM (\t -> rep_specialise nm t ispec loc) tys
736 rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc
737 rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty
738 rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty
739 rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc
740
741
742 rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
743 -> DsM (SrcSpan, Core TH.DecQ)
744 rep_ty_sig mk_sig loc sig_ty nm
745 = do { nm1 <- lookupLOcc nm
746 ; ty1 <- repHsSigType sig_ty
747 ; sig <- repProto mk_sig nm1 ty1
748 ; return (loc, sig) }
749
750 rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
751 -> DsM (SrcSpan, Core TH.DecQ)
752 -- represents a pattern synonym type signature;
753 -- see Note [Pattern synonym type signatures and Template Haskell] in Convert
754 rep_patsyn_ty_sig loc sig_ty nm
755 = do { nm1 <- lookupLOcc nm
756 ; ty1 <- repHsPatSynSigType sig_ty
757 ; sig <- repProto patSynSigDName nm1 ty1
758 ; return (loc, sig) }
759
760 rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
761 -> DsM (SrcSpan, Core TH.DecQ)
762 -- We must special-case the top-level explicit for-all of a TypeSig
763 -- See Note [Scoped type variables in bindings]
764 rep_wc_ty_sig mk_sig loc sig_ty nm
765 | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty
766 , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
767 = do { nm1 <- lookupLOcc nm
768 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
769 ; repTyVarBndrWithKind tv name }
770 ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
771 explicit_tvs
772 -- NB: Don't pass any implicit type variables to repList above
773 -- See Note [Don't quantify implicit type variables in quotes]
774
775 ; th_ctxt <- repLContext ctxt
776 ; th_ty <- repLTy ty
777 ; ty1 <- if null explicit_tvs && null (unLoc ctxt)
778 then return th_ty
779 else repTForall th_explicit_tvs th_ctxt th_ty
780 ; sig <- repProto mk_sig nm1 ty1
781 ; return (loc, sig) }
782
783 rep_inline :: Located Name
784 -> InlinePragma -- Never defaultInlinePragma
785 -> SrcSpan
786 -> DsM [(SrcSpan, Core TH.DecQ)]
787 rep_inline nm ispec loc
788 = do { nm1 <- lookupLOcc nm
789 ; inline <- repInline $ inl_inline ispec
790 ; rm <- repRuleMatch $ inl_rule ispec
791 ; phases <- repPhases $ inl_act ispec
792 ; pragma <- repPragInl nm1 inline rm phases
793 ; return [(loc, pragma)]
794 }
795
796 rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
797 -> SrcSpan
798 -> DsM [(SrcSpan, Core TH.DecQ)]
799 rep_specialise nm ty ispec loc
800 = do { nm1 <- lookupLOcc nm
801 ; ty1 <- repHsSigType ty
802 ; phases <- repPhases $ inl_act ispec
803 ; let inline = inl_inline ispec
804 ; pragma <- if noUserInlineSpec inline
805 then -- SPECIALISE
806 repPragSpec nm1 ty1 phases
807 else -- SPECIALISE INLINE
808 do { inline1 <- repInline inline
809 ; repPragSpecInl nm1 ty1 inline1 phases }
810 ; return [(loc, pragma)]
811 }
812
813 rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
814 -> DsM [(SrcSpan, Core TH.DecQ)]
815 rep_specialiseInst ty loc
816 = do { ty1 <- repHsSigType ty
817 ; pragma <- repPragSpecInst ty1
818 ; return [(loc, pragma)] }
819
820 repInline :: InlineSpec -> DsM (Core TH.Inline)
821 repInline NoInline = dataCon noInlineDataConName
822 repInline Inline = dataCon inlineDataConName
823 repInline Inlinable = dataCon inlinableDataConName
824 repInline spec = notHandled "repInline" (ppr spec)
825
826 repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
827 repRuleMatch ConLike = dataCon conLikeDataConName
828 repRuleMatch FunLike = dataCon funLikeDataConName
829
830 repPhases :: Activation -> DsM (Core TH.Phases)
831 repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
832 ; dataCon' beforePhaseDataConName [arg] }
833 repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i
834 ; dataCon' fromPhaseDataConName [arg] }
835 repPhases _ = dataCon allPhasesDataConName
836
837 rep_complete_sig :: Located [Located Name]
838 -> Maybe (Located Name)
839 -> SrcSpan
840 -> DsM [(SrcSpan, Core TH.DecQ)]
841 rep_complete_sig (L _ cls) mty loc
842 = do { mty' <- rep_maybe_name mty
843 ; cls' <- repList nameTyConName lookupLOcc cls
844 ; sig <- repPragComplete cls' mty'
845 ; return [(loc, sig)] }
846 where
847 rep_maybe_name Nothing = coreNothing nameTyConName
848 rep_maybe_name (Just n) = do
849 cn <- lookupLOcc n
850 coreJust nameTyConName cn
851
852 -------------------------------------------------------
853 -- Types
854 -------------------------------------------------------
855
856 addSimpleTyVarBinds :: [Name] -- the binders to be added
857 -> DsM (Core (TH.Q a)) -- action in the ext env
858 -> DsM (Core (TH.Q a))
859 addSimpleTyVarBinds names thing_inside
860 = do { fresh_names <- mkGenSyms names
861 ; term <- addBinds fresh_names thing_inside
862 ; wrapGenSyms fresh_names term }
863
864 addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added
865 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
866 -> DsM (Core (TH.Q a))
867 addHsTyVarBinds exp_tvs thing_inside
868 = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
869 ; term <- addBinds fresh_exp_names $
870 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
871 (exp_tvs `zip` fresh_exp_names)
872 ; thing_inside kbs }
873 ; wrapGenSyms fresh_exp_names term }
874 where
875 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
876
877 addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
878 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env
879 -> DsM (Core (TH.Q a))
880 -- gensym a list of type variables and enter them into the meta environment;
881 -- the computations passed as the second argument is executed in that extended
882 -- meta environment and gets the *new* names on Core-level as an argument
883 addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
884 thing_inside
885 = addSimpleTyVarBinds imp_tvs $
886 addHsTyVarBinds exp_tvs $
887 thing_inside
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
925 -- | Represent a type variable binder
926 repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
927 repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
928 ; repPlainTV nm' }
929 repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
930 ; ki' <- repLTy ki
931 ; repKindedTV nm' ki' }
932
933 -- represent a type context
934 --
935 repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
936 repLContext (L _ ctxt) = repContext ctxt
937
938 repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
939 repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
940 repCtxt preds
941
942 repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
943 repHsSigType (HsIB { hsib_vars = implicit_tvs
944 , hsib_body = body })
945 | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
946 = addSimpleTyVarBinds implicit_tvs $
947 -- See Note [Don't quantify implicit type variables in quotes]
948 addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
949 do { th_ctxt <- repLContext ctxt
950 ; th_ty <- repLTy ty
951 ; if null explicit_tvs && null (unLoc ctxt)
952 then return th_ty
953 else repTForall th_explicit_tvs th_ctxt th_ty }
954
955 repHsPatSynSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
956 repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
957 , hsib_body = body })
958 = addSimpleTyVarBinds implicit_tvs $
959 -- See Note [Don't quantify implicit type variables in quotes]
960 addHsTyVarBinds univs $ \th_univs ->
961 addHsTyVarBinds exis $ \th_exis ->
962 do { th_reqs <- repLContext reqs
963 ; th_provs <- repLContext provs
964 ; th_ty <- repLTy ty
965 ; repTForall th_univs th_reqs =<< (repTForall th_exis th_provs th_ty) }
966 where
967 (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
968
969 repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
970 repHsSigWcType (HsWC { hswc_body = sig1 })
971 = repHsSigType sig1
972
973 -- yield the representation of a list of types
974 repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
975 repLTys tys = mapM repLTy tys
976
977 -- represent a type
978 repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
979 repLTy (L _ ty) = repTy ty
980
981 repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
982 -- Arg of repForall is always HsForAllTy or HsQualTy
983 repForall ty
984 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
985 = addHsTyVarBinds tvs $ \bndrs ->
986 do { ctxt1 <- repLContext ctxt
987 ; ty1 <- repLTy tau
988 ; repTForall bndrs ctxt1 ty1 }
989
990 repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
991 repTy ty@(HsForAllTy {}) = repForall ty
992 repTy ty@(HsQualTy {}) = repForall ty
993
994 repTy (HsTyVar _ (L _ n))
995 | isLiftedTypeKindTyConName n = repTStar
996 | n `hasKey` constraintKindTyConKey = repTConstraint
997 | isTvOcc occ = do tv1 <- lookupOcc n
998 repTvar tv1
999 | isDataOcc occ = do tc1 <- lookupOcc n
1000 repPromotedDataCon tc1
1001 | n == eqTyConName = repTequality
1002 | otherwise = do tc1 <- lookupOcc n
1003 repNamedTyCon tc1
1004 where
1005 occ = nameOccName n
1006
1007 repTy (HsAppTy f a) = do
1008 f1 <- repLTy f
1009 a1 <- repLTy a
1010 repTapp f1 a1
1011 repTy (HsFunTy f a) = do
1012 f1 <- repLTy f
1013 a1 <- repLTy a
1014 tcon <- repArrowTyCon
1015 repTapps tcon [f1, a1]
1016 repTy (HsListTy t) = do
1017 t1 <- repLTy t
1018 tcon <- repListTyCon
1019 repTapp tcon t1
1020 repTy (HsPArrTy t) = do
1021 t1 <- repLTy t
1022 tcon <- repTy (HsTyVar NotPromoted
1023 (noLoc (tyConName parrTyCon)))
1024 repTapp tcon t1
1025 repTy (HsTupleTy HsUnboxedTuple tys) = do
1026 tys1 <- repLTys tys
1027 tcon <- repUnboxedTupleTyCon (length tys)
1028 repTapps tcon tys1
1029 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys
1030 tcon <- repTupleTyCon (length tys)
1031 repTapps tcon tys1
1032 repTy (HsSumTy tys) = do tys1 <- repLTys tys
1033 tcon <- repUnboxedSumTyCon (length tys)
1034 repTapps tcon tys1
1035 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
1036 `nlHsAppTy` ty2)
1037 repTy (HsParTy t) = repLTy t
1038 repTy (HsEqTy t1 t2) = do
1039 t1' <- repLTy t1
1040 t2' <- repLTy t2
1041 eq <- repTequality
1042 repTapps eq [t1', t2']
1043 repTy (HsKindSig t k) = do
1044 t1 <- repLTy t
1045 k1 <- repLTy k
1046 repTSig t1 k1
1047 repTy (HsSpliceTy splice _) = repSplice splice
1048 repTy (HsExplicitListTy _ _ tys) = do
1049 tys1 <- repLTys tys
1050 repTPromotedList tys1
1051 repTy (HsExplicitTupleTy _ tys) = do
1052 tys1 <- repLTys tys
1053 tcon <- repPromotedTupleTyCon (length tys)
1054 repTapps tcon tys1
1055 repTy (HsTyLit lit) = do
1056 lit' <- repTyLit lit
1057 repTLit lit'
1058 repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
1059
1060 repTy ty = notHandled "Exotic form of type" (ppr ty)
1061
1062 repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
1063 repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
1064 rep2 numTyLitName [iExpr]
1065 repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
1066 ; rep2 strTyLitName [s']
1067 }
1068
1069 -- | Represent a type wrapped in a Maybe
1070 repMaybeLTy :: Maybe (LHsKind GhcRn)
1071 -> DsM (Core (Maybe TH.TypeQ))
1072 repMaybeLTy Nothing =
1073 do { coreNothing kindQTyConName }
1074 repMaybeLTy (Just ki) =
1075 do { ki' <- repLTy ki
1076 ; coreJust kindQTyConName ki' }
1077
1078 repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
1079 repRole (L _ (Just Nominal)) = rep2 nominalRName []
1080 repRole (L _ (Just Representational)) = rep2 representationalRName []
1081 repRole (L _ (Just Phantom)) = rep2 phantomRName []
1082 repRole (L _ Nothing) = rep2 inferRName []
1083
1084 -----------------------------------------------------------------------------
1085 -- Splices
1086 -----------------------------------------------------------------------------
1087
1088 repSplice :: HsSplice GhcRn -> DsM (Core a)
1089 -- See Note [How brackets and nested splices are handled] in TcSplice
1090 -- We return a CoreExpr of any old type; the context should know
1091 repSplice (HsTypedSplice _ n _) = rep_splice n
1092 repSplice (HsUntypedSplice _ n _) = rep_splice n
1093 repSplice (HsQuasiQuote n _ _ _) = rep_splice n
1094 repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e)
1095
1096 rep_splice :: Name -> DsM (Core a)
1097 rep_splice splice_name
1098 = do { mb_val <- dsLookupMetaEnv splice_name
1099 ; case mb_val of
1100 Just (DsSplice e) -> do { e' <- dsExpr e
1101 ; return (MkC e') }
1102 _ -> pprPanic "HsSplice" (ppr splice_name) }
1103 -- Should not happen; statically checked
1104
1105 -----------------------------------------------------------------------------
1106 -- Expressions
1107 -----------------------------------------------------------------------------
1108
1109 repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
1110 repLEs es = repList expQTyConName repLE es
1111
1112 -- FIXME: some of these panics should be converted into proper error messages
1113 -- unless we can make sure that constructs, which are plainly not
1114 -- supported in TH already lead to error messages at an earlier stage
1115 repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
1116 repLE (L loc e) = putSrcSpanDs loc (repE e)
1117
1118 repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
1119 repE (HsVar (L _ x)) =
1120 do { mb_val <- dsLookupMetaEnv x
1121 ; case mb_val of
1122 Nothing -> do { str <- globalVar x
1123 ; repVarOrCon x str }
1124 Just (DsBound y) -> repVarOrCon x (coreVar y)
1125 Just (DsSplice e) -> do { e' <- dsExpr e
1126 ; return (MkC e') } }
1127 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
1128 repE (HsOverLabel _ s) = repOverLabel s
1129
1130 repE e@(HsRecFld f) = case f of
1131 Unambiguous _ x -> repE (HsVar (noLoc x))
1132 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
1133
1134 -- Remember, we're desugaring renamer output here, so
1135 -- HsOverlit can definitely occur
1136 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
1137 repE (HsLit l) = do { a <- repLiteral l; repLit a }
1138 repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
1139 repE (HsLamCase (MG { mg_alts = L _ ms }))
1140 = do { ms' <- mapM repMatchTup ms
1141 ; core_ms <- coreList matchQTyConName ms'
1142 ; repLamCase core_ms }
1143 repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
1144 repE (HsAppType e t) = do { a <- repLE e
1145 ; s <- repLTy (hswc_body t)
1146 ; repAppType a s }
1147
1148 repE (OpApp e1 op _ e2) =
1149 do { arg1 <- repLE e1;
1150 arg2 <- repLE e2;
1151 the_op <- repLE op ;
1152 repInfixApp arg1 the_op arg2 }
1153 repE (NegApp x _) = do
1154 a <- repLE x
1155 negateVar <- lookupOcc negateName >>= repVar
1156 negateVar `repApp` a
1157 repE (HsPar x) = repLE x
1158 repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
1159 repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
1160 repE (HsCase e (MG { mg_alts = L _ ms }))
1161 = do { arg <- repLE e
1162 ; ms2 <- mapM repMatchTup ms
1163 ; core_ms2 <- coreList matchQTyConName ms2
1164 ; repCaseE arg core_ms2 }
1165 repE (HsIf _ x y z) = do
1166 a <- repLE x
1167 b <- repLE y
1168 c <- repLE z
1169 repCond a b c
1170 repE (HsMultiIf _ alts)
1171 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
1172 ; expr' <- repMultiIf (nonEmptyCoreList alts')
1173 ; wrapGenSyms (concat binds) expr' }
1174 repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs
1175 ; e2 <- addBinds ss (repLE e)
1176 ; z <- repLetE ds e2
1177 ; wrapGenSyms ss z }
1178
1179 -- FIXME: I haven't got the types here right yet
1180 repE e@(HsDo ctxt (L _ sts) _)
1181 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
1182 = do { (ss,zs) <- repLSts sts;
1183 e' <- repDoE (nonEmptyCoreList zs);
1184 wrapGenSyms ss e' }
1185
1186 | ListComp <- ctxt
1187 = do { (ss,zs) <- repLSts sts;
1188 e' <- repComp (nonEmptyCoreList zs);
1189 wrapGenSyms ss e' }
1190
1191 | otherwise
1192 = notHandled "mdo, monad comprehension and [: :]" (ppr e)
1193
1194 repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
1195 repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
1196 repE e@(ExplicitTuple es boxed)
1197 | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
1198 | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
1199 | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
1200 ; repUnboxedTup xs }
1201
1202 repE (ExplicitSum alt arity e _)
1203 = do { e1 <- repLE e
1204 ; repUnboxedSum e1 alt arity }
1205
1206 repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
1207 = do { x <- lookupLOcc c;
1208 fs <- repFields flds;
1209 repRecCon x fs }
1210 repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
1211 = do { x <- repLE e;
1212 fs <- repUpdFields flds;
1213 repRecUpd x fs }
1214
1215 repE (ExprWithTySig e ty)
1216 = do { e1 <- repLE e
1217 ; t1 <- repHsSigWcType ty
1218 ; repSigExp e1 t1 }
1219
1220 repE (ArithSeq _ _ aseq) =
1221 case aseq of
1222 From e -> do { ds1 <- repLE e; repFrom ds1 }
1223 FromThen e1 e2 -> do
1224 ds1 <- repLE e1
1225 ds2 <- repLE e2
1226 repFromThen ds1 ds2
1227 FromTo e1 e2 -> do
1228 ds1 <- repLE e1
1229 ds2 <- repLE e2
1230 repFromTo ds1 ds2
1231 FromThenTo e1 e2 e3 -> do
1232 ds1 <- repLE e1
1233 ds2 <- repLE e2
1234 ds3 <- repLE e3
1235 repFromThenTo ds1 ds2 ds3
1236
1237 repE (HsSpliceE splice) = repSplice splice
1238 repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
1239 repE (HsUnboundVar uv) = do
1240 occ <- occNameLit (unboundVarOcc uv)
1241 sname <- repNameS occ
1242 repUnboundVar sname
1243
1244 repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
1245 repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
1246 repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
1247 repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
1248 repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
1249 repE e = notHandled "Expression form" (ppr e)
1250
1251 -----------------------------------------------------------------------------
1252 -- Building representations of auxillary structures like Match, Clause, Stmt,
1253
1254 repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
1255 repMatchTup (L _ (Match { m_pats = [p], m_grhss = GRHSs guards (L _ wheres) })) =
1256 do { ss1 <- mkGenSyms (collectPatBinders p)
1257 ; addBinds ss1 $ do {
1258 ; p1 <- repLP p
1259 ; (ss2,ds) <- repBinds wheres
1260 ; addBinds ss2 $ do {
1261 ; gs <- repGuards guards
1262 ; match <- repMatch p1 gs ds
1263 ; wrapGenSyms (ss1++ss2) match }}}
1264 repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
1265
1266 repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
1267 repClauseTup (L _ (Match { m_pats = ps, m_grhss = GRHSs guards (L _ wheres) })) =
1268 do { ss1 <- mkGenSyms (collectPatsBinders ps)
1269 ; addBinds ss1 $ do {
1270 ps1 <- repLPs ps
1271 ; (ss2,ds) <- repBinds wheres
1272 ; addBinds ss2 $ do {
1273 gs <- repGuards guards
1274 ; clause <- repClause ps1 gs ds
1275 ; wrapGenSyms (ss1++ss2) clause }}}
1276
1277 repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ)
1278 repGuards [L _ (GRHS [] e)]
1279 = do {a <- repLE e; repNormal a }
1280 repGuards other
1281 = do { zs <- mapM repLGRHS other
1282 ; let (xs, ys) = unzip zs
1283 ; gd <- repGuarded (nonEmptyCoreList ys)
1284 ; wrapGenSyms (concat xs) gd }
1285
1286 repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
1287 -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
1288 repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))
1289 = do { guarded <- repLNormalGE e1 e2
1290 ; return ([], guarded) }
1291 repLGRHS (L _ (GRHS ss rhs))
1292 = do { (gs, ss') <- repLSts ss
1293 ; rhs' <- addBinds gs $ repLE rhs
1294 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
1295 ; return (gs, guarded) }
1296
1297 repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
1298 repFields (HsRecFields { rec_flds = flds })
1299 = repList fieldExpQTyConName rep_fld flds
1300 where
1301 rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
1302 -> DsM (Core (TH.Q TH.FieldExp))
1303 rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
1304 ; e <- repLE (hsRecFieldArg fld)
1305 ; repFieldExp fn e }
1306
1307 repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
1308 repUpdFields = repList fieldExpQTyConName rep_fld
1309 where
1310 rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
1311 rep_fld (L l fld) = case unLoc (hsRecFieldLbl fld) of
1312 Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
1313 ; e <- repLE (hsRecFieldArg fld)
1314 ; repFieldExp fn e }
1315 _ -> notHandled "Ambiguous record updates" (ppr fld)
1316
1317
1318
1319 -----------------------------------------------------------------------------
1320 -- Representing Stmt's is tricky, especially if bound variables
1321 -- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
1322 -- First gensym new names for every variable in any of the patterns.
1323 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
1324 -- if variables didn't shaddow, the static gensym wouldn't be necessary
1325 -- and we could reuse the original names (x and x).
1326 --
1327 -- do { x'1 <- gensym "x"
1328 -- ; x'2 <- gensym "x"
1329 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
1330 -- , BindSt (pvar x'2) [| f x |]
1331 -- , NoBindSt [| g x |]
1332 -- ]
1333 -- }
1334
1335 -- The strategy is to translate a whole list of do-bindings by building a
1336 -- bigger environment, and a bigger set of meta bindings
1337 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
1338 -- of the expressions within the Do
1339
1340 -----------------------------------------------------------------------------
1341 -- The helper function repSts computes the translation of each sub expression
1342 -- and a bunch of prefix bindings denoting the dynamic renaming.
1343
1344 repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1345 repLSts stmts = repSts (map unLoc stmts)
1346
1347 repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
1348 repSts (BindStmt p e _ _ _ : ss) =
1349 do { e2 <- repLE e
1350 ; ss1 <- mkGenSyms (collectPatBinders p)
1351 ; addBinds ss1 $ do {
1352 ; p1 <- repLP p;
1353 ; (ss2,zs) <- repSts ss
1354 ; z <- repBindSt p1 e2
1355 ; return (ss1++ss2, z : zs) }}
1356 repSts (LetStmt (L _ bs) : ss) =
1357 do { (ss1,ds) <- repBinds bs
1358 ; z <- repLetSt ds
1359 ; (ss2,zs) <- addBinds ss1 (repSts ss)
1360 ; return (ss1++ss2, z : zs) }
1361 repSts (BodyStmt e _ _ _ : ss) =
1362 do { e2 <- repLE e
1363 ; z <- repNoBindSt e2
1364 ; (ss2,zs) <- repSts ss
1365 ; return (ss2, z : zs) }
1366 repSts (ParStmt stmt_blocks _ _ _ : ss) =
1367 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
1368 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
1369 ss1 = concat ss_s
1370 ; z <- repParSt stmt_blocks2
1371 ; (ss2, zs) <- addBinds ss1 (repSts ss)
1372 ; return (ss1++ss2, z : zs) }
1373 where
1374 rep_stmt_block :: ParStmtBlock GhcRn GhcRn
1375 -> DsM ([GenSymBind], Core [TH.StmtQ])
1376 rep_stmt_block (ParStmtBlock stmts _ _) =
1377 do { (ss1, zs) <- repSts (map unLoc stmts)
1378 ; zs1 <- coreList stmtQTyConName zs
1379 ; return (ss1, zs1) }
1380 repSts [LastStmt e _ _]
1381 = do { e2 <- repLE e
1382 ; z <- repNoBindSt e2
1383 ; return ([], [z]) }
1384 repSts [] = return ([],[])
1385 repSts other = notHandled "Exotic statement" (ppr other)
1386
1387
1388 -----------------------------------------------------------
1389 -- Bindings
1390 -----------------------------------------------------------
1391
1392 repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
1393 repBinds EmptyLocalBinds
1394 = do { core_list <- coreList decQTyConName []
1395 ; return ([], core_list) }
1396
1397 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
1398
1399 repBinds (HsValBinds decs)
1400 = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }
1401 -- No need to worry about detailed scopes within
1402 -- the binding group, because we are talking Names
1403 -- here, so we can safely treat it as a mutually
1404 -- recursive group
1405 -- For hsSigTvBinders see Note [Scoped type variables in bindings]
1406 ; ss <- mkGenSyms bndrs
1407 ; prs <- addBinds ss (rep_val_binds decs)
1408 ; core_list <- coreList decQTyConName
1409 (de_loc (sort_by_loc prs))
1410 ; return (ss, core_list) }
1411
1412 rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1413 -- Assumes: all the binders of the binding are already in the meta-env
1414 rep_val_binds (ValBindsOut binds sigs)
1415 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
1416 ; core2 <- rep_sigs' sigs
1417 ; return (core1 ++ core2) }
1418 rep_val_binds (ValBindsIn _ _)
1419 = panic "rep_val_binds: ValBindsIn"
1420
1421 rep_binds :: LHsBinds GhcRn -> DsM [Core TH.DecQ]
1422 rep_binds binds = do { binds_w_locs <- rep_binds' binds
1423 ; return (de_loc (sort_by_loc binds_w_locs)) }
1424
1425 rep_binds' :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
1426 rep_binds' = mapM rep_bind . bagToList
1427
1428 rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
1429 -- Assumes: all the binders of the binding are already in the meta-env
1430
1431 -- Note GHC treats declarations of a variable (not a pattern)
1432 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
1433 -- with an empty list of patterns
1434 rep_bind (L loc (FunBind
1435 { fun_id = fn,
1436 fun_matches = MG { mg_alts
1437 = L _ [L _ (Match { m_pats = []
1438 , m_grhss = GRHSs guards (L _ wheres) })] } }))
1439 = do { (ss,wherecore) <- repBinds wheres
1440 ; guardcore <- addBinds ss (repGuards guards)
1441 ; fn' <- lookupLBinder fn
1442 ; p <- repPvar fn'
1443 ; ans <- repVal p guardcore wherecore
1444 ; ans' <- wrapGenSyms ss ans
1445 ; return (loc, ans') }
1446
1447 rep_bind (L loc (FunBind { fun_id = fn
1448 , fun_matches = MG { mg_alts = L _ ms } }))
1449 = do { ms1 <- mapM repClauseTup ms
1450 ; fn' <- lookupLBinder fn
1451 ; ans <- repFun fn' (nonEmptyCoreList ms1)
1452 ; return (loc, ans) }
1453
1454 rep_bind (L loc (PatBind { pat_lhs = pat
1455 , pat_rhs = GRHSs guards (L _ wheres) }))
1456 = do { patcore <- repLP pat
1457 ; (ss,wherecore) <- repBinds wheres
1458 ; guardcore <- addBinds ss (repGuards guards)
1459 ; ans <- repVal patcore guardcore wherecore
1460 ; ans' <- wrapGenSyms ss ans
1461 ; return (loc, ans') }
1462
1463 rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
1464 = do { v' <- lookupBinder v
1465 ; e2 <- repLE e
1466 ; x <- repNormal e2
1467 ; patcore <- repPvar v'
1468 ; empty_decls <- coreList decQTyConName []
1469 ; ans <- repVal patcore x empty_decls
1470 ; return (srcLocSpan (getSrcLoc v), ans) }
1471
1472 rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"
1473 rep_bind (L loc (PatSynBind (PSB { psb_id = syn
1474 , psb_fvs = _fvs
1475 , psb_args = args
1476 , psb_def = pat
1477 , psb_dir = dir })))
1478 = do { syn' <- lookupLBinder syn
1479 ; dir' <- repPatSynDir dir
1480 ; ss <- mkGenArgSyms args
1481 ; patSynD' <- addBinds ss (
1482 do { args' <- repPatSynArgs args
1483 ; pat' <- repLP pat
1484 ; repPatSynD syn' args' dir' pat' })
1485 ; patSynD'' <- wrapGenArgSyms args ss patSynD'
1486 ; return (loc, patSynD'') }
1487 where
1488 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
1489 -- for Record Pattern Synonyms we want to conflate the selector
1490 -- and the pattern-only names in order to provide a nicer TH
1491 -- API. Whereas inside GHC, record pattern synonym selectors and
1492 -- their pattern-only bound right hand sides have different names,
1493 -- we want to treat them the same in TH. This is the reason why we
1494 -- need an adjusted mkGenArgSyms in the `RecCon` case below.
1495 mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
1496 mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
1497 mkGenArgSyms (RecCon fields)
1498 = do { let pats = map (unLoc . recordPatSynPatVar) fields
1499 sels = map (unLoc . recordPatSynSelectorId) fields
1500 ; ss <- mkGenSyms sels
1501 ; return $ replaceNames (zip sels pats) ss }
1502
1503 replaceNames selsPats genSyms
1504 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
1505 , sel == sel' ]
1506
1507 wrapGenArgSyms :: HsPatSynDetails (Located Name)
1508 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
1509 wrapGenArgSyms (RecCon _) _ dec = return dec
1510 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
1511
1512 repPatSynD :: Core TH.Name
1513 -> Core TH.PatSynArgsQ
1514 -> Core TH.PatSynDirQ
1515 -> Core TH.PatQ
1516 -> DsM (Core TH.DecQ)
1517 repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
1518 = rep2 patSynDName [syn, args, dir, pat]
1519
1520 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
1521 repPatSynArgs (PrefixCon args)
1522 = do { args' <- repList nameTyConName lookupLOcc args
1523 ; repPrefixPatSynArgs args' }
1524 repPatSynArgs (InfixCon arg1 arg2)
1525 = do { arg1' <- lookupLOcc arg1
1526 ; arg2' <- lookupLOcc arg2
1527 ; repInfixPatSynArgs arg1' arg2' }
1528 repPatSynArgs (RecCon fields)
1529 = do { sels' <- repList nameTyConName lookupLOcc sels
1530 ; repRecordPatSynArgs sels' }
1531 where sels = map recordPatSynSelectorId fields
1532
1533 repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
1534 repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
1535
1536 repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
1537 repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
1538
1539 repRecordPatSynArgs :: Core [TH.Name]
1540 -> DsM (Core TH.PatSynArgsQ)
1541 repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
1542
1543 repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
1544 repPatSynDir Unidirectional = rep2 unidirPatSynName []
1545 repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
1546 repPatSynDir (ExplicitBidirectional (MG { mg_alts = L _ clauses }))
1547 = do { clauses' <- mapM repClauseTup clauses
1548 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
1549
1550 repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
1551 repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
1552
1553
1554 -----------------------------------------------------------------------------
1555 -- Since everything in a Bind is mutually recursive we need rename all
1556 -- all the variables simultaneously. For example:
1557 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
1558 -- do { f'1 <- gensym "f"
1559 -- ; g'2 <- gensym "g"
1560 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
1561 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
1562 -- ]}
1563 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
1564 -- environment ( f |-> f'1 ) from each binding, and then unioning them
1565 -- together. As we do this we collect GenSymBinds's which represent the renamed
1566 -- variables bound by the Bindings. In order not to lose track of these
1567 -- representations we build a shadow datatype MB with the same structure as
1568 -- MonoBinds, but which has slots for the representations
1569
1570
1571 -----------------------------------------------------------------------------
1572 -- GHC allows a more general form of lambda abstraction than specified
1573 -- by Haskell 98. In particular it allows guarded lambda's like :
1574 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
1575 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
1576 -- (\ p1 .. pn -> exp) by causing an error.
1577
1578 repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
1579 repLambda (L _ (Match { m_pats = ps
1580 , m_grhss = GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds) } ))
1581 = do { let bndrs = collectPatsBinders ps ;
1582 ; ss <- mkGenSyms bndrs
1583 ; lam <- addBinds ss (
1584 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
1585 ; wrapGenSyms ss lam }
1586
1587 repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
1588
1589
1590 -----------------------------------------------------------------------------
1591 -- Patterns
1592 -- repP deals with patterns. It assumes that we have already
1593 -- walked over the pattern(s) once to collect the binders, and
1594 -- have extended the environment. So every pattern-bound
1595 -- variable should already appear in the environment.
1596
1597 -- Process a list of patterns
1598 repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
1599 repLPs ps = repList patQTyConName repLP ps
1600
1601 repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
1602 repLP (L _ p) = repP p
1603
1604 repP :: Pat GhcRn -> DsM (Core TH.PatQ)
1605 repP (WildPat _) = repPwild
1606 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
1607 repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' }
1608 repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }
1609 repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }
1610 repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
1611 repP (ParPat p) = repLP p
1612 repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }
1613 repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
1614 repP (TuplePat ps boxed _)
1615 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }
1616 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }
1617 repP (SumPat p alt arity _) = do { p1 <- repLP p; repPunboxedSum p1 alt arity }
1618 repP (ConPatIn dc details)
1619 = do { con_str <- lookupLOcc dc
1620 ; case details of
1621 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
1622 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
1623 ; repPrec con_str fps }
1624 InfixCon p1 p2 -> do { p1' <- repLP p1;
1625 p2' <- repLP p2;
1626 repPinfix p1' con_str p2' }
1627 }
1628 where
1629 rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
1630 rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
1631 ; MkC p <- repLP (hsRecFieldArg fld)
1632 ; rep2 fieldPatName [v,p] }
1633
1634 repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
1635 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
1636 repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
1637 repP (SigPatIn p t) = do { p' <- repLP p
1638 ; t' <- repLTy (hsSigWcType t)
1639 ; repPsig p' t' }
1640 repP (SplicePat splice) = repSplice splice
1641
1642 repP other = notHandled "Exotic pattern" (ppr other)
1643
1644 ----------------------------------------------------------
1645 -- Declaration ordering helpers
1646
1647 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
1648 sort_by_loc xs = sortBy comp xs
1649 where comp x y = compare (fst x) (fst y)
1650
1651 de_loc :: [(a, b)] -> [b]
1652 de_loc = map snd
1653
1654 ----------------------------------------------------------
1655 -- The meta-environment
1656
1657 -- A name/identifier association for fresh names of locally bound entities
1658 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
1659 -- I.e. (x, x_id) means
1660 -- let x_id = gensym "x" in ...
1661
1662 -- Generate a fresh name for a locally bound entity
1663
1664 mkGenSyms :: [Name] -> DsM [GenSymBind]
1665 -- We can use the existing name. For example:
1666 -- [| \x_77 -> x_77 + x_77 |]
1667 -- desugars to
1668 -- do { x_77 <- genSym "x"; .... }
1669 -- We use the same x_77 in the desugared program, but with the type Bndr
1670 -- instead of Int
1671 --
1672 -- We do make it an Internal name, though (hence localiseName)
1673 --
1674 -- Nevertheless, it's monadic because we have to generate nameTy
1675 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
1676 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
1677
1678
1679 addBinds :: [GenSymBind] -> DsM a -> DsM a
1680 -- Add a list of fresh names for locally bound entities to the
1681 -- meta environment (which is part of the state carried around
1682 -- by the desugarer monad)
1683 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
1684
1685 -- Look up a locally bound name
1686 --
1687 lookupLBinder :: Located Name -> DsM (Core TH.Name)
1688 lookupLBinder (L _ n) = lookupBinder n
1689
1690 lookupBinder :: Name -> DsM (Core TH.Name)
1691 lookupBinder = lookupOcc
1692 -- Binders are brought into scope before the pattern or what-not is
1693 -- desugared. Moreover, in instance declaration the binder of a method
1694 -- will be the selector Id and hence a global; so we need the
1695 -- globalVar case of lookupOcc
1696
1697 -- Look up a name that is either locally bound or a global name
1698 --
1699 -- * If it is a global name, generate the "original name" representation (ie,
1700 -- the <module>:<name> form) for the associated entity
1701 --
1702 lookupLOcc :: Located Name -> DsM (Core TH.Name)
1703 -- Lookup an occurrence; it can't be a splice.
1704 -- Use the in-scope bindings if they exist
1705 lookupLOcc (L _ n) = lookupOcc n
1706
1707 lookupOcc :: Name -> DsM (Core TH.Name)
1708 lookupOcc n
1709 = do { mb_val <- dsLookupMetaEnv n ;
1710 case mb_val of
1711 Nothing -> globalVar n
1712 Just (DsBound x) -> return (coreVar x)
1713 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
1714 }
1715
1716 globalVar :: Name -> DsM (Core TH.Name)
1717 -- Not bound by the meta-env
1718 -- Could be top-level; or could be local
1719 -- f x = $(g [| x |])
1720 -- Here the x will be local
1721 globalVar name
1722 | isExternalName name
1723 = do { MkC mod <- coreStringLit name_mod
1724 ; MkC pkg <- coreStringLit name_pkg
1725 ; MkC occ <- nameLit name
1726 ; rep2 mk_varg [pkg,mod,occ] }
1727 | otherwise
1728 = do { MkC occ <- nameLit name
1729 ; MkC uni <- coreIntLit (getKey (getUnique name))
1730 ; rep2 mkNameLName [occ,uni] }
1731 where
1732 mod = ASSERT( isExternalName name) nameModule name
1733 name_mod = moduleNameString (moduleName mod)
1734 name_pkg = unitIdString (moduleUnitId mod)
1735 name_occ = nameOccName name
1736 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
1737 | OccName.isVarOcc name_occ = mkNameG_vName
1738 | OccName.isTcOcc name_occ = mkNameG_tcName
1739 | otherwise = pprPanic "DsMeta.globalVar" (ppr name)
1740
1741 lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)
1742 -> DsM Type -- The type
1743 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
1744 return (mkTyConApp tc []) }
1745
1746 wrapGenSyms :: [GenSymBind]
1747 -> Core (TH.Q a) -> DsM (Core (TH.Q a))
1748 -- wrapGenSyms [(nm1,id1), (nm2,id2)] y
1749 -- --> bindQ (gensym nm1) (\ id1 ->
1750 -- bindQ (gensym nm2 (\ id2 ->
1751 -- y))
1752
1753 wrapGenSyms binds body@(MkC b)
1754 = do { var_ty <- lookupType nameTyConName
1755 ; go var_ty binds }
1756 where
1757 [elt_ty] = tcTyConAppArgs (exprType b)
1758 -- b :: Q a, so we can get the type 'a' by looking at the
1759 -- argument type. NB: this relies on Q being a data/newtype,
1760 -- not a type synonym
1761
1762 go _ [] = return body
1763 go var_ty ((name,id) : binds)
1764 = do { MkC body' <- go var_ty binds
1765 ; lit_str <- nameLit name
1766 ; gensym_app <- repGensym lit_str
1767 ; repBindQ var_ty elt_ty
1768 gensym_app (MkC (Lam id body')) }
1769
1770 nameLit :: Name -> DsM (Core String)
1771 nameLit n = coreStringLit (occNameString (nameOccName n))
1772
1773 occNameLit :: OccName -> DsM (Core String)
1774 occNameLit name = coreStringLit (occNameString name)
1775
1776
1777 -- %*********************************************************************
1778 -- %* *
1779 -- Constructing code
1780 -- %* *
1781 -- %*********************************************************************
1782
1783 -----------------------------------------------------------------------------
1784 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
1785 -- we invent a new datatype which uses phantom types.
1786
1787 newtype Core a = MkC CoreExpr
1788 unC :: Core a -> CoreExpr
1789 unC (MkC x) = x
1790
1791 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
1792 rep2 n xs = do { id <- dsLookupGlobalId n
1793 ; return (MkC (foldl App (Var id) xs)) }
1794
1795 dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
1796 dataCon' n args = do { id <- dsLookupDataCon n
1797 ; return $ MkC $ mkCoreConApps id args }
1798
1799 dataCon :: Name -> DsM (Core a)
1800 dataCon n = dataCon' n []
1801
1802
1803 -- %*********************************************************************
1804 -- %* *
1805 -- The 'smart constructors'
1806 -- %* *
1807 -- %*********************************************************************
1808
1809 --------------- Patterns -----------------
1810 repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)
1811 repPlit (MkC l) = rep2 litPName [l]
1812
1813 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1814 repPvar (MkC s) = rep2 varPName [s]
1815
1816 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1817 repPtup (MkC ps) = rep2 tupPName [ps]
1818
1819 repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1820 repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
1821
1822 repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
1823 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1824 repPunboxedSum (MkC p) alt arity
1825 = do { dflags <- getDynFlags
1826 ; rep2 unboxedSumPName [ p
1827 , mkIntExprInt dflags alt
1828 , mkIntExprInt dflags arity ] }
1829
1830 repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1831 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1832
1833 repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1834 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1835
1836 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1837 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1838
1839 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1840 repPtilde (MkC p) = rep2 tildePName [p]
1841
1842 repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
1843 repPbang (MkC p) = rep2 bangPName [p]
1844
1845 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1846 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1847
1848 repPwild :: DsM (Core TH.PatQ)
1849 repPwild = rep2 wildPName []
1850
1851 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1852 repPlist (MkC ps) = rep2 listPName [ps]
1853
1854 repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
1855 repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
1856
1857 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1858 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1859
1860 --------------- Expressions -----------------
1861 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1862 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1863 | otherwise = repVar str
1864
1865 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1866 repVar (MkC s) = rep2 varEName [s]
1867
1868 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1869 repCon (MkC s) = rep2 conEName [s]
1870
1871 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1872 repLit (MkC c) = rep2 litEName [c]
1873
1874 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1875 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1876
1877 repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1878 repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
1879
1880 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1881 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1882
1883 repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
1884 repLamCase (MkC ms) = rep2 lamCaseEName [ms]
1885
1886 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1887 repTup (MkC es) = rep2 tupEName [es]
1888
1889 repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1890 repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
1891
1892 repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
1893 -- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
1894 repUnboxedSum (MkC e) alt arity
1895 = do { dflags <- getDynFlags
1896 ; rep2 unboxedSumEName [ e
1897 , mkIntExprInt dflags alt
1898 , mkIntExprInt dflags arity ] }
1899
1900 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1901 repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
1902
1903 repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
1904 repMultiIf (MkC alts) = rep2 multiIfEName [alts]
1905
1906 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1907 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1908
1909 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1910 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1911
1912 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1913 repDoE (MkC ss) = rep2 doEName [ss]
1914
1915 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1916 repComp (MkC ss) = rep2 compEName [ss]
1917
1918 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1919 repListExp (MkC es) = rep2 listEName [es]
1920
1921 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1922 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1923
1924 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1925 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1926
1927 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1928 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1929
1930 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1931 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1932
1933 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1934 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1935
1936 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1937 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1938
1939 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1940 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1941
1942 ------------ Right hand sides (guarded expressions) ----
1943 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1944 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1945
1946 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1947 repNormal (MkC e) = rep2 normalBName [e]
1948
1949 ------------ Guards ----
1950 repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
1951 -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1952 repLNormalGE g e = do g' <- repLE g
1953 e' <- repLE e
1954 repNormalGE g' e'
1955
1956 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1957 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1958
1959 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1960 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1961
1962 ------------- Stmts -------------------
1963 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1964 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1965
1966 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1967 repLetSt (MkC ds) = rep2 letSName [ds]
1968
1969 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1970 repNoBindSt (MkC e) = rep2 noBindSName [e]
1971
1972 repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
1973 repParSt (MkC sss) = rep2 parSName [sss]
1974
1975 -------------- Range (Arithmetic sequences) -----------
1976 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1977 repFrom (MkC x) = rep2 fromEName [x]
1978
1979 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1980 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1981
1982 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1983 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1984
1985 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1986 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1987
1988 ------------ Match and Clause Tuples -----------
1989 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1990 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1991
1992 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1993 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1994
1995 -------------- Dec -----------------------------
1996 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1997 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1998
1999 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
2000 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
2001
2002 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2003 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
2004 -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2005 repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
2006 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
2007 repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
2008 (MkC derivs)
2009 = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
2010
2011 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2012 -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
2013 -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
2014 repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
2015 (MkC derivs)
2016 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
2017 repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
2018 (MkC derivs)
2019 = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
2020
2021 repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
2022 -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2023 repTySyn (MkC nm) (MkC tvs) (MkC rhs)
2024 = rep2 tySynDName [nm, tvs, rhs]
2025
2026 repInst :: Core (Maybe TH.Overlap) ->
2027 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
2028 repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
2029 [o, cxt, ty, ds]
2030
2031 repDerivStrategy :: Maybe (Located DerivStrategy)
2032 -> DsM (Core (Maybe TH.DerivStrategy))
2033 repDerivStrategy mds =
2034 case mds of
2035 Nothing -> nothing
2036 Just (L _ ds) ->
2037 case ds of
2038 StockStrategy -> just =<< dataCon stockStrategyDataConName
2039 AnyclassStrategy -> just =<< dataCon anyclassStrategyDataConName
2040 NewtypeStrategy -> just =<< dataCon newtypeStrategyDataConName
2041 where
2042 nothing = coreNothing derivStrategyTyConName
2043 just = coreJust derivStrategyTyConName
2044
2045 repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
2046 repOverlap mb =
2047 case mb of
2048 Nothing -> nothing
2049 Just o ->
2050 case o of
2051 NoOverlap _ -> nothing
2052 Overlappable _ -> just =<< dataCon overlappableDataConName
2053 Overlapping _ -> just =<< dataCon overlappingDataConName
2054 Overlaps _ -> just =<< dataCon overlapsDataConName
2055 Incoherent _ -> just =<< dataCon incoherentDataConName
2056 where
2057 nothing = coreNothing overlapTyConName
2058 just = coreJust overlapTyConName
2059
2060
2061 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
2062 -> Core [TH.FunDep] -> Core [TH.DecQ]
2063 -> DsM (Core TH.DecQ)
2064 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
2065 = rep2 classDName [cxt, cls, tvs, fds, ds]
2066
2067 repDeriv :: Core (Maybe TH.DerivStrategy)
2068 -> Core TH.CxtQ -> Core TH.TypeQ
2069 -> DsM (Core TH.DecQ)
2070 repDeriv (MkC ds) (MkC cxt) (MkC ty)
2071 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
2072
2073 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
2074 -> Core TH.Phases -> DsM (Core TH.DecQ)
2075 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
2076 = rep2 pragInlDName [nm, inline, rm, phases]
2077
2078 repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
2079 -> DsM (Core TH.DecQ)
2080 repPragSpec (MkC nm) (MkC ty) (MkC phases)
2081 = rep2 pragSpecDName [nm, ty, phases]
2082
2083 repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
2084 -> Core TH.Phases -> DsM (Core TH.DecQ)
2085 repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
2086 = rep2 pragSpecInlDName [nm, ty, inline, phases]
2087
2088 repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
2089 repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
2090
2091 repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
2092 repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
2093
2094 repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
2095 -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
2096 repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
2097 = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
2098
2099 repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
2100 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
2101
2102 repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
2103 repTySynInst (MkC nm) (MkC eqn)
2104 = rep2 tySynInstDName [nm, eqn]
2105
2106 repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
2107 -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
2108 repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
2109 = rep2 dataFamilyDName [nm, tvs, kind]
2110
2111 repOpenFamilyD :: Core TH.Name
2112 -> Core [TH.TyVarBndrQ]
2113 -> Core TH.FamilyResultSigQ
2114 -> Core (Maybe TH.InjectivityAnn)
2115 -> DsM (Core TH.DecQ)
2116 repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
2117 = rep2 openTypeFamilyDName [nm, tvs, result, inj]
2118
2119 repClosedFamilyD :: Core TH.Name
2120 -> Core [TH.TyVarBndrQ]
2121 -> Core TH.FamilyResultSigQ
2122 -> Core (Maybe TH.InjectivityAnn)
2123 -> Core [TH.TySynEqnQ]
2124 -> DsM (Core TH.DecQ)
2125 repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
2126 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
2127
2128 repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
2129 repTySynEqn (MkC lhs) (MkC rhs)
2130 = rep2 tySynEqnName [lhs, rhs]
2131
2132 repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
2133 repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
2134
2135 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
2136 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
2137
2138 repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
2139 repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
2140
2141 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
2142 repCtxt (MkC tys) = rep2 cxtName [tys]
2143
2144 repDataCon :: Located Name
2145 -> HsConDeclDetails GhcRn
2146 -> DsM (Core TH.ConQ)
2147 repDataCon con details
2148 = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
2149 repConstr details Nothing [con']
2150
2151 repGadtDataCons :: [Located Name]
2152 -> HsConDeclDetails GhcRn
2153 -> LHsType GhcRn
2154 -> DsM (Core TH.ConQ)
2155 repGadtDataCons cons details res_ty
2156 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
2157 repConstr details (Just res_ty) cons'
2158
2159 -- Invariant:
2160 -- * for plain H98 data constructors second argument is Nothing and third
2161 -- argument is a singleton list
2162 -- * for GADTs data constructors second argument is (Just return_type) and
2163 -- third argument is a non-empty list
2164 repConstr :: HsConDeclDetails GhcRn
2165 -> Maybe (LHsType GhcRn)
2166 -> [Core TH.Name]
2167 -> DsM (Core TH.ConQ)
2168 repConstr (PrefixCon ps) Nothing [con]
2169 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2170 rep2 normalCName [unC con, unC arg_tys]
2171
2172 repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
2173 = do arg_tys <- repList bangTypeQTyConName repBangTy ps
2174 res_ty' <- repTy res_ty
2175 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
2176
2177 repConstr (RecCon (L _ ips)) resTy cons
2178 = do args <- concatMapM rep_ip ips
2179 arg_vtys <- coreList varBangTypeQTyConName args
2180 case resTy of
2181 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
2182 Just (L _ res_ty) -> do
2183 res_ty' <- repTy res_ty
2184 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
2185 unC res_ty']
2186
2187 where
2188 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
2189
2190 rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
2191 rep_one_ip t n = do { MkC v <- lookupOcc (selectorFieldOcc $ unLoc n)
2192 ; MkC ty <- repBangTy t
2193 ; rep2 varBangTypeName [v,ty] }
2194
2195 repConstr (InfixCon st1 st2) Nothing [con]
2196 = do arg1 <- repBangTy st1
2197 arg2 <- repBangTy st2
2198 rep2 infixCName [unC arg1, unC con, unC arg2]
2199
2200 repConstr (InfixCon {}) (Just _) _ =
2201 panic "repConstr: infix GADT constructor should be in a PrefixCon"
2202 repConstr _ _ _ =
2203 panic "repConstr: invariant violated"
2204
2205 ------------ Types -------------------
2206
2207 repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
2208 -> DsM (Core TH.TypeQ)
2209 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
2210 = rep2 forallTName [tvars, ctxt, ty]
2211
2212 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
2213 repTvar (MkC s) = rep2 varTName [s]
2214
2215 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
2216 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
2217
2218 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2219 repTapps f [] = return f
2220 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
2221
2222 repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
2223 repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
2224
2225 repTequality :: DsM (Core TH.TypeQ)
2226 repTequality = rep2 equalityTName []
2227
2228 repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
2229 repTPromotedList [] = repPromotedNilTyCon
2230 repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon
2231 ; f <- repTapp tcon t
2232 ; t' <- repTPromotedList ts
2233 ; repTapp f t'
2234 }
2235
2236 repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
2237 repTLit (MkC lit) = rep2 litTName [lit]
2238
2239 repTWildCard :: DsM (Core TH.TypeQ)
2240 repTWildCard = rep2 wildCardTName []
2241
2242 repTStar :: DsM (Core TH.TypeQ)
2243 repTStar = rep2 starKName []
2244
2245 repTConstraint :: DsM (Core TH.TypeQ)
2246 repTConstraint = rep2 constraintKName []
2247
2248 --------- Type constructors --------------
2249
2250 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2251 repNamedTyCon (MkC s) = rep2 conTName [s]
2252
2253 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2254 -- Note: not Core Int; it's easier to be direct here
2255 repTupleTyCon i = do dflags <- getDynFlags
2256 rep2 tupleTName [mkIntExprInt dflags i]
2257
2258 repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2259 -- Note: not Core Int; it's easier to be direct here
2260 repUnboxedTupleTyCon i = do dflags <- getDynFlags
2261 rep2 unboxedTupleTName [mkIntExprInt dflags i]
2262
2263 repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
2264 -- Note: not Core TH.SumArity; it's easier to be direct here
2265 repUnboxedSumTyCon arity = do dflags <- getDynFlags
2266 rep2 unboxedSumTName [mkIntExprInt dflags arity]
2267
2268 repArrowTyCon :: DsM (Core TH.TypeQ)
2269 repArrowTyCon = rep2 arrowTName []
2270
2271 repListTyCon :: DsM (Core TH.TypeQ)
2272 repListTyCon = rep2 listTName []
2273
2274 repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
2275 repPromotedDataCon (MkC s) = rep2 promotedTName [s]
2276
2277 repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
2278 repPromotedTupleTyCon i = do dflags <- getDynFlags
2279 rep2 promotedTupleTName [mkIntExprInt dflags i]
2280
2281 repPromotedNilTyCon :: DsM (Core TH.TypeQ)
2282 repPromotedNilTyCon = rep2 promotedNilTName []
2283
2284 repPromotedConsTyCon :: DsM (Core TH.TypeQ)
2285 repPromotedConsTyCon = rep2 promotedConsTName []
2286
2287 ------------ TyVarBndrs -------------------
2288
2289 repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
2290 repPlainTV (MkC nm) = rep2 plainTVName [nm]
2291
2292 repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
2293 repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
2294
2295 ----------------------------------------------------------
2296 -- Type family result signature
2297
2298 repNoSig :: DsM (Core TH.FamilyResultSigQ)
2299 repNoSig = rep2 noSigName []
2300
2301 repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
2302 repKindSig (MkC ki) = rep2 kindSigName [ki]
2303
2304 repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
2305 repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
2306
2307 ----------------------------------------------------------
2308 -- Literals
2309
2310 repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
2311 repLiteral (HsStringPrim _ bs)
2312 = do dflags <- getDynFlags
2313 word8_ty <- lookupType word8TyConName
2314 let w8s = unpack bs
2315 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
2316 [mkWordLit dflags (toInteger w8)]) w8s
2317 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
2318 repLiteral lit
2319 = do lit' <- case lit of
2320 HsIntPrim _ i -> mk_integer i
2321 HsWordPrim _ w -> mk_integer w
2322 HsInt _ i -> mk_integer (il_value i)
2323 HsFloatPrim _ r -> mk_rational r
2324 HsDoublePrim _ r -> mk_rational r
2325 HsCharPrim _ c -> mk_char c
2326 _ -> return lit
2327 lit_expr <- dsLit lit'
2328 case mb_lit_name of
2329 Just lit_name -> rep2 lit_name [lit_expr]
2330 Nothing -> notHandled "Exotic literal" (ppr lit)
2331 where
2332 mb_lit_name = case lit of
2333 HsInteger _ _ _ -> Just integerLName
2334 HsInt _ _ -> Just integerLName
2335 HsIntPrim _ _ -> Just intPrimLName
2336 HsWordPrim _ _ -> Just wordPrimLName
2337 HsFloatPrim _ _ -> Just floatPrimLName
2338 HsDoublePrim _ _ -> Just doublePrimLName
2339 HsChar _ _ -> Just charLName
2340 HsCharPrim _ _ -> Just charPrimLName
2341 HsString _ _ -> Just stringLName
2342 HsRat _ _ _ -> Just rationalLName
2343 _ -> Nothing
2344
2345 mk_integer :: Integer -> DsM (HsLit GhcRn)
2346 mk_integer i = do integer_ty <- lookupType integerTyConName
2347 return $ HsInteger noSourceText i integer_ty
2348
2349 mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
2350 mk_rational r = do rat_ty <- lookupType rationalTyConName
2351 return $ HsRat def r rat_ty
2352 mk_string :: FastString -> DsM (HsLit GhcRn)
2353 mk_string s = return $ HsString noSourceText s
2354
2355 mk_char :: Char -> DsM (HsLit GhcRn)
2356 mk_char c = return $ HsChar noSourceText c
2357
2358 repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
2359 repOverloadedLiteral (OverLit { ol_val = val})
2360 = do { lit <- mk_lit val; repLiteral lit }
2361 -- The type Rational will be in the environment, because
2362 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
2363 -- and rationalL is sucked in when any TH stuff is used
2364
2365 mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
2366 mk_lit (HsIntegral i) = mk_integer (il_value i)
2367 mk_lit (HsFractional f) = mk_rational f
2368 mk_lit (HsIsString _ s) = mk_string s
2369
2370 repNameS :: Core String -> DsM (Core TH.Name)
2371 repNameS (MkC name) = rep2 mkNameSName [name]
2372
2373 --------------- Miscellaneous -------------------
2374
2375 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
2376 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
2377
2378 repBindQ :: Type -> Type -- a and b
2379 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
2380 repBindQ ty_a ty_b (MkC x) (MkC y)
2381 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
2382
2383 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
2384 repSequenceQ ty_a (MkC list)
2385 = rep2 sequenceQName [Type ty_a, list]
2386
2387 repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
2388 repUnboundVar (MkC name) = rep2 unboundVarEName [name]
2389
2390 repOverLabel :: FastString -> DsM (Core TH.ExpQ)
2391 repOverLabel fs = do
2392 (MkC s) <- coreStringLit $ unpackFS fs
2393 rep2 labelEName [s]
2394
2395
2396 ------------ Lists -------------------
2397 -- turn a list of patterns into a single pattern matching a list
2398
2399 repList :: Name -> (a -> DsM (Core b))
2400 -> [a] -> DsM (Core [b])
2401 repList tc_name f args
2402 = do { args1 <- mapM f args
2403 ; coreList tc_name args1 }
2404
2405 coreList :: Name -- Of the TyCon of the element type
2406 -> [Core a] -> DsM (Core [a])
2407 coreList tc_name es
2408 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
2409
2410 coreList' :: Type -- The element type
2411 -> [Core a] -> Core [a]
2412 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
2413
2414 nonEmptyCoreList :: [Core a] -> Core [a]
2415 -- The list must be non-empty so we can get the element type
2416 -- Otherwise use coreList
2417 nonEmptyCoreList [] = panic "coreList: empty argument"
2418 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
2419
2420 coreStringLit :: String -> DsM (Core String)
2421 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
2422
2423 ------------------- Maybe ------------------
2424
2425 -- | Construct Core expression for Nothing of a given type name
2426 coreNothing :: Name -- ^ Name of the TyCon of the element type
2427 -> DsM (Core (Maybe a))
2428 coreNothing tc_name =
2429 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
2430
2431 -- | Construct Core expression for Nothing of a given type
2432 coreNothing' :: Type -- ^ The element type
2433 -> Core (Maybe a)
2434 coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
2435
2436 -- | Store given Core expression in a Just of a given type name
2437 coreJust :: Name -- ^ Name of the TyCon of the element type
2438 -> Core a -> DsM (Core (Maybe a))
2439 coreJust tc_name es
2440 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
2441
2442 -- | Store given Core expression in a Just of a given type
2443 coreJust' :: Type -- ^ The element type
2444 -> Core a -> Core (Maybe a)
2445 coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
2446
2447 ------------ Literals & Variables -------------------
2448
2449 coreIntLit :: Int -> DsM (Core Int)
2450 coreIntLit i = do dflags <- getDynFlags
2451 return (MkC (mkIntExprInt dflags i))
2452
2453 coreVar :: Id -> Core TH.Name -- The Id has type Name
2454 coreVar id = MkC (Var id)
2455
2456 ----------------- Failure -----------------------
2457 notHandledL :: SrcSpan -> String -> SDoc -> DsM a
2458 notHandledL loc what doc
2459 | isGoodSrcSpan loc
2460 = putSrcSpanDs loc $ notHandled what doc
2461 | otherwise
2462 = notHandled what doc
2463
2464 notHandled :: String -> SDoc -> DsM a
2465 notHandled what doc = failWithDs msg
2466 where
2467 msg = hang (text what <+> text "not (yet) handled by Template Haskell")
2468 2 doc