From: simonpj Date: Fri, 11 Oct 2002 16:45:20 +0000 (+0000) Subject: [project @ 2002-10-11 16:45:16 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1561 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=37f7228038a8228e1c33c4eaa3c19cab840ad051;p=ghc-hetmet.git [project @ 2002-10-11 16:45:16 by simonpj] More reification wibbling; and -ddump-splices --- diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 3d2450b..296766b 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -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) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 3344705..904d575 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -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) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 9afd12e..ac9fa7e 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 4dd7261..f5a83b9 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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 diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 8b1a8da..cf039d9 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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) ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index f424dbc..bd31533 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index f450dcf..58930ac 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -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 () diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index e269f9f..f29069e 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -1,4 +1,4 @@ -% +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