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