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