[project @ 1999-12-06 11:54:56 by simonpj]

Fix a major bug in exporting unfoldings involving existentials.

Change core printing so that we put an '@' before type
variables in case patterns.  This only affects existentials.

	case x of
	  C @ a x y -> ...

Here 'a' is an existentially quantified type variable, and the
'@' signifies this.  We continue to omit kinds and type on case-bound
variables; the type checker can fill them in.

The reason for this change is that type variables and term variables
live in a different name space, so we need to know which name space
is  involved when binding one.  How this ever worked I will never know.

While I was at it, I also arranged that -ddump-rn prints out whatever
it has even if it finds errors.  Adding -dppr-debug prints even the
unfoldings on imported things.

Simon

diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 9f8a16d..67bd8a4 100644 (file)
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -321,7 +321,7 @@ pprIfaceBinder CaseBind binder = pprUntypedBinder binder
 pprIfaceBinder other    binder = pprTypedBinder binder
 
 pprUntypedBinder binder
-  | isTyVar binder = pprTyVarBndr binder
+  | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
   | otherwise      = pprIdBndr binder
 
 pprTypedBinder binder

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 07293c6..7148311 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -120,9 +120,11 @@ instance Outputable name => Outputable (UfExpr name) where
       = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 
 instance Outputable name => Outputable (UfCon name) where
-    ppr UfDefault      = text "DEFAULT"
-    ppr (UfDataCon d)  = ppr d
-    ppr (UfPrimOp p)   = ppr p
+    ppr UfDefault         = text "DEFAULT"
+    ppr (UfLitCon l)       = ppr l
+    ppr (UfLitLitCon l ty) = ppr l
+    ppr (UfDataCon d)     = ppr d
+    ppr (UfPrimOp p)      = ppr p
     ppr (UfCCallOp str is_dyn is_casm can_gc)
       =        hcat [before, ptext str, after]
       where
@@ -150,9 +152,9 @@ data IfaceSig name
                SrcLoc
 
 instance (Outputable name) => Outputable (IfaceSig name) where
-    ppr (IfaceSig var ty _ _)
+    ppr (IfaceSig var ty info _)
       = hang (hsep [ppr var, dcolon])
-            4 (ppr ty)
+            4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
 
 data HsIdInfo name
   = HsArity            ArityInfo
@@ -164,6 +166,10 @@ data HsIdInfo name
   | HsCprInfo           CprInfo
   | HsWorker           name            -- Worker, if any
 
+instance Outputable name => Outputable (HsIdInfo name) where
+  ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
+  ppr other           = empty  -- Havn't got around to this yet
+
 data HsStrictnessInfo
   = HsStrictnessInfo ([Demand], Bool)
   | HsBottom

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index e507f7e..f894349 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -714,13 +714,24 @@ core_alt  : core_pat '->' core_expr       { (fst $1, snd $1, $3) }
 core_pat       :: { (UfCon RdrName, [RdrName]) }
 core_pat       : core_lit                      { (UfLitCon  $1, []) }
                | '__litlit' STRING atype       { (UfLitLitCon $2 $3, []) }
-               | qdata_name var_names          { (UfDataCon $1, $2) }
+               | qdata_name core_pat_names     { (UfDataCon $1, $2) }
                | '(' comma_var_names1 ')'      { (UfDataCon (mkTupConRdrName (length $2)), $2) }
                | '(#' comma_var_names1 '#)'    { (UfDataCon (mkUbxTupConRdrName (length $2)), $2) }
                | '__DEFAULT'                   { (UfDefault, []) }
                | '(' core_pat ')'              { $2 }
 
-
+core_pat_names :: { [RdrName] }
+core_pat_names :                               { [] }
+               | core_pat_name core_pat_names  { $1 : $2 }
+
+-- Tyvar names and variable names live in different name spaces
+-- so they need to be signalled separately.  But we don't record 
+-- types or kinds in a pattern; we work that out from the type 
+-- of the case scrutinee
+core_pat_name  :: { RdrName }
+core_pat_name  : var_name                      { $1 }
+               | '@' tv_name                   { $2 }
+       
 comma_var_names1 :: { [RdrName] }      -- One or more
 comma_var_names1 : var_name                                    { [$1] }
                 | var_name ',' comma_var_names1                { $1 : $3 }

diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 9893a3e..730f02d 100644 (file)
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -72,18 +72,13 @@ renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc
   =    -- Initialise the renamer monad
     initRn mod_name us (mkSearchPath opt_HiMap) loc
           (rename this_mod)                            >>=
-       \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
+       \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) ->
 
        -- Check for warnings
     printErrorsAndWarnings rn_errs_bag rn_warns_bag    >>
 
-       -- Dump output, if any
-    (case maybe_rn_stuff of
-       Nothing  -> return ()
-       Just results@(_, rn_mod, _, _, _)
-                -> dumpIfSet opt_D_dump_rn "Renamer:"
-                             (ppr rn_mod)
-    )                                                  >>
+       -- Dump any debugging output
+    dump_action                                        >>
 
        -- Return results
     if not (isEmptyBag rn_errs_bag) then
@@ -101,8 +96,8 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
        -- CHECK FOR EARLY EXIT
     if not (maybeToBool maybe_stuff) then
        -- Everything is up to date; no need to recompile further
-       rnStats []              `thenRn_`
-       returnRn Nothing
+       rnDump [] []            `thenRn` \ dump_action ->
+       returnRn (Nothing, dump_action)
     else
     let
        Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
@@ -122,13 +117,16 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
                -- override the implicit ones. 
     in
     slurpImpDecls real_source_fvs      `thenRn` \ rn_imp_decls ->
+    let
+       rn_all_decls       = rn_imp_decls ++ rn_local_decls 
+    in
 
        -- EXIT IF ERRORS FOUND
-    checkErrsRn                                `thenRn` \ no_errs_so_far ->
+    checkErrsRn                                        `thenRn` \ no_errs_so_far ->
     if not no_errs_so_far then
        -- Found errors already, so exit now
-       rnStats []              `thenRn_`
-       returnRn Nothing
+       rnDump rn_imp_decls rn_all_decls        `thenRn` \ dump_action ->
+       returnRn (Nothing, dump_action)
     else
 
        -- GENERATE THE VERSION/USAGE INFO
@@ -144,18 +142,17 @@ rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
     let
        has_orphans        = any isOrphanDecl rn_local_decls
        direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
-       rn_all_decls       = rn_imp_decls ++ rn_local_decls 
        renamed_module = HsModule mod_name vers 
                                  trashed_exports trashed_imports
                                  rn_all_decls
                                  loc
     in
-    rnStats rn_imp_decls       `thenRn_`
+    rnDump rn_imp_decls        rn_all_decls            `thenRn` \ dump_action ->
     returnRn (Just (mkThisModule mod_name,
                    renamed_module, 
                    (has_orphans, my_usages, export_env),
                    name_supply,
-                   direct_import_mods))
+                   direct_import_mods), dump_action)
   where
     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
@@ -517,18 +514,20 @@ reportableUnusedName name
     explicitlyImported other                                = False
        -- Don't report others
 
-rnStats :: [RenamedHsDecl] -> RnMG ()
-rnStats imp_decls
+rnDump  :: [RenamedHsDecl]     -- Renamed imported decls
+       -> [RenamedHsDecl]      -- Renamed local decls
+       -> RnMG (IO ())
+rnDump imp_decls decls
         | opt_D_dump_rn_trace || 
          opt_D_dump_rn_stats ||
          opt_D_dump_rn 
-       = getRnStats imp_decls          `thenRn` \ msg ->
-         ioToRnM (printErrs msg)       `thenRn_`
-         returnRn ()
+       = getRnStats imp_decls          `thenRn` \ stats_msg ->
 
-       | otherwise = returnRn ()
-\end{code}
+         returnRn (printErrs stats_msg >> 
+                   dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls)))
 
+       | otherwise = returnRn (return ())
+\end{code}
 
 
 %*********************************************************