Commit 37f72280 authored by simonpj's avatar simonpj

[project @ 2002-10-11 16:45:16 by simonpj]

More reification wibbling; and -ddump-splices
parent fe37fd97
......@@ -85,12 +85,20 @@ dsReify :: HsReify Id -> DsM CoreExpr
-- Returns a CoreExpr of type reifyType --> M.Typ
-- reifyDecl --> M.Dec
-- reifyFixty --> M.Fix
dsReify (ReifyOut ReifyType (AnId id))
= do { MkC e <- repTy (toHsType (idType id)) ;
return e }
dsReify (ReifyOut ReifyType name)
= do { thing <- dsLookupGlobal name ;
-- By deferring the lookup until now (rather than doing it
-- in the type checker) we ensure that all zonking has
-- been done.
case thing of
AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
return e }
other -> pprPanic "dsReify: reifyType" (ppr name)
}
dsReify r@(ReifyOut ReifyDecl thing)
= do { mb_d <- repTyClD (ifaceTyThing thing) ;
dsReify r@(ReifyOut ReifyDecl name)
= do { thing <- dsLookupGlobal name ;
mb_d <- repTyClD (ifaceTyThing thing) ;
case mb_d of
Just (MkC d) -> return d
Nothing -> pprPanic "dsReify" (ppr r)
......
......@@ -16,7 +16,7 @@ module DsMonad (
getModuleDs,
getUniqueDs, getUniquesDs,
getDOptsDs,
dsLookupGlobalId, dsLookupTyCon,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
......@@ -231,13 +231,19 @@ dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
\end{code}
\begin{code}
dsLookupGlobal :: Name -> DsM TyThing
dsLookupGlobal name
= DsM(\ env warns -> returnUs (ds_globals env name, warns))
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name = DsM(\ env warns ->
returnUs (get_id name (ds_globals env name), warns))
dsLookupGlobalId name
= dsLookupGlobal name `thenDs` \ thing ->
returnDs (get_id name thing)
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name = DsM(\ env warns ->
returnUs (get_tycon name (ds_globals env name), warns))
dsLookupTyCon name
= dsLookupGlobal name `thenDs` \ thing ->
returnDs (get_tycon name thing)
get_id name (AnId id) = id
get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
......
......@@ -695,7 +695,9 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+>
pp_body <+> ptext SLIT("|]")
data HsReify id = Reify ReifyFlavour id -- Pre typechecking
| ReifyOut ReifyFlavour TyThing -- Post typechecking
| ReifyOut ReifyFlavour Name -- Post typechecking
-- The Name could be the name of
-- an Id, TyCon, or Class
data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity
......
......@@ -258,6 +258,7 @@ data DynFlag
| Opt_D_dump_stix
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
| Opt_D_dump_splices
| Opt_D_dump_BCOs
| Opt_D_dump_vect
| Opt_D_source_stats
......
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.102 2002/09/13 15:02:34 simonpj Exp $
-- $Id: DriverFlags.hs,v 1.103 2002/10/11 16:45:17 simonpj Exp $
--
-- Driver flags
--
......@@ -400,6 +400,7 @@ dynamic_flags = [
, ( "dshow-passes", NoArg (setVerbosity "2") )
, ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) )
, ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) )
, ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) )
, ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) )
, ( "ddump-stix", NoArg (setDynFlag Opt_D_dump_stix) )
, ( "ddump-simpl-stats", NoArg (setDynFlag Opt_D_dump_simpl_stats) )
......
......@@ -651,15 +651,9 @@ tcMonoExpr (HsBracket brack loc) res_ty
tcMonoExpr (HsReify (Reify flavour name)) res_ty
= addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
tcLookupGlobal name `thenM` \ thing ->
-- For now, we can only reify top-level things
-- The complication for non-top-level things is just that
-- they might be a TcId, and need zonking etc.
tcMetaTy tycon_name `thenM` \ reify_ty ->
unifyTauTy res_ty reify_ty `thenM_`
returnM (HsReify (ReifyOut flavour thing))
returnM (HsReify (ReifyOut flavour name))
where
tycon_name = case flavour of
ReifyDecl -> DsMeta.decTyConName
......
......@@ -528,6 +528,7 @@ setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv;
traceTc, traceRn :: SDoc -> TcRn a ()
traceRn = dumpOptTcRn Opt_D_dump_rn_trace
traceTc = dumpOptTcRn Opt_D_dump_tc_trace
traceSplice = dumpOptTcRn Opt_D_dump_splices
traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs
dumpOptTcRn :: DynFlag -> SDoc -> TcRn a ()
......
%
2%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSplice]{Template Haskell splices}
......@@ -144,6 +144,9 @@ tcTopSplice expr res_ty
expr2 = convertToHsExpr simple_expr
in
traceTc (text "Got result" <+> ppr expr2) `thenM_`
showSplice "expression"
zonked_q_expr (ppr expr2) `thenM_`
initRn SourceMode (rnExpr expr2) `thenM` \ (exp3, fvs) ->
importSupportingDecls fvs `thenM` \ env ->
......@@ -180,6 +183,8 @@ tcSpliceDecls expr
decls = convertToHsDecls simple_expr
in
traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
showSplice "declarations"
zonked_q_expr (vcat (map ppr decls)) `thenM_`
returnM decls
\end{code}
......@@ -341,6 +346,14 @@ Two successive brackets aren't allowed
%************************************************************************
\begin{code}
showSplice :: String -> TypecheckedHsExpr -> SDoc -> TcM ()
showSplice what before after
= getSrcLocM `thenM` \ loc ->
traceSplice (hang (ppr loc <> colon <+> text "Splicing" <+> text what) 4
(sep [nest 2 (ppr before),
text "======>",
nest 2 after]))
illegalSplice level
= ptext SLIT("Illegal splice at level") <+> ppr level
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment