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