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