1 -----------------------------------------------------------------------------
2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
4 -- input HsExpr. We do this in the DsM monad, which supplies access to
5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
7 -- It also defines a bunch of knownKeyNames, in the same way as is done
8 -- in prelude/PrelNames. It's much more convenient to do it here, becuase
9 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
10 -- a Royal Pain (triggers other recompilation).
11 -----------------------------------------------------------------------------
14 module DsMeta( dsBracket, dsReify,
15 templateHaskellNames, qTyConName,
16 liftName, exprTyConName, declTyConName, typeTyConName,
17 decTyConName, typTyConName ) where
19 #include "HsVersions.h"
21 import {-# SOURCE #-} DsExpr ( dsExpr )
23 import MatchLit ( dsLit )
24 import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
27 import qualified Language.Haskell.THSyntax as M
29 import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
30 Match(..), GRHSs(..), GRHS(..), HsBracket(..),
31 HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
32 HsBinds(..), MonoBinds(..), HsConDetails(..),
33 TyClDecl(..), HsGroup(..),
34 HsReify(..), ReifyFlavour(..),
35 HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
36 HsTyVarBndr(..), Sig(..), ForeignDecl(..),
37 InstDecl(..), ConDecl(..), BangType(..),
38 PendingSplice, splitHsInstDeclTy,
39 placeHolderType, tyClDeclNames,
40 collectHsBinders, collectPatBinders, collectPatsBinders,
41 hsTyVarName, hsConArgs, getBangType,
45 import PrelNames ( mETA_META_Name, rationalTyConName, negateName,
47 import MkIface ( ifaceTyThing )
48 import Name ( Name, nameOccName, nameModule, getSrcLoc )
49 import OccName ( isDataOcc, isTvOcc, occNameUserString )
50 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
51 -- we do this by removing varName from the import of OccName above, making
52 -- a qualified instance of OccName and using OccNameAlias.varName where varName
53 -- ws previously used in this file.
54 import qualified OccName( varName, tcName )
56 import Module ( Module, mkThPkgModule, moduleUserString )
57 import Id ( Id, idType )
58 import Name ( mkKnownKeyExternalName )
59 import OccName ( mkOccFS )
62 import Type ( Type, mkGenTyConApp )
63 import TcType ( TyThing(..), tcTyConAppArgs )
64 import TyCon ( DataConDetails(..) )
65 import TysWiredIn ( stringTy )
67 import CoreUtils ( exprType )
68 import SrcLoc ( noSrcLoc )
69 import Maybes ( orElse )
70 import Maybe ( catMaybes, fromMaybe )
71 import Panic ( panic )
72 import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
73 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
74 import SrcLoc ( SrcLoc )
77 import FastString ( mkFastString )
79 import Monad ( zipWithM )
80 import List ( sortBy )
82 -----------------------------------------------------------------------------
83 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
84 -- Returns a CoreExpr of type M.ExpQ
85 -- The quoted thing is parameterised over Name, even though it has
86 -- been type checked. We don't want all those type decorations!
88 dsBracket brack splices
89 = dsExtendMetaEnv new_bit (do_brack brack)
91 new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
93 do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 }
94 do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 }
95 do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 }
96 do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
98 -----------------------------------------------------------------------------
99 dsReify :: HsReify Id -> DsM CoreExpr
100 -- Returns a CoreExpr of type reifyType --> M.TypQ
101 -- reifyDecl --> M.DecQ
102 -- reifyFixty --> Q M.Fix
103 dsReify (ReifyOut ReifyType name)
104 = do { thing <- dsLookupGlobal name ;
105 -- By deferring the lookup until now (rather than doing it
106 -- in the type checker) we ensure that all zonking has
109 AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
111 other -> pprPanic "dsReify: reifyType" (ppr name)
114 dsReify r@(ReifyOut ReifyDecl name)
115 = do { thing <- dsLookupGlobal name ;
116 mb_d <- repTyClD (ifaceTyThing thing) ;
118 Just (MkC d) -> return d
119 Nothing -> pprPanic "dsReify" (ppr r)
122 {- -------------- Examples --------------------
126 gensym (unpackString "x"#) `bindQ` \ x1::String ->
127 lam (pvar x1) (var x1)
130 [| \x -> $(f [| x |]) |]
132 gensym (unpackString "x"#) `bindQ` \ x1::String ->
133 lam (pvar x1) (f (var x1))
137 -------------------------------------------------------
139 -------------------------------------------------------
141 repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
143 = do { let { bndrs = groupBinders group } ;
144 ss <- mkGenSyms bndrs ;
146 -- Bind all the names mainly to avoid repeated use of explicit strings.
148 -- do { t :: String <- genSym "T" ;
149 -- return (Data t [] ...more t's... }
150 -- The other important reason is that the output must mention
151 -- only "T", not "Foo:T" where Foo is the current module
154 decls <- addBinds ss (do {
155 val_ds <- rep_binds' (hs_valds group) ;
156 tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
157 inst_ds <- mapM repInstD' (hs_instds group) ;
159 return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
161 decl_ty <- lookupType declTyConName ;
162 let { core_list = coreList' decl_ty decls } ;
164 dec_ty <- lookupType decTyConName ;
165 q_decs <- repSequenceQ dec_ty core_list ;
167 wrapNongenSyms ss q_decs
168 -- Do *not* gensym top-level binders
171 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
172 hs_fords = foreign_decls })
173 -- Collect the binders of a Group
174 = collectHsBinders val_decls ++
175 [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
176 [n | ForeignImport n _ _ _ _ <- foreign_decls]
179 {- Note [Binders and occurrences]
180 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
181 When we desugar [d| data T = MkT |]
183 Data "T" [] [Con "MkT" []] []
185 Data "Foo:T" [] [Con "Foo:MkT" []] []
186 That is, the new data decl should fit into whatever new module it is
187 asked to fit in. We do *not* clone, though; no need for this:
194 then we must desugar to
195 foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
197 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
198 but in dsReify we do not. And we use lookupOcc, rather than lookupBinder
199 in repTyClD and repC.
203 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
204 repTyClD decl = do x <- repTyClD' decl
207 repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))
209 repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt,
210 tcdName = tc, tcdTyVars = tvs,
211 tcdCons = DataCons cons, tcdDerivs = mb_derivs,
213 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
214 dec <- addTyVarBinds tvs $ \bndrs -> do {
215 cxt1 <- repContext cxt ;
216 cons1 <- mapM repC cons ;
217 cons2 <- coreList consTyConName cons1 ;
218 derivs1 <- repDerivs mb_derivs ;
219 repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
220 return $ Just (loc, dec) }
222 repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt,
223 tcdName = tc, tcdTyVars = tvs,
224 tcdCons = DataCons [con], tcdDerivs = mb_derivs,
226 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
227 dec <- addTyVarBinds tvs $ \bndrs -> do {
228 cxt1 <- repContext cxt ;
230 derivs1 <- repDerivs mb_derivs ;
231 repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
232 return $ Just (loc, dec) }
234 repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
236 = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences]
237 dec <- addTyVarBinds tvs $ \bndrs -> do {
239 repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
240 return (Just (loc, dec)) }
242 repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls,
244 tcdFDs = [], -- We don't understand functional dependencies
245 tcdSigs = sigs, tcdMeths = mb_meth_binds,
247 = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences]
248 dec <- addTyVarBinds tvs $ \bndrs -> do {
249 cxt1 <- repContext cxt ;
250 sigs1 <- rep_sigs sigs ;
251 binds1 <- rep_monobind meth_binds ;
252 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
253 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
254 return $ Just (loc, dec) }
256 -- If the user quotes a class decl, it'll have default-method
257 -- bindings; but if we (reifyDecl C) where C is a class, we
258 -- won't be given the default methods (a definite infelicity).
259 meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
262 repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
266 msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
268 repInstD' (InstDecl ty binds _ _ loc)
269 -- Ignore user pragmas for now
270 = do { cxt1 <- repContext cxt ;
271 inst_ty1 <- repPred (HsClassP cls tys) ;
272 binds1 <- rep_monobind binds ;
273 decls1 <- coreList declTyConName binds1 ;
274 i <- repInst cxt1 inst_ty1 decls1;
277 (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
280 -------------------------------------------------------
282 -------------------------------------------------------
284 repC :: ConDecl Name -> DsM (Core M.ConQ)
285 repC (ConDecl con [] [] details loc)
286 = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences]
287 repConstr con1 details }
289 repBangTy :: BangType Name -> DsM (Core (M.StrictTypQ))
290 repBangTy (BangType str ty) = do MkC s <- rep2 strName []
292 rep2 strictTypeName [s, t]
293 where strName = case str of
294 NotMarkedStrict -> nonstrictName
297 -------------------------------------------------------
299 -------------------------------------------------------
301 repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
302 repDerivs Nothing = return (coreList' stringTy [])
303 repDerivs (Just ctxt)
304 = do { strs <- mapM rep_deriv ctxt ;
305 return (coreList' stringTy strs) }
307 rep_deriv :: HsPred Name -> DsM (Core String)
308 -- Deriving clauses must have the simple H98 form
309 rep_deriv (HsClassP cls []) = lookupOcc cls
310 rep_deriv other = panic "rep_deriv"
313 -------------------------------------------------------
314 -- Signatures in a class decl, or a group of bindings
315 -------------------------------------------------------
317 rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
318 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
319 return $ de_loc $ sort_by_loc locs_cores
321 rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
322 -- We silently ignore ones we don't recognise
323 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
324 return (concat sigs1) }
326 rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
328 -- Empty => Too hard, signature ignored
329 rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc
330 rep_sig (Sig nm ty loc) = rep_proto nm ty loc
331 rep_sig other = return []
333 rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
334 rep_proto nm ty loc = do { nm1 <- lookupOcc nm ;
336 sig <- repProto nm1 ty1 ;
337 return [(loc, sig)] }
340 -------------------------------------------------------
342 -------------------------------------------------------
344 -- gensym a list of type variables and enter them into the meta environment;
345 -- the computations passed as the second argument is executed in that extended
346 -- meta environment and gets the *new* names on Core-level as an argument
348 addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added
349 -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
350 -> DsM (Core (M.Q a))
351 addTyVarBinds tvs m =
353 let names = map hsTyVarName tvs
354 freshNames <- mkGenSyms names
355 term <- addBinds freshNames $ do
356 bndrs <- mapM lookupBinder names
358 wrapGenSyns freshNames term
360 -- represent a type context
362 repContext :: HsContext Name -> DsM (Core M.CxtQ)
364 preds <- mapM repPred ctxt
365 predList <- coreList typeTyConName preds
368 -- represent a type predicate
370 repPred :: HsPred Name -> DsM (Core M.TypQ)
371 repPred (HsClassP cls tys) = do
372 tcon <- repTy (HsTyVar cls)
375 repPred (HsIParam _ _) =
376 panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
378 -- yield the representation of a list of types
380 repTys :: [HsType Name] -> DsM [Core M.TypQ]
381 repTys tys = mapM repTy tys
385 repTy :: HsType Name -> DsM (Core M.TypQ)
386 repTy (HsForAllTy bndrs ctxt ty) =
387 addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
388 ctxt' <- repContext ctxt
390 repTForall (coreList' stringTy bndrs') ctxt' ty'
393 | isTvOcc (nameOccName n) = do
394 tv1 <- lookupBinder n
399 repTy (HsAppTy f a) = do
403 repTy (HsFunTy f a) = do
406 tcon <- repArrowTyCon
407 repTapps tcon [f1, a1]
408 repTy (HsListTy t) = do
412 repTy (HsPArrTy t) = do
414 tcon <- repTy (HsTyVar parrTyConName)
416 repTy (HsTupleTy tc tys) = do
418 tcon <- repTupleTyCon (length tys)
420 repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2)
421 repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1)
423 repTy (HsParTy t) = repTy t
425 panic "DsMeta.repTy: Can't represent number types (for generics)"
426 repTy (HsPredTy pred) = repPred pred
427 repTy (HsKindSig ty kind) =
428 panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
431 -----------------------------------------------------------------------------
433 -----------------------------------------------------------------------------
435 repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
436 repEs es = do { es' <- mapM repE es ;
437 coreList exprTyConName es' }
439 -- FIXME: some of these panics should be converted into proper error messages
440 -- unless we can make sure that constructs, which are plainly not
441 -- supported in TH already lead to error messages at an earlier stage
442 repE :: HsExpr Name -> DsM (Core M.ExpQ)
444 do { mb_val <- dsLookupMetaEnv x
446 Nothing -> do { str <- globalVar x
447 ; repVarOrCon x str }
448 Just (Bound y) -> repVarOrCon x (coreVar y)
449 Just (Splice e) -> do { e' <- dsExpr e
450 ; return (MkC e') } }
451 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
453 -- Remember, we're desugaring renamer output here, so
454 -- HsOverlit can definitely occur
455 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
456 repE (HsLit l) = do { a <- repLiteral l; repLit a }
457 repE (HsLam m) = repLambda m
458 repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b}
460 repE (OpApp e1 op fix e2) =
461 do { arg1 <- repE e1;
464 repInfixApp arg1 the_op arg2 }
465 repE (NegApp x nm) = do
467 negateVar <- lookupOcc negateName >>= repVar
469 repE (HsPar x) = repE x
470 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
471 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
472 repE (HsCase e ms loc) = do { arg <- repE e
473 ; ms2 <- mapM repMatchTup ms
474 ; repCaseE arg (nonEmptyCoreList ms2) }
475 repE (HsIf x y z loc) = do
480 repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
481 ; e2 <- addBinds ss (repE e)
484 -- FIXME: I haven't got the types here right yet
485 repE (HsDo DoExpr sts _ ty loc)
486 = do { (ss,zs) <- repSts sts;
487 e <- repDoE (nonEmptyCoreList zs);
489 repE (HsDo ListComp sts _ ty loc)
490 = do { (ss,zs) <- repSts sts;
491 e <- repComp (nonEmptyCoreList zs);
493 repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
494 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs }
495 repE (ExplicitPArr ty es) =
496 panic "DsMeta.repE: No explicit parallel arrays yet"
497 repE (ExplicitTuple es boxed)
498 | isBoxed boxed = do { xs <- repEs es; repTup xs }
499 | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples"
500 repE (RecordCon c flds)
501 = do { x <- lookupOcc c;
502 fs <- repFields flds;
504 repE (RecordUpd e flds)
506 fs <- repFields flds;
509 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
510 repE (ArithSeqIn aseq) =
512 From e -> do { ds1 <- repE e; repFrom ds1 }
521 FromThenTo e1 e2 e3 -> do
525 repFromThenTo ds1 ds2 ds3
526 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
527 repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
528 repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
529 repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
530 repE (HsBracketOut _ _) =
531 panic "DsMeta.repE: Can't represent Oxford brackets"
532 repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n
534 Just (Splice e) -> do { e' <- dsExpr e
536 other -> pprPanic "HsSplice" (ppr n) }
537 repE (HsReify _) = panic "DsMeta.repE: Can't represent reification"
539 pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
541 -----------------------------------------------------------------------------
542 -- Building representations of auxillary structures like Match, Clause, Stmt,
544 repMatchTup :: Match Name -> DsM (Core M.MatchQ)
545 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
546 do { ss1 <- mkGenSyms (collectPatBinders p)
547 ; addBinds ss1 $ do {
549 ; (ss2,ds) <- repBinds wheres
550 ; addBinds ss2 $ do {
551 ; gs <- repGuards guards
552 ; match <- repMatch p1 gs ds
553 ; wrapGenSyns (ss1++ss2) match }}}
555 repClauseTup :: Match Name -> DsM (Core M.ClauseQ)
556 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
557 do { ss1 <- mkGenSyms (collectPatsBinders ps)
558 ; addBinds ss1 $ do {
560 ; (ss2,ds) <- repBinds wheres
561 ; addBinds ss2 $ do {
562 gs <- repGuards guards
563 ; clause <- repClause ps1 gs ds
564 ; wrapGenSyns (ss1++ss2) clause }}}
566 repGuards :: [GRHS Name] -> DsM (Core M.RHSQ)
567 repGuards [GRHS [ResultStmt e loc] loc2]
568 = do {a <- repE e; repNormal a }
570 = do { zs <- mapM process other;
571 repGuarded (nonEmptyCoreList (map corePair zs)) }
573 process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
574 = do { x <- repE e1; y <- repE e2; return (x, y) }
575 process other = panic "Non Haskell 98 guarded body"
577 repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
579 fnames <- mapM lookupOcc (map fst flds)
580 es <- mapM repE (map snd flds)
581 fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
582 coreList fieldTyConName fs
585 -----------------------------------------------------------------------------
586 -- Representing Stmt's is tricky, especially if bound variables
587 -- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]
588 -- First gensym new names for every variable in any of the patterns.
589 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
590 -- if variables didn't shaddow, the static gensym wouldn't be necessary
591 -- and we could reuse the original names (x and x).
593 -- do { x'1 <- gensym "x"
594 -- ; x'2 <- gensym "x"
595 -- ; doE [ BindSt (pvar x'1) [| f 1 |]
596 -- , BindSt (pvar x'2) [| f x |]
597 -- , NoBindSt [| g x |]
601 -- The strategy is to translate a whole list of do-bindings by building a
602 -- bigger environment, and a bigger set of meta bindings
603 -- (like: x'1 <- gensym "x" ) and then combining these with the translations
604 -- of the expressions within the Do
606 -----------------------------------------------------------------------------
607 -- The helper function repSts computes the translation of each sub expression
608 -- and a bunch of prefix bindings denoting the dynamic renaming.
610 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
611 repSts [ResultStmt e loc] =
613 ; e1 <- repNoBindSt a
614 ; return ([], [e1]) }
615 repSts (BindStmt p e loc : ss) =
617 ; ss1 <- mkGenSyms (collectPatBinders p)
618 ; addBinds ss1 $ do {
620 ; (ss2,zs) <- repSts ss
621 ; z <- repBindSt p1 e2
622 ; return (ss1++ss2, z : zs) }}
623 repSts (LetStmt bs : ss) =
624 do { (ss1,ds) <- repBinds bs
626 ; (ss2,zs) <- addBinds ss1 (repSts ss)
627 ; return (ss1++ss2, z : zs) }
628 repSts (ExprStmt e ty loc : ss) =
630 ; z <- repNoBindSt e2
631 ; (ss2,zs) <- repSts ss
632 ; return (ss2, z : zs) }
633 repSts other = panic "Exotic Stmt in meta brackets"
636 -----------------------------------------------------------
638 -----------------------------------------------------------
640 repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ])
642 = do { let { bndrs = collectHsBinders decs } ;
643 ss <- mkGenSyms bndrs ;
644 core <- addBinds ss (rep_binds decs) ;
645 core_list <- coreList declTyConName core ;
646 return (ss, core_list) }
648 rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
649 rep_binds binds = do locs_cores <- rep_binds' binds
650 return $ de_loc $ sort_by_loc locs_cores
652 rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
653 rep_binds' EmptyBinds = return []
654 rep_binds' (ThenBinds x y)
655 = do { core1 <- rep_binds' x
656 ; core2 <- rep_binds' y
657 ; return (core1 ++ core2) }
658 rep_binds' (MonoBind bs sigs _)
659 = do { core1 <- rep_monobind' bs
660 ; core2 <- rep_sigs' sigs
661 ; return (core1 ++ core2) }
662 rep_binds' (IPBinds _ _)
663 = panic "DsMeta:repBinds: can't do implicit parameters"
665 rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
666 rep_monobind binds = do locs_cores <- rep_monobind' binds
667 return $ de_loc $ sort_by_loc locs_cores
669 rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
670 rep_monobind' EmptyMonoBinds = return []
671 rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x;
672 y1 <- rep_monobind' y;
675 -- Note GHC treats declarations of a variable (not a pattern)
676 -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
677 -- with an empty list of patterns
678 rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
679 = do { (ss,wherecore) <- repBinds wheres
680 ; guardcore <- addBinds ss (repGuards guards)
681 ; fn' <- lookupBinder fn
683 ; ans <- repVal p guardcore wherecore
684 ; return [(loc, ans)] }
686 rep_monobind' (FunMonoBind fn infx ms loc)
687 = do { ms1 <- mapM repClauseTup ms
688 ; fn' <- lookupBinder fn
689 ; ans <- repFun fn' (nonEmptyCoreList ms1)
690 ; return [(loc, ans)] }
692 rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
693 = do { patcore <- repP pat
694 ; (ss,wherecore) <- repBinds wheres
695 ; guardcore <- addBinds ss (repGuards guards)
696 ; ans <- repVal patcore guardcore wherecore
697 ; return [(loc, ans)] }
699 rep_monobind' (VarMonoBind v e)
700 = do { v' <- lookupBinder v
703 ; patcore <- repPvar v'
704 ; empty_decls <- coreList declTyConName []
705 ; ans <- repVal patcore x empty_decls
706 ; return [(getSrcLoc v, ans)] }
708 -----------------------------------------------------------------------------
709 -- Since everything in a MonoBind is mutually recursive we need rename all
710 -- all the variables simultaneously. For example:
711 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
712 -- do { f'1 <- gensym "f"
713 -- ; g'2 <- gensym "g"
714 -- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
715 -- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
717 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
718 -- environment ( f |-> f'1 ) from each binding, and then unioning them
719 -- together. As we do this we collect GenSymBinds's which represent the renamed
720 -- variables bound by the Bindings. In order not to lose track of these
721 -- representations we build a shadow datatype MB with the same structure as
722 -- MonoBinds, but which has slots for the representations
725 -----------------------------------------------------------------------------
726 -- GHC allows a more general form of lambda abstraction than specified
727 -- by Haskell 98. In particular it allows guarded lambda's like :
728 -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
729 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
730 -- (\ p1 .. pn -> exp) by causing an error.
732 repLambda :: Match Name -> DsM (Core M.ExpQ)
733 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
735 = do { let bndrs = collectPatsBinders ps ;
736 ; ss <- mkGenSyms bndrs
737 ; lam <- addBinds ss (
738 do { xs <- repPs ps; body <- repE e; repLam xs body })
739 ; wrapGenSyns ss lam }
741 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
744 -----------------------------------------------------------------------------
746 -- repP deals with patterns. It assumes that we have already
747 -- walked over the pattern(s) once to collect the binders, and
748 -- have extended the environment. So every pattern-bound
749 -- variable should already appear in the environment.
751 -- Process a list of patterns
752 repPs :: [Pat Name] -> DsM (Core [M.Pat])
753 repPs ps = do { ps' <- mapM repP ps ;
754 coreList pattTyConName ps' }
756 repP :: Pat Name -> DsM (Core M.Pat)
757 repP (WildPat _) = repPwild
758 repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
759 repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
760 repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 }
761 repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
762 repP (ParPat p) = repP p
763 repP (ListPat ps _) = repListPat ps
764 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
765 repP (ConPatIn dc details)
766 = do { con_str <- lookupOcc dc
768 PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs }
769 RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
770 ; ps <- sequence $ map repP (map snd pairs)
771 ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
772 ; fps' <- coreList fieldPTyConName fps
773 ; repPrec con_str fps' }
774 InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
776 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
777 repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
778 repP other = panic "Exotic pattern inside meta brackets"
780 repListPat :: [Pat Name] -> DsM (Core M.Pat)
781 repListPat [] = do { nil_con <- coreStringLit "[]"
782 ; nil_args <- coreList pattTyConName []
783 ; repPcon nil_con nil_args }
784 repListPat (p:ps) = do { p2 <- repP p
785 ; ps2 <- repListPat ps
786 ; cons_con <- coreStringLit ":"
787 ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
790 ----------------------------------------------------------
791 -- Declaration ordering helpers
793 sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
794 sort_by_loc xs = sortBy comp xs
795 where comp x y = compare (fst x) (fst y)
797 de_loc :: [(SrcLoc, a)] -> [a]
800 ----------------------------------------------------------
801 -- The meta-environment
803 -- A name/identifier association for fresh names of locally bound entities
805 type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id
806 -- I.e. (x, x_id) means
807 -- let x_id = gensym "x" in ...
809 -- Generate a fresh name for a locally bound entity
811 mkGenSym :: Name -> DsM GenSymBind
812 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
814 -- Ditto for a list of names
816 mkGenSyms :: [Name] -> DsM [GenSymBind]
817 mkGenSyms ns = mapM mkGenSym ns
819 -- Add a list of fresh names for locally bound entities to the meta
820 -- environment (which is part of the state carried around by the desugarer
823 addBinds :: [GenSymBind] -> DsM a -> DsM a
824 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
826 -- Look up a locally bound name
828 lookupBinder :: Name -> DsM (Core String)
830 = do { mb_val <- dsLookupMetaEnv n;
832 Just (Bound x) -> return (coreVar x)
833 other -> pprPanic "Failed binder lookup:" (ppr n) }
835 -- Look up a name that is either locally bound or a global name
837 -- * If it is a global name, generate the "original name" representation (ie,
838 -- the <module>:<name> form) for the associated entity
840 lookupOcc :: Name -> DsM (Core String)
841 -- Lookup an occurrence; it can't be a splice.
842 -- Use the in-scope bindings if they exist
844 = do { mb_val <- dsLookupMetaEnv n ;
846 Nothing -> globalVar n
847 Just (Bound x) -> return (coreVar x)
848 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
851 globalVar :: Name -> DsM (Core String)
852 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
854 name_mod = moduleUserString (nameModule n)
855 name_occ = occNameUserString (nameOccName n)
857 localVar :: Name -> DsM (Core String)
858 localVar n = coreStringLit (occNameUserString (nameOccName n))
860 lookupType :: Name -- Name of type constructor (e.g. M.ExpQ)
861 -> DsM Type -- The type
862 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
863 return (mkGenTyConApp tc []) }
865 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
866 -- --> bindQ (gensym nm1) (\ id1 ->
867 -- bindQ (gensym nm2 (\ id2 ->
870 wrapGenSyns :: [GenSymBind]
871 -> Core (M.Q a) -> DsM (Core (M.Q a))
872 wrapGenSyns binds body@(MkC b)
875 [elt_ty] = tcTyConAppArgs (exprType b)
876 -- b :: Q a, so we can get the type 'a' by looking at the
877 -- argument type. NB: this relies on Q being a data/newtype,
878 -- not a type synonym
881 go ((name,id) : binds)
882 = do { MkC body' <- go binds
883 ; lit_str <- localVar name
884 ; gensym_app <- repGensym lit_str
885 ; repBindQ stringTy elt_ty
886 gensym_app (MkC (Lam id body')) }
888 -- Just like wrapGenSym, but don't actually do the gensym
889 -- Instead use the existing name
890 -- Only used for [Decl]
891 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
892 wrapNongenSyms binds (MkC body)
893 = do { binds' <- mapM do_one binds ;
894 return (MkC (mkLets binds' body)) }
897 = do { MkC lit_str <- localVar name -- No gensym
898 ; return (NonRec id lit_str) }
900 void = placeHolderType
902 string :: String -> HsExpr Id
903 string s = HsLit (HsString (mkFastString s))
906 -- %*********************************************************************
910 -- %*********************************************************************
912 -----------------------------------------------------------------------------
913 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
914 -- we invent a new datatype which uses phantom types.
916 newtype Core a = MkC CoreExpr
919 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
920 rep2 n xs = do { id <- dsLookupGlobalId n
921 ; return (MkC (foldl App (Var id) xs)) }
923 -- Then we make "repConstructors" which use the phantom types for each of the
924 -- smart constructors of the Meta.Meta datatypes.
927 -- %*********************************************************************
929 -- The 'smart constructors'
931 -- %*********************************************************************
933 --------------- Patterns -----------------
934 repPlit :: Core M.Lit -> DsM (Core M.Pat)
935 repPlit (MkC l) = rep2 plitName [l]
937 repPvar :: Core String -> DsM (Core M.Pat)
938 repPvar (MkC s) = rep2 pvarName [s]
940 repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
941 repPtup (MkC ps) = rep2 ptupName [ps]
943 repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
944 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
946 repPrec :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
947 repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
949 repPtilde :: Core M.Pat -> DsM (Core M.Pat)
950 repPtilde (MkC p) = rep2 ptildeName [p]
952 repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
953 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
955 repPwild :: DsM (Core M.Pat)
956 repPwild = rep2 pwildName []
958 --------------- Expressions -----------------
959 repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ)
960 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
961 | otherwise = repVar str
963 repVar :: Core String -> DsM (Core M.ExpQ)
964 repVar (MkC s) = rep2 varName [s]
966 repCon :: Core String -> DsM (Core M.ExpQ)
967 repCon (MkC s) = rep2 conName [s]
969 repLit :: Core M.Lit -> DsM (Core M.ExpQ)
970 repLit (MkC c) = rep2 litName [c]
972 repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
973 repApp (MkC x) (MkC y) = rep2 appName [x,y]
975 repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ)
976 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
978 repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
979 repTup (MkC es) = rep2 tupName [es]
981 repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
982 repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z]
984 repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ)
985 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
987 repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ)
988 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
990 repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
991 repDoE (MkC ss) = rep2 doEName [ss]
993 repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ)
994 repComp (MkC ss) = rep2 compName [ss]
996 repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ)
997 repListExp (MkC es) = rep2 listExpName [es]
999 repSigExp :: Core M.ExpQ -> Core M.TypQ -> DsM (Core M.ExpQ)
1000 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
1002 repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ)
1003 repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
1005 repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ)
1006 repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
1008 repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1009 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1011 repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1012 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1014 repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1015 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1017 ------------ Right hand sides (guarded expressions) ----
1018 repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.RHSQ)
1019 repGuarded (MkC pairs) = rep2 guardedName [pairs]
1021 repNormal :: Core M.ExpQ -> DsM (Core M.RHSQ)
1022 repNormal (MkC e) = rep2 normalName [e]
1024 ------------- Stmts -------------------
1025 repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ)
1026 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
1028 repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ)
1029 repLetSt (MkC ds) = rep2 letStName [ds]
1031 repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ)
1032 repNoBindSt (MkC e) = rep2 noBindStName [e]
1034 -------------- DotDot (Arithmetic sequences) -----------
1035 repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ)
1036 repFrom (MkC x) = rep2 fromName [x]
1038 repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1039 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
1041 repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1042 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
1044 repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ)
1045 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
1047 ------------ Match and Clause Tuples -----------
1048 repMatch :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.MatchQ)
1049 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1051 repClause :: Core [M.Pat] -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ)
1052 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1054 -------------- Dec -----------------------------
1055 repVal :: Core M.Pat -> Core M.RHSQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1056 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
1058 repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ)
1059 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
1061 repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ)
1062 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1064 repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ)
1065 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1067 repTySyn :: Core String -> Core [String] -> Core M.TypQ -> DsM (Core M.DecQ)
1068 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1070 repInst :: Core M.CxtQ -> Core M.TypQ -> Core [M.DecQ] -> DsM (Core M.DecQ)
1071 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
1073 repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ)
1074 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
1076 repProto :: Core String -> Core M.TypQ -> DsM (Core M.DecQ)
1077 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
1079 repCtxt :: Core [M.TypQ] -> DsM (Core M.CxtQ)
1080 repCtxt (MkC tys) = rep2 ctxtName [tys]
1082 repConstr :: Core String -> HsConDetails Name (BangType Name)
1083 -> DsM (Core M.ConQ)
1084 repConstr con (PrefixCon ps)
1085 = do arg_tys <- mapM repBangTy ps
1086 arg_tys1 <- coreList strTypeTyConName arg_tys
1087 rep2 constrName [unC con, unC arg_tys1]
1088 repConstr con (RecCon ips)
1089 = do arg_vs <- mapM lookupOcc (map fst ips)
1090 arg_tys <- mapM repBangTy (map snd ips)
1091 arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1093 arg_vtys' <- coreList varStrTypeTyConName arg_vtys
1094 rep2 recConstrName [unC con, unC arg_vtys']
1095 repConstr con (InfixCon st1 st2)
1096 = do arg1 <- repBangTy st1
1097 arg2 <- repBangTy st2
1098 rep2 infixConstrName [unC arg1, unC con, unC arg2]
1100 ------------ Types -------------------
1102 repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypQ -> DsM (Core M.TypQ)
1103 repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty]
1105 repTvar :: Core String -> DsM (Core M.TypQ)
1106 repTvar (MkC s) = rep2 tvarName [s]
1108 repTapp :: Core M.TypQ -> Core M.TypQ -> DsM (Core M.TypQ)
1109 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
1111 repTapps :: Core M.TypQ -> [Core M.TypQ] -> DsM (Core M.TypQ)
1112 repTapps f [] = return f
1113 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1115 --------- Type constructors --------------
1117 repNamedTyCon :: Core String -> DsM (Core M.TypQ)
1118 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
1120 repTupleTyCon :: Int -> DsM (Core M.TypQ)
1121 -- Note: not Core Int; it's easier to be direct here
1122 repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)]
1124 repArrowTyCon :: DsM (Core M.TypQ)
1125 repArrowTyCon = rep2 arrowTyConName []
1127 repListTyCon :: DsM (Core M.TypQ)
1128 repListTyCon = rep2 listTyConName []
1131 ----------------------------------------------------------
1134 repLiteral :: HsLit -> DsM (Core M.Lit)
1136 = do lit' <- case lit of
1137 HsIntPrim i -> return $ HsInteger i
1138 HsInt i -> return $ HsInteger i
1139 HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName
1140 return $ HsRat r rat_ty
1141 HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName
1142 return $ HsRat r rat_ty
1144 lit_expr <- dsLit lit'
1145 rep2 lit_name [lit_expr]
1147 lit_name = case lit of
1148 HsInteger _ -> integerLName
1149 HsInt _ -> integerLName
1150 HsIntPrim _ -> intPrimLName
1151 HsFloatPrim _ -> floatPrimLName
1152 HsDoublePrim _ -> doublePrimLName
1153 HsChar _ -> charLName
1154 HsString _ -> stringLName
1155 HsRat _ _ -> rationalLName
1157 uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1160 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
1161 repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i)
1162 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
1163 repLiteral (HsRat f rat_ty) }
1164 -- The type Rational will be in the environment, becuase
1165 -- the smart constructor 'THSyntax.rationalL' uses it in its type,
1166 -- and rationalL is sucked in when any TH stuff is used
1168 --------------- Miscellaneous -------------------
1170 repLift :: Core e -> DsM (Core M.ExpQ)
1171 repLift (MkC x) = rep2 liftName [x]
1173 repGensym :: Core String -> DsM (Core (M.Q String))
1174 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
1176 repBindQ :: Type -> Type -- a and b
1177 -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
1178 repBindQ ty_a ty_b (MkC x) (MkC y)
1179 = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1181 repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a]))
1182 repSequenceQ ty_a (MkC list)
1183 = rep2 sequenceQName [Type ty_a, list]
1185 ------------ Lists and Tuples -------------------
1186 -- turn a list of patterns into a single pattern matching a list
1188 coreList :: Name -- Of the TyCon of the element type
1189 -> [Core a] -> DsM (Core [a])
1191 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1193 coreList' :: Type -- The element type
1194 -> [Core a] -> Core [a]
1195 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1197 nonEmptyCoreList :: [Core a] -> Core [a]
1198 -- The list must be non-empty so we can get the element type
1199 -- Otherwise use coreList
1200 nonEmptyCoreList [] = panic "coreList: empty argument"
1201 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1203 corePair :: (Core a, Core b) -> Core (a,b)
1204 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1206 coreStringLit :: String -> DsM (Core String)
1207 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
1209 coreVar :: Id -> Core String -- The Id has type String
1210 coreVar id = MkC (Var id)
1214 -- %************************************************************************
1216 -- The known-key names for Template Haskell
1218 -- %************************************************************************
1220 -- To add a name, do three things
1222 -- 1) Allocate a key
1224 -- 3) Add the name to knownKeyNames
1226 templateHaskellNames :: NameSet
1227 -- The names that are implicitly mentioned by ``bracket''
1228 -- Should stay in sync with the import list of DsMeta
1229 templateHaskellNames
1230 = mkNameSet [ intPrimLName, floatPrimLName, doublePrimLName,
1231 integerLName, charLName, stringLName, rationalLName,
1232 plitName, pvarName, ptupName,
1233 pconName, ptildeName, paspatName, pwildName,
1234 varName, conName, litName, appName, infixEName, lamName,
1235 tupName, doEName, compName,
1236 listExpName, sigExpName, condName, letEName, caseEName,
1237 infixAppName, sectionLName, sectionRName,
1238 guardedName, normalName,
1239 bindStName, letStName, noBindStName, parStName,
1240 fromName, fromThenName, fromToName, fromThenToName,
1241 funName, valName, liftName,
1242 gensymName, returnQName, bindQName, sequenceQName,
1243 matchName, clauseName, funName, valName, tySynDName, dataDName, newtypeDName, classDName,
1244 instName, protoName, tforallName, tvarName, tconName, tappName,
1245 arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
1246 ctxtName, constrName, recConstrName, infixConstrName,
1247 exprTyConName, declTyConName, pattTyConName, mtchTyConName,
1248 clseTyConName, stmtTyConName, consTyConName, typeTyConName,
1249 strTypeTyConName, varStrTypeTyConName,
1250 qTyConName, expTyConName, matTyConName, clsTyConName,
1251 decTyConName, typTyConName, strictTypeName, varStrictTypeName,
1252 recConName, recUpdName, precName,
1253 fieldName, fieldTyConName, fieldPName, fieldPTyConName,
1254 strictName, nonstrictName ]
1257 varQual = mk_known_key_name OccName.varName
1258 tcQual = mk_known_key_name OccName.tcName
1261 -- NB: the THSyntax module comes from the "haskell-src" package
1262 thModule = mkThPkgModule mETA_META_Name
1264 mk_known_key_name space str uniq
1265 = mkKnownKeyExternalName thModule (mkOccFS space str) uniq
1267 intPrimLName = varQual FSLIT("intPrimLit") intPrimLIdKey
1268 floatPrimLName = varQual FSLIT("floatPrimLit") floatPrimLIdKey
1269 doublePrimLName = varQual FSLIT("doublePrimLit") doublePrimLIdKey
1270 integerLName = varQual FSLIT("integerLit") integerLIdKey
1271 charLName = varQual FSLIT("charLit") charLIdKey
1272 stringLName = varQual FSLIT("stringLit") stringLIdKey
1273 rationalLName = varQual FSLIT("rationalLit") rationalLIdKey
1274 plitName = varQual FSLIT("litPat") plitIdKey
1275 pvarName = varQual FSLIT("varPat") pvarIdKey
1276 ptupName = varQual FSLIT("tupPat") ptupIdKey
1277 pconName = varQual FSLIT("conPat") pconIdKey
1278 ptildeName = varQual FSLIT("tildePat") ptildeIdKey
1279 paspatName = varQual FSLIT("asPat") paspatIdKey
1280 pwildName = varQual FSLIT("wildPat") pwildIdKey
1281 precName = varQual FSLIT("recPat") precIdKey
1282 varName = varQual FSLIT("varExp") varIdKey
1283 conName = varQual FSLIT("conExp") conIdKey
1284 litName = varQual FSLIT("litExp") litIdKey
1285 appName = varQual FSLIT("appExp") appIdKey
1286 infixEName = varQual FSLIT("infixExp") infixEIdKey
1287 lamName = varQual FSLIT("lamExp") lamIdKey
1288 tupName = varQual FSLIT("tupExp") tupIdKey
1289 doEName = varQual FSLIT("doExp") doEIdKey
1290 compName = varQual FSLIT("compExp") compIdKey
1291 listExpName = varQual FSLIT("listExp") listExpIdKey
1292 sigExpName = varQual FSLIT("sigExp") sigExpIdKey
1293 condName = varQual FSLIT("condExp") condIdKey
1294 letEName = varQual FSLIT("letExp") letEIdKey
1295 caseEName = varQual FSLIT("caseExp") caseEIdKey
1296 infixAppName = varQual FSLIT("infixApp") infixAppIdKey
1297 sectionLName = varQual FSLIT("sectionL") sectionLIdKey
1298 sectionRName = varQual FSLIT("sectionR") sectionRIdKey
1299 recConName = varQual FSLIT("recConExp") recConIdKey
1300 recUpdName = varQual FSLIT("recUpdExp") recUpdIdKey
1301 guardedName = varQual FSLIT("guardedRHS") guardedIdKey
1302 normalName = varQual FSLIT("normalRHS") normalIdKey
1303 bindStName = varQual FSLIT("bindStmt") bindStIdKey
1304 letStName = varQual FSLIT("letStmt") letStIdKey
1305 noBindStName = varQual FSLIT("noBindStmt") noBindStIdKey
1306 parStName = varQual FSLIT("parStmt") parStIdKey
1307 fromName = varQual FSLIT("fromExp") fromIdKey
1308 fromThenName = varQual FSLIT("fromThenExp") fromThenIdKey
1309 fromToName = varQual FSLIT("fromToExp") fromToIdKey
1310 fromThenToName = varQual FSLIT("fromThenToExp") fromThenToIdKey
1311 liftName = varQual FSLIT("lift") liftIdKey
1312 gensymName = varQual FSLIT("gensym") gensymIdKey
1313 returnQName = varQual FSLIT("returnQ") returnQIdKey
1314 bindQName = varQual FSLIT("bindQ") bindQIdKey
1315 sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey
1318 matchName = varQual FSLIT("match") matchIdKey
1320 -- data Clause = ...
1321 clauseName = varQual FSLIT("clause") clauseIdKey
1324 funName = varQual FSLIT("funDec") funIdKey
1325 valName = varQual FSLIT("valDec") valIdKey
1326 dataDName = varQual FSLIT("dataDec") dataDIdKey
1327 newtypeDName = varQual FSLIT("newtypeDec") newtypeDIdKey
1328 tySynDName = varQual FSLIT("tySynDec") tySynDIdKey
1329 classDName = varQual FSLIT("classDec") classDIdKey
1330 instName = varQual FSLIT("instanceDec") instIdKey
1331 protoName = varQual FSLIT("sigDec") protoIdKey
1334 tforallName = varQual FSLIT("forallTyp") tforallIdKey
1335 tvarName = varQual FSLIT("varTyp") tvarIdKey
1336 tconName = varQual FSLIT("conTyp") tconIdKey
1337 tappName = varQual FSLIT("appTyp") tappIdKey
1340 arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey
1341 tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey
1342 listTyConName = varQual FSLIT("listTyCon") listIdKey
1343 namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey
1346 ctxtName = varQual FSLIT("cxt") ctxtIdKey
1349 constrName = varQual FSLIT("normalCon") constrIdKey
1350 recConstrName = varQual FSLIT("recCon") recConstrIdKey
1351 infixConstrName = varQual FSLIT("infixCon") infixConstrIdKey
1353 exprTyConName = tcQual FSLIT("ExpQ") exprTyConKey
1354 declTyConName = tcQual FSLIT("DecQ") declTyConKey
1355 pattTyConName = tcQual FSLIT("Pat") pattTyConKey
1356 mtchTyConName = tcQual FSLIT("MatchQ") mtchTyConKey
1357 clseTyConName = tcQual FSLIT("ClauseQ") clseTyConKey
1358 stmtTyConName = tcQual FSLIT("StmtQ") stmtTyConKey
1359 consTyConName = tcQual FSLIT("ConQ") consTyConKey
1360 typeTyConName = tcQual FSLIT("TypQ") typeTyConKey
1361 strTypeTyConName = tcQual FSLIT("StrictTypQ") strTypeTyConKey
1362 varStrTypeTyConName = tcQual FSLIT("VarStrictTypQ") varStrTypeTyConKey
1364 fieldTyConName = tcQual FSLIT("FieldExp") fieldTyConKey
1365 fieldPTyConName = tcQual FSLIT("FieldPat") fieldPTyConKey
1367 qTyConName = tcQual FSLIT("Q") qTyConKey
1368 expTyConName = tcQual FSLIT("Exp") expTyConKey
1369 decTyConName = tcQual FSLIT("Dec") decTyConKey
1370 typTyConName = tcQual FSLIT("Typ") typTyConKey
1371 matTyConName = tcQual FSLIT("Match") matTyConKey
1372 clsTyConName = tcQual FSLIT("Clause") clsTyConKey
1374 strictTypeName = varQual FSLIT("strictTypQ") strictTypeKey
1375 varStrictTypeName = varQual FSLIT("varStrictTypQ") varStrictTypeKey
1376 strictName = varQual FSLIT("isStrict") strictKey
1377 nonstrictName = varQual FSLIT("notStrict") nonstrictKey
1379 fieldName = varQual FSLIT("fieldExp") fieldKey
1380 fieldPName = varQual FSLIT("fieldPat") fieldPKey
1382 -- TyConUniques available: 100-119
1383 -- Check in PrelNames if you want to change this
1385 expTyConKey = mkPreludeTyConUnique 100
1386 matTyConKey = mkPreludeTyConUnique 101
1387 clsTyConKey = mkPreludeTyConUnique 102
1388 qTyConKey = mkPreludeTyConUnique 103
1389 exprTyConKey = mkPreludeTyConUnique 104
1390 declTyConKey = mkPreludeTyConUnique 105
1391 pattTyConKey = mkPreludeTyConUnique 106
1392 mtchTyConKey = mkPreludeTyConUnique 107
1393 clseTyConKey = mkPreludeTyConUnique 108
1394 stmtTyConKey = mkPreludeTyConUnique 109
1395 consTyConKey = mkPreludeTyConUnique 110
1396 typeTyConKey = mkPreludeTyConUnique 111
1397 typTyConKey = mkPreludeTyConUnique 112
1398 decTyConKey = mkPreludeTyConUnique 113
1399 varStrTypeTyConKey = mkPreludeTyConUnique 114
1400 strTypeTyConKey = mkPreludeTyConUnique 115
1401 fieldTyConKey = mkPreludeTyConUnique 116
1402 fieldPTyConKey = mkPreludeTyConUnique 117
1406 -- IdUniques available: 200-299
1407 -- If you want to change this, make sure you check in PrelNames
1408 fromIdKey = mkPreludeMiscIdUnique 200
1409 fromThenIdKey = mkPreludeMiscIdUnique 201
1410 fromToIdKey = mkPreludeMiscIdUnique 202
1411 fromThenToIdKey = mkPreludeMiscIdUnique 203
1412 liftIdKey = mkPreludeMiscIdUnique 204
1413 gensymIdKey = mkPreludeMiscIdUnique 205
1414 returnQIdKey = mkPreludeMiscIdUnique 206
1415 bindQIdKey = mkPreludeMiscIdUnique 207
1416 funIdKey = mkPreludeMiscIdUnique 208
1417 valIdKey = mkPreludeMiscIdUnique 209
1418 protoIdKey = mkPreludeMiscIdUnique 210
1419 matchIdKey = mkPreludeMiscIdUnique 211
1420 clauseIdKey = mkPreludeMiscIdUnique 212
1421 integerLIdKey = mkPreludeMiscIdUnique 213
1422 charLIdKey = mkPreludeMiscIdUnique 214
1424 classDIdKey = mkPreludeMiscIdUnique 215
1425 instIdKey = mkPreludeMiscIdUnique 216
1426 dataDIdKey = mkPreludeMiscIdUnique 217
1428 sequenceQIdKey = mkPreludeMiscIdUnique 218
1429 tySynDIdKey = mkPreludeMiscIdUnique 219
1431 plitIdKey = mkPreludeMiscIdUnique 220
1432 pvarIdKey = mkPreludeMiscIdUnique 221
1433 ptupIdKey = mkPreludeMiscIdUnique 222
1434 pconIdKey = mkPreludeMiscIdUnique 223
1435 ptildeIdKey = mkPreludeMiscIdUnique 224
1436 paspatIdKey = mkPreludeMiscIdUnique 225
1437 pwildIdKey = mkPreludeMiscIdUnique 226
1438 varIdKey = mkPreludeMiscIdUnique 227
1439 conIdKey = mkPreludeMiscIdUnique 228
1440 litIdKey = mkPreludeMiscIdUnique 229
1441 appIdKey = mkPreludeMiscIdUnique 230
1442 infixEIdKey = mkPreludeMiscIdUnique 231
1443 lamIdKey = mkPreludeMiscIdUnique 232
1444 tupIdKey = mkPreludeMiscIdUnique 233
1445 doEIdKey = mkPreludeMiscIdUnique 234
1446 compIdKey = mkPreludeMiscIdUnique 235
1447 listExpIdKey = mkPreludeMiscIdUnique 237
1448 condIdKey = mkPreludeMiscIdUnique 238
1449 letEIdKey = mkPreludeMiscIdUnique 239
1450 caseEIdKey = mkPreludeMiscIdUnique 240
1451 infixAppIdKey = mkPreludeMiscIdUnique 241
1453 sectionLIdKey = mkPreludeMiscIdUnique 243
1454 sectionRIdKey = mkPreludeMiscIdUnique 244
1455 guardedIdKey = mkPreludeMiscIdUnique 245
1456 normalIdKey = mkPreludeMiscIdUnique 246
1457 bindStIdKey = mkPreludeMiscIdUnique 247
1458 letStIdKey = mkPreludeMiscIdUnique 248
1459 noBindStIdKey = mkPreludeMiscIdUnique 249
1460 parStIdKey = mkPreludeMiscIdUnique 250
1462 tforallIdKey = mkPreludeMiscIdUnique 251
1463 tvarIdKey = mkPreludeMiscIdUnique 252
1464 tconIdKey = mkPreludeMiscIdUnique 253
1465 tappIdKey = mkPreludeMiscIdUnique 254
1467 arrowIdKey = mkPreludeMiscIdUnique 255
1468 tupleIdKey = mkPreludeMiscIdUnique 256
1469 listIdKey = mkPreludeMiscIdUnique 257
1470 namedTyConIdKey = mkPreludeMiscIdUnique 258
1472 ctxtIdKey = mkPreludeMiscIdUnique 259
1474 constrIdKey = mkPreludeMiscIdUnique 260
1476 stringLIdKey = mkPreludeMiscIdUnique 261
1477 rationalLIdKey = mkPreludeMiscIdUnique 262
1479 sigExpIdKey = mkPreludeMiscIdUnique 263
1481 strictTypeKey = mkPreludeMiscIdUnique 264
1482 strictKey = mkPreludeMiscIdUnique 265
1483 nonstrictKey = mkPreludeMiscIdUnique 266
1484 varStrictTypeKey = mkPreludeMiscIdUnique 267
1486 recConstrIdKey = mkPreludeMiscIdUnique 268
1487 infixConstrIdKey = mkPreludeMiscIdUnique 269
1489 recConIdKey = mkPreludeMiscIdUnique 270
1490 recUpdIdKey = mkPreludeMiscIdUnique 271
1491 precIdKey = mkPreludeMiscIdUnique 272
1492 fieldKey = mkPreludeMiscIdUnique 273
1493 fieldPKey = mkPreludeMiscIdUnique 274
1495 intPrimLIdKey = mkPreludeMiscIdUnique 275
1496 floatPrimLIdKey = mkPreludeMiscIdUnique 276
1497 doublePrimLIdKey = mkPreludeMiscIdUnique 277
1499 newtypeDIdKey = mkPreludeMiscIdUnique 278
1501 -- %************************************************************************
1505 -- %************************************************************************
1507 -- It is rather usatisfactory that we don't have a SrcLoc
1508 addDsWarn :: SDoc -> DsM ()
1509 addDsWarn msg = dsWarn (noSrcLoc, msg)