[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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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