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