From 972d6442ee3a6ee0a5fa20655d882e0041646892 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 15 Jun 2001 08:29:58 +0000
Subject: [PATCH] [project @ 2001-06-15 08:29:57 by simonpj] Some tidying up

* Remove CmStaticInfo
   - GhciMode moves to HscTypes
   - The package stuff moves to new module main/Packages.lhs

[put any package-related stuff in the new module]

* Add Outputable.docToSDoc
---
 ghc/compiler/Makefile                 |   11 ++++-
 ghc/compiler/compMan/CmLink.lhs       |    2 +-
 ghc/compiler/compMan/CmStaticInfo.lhs |   19 ---------
 ghc/compiler/compMan/CompManager.lhs  |    1 -
 ghc/compiler/ghci/InteractiveUI.hs    |    4 +-
 ghc/compiler/main/DriverFlags.hs      |    3 +-
 ghc/compiler/main/DriverPipeline.hs   |    4 +-
 ghc/compiler/main/DriverState.hs      |    4 +-
 ghc/compiler/main/Finder.lhs          |    2 +-
 ghc/compiler/main/HscMain.lhs         |    1 -
 ghc/compiler/main/HscTypes.lhs        |   14 +++++++
 ghc/compiler/main/Main.hs             |   39 ++++++------------
 ghc/compiler/main/MkIface.lhs         |    3 +-
 ghc/compiler/main/Packages.lhs        |   72 +++++++++++++++++++++++++++++++++
 ghc/compiler/main/ParsePkgConf.y      |   17 +++++---
 ghc/compiler/main/SysTools.lhs        |   14 ++++---
 ghc/compiler/rename/Rename.lhs        |    3 +-
 ghc/compiler/utils/Outputable.lhs     |    4 ++
 18 files changed, 145 insertions(+), 72 deletions(-)
 delete mode 100644 ghc/compiler/compMan/CmStaticInfo.lhs
 create mode 100644 ghc/compiler/main/Packages.lhs

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index 971a83d..1bf9cae 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.158 2001/06/14 15:42:35 simonpj Exp $
+# $Id: Makefile,v 1.159 2001/06/15 08:29:57 simonpj Exp $
 
 TOP = ..
 include $(TOP)/mk/boilerplate.mk
@@ -176,6 +176,15 @@ SRC_HC_OPTS += \
   -I. -IcodeGen -InativeGen -Iparser \
   -i$(subst $(space),:,$(DIRS)) 
 
+# We should do this, to avoid the use of an explicit path
+# 	in GHC source files (include "../includes/config.h"
+# But alas GHC 4.08 (and others for all I know) uses this very
+# same include path when compiling the .hc files it generates.
+# Disaster!  Then the hc file sees the GHC 5.02 (or whatever)
+# include files.   For the moment we've reverted to using
+# an explicit path in the .hs sources
+#  -I$(GHC_INCLUDE_DIR) \
+
 ifneq "$(mingw32_TARGET_OS)" "1"
 SRC_HC_OPTS += -package concurrent -package posix -package text -package util
 else
diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index f22f2de..4b592f5 100644
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -26,7 +26,7 @@ import ByteCodeLink	( linkIModules, linkIExpr )
 import Interpreter
 import DriverPipeline
 import CmTypes
-import CmStaticInfo	( GhciMode(..) )
+import HscTypes		( GhciMode(..) )
 import Outputable	( SDoc )
 import Digraph		( SCC(..), flattenSCC )
 import Name		( Name )
diff --git a/ghc/compiler/compMan/CmStaticInfo.lhs b/ghc/compiler/compMan/CmStaticInfo.lhs
deleted file mode 100644
index 0c310f8..0000000
--- a/ghc/compiler/compMan/CmStaticInfo.lhs
+++ /dev/null
@@ -1,19 +0,0 @@
-%
-% (c) The University of Glasgow, 2000
-%
-\section[CmStaticInfo]{Session-static info for the Compilation Manager}
-
-\begin{code}
-module CmStaticInfo ( GhciMode(..), PackageConfig(..), defaultPackageConfig )
-where
-
-#include "HsVersions.h"
-
-\end{code}
-
-\begin{code}
-data GhciMode = Batch | Interactive | OneShot 
-     deriving Eq
-
-#include "../utils/ghc-pkg/Package.hs"
-\end{code}
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 144144e..8c7cf64 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -34,7 +34,6 @@ where
 
 import CmLink
 import CmTypes
-import CmStaticInfo	( GhciMode(..) )
 import DriverPipeline
 import DriverFlags	( getDynFlags )
 import DriverPhases
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 2bf39b5..2ac225a 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.74 2001/06/14 12:50:06 simonpj Exp $
+-- $Id: InteractiveUI.hs,v 1.75 2001/06/15 08:29:57 simonpj Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -14,7 +14,7 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 #include "HsVersions.h"
 
 import CompManager
