Commit 972d6442 authored by simonpj's avatar simonpj

[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
parent 82db18e4
# -----------------------------------------------------------------------------
# $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
......
......@@ -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 )
......
%
% (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}
......@@ -34,7 +34,6 @@ where
import CmLink
import CmTypes
import CmStaticInfo ( GhciMode(..) )
import DriverPipeline
import DriverFlags ( getDynFlags )
import DriverPhases
......
-----------------------------------------------------------------------------
-- $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
......
{-# 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
......
-----------------------------------------------------------------------------
-- $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
......
-----------------------------------------------------------------------------
-- $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
......
......@@ -16,7 +16,7 @@ module Finder (
#include "HsVersions.h"
import HscTypes ( ModuleLocation(..) )
import CmStaticInfo
import Packages ( PackageConfig(..) )
import DriverPhases
import DriverState
import Module
......
......@@ -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 )
......
......@@ -5,6 +5,8 @@
\begin{code}
module HscTypes (
GhciMode(..),
ModuleLocation(..),
ModDetails(..), ModIface(..),
......@@ -82,6 +84,18 @@ import Util ( thenCmp, sortLt )
import UniqSupply ( UniqSupply )
\end{code}
%************************************************************************
%* *
\subsection{Which mode we're in
%* *
%************************************************************************
\begin{code}
data GhciMode = Batch | Interactive | OneShot
deriving Eq
\end{code}
%************************************************************************
%* *
\subsection{Module locations}
......
{-# 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 ()
......
......@@ -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,
......
%
% (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}
{
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
}
......@@ -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
......
......@@ -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}
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment