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