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