More reification wibbling; and -ddump-splices
-- Returns a CoreExpr of type reifyType --> M.Typ
-- reifyDecl --> M.Dec
-- reifyFixty --> M.Fix
-- 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)
case mb_d of
Just (MkC d) -> return d
Nothing -> pprPanic "dsReify" (ppr r)
getModuleDs,
getUniqueDs, getUniquesDs,
getDOptsDs,
getModuleDs,
getUniqueDs, getUniquesDs,
getDOptsDs,
- dsLookupGlobalId, dsLookupTyCon,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
+dsLookupGlobal :: Name -> DsM TyThing
+dsLookupGlobal name
+ = DsM(\ env warns -> returnUs (ds_globals env name, warns))
+
dsLookupGlobalId :: Name -> DsM Id
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 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)
get_id name (AnId id) = id
get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
pp_body <+> ptext SLIT("|]")
data HsReify id = Reify ReifyFlavour id -- Pre typechecking
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
data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity
| Opt_D_dump_stix
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
| Opt_D_dump_stix
| Opt_D_dump_simpl_stats
| Opt_D_dump_tc_trace
| Opt_D_dump_BCOs
| Opt_D_dump_vect
| Opt_D_source_stats
| 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 $
, ( "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) )
, ( "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) )
, ( "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) )
tcMonoExpr (HsReify (Reify flavour name)) res_ty
= addErrCtxt (ptext SLIT("At the reification of") <+> ppr name) $
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_`
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
where
tycon_name = case flavour of
ReifyDecl -> DsMeta.decTyConName
traceTc, traceRn :: SDoc -> TcRn a ()
traceRn = dumpOptTcRn Opt_D_dump_rn_trace
traceTc = dumpOptTcRn Opt_D_dump_tc_trace
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 ()
traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs
dumpOptTcRn :: DynFlag -> SDoc -> TcRn a ()
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSplice]{Template Haskell splices}
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcSplice]{Template Haskell splices}
expr2 = convertToHsExpr simple_expr
in
traceTc (text "Got result" <+> ppr expr2) `thenM_`
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 ->
initRn SourceMode (rnExpr expr2) `thenM` \ (exp3, fvs) ->
importSupportingDecls fvs `thenM` \ env ->
decls = convertToHsDecls simple_expr
in
traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
decls = convertToHsDecls simple_expr
in
traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_`
+ showSplice "declarations"
+ zonked_q_expr (vcat (map ppr decls)) `thenM_`
%************************************************************************
\begin{code}
%************************************************************************
\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
illegalSplice level
= ptext SLIT("Illegal splice at level") <+> ppr level