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