-import CmStaticInfo
+import HscTypes		( GhciMode(..) )
 import ByteCodeLink
 import DriverFlags
 import DriverState
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index f7a48ed..739e760 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS -#include "hschooks.h" #-}
 
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.58 2001/06/14 12:50:06 simonpj Exp $
+-- $Id: DriverFlags.hs,v 1.59 2001/06/15 08:29:58 simonpj Exp $
 --
 -- Driver flags
 --
@@ -18,6 +18,7 @@ module DriverFlags (
   ) where
 
 #include "HsVersions.h"
+#include "../includes/config.h"
 
 import DriverState
 import DriverUtil
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 2ff3078..5a02850 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.78 2001/06/14 12:50:06 simonpj Exp $
+-- $Id: DriverPipeline.hs,v 1.79 2001/06/15 08:29:58 simonpj Exp $
 --
 -- GHC Driver
 --
@@ -26,7 +26,7 @@ module DriverPipeline (
 
 #include "HsVersions.h"
 
-import CmStaticInfo
+import Packages
 import CmTypes
 import GetImports
 import DriverState
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index 06e23e5..21cb1bc 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.44 2001/06/14 12:50:06 simonpj Exp $
+-- $Id: DriverState.hs,v 1.45 2001/06/15 08:29:58 simonpj Exp $
 --
 -- Settings for the driver
 --
@@ -12,7 +12,7 @@ module DriverState where
 #include "../includes/config.h"
 #include "HsVersions.h"
 
-import CmStaticInfo
+import Packages		( PackageConfig(..) )
 import CmdLineOpts
 import DriverUtil
 import Util
diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs
index 65fbb2e..2fc393d 100644
--- a/ghc/compiler/main/Finder.lhs
+++ b/ghc/compiler/main/Finder.lhs
@@ -16,7 +16,7 @@ module Finder (
 #include "HsVersions.h"
 
 import HscTypes		( ModuleLocation(..) )
-import CmStaticInfo
+import Packages		( PackageConfig(..) )
 import DriverPhases
 import DriverState
 import Module
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 5d09d7b..04e023e 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -64,7 +64,6 @@ import UniqSupply	( mkSplitUniqSupply )
 import Bag		( emptyBag )
 import Outputable
 import Interpreter
-import CmStaticInfo	( GhciMode(..) )
 import HscStats		( ppSourceStats )
 import HscTypes
 import FiniteMap	( FiniteMap, plusFM, emptyFM, addToFM )
diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index a490730..2c8757f 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -5,6 +5,8 @@
 
 \begin{code}
 module HscTypes ( 
+	GhciMode(..),
+
 	ModuleLocation(..),
 
 	ModDetails(..),	ModIface(..), 
@@ -84,6 +86,18 @@ import UniqSupply	( UniqSupply )
 
 %************************************************************************
 %*									*
+\subsection{Which mode we're in
+%*									*
+%************************************************************************
+
+\begin{code}
+data GhciMode = Batch | Interactive | OneShot 
+     deriving Eq
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Module locations}
 %*									*
 %************************************************************************
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index b0cbedd..2336b4e 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.71 2001/06/14 15:42:35 simonpj Exp $
+-- $Id: Main.hs,v 1.72 2001/06/15 08:29:58 simonpj Exp $
 --
 -- GHC Driver program
 --
@@ -23,10 +23,11 @@ import InteractiveUI(ghciWelcomeMsg, interactiveUI)
 
 import Finder		( initFinder )
 import CompManager	( cmInit, cmLoadModule )
-import CmStaticInfo	( GhciMode(..), PackageConfig(..) )
+import HscTypes		( GhciMode(..) )
 import Config		( cBooterVersion, cGhcUnregisterised, cProjectVersion )
 import SysTools		( packageConfigPath, initSysTools, cleanTempFiles )
-import ParsePkgConf	( parsePkgConf )
+import Packages		( showPackages, mungePackagePaths )
+import ParsePkgConf	( loadPackageConfig )
 
 import DriverPipeline	( GhcMode(..), doLink, doMkDLL, genPipeline,
 			  getGhcMode, pipeLoop, v_GhcMode
@@ -50,6 +51,7 @@ import CmdLineOpts	( dynFlag,
 			)
 
 import Outputable
+import ErrUtils		( dumpIfSet )
 import Util
 import Panic		( GhcException(..), panic )
 
@@ -138,14 +140,11 @@ main =
    let (minusB_args, argv') = partition (prefixMatch "-B") argv
    top_dir <- initSysTools minusB_args
 
-	-- read the package configuration
-   conf_file <- packageConfigPath
-   r	     <- parsePkgConf conf_file
-   case r of {
-	Left err -> throwDyn (InstallationError (showSDoc err));
-	Right pkg_details -> do
-
-   writeIORef v_Package_details (mungePackagePaths top_dir pkg_details)
+	-- Read the package configuration
+   conf_file	     <- packageConfigPath
+   proto_pkg_details <- loadPackageConfig conf_file
+   let pkg_details    = mungePackagePaths top_dir proto_pkg_details
+   writeIORef v_Package_details pkg_details
 
 	-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
    (flags2, mode, stop_flag) <- getGhcMode argv'
@@ -222,6 +221,7 @@ main =
     	-- complain about any unknown flags
    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 
+	-- Display details of the configuration in verbose mode
    verb <- dynFlag verbosity
 
    when (verb >= 2) 
@@ -236,6 +236,8 @@ main =
    when (verb >= 3) 
 	(hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))
 
+   showPackages pkg_details
+
 	-- initialise the finder
    pkg_avails <- getPackageInfo
    initFinder pkg_avails
@@ -293,22 +295,7 @@ main =
    when (mode == DoMkDependHS) endMkDependHS
    when (mode == DoLink) (doLink o_files)
    when (mode == DoMkDLL) (doMkDLL o_files)
-  }
-
-
--- replace the string "$libdir" at the beginning of a path with the
--- current libdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where 
-  munge_pkg p = p{ import_dirs  = munge_paths (import_dirs p),
-		   include_dirs = munge_paths (include_dirs p),
-    		   library_dirs = munge_paths (library_dirs p) }
-
-  munge_paths = map munge_path
 
-  munge_path p 
-	  | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
-	  | otherwise = trace ("not: " ++ p) p
 
 
 beginMake :: [String] -> IO ()
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 85b7a92..8cbf484 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -21,14 +21,13 @@ import BasicTypes	( Fixity(..), NewOrData(..),
 import RnMonad
 import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl )
 import HscTypes		( VersionInfo(..), ModIface(..), ModDetails(..),
-			  ModuleLocation(..), 
+			  ModuleLocation(..), GhciMode(..),
 			  IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
 			  TyThing(..), DFunId, Avails,
 			  WhatsImported(..), GenAvailInfo(..), 
 			  ImportVersion, AvailInfo, Deprecations(..),
 			  lookupVersion,
 			)
-import CmStaticInfo	( GhciMode(..) )
 
 import CmdLineOpts
 import Id		( idType, idInfo, isImplicitId, idCgInfo,
diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
new file mode 100644
index 0000000..3503d46
--- /dev/null
+++ b/ghc/compiler/main/Packages.lhs
@@ -0,0 +1,72 @@
+%
+% (c) The University of Glasgow, 2000
+%
+\section{Package manipulation}
+
+\begin{code}
+module Packages ( PackageConfig(..), 
+		  defaultPackageConfig,
+		  mungePackagePaths,
+		  showPackages
+		)
+where
+
+#include "HsVersions.h"
+import Pretty
+
+import SysTools		( dosifyPath )
+import CmdLineOpts	( dynFlag, verbosity )
+import DriverUtil	( my_prefix_match )
+import ErrUtils		( dumpIfSet )
+import Outputable	( docToSDoc, trace )
+\end{code}
+
+\begin{code}
+#define WANT_PRETTY
+-- Yes, do generate pretty-printing stuff for packages
+
+-- There's a blob of code shared with ghc-pkg, 
+-- so we just include it from there 
+#include "../utils/ghc-pkg/Package.hs"
+\end{code}
+
+%*********************************************************
+%*						 	 *
+\subsection{Load the config file}
+%*							 *
+%*********************************************************
+
+\begin{code}
+mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
+-- a) replace the string "$libdir" at the beginning of a path with the
+--    current libdir (obtained from the -B option).
+-- b) dosify the paths [paths in the package-conf file aren't DOS style]
+mungePackagePaths top_dir ps = map munge_pkg ps
+ where 
+  munge_pkg p = p{ import_dirs  = munge_paths (import_dirs p),
+		   include_dirs = munge_paths (include_dirs p),
+    		   library_dirs = munge_paths (library_dirs p) }
+
+  munge_paths = map munge_path
+
+  munge_path p 
+	  | Just p' <- my_prefix_match "$libdir" p = dosifyPath (top_dir ++ p')
+	  | otherwise				   = trace ("not: " ++ p) p
+\end{code}
+
+
+%*********************************************************
+%*						 	 *
+\subsection{Display results}
+%*							 *
+%*********************************************************
+
+\begin{code}
+showPackages :: [PackageConfig] -> IO ()
+-- Show package info on console, if verbosity is >=2
+showPackages ps
+  = do  { verb <- dynFlag verbosity
+	; dumpIfSet (verb >= 2) "Packages"
+	  	    (docToSDoc (vcat (map dumpPkgGuts ps)))
+	}
+\end{code}
diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y
index 1a8f9db..c61d31c 100644
--- a/ghc/compiler/main/ParsePkgConf.y
+++ b/ghc/compiler/main/ParsePkgConf.y
@@ -1,12 +1,17 @@
 {
-module ParsePkgConf (parsePkgConf) where
-import CmStaticInfo
+module ParsePkgConf( loadPackageConfig ) where
+
+import Packages  ( PackageConfig(..), defaultPackageConfig )
 import Lex
 import FastString
 import StringBuffer
 import SrcLoc
 import Outputable
+import Panic     ( GhcException(..) )
+import Exception ( throwDyn )
+
 #include "HsVersions.h"
+
 }
 
 %token
@@ -72,17 +77,17 @@ strs	:: { [String] }
 happyError :: P a
 happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
 
-parsePkgConf :: FilePath -> IO (Either SDoc [PackageConfig])
-parsePkgConf conf_filename = do
+loadPackageConfig :: FilePath -> IO [PackageConfig]
+loadPackageConfig conf_filename = do
    buf <- hGetStringBuffer False conf_filename
    case parse buf PState{ bol = 0#, atbol = 1#,
 	 	          context = [], glasgow_exts = 0#,
   			  loc = mkSrcLoc (_PK_ conf_filename) 1 } of
 	PFailed err -> do
 	    freeStringBuffer buf
-            return (Left err)
+            throwDyn (InstallationError (showSDoc err))
 
 	POk _ pkg_details -> do
 	    freeStringBuffer buf
-	    return (Right pkg_details)
+	    return pkg_details
 }
diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index 876d210..b65b4e9 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -38,6 +38,7 @@ module SysTools (
 	-- Misc
 	showGhcUsage,		-- IO ()	Shows usage message and exits
 	getSysMan,		-- IO String	Parallel system only
+	dosifyPath,		-- String -> String
 
 	runSomething	-- ToDo: make private
  ) where
@@ -65,7 +66,7 @@ import System		( ExitCode(..) )
 #if !defined(mingw32_TARGET_OS)
 import qualified Posix
 #else
-import Ptr              ( nullPtr )
+import Addr              ( nullAddr )
 #endif
 
 #include "HsVersions.h"
@@ -344,8 +345,6 @@ getTopDir minusbs
 	 p1      = dropWhile (not . isSlash) (reverse dir)
 	 p2      = dropWhile (not . isSlash) (tail p1)	-- head is '/'
 	 top_dir = reverse (tail p2)			-- head is '/'
-
-getExecDir = return Nothing
 \end{code}
 
 
@@ -604,18 +603,23 @@ slash s1 s2 = s1 ++ ('/' : s2)
 
 -----------------------------------------------------------------------------
 -- Define	myGetProcessId :: IO Int
+--		getExecDir     :: IO (Maybe String)
 
 #ifdef mingw32_TARGET_OS
 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
-foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
+
 getExecDir :: IO (Maybe String)
-getExecDir = do len <- getCurrentDirectory 0 nullPtr
+getExecDir = return Nothing
+{-
+foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
+getExecDir = do len <- getCurrentDirectory 0 nullAddr
 		buf <- mallocArray (fromIntegral len)
 		ret <- getCurrentDirectory len buf
 		if ret == 0 then return Nothing
 		            else do s <- peekCString buf
 				    destructArray (fromIntegral len) buf
 				    return (Just s)
+-}
 #else
 getProcessID :: IO Int
 getProcessID = Posix.getProcessID
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index b8fce2e..c46b48e 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -62,10 +62,9 @@ import HscTypes		( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
 			  GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
 			  AvailEnv, GenAvailInfo(..), AvailInfo, 
 			  Provenance(..), ImportReason(..), initialVersionInfo,
-			  Deprecations(..),
+			  Deprecations(..), GhciMode(..),
 			  LocalRdrEnv
 			 )
-import CmStaticInfo	( GhciMode(..) )
 import List		( partition, nub )
 \end{code}
 
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index b805da4..7aa2461 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -17,6 +17,7 @@ module Outputable (
 	ifPprDebug, unqualStyle,
 
 	SDoc, 		-- Abstract
+	docToSDoc,
 	interppSP, interpp'SP, pprQuotedList, pprWithCommas,
 	empty, nest,
 	text, char, ptext,
@@ -224,6 +225,9 @@ showSDocDebug d = show (d PprDebug)
 \end{code}
 
 \begin{code}
+docToSDoc :: Doc -> SDoc
+docToSDoc d = \_ -> d
+
 empty sty      = Pretty.empty
 text s sty     = Pretty.text s
 char c sty     = Pretty.char c
-- 
1.7.10.4