Commit 292c077d authored by simonmar's avatar simonmar
Browse files

[project @ 2000-11-16 11:39:36 by simonmar]

Current state of the interactive system; can load packages (in theory).
parent 8894fd85
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------
# $Id: Makefile,v 1.113 2000/11/10 14:29:20 simonmar Exp $ # $Id: Makefile,v 1.114 2000/11/16 11:39:36 simonmar Exp $
TOP = .. TOP = ..
include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/boilerplate.mk
...@@ -175,12 +175,12 @@ SRC_HC_OPTS += \ ...@@ -175,12 +175,12 @@ SRC_HC_OPTS += \
ghc_407_at_least = $(shell expr "$(GhcMinVersion)" \>= 7) ghc_407_at_least = $(shell expr "$(GhcMinVersion)" \>= 7)
ifeq "$(ghc_407_at_least)" "1" ifeq "$(ghc_407_at_least)" "1"
ifneq "$(mingw32_TARGET_OS)" "1" ifneq "$(mingw32_TARGET_OS)" "1"
SRC_HC_OPTS += -package concurrent -package posix -package text SRC_HC_OPTS += -package concurrent -package posix -package text -package util
else else
SRC_HC_OPTS += -package concurrent -package text SRC_HC_OPTS += -package concurrent -package text -package util
endif endif
else else
SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc -syslib util
endif endif
SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O
......
...@@ -33,7 +33,6 @@ module Module ...@@ -33,7 +33,6 @@ module Module
, moduleString -- :: Module -> EncodedString , moduleString -- :: Module -> EncodedString
, moduleUserString -- :: Module -> UserString , moduleUserString -- :: Module -> UserString
, moduleName -- :: Module -> ModuleName
, mkVanillaModule -- :: ModuleName -> Module , mkVanillaModule -- :: ModuleName -> Module
, mkPrelModule -- :: UserString -> Module , mkPrelModule -- :: UserString -> Module
......
...@@ -18,6 +18,7 @@ import Interpreter ...@@ -18,6 +18,7 @@ import Interpreter
import CmStaticInfo ( PackageConfigInfo, GhciMode(..) ) import CmStaticInfo ( PackageConfigInfo, GhciMode(..) )
import Module ( ModuleName, PackageName ) import Module ( ModuleName, PackageName )
import Outputable ( SDoc ) import Outputable ( SDoc )
import FiniteMap
import Digraph ( SCC(..), flattenSCC ) import Digraph ( SCC(..), flattenSCC )
import Outputable import Outputable
import Panic ( panic ) import Panic ( panic )
...@@ -145,7 +146,6 @@ link doLink Interactive batch_attempt_linking linkables pls1 ...@@ -145,7 +146,6 @@ link doLink Interactive batch_attempt_linking linkables pls1
= do putStrLn "LINKER(interactive): not yet implemented" = do putStrLn "LINKER(interactive): not yet implemented"
return (LinkOK pls1) return (LinkOK pls1)
ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC :: SCC Linkable -> SDoc
ppLinkableSCC = ppr . flattenSCC ppLinkableSCC = ppr . flattenSCC
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.1 2000/11/16 10:48:22 simonmar Exp $ -- $Id: InteractiveUI.hs,v 1.2 2000/11/16 11:39:37 simonmar Exp $
-- --
-- GHC Interactive User Interface -- GHC Interactive User Interface
-- --
...@@ -7,14 +7,20 @@ ...@@ -7,14 +7,20 @@
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module InteractiveUI where module InteractiveUI (interactiveUI) where
import CompManager import CompManager
import CmStaticInfo
import DriverUtil
import DriverState
import Linker
import Module import Module
import Panic import Panic
import Util import Util
import Exception
import Readline import Readline
import IOExts
import System import System
import Directory import Directory
...@@ -61,9 +67,14 @@ helpText = "\ ...@@ -61,9 +67,14 @@ helpText = "\
interactiveUI :: CmState -> IO () interactiveUI :: CmState -> IO ()
interactiveUI st = do interactiveUI st = do
hPutStr stdout ghciWelcomeMsg hPutStrLn stdout ghciWelcomeMsg
hFlush stdout hFlush stdout
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
-- link in the available packages
pkgs <- getPackageInfo
linkPackages (reverse pkgs)
#ifndef NO_READLINE #ifndef NO_READLINE
Readline.initialize Readline.initialize
#endif #endif
...@@ -108,7 +119,7 @@ specialCommand str = do ...@@ -108,7 +119,7 @@ specialCommand str = do
" matches multiple commands (" ++ " matches multiple commands (" ++
foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")") foldr1 (\a b -> a ++ ',':b) (map fst cs) ++ ")")
noArgs c = io (hPutStr stdout ("command `:" ++ c ++ "' takes no arguments")) noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments"))
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Commands -- Commands
...@@ -131,7 +142,7 @@ reloadModule :: String -> GHCi () ...@@ -131,7 +142,7 @@ reloadModule :: String -> GHCi ()
reloadModule "" = do reloadModule "" = do
state <- getGHCiState state <- getGHCiState
case target state of case target state of
Nothing -> io (hPutStr stdout "no current target") Nothing -> io (putStr "no current target\n")
Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path)) Just path -> do (new_cmstate, mod) <- io (cmLoadModule (cmstate state) (mkModuleName path))
setGHCiState state{cmstate=new_cmstate} setGHCiState state{cmstate=new_cmstate}
reloadModule _ = noArgs ":reload" reloadModule _ = noArgs ":reload"
...@@ -169,4 +180,34 @@ setGHCiState s = GHCi $ \_ -> return (s,()) ...@@ -169,4 +180,34 @@ setGHCiState s = GHCi $ \_ -> return (s,())
io m = GHCi $ \s -> m >>= \a -> return (s,a) io m = GHCi $ \s -> m >>= \a -> return (s,a)
myCatch (GHCi m) h = GHCi $ \s -> catch (m s) (\e -> unGHCi (h e) s) myCatch (GHCi m) h = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s)
-----------------------------------------------------------------------------
-- package loader
linkPackages :: [Package] -> IO ()
linkPackages pkgs = mapM_ linkPackage pkgs
linkPackage :: Package -> IO ()
-- ignore rts and gmp for now (ToDo; better?)
linkPackage pkg | name pkg `elem` ["rts", "gmp"] = return ()
linkPackage pkg = do
putStr ("Loading package " ++ name pkg ++ " ... ")
let dirs = library_dirs pkg
let objs = map (++".o") (hs_libraries pkg ++ extra_libraries pkg)
mapM (linkOneObj dirs) objs
putStr "resolving ... "
resolveObjs
putStrLn "done."
linkOneObj dirs obj = do
filename <- findFile dirs obj
loadObj filename
findFile [] obj = throwDyn (OtherError ("can't find " ++ obj))
findFile (d:ds) obj = do
let path = d ++ '/':obj
b <- doesFileExist path
if b then return path else findFile ds obj
...@@ -10,47 +10,13 @@ module Linker ( ...@@ -10,47 +10,13 @@ module Linker (
unloadObj, -- :: String -> IO () unloadObj, -- :: String -> IO ()
lookupSymbol, -- :: String -> IO (Maybe Addr) lookupSymbol, -- :: String -> IO (Maybe Addr)
resolveObjs, -- :: IO () resolveObjs, -- :: IO ()
linkPrelude -- tmp
) where ) where
import IO
import Exception
import Addr import Addr
import PrelByteArr import PrelByteArr
import PrelPack (packString) import PrelPack (packString)
import Panic ( panic ) import Panic ( panic )
#if __GLASGOW_HASKELL__ <= 408
loadObj = bogus "loadObj"
unloadObj = bogus "unloadObj"
lookupSymbol = bogus "lookupSymbol"
resolveObjs = bogus "resolveObjs"
linkPrelude = bogus "linkPrelude"
bogus f = panic ("Linker." ++ f ++ ": this hsc was built without an interpreter.")
#else
linkPrelude = do
hPutStr stderr "Loading HSstd_cbits.o..."
loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
hPutStr stderr "done.\n"
hPutStr stderr "Resolving..."
resolveObjs
hPutStr stderr "done.\n"
hPutStr stderr "Loading HSstd.o..."
loadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
hPutStr stderr "done.\n"
hPutStr stderr "Resolving..."
resolveObjs
hPutStr stderr "done.\n"
{-
hPutStr stderr "Unloading HSstd.o..."
unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/HSstd.o"
hPutStr stderr "done.\n"
unloadObj "/home/simonmar/builds/i386-unknown-linux-boot/ghc/lib/std/cbits/HSstd_cbits.o"
hPutStr stderr "done.\n"
-}
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
-- RTS Linker Interface -- RTS Linker Interface
-- --------------------------------------------------------------------------- -- ---------------------------------------------------------------------------
...@@ -64,19 +30,19 @@ lookupSymbol str = do ...@@ -64,19 +30,19 @@ lookupSymbol str = do
loadObj str = do loadObj str = do
r <- c_loadObj (packString str) r <- c_loadObj (packString str)
if (r == 0) if (r == 0)
then error "loadObj: failed" then panic "loadObj: failed"
else return () else return ()
unloadObj str = do unloadObj str = do
r <- c_unloadObj (packString str) r <- c_unloadObj (packString str)
if (r == 0) if (r == 0)
then error "unloadObj: failed" then panic "unloadObj: failed"
else return () else return ()
resolveObjs = do resolveObjs = do
r <- c_resolveObjs r <- c_resolveObjs
if (r == 0) if (r == 0)
then error "resolveObjs: failed" then panic "resolveObjs: failed"
else return () else return ()
...@@ -93,6 +59,4 @@ foreign import "unloadObj" unsafe ...@@ -93,6 +59,4 @@ foreign import "unloadObj" unsafe
foreign import "resolveObjs" unsafe foreign import "resolveObjs" unsafe
c_resolveObjs :: IO Int c_resolveObjs :: IO Int
#endif /* __GLASGOW_HASKELL__ <= 408 */
\end{code} \end{code}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: DriverState.hs,v 1.13 2000/11/14 16:28:38 simonmar Exp $ -- $Id: DriverState.hs,v 1.14 2000/11/16 11:39:37 simonmar Exp $
-- --
-- Settings for the driver -- Settings for the driver
-- --
...@@ -439,56 +439,53 @@ addPackage package ...@@ -439,56 +439,53 @@ addPackage package
getPackageImportPath :: IO [String] getPackageImportPath :: IO [String]
getPackageImportPath = do getPackageImportPath = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (nub (concat (map import_dirs ps)))
return (nub (concat (map import_dirs ps')))
getPackageIncludePath :: IO [String] getPackageIncludePath :: IO [String]
getPackageIncludePath = do getPackageIncludePath = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (nub (filter (not.null) (concatMap include_dirs ps)))
return (nub (filter (not.null) (concatMap include_dirs ps')))
-- includes are in reverse dependency order (i.e. rts first) -- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String] getPackageCIncludes :: IO [String]
getPackageCIncludes = do getPackageCIncludes = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
getPackageLibraryPath :: IO [String] getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do getPackageLibraryPath = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (nub (concat (map library_dirs ps)))
return (nub (concat (map library_dirs ps')))
getPackageLibraries :: IO [String] getPackageLibraries :: IO [String]
getPackageLibraries = do getPackageLibraries = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps
tag <- readIORef v_Build_tag tag <- readIORef v_Build_tag
let suffix = if null tag then "" else '_':tag let suffix = if null tag then "" else '_':tag
return (concat ( return (concat (
map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps' map (\p -> map (++suffix) (hs_libraries p) ++ extra_libraries p) ps
)) ))
getPackageExtraGhcOpts :: IO [String] getPackageExtraGhcOpts :: IO [String]
getPackageExtraGhcOpts = do getPackageExtraGhcOpts = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (concatMap extra_ghc_opts ps)
return (concatMap extra_ghc_opts ps')
getPackageExtraCcOpts :: IO [String] getPackageExtraCcOpts :: IO [String]
getPackageExtraCcOpts = do getPackageExtraCcOpts = do
ps <- readIORef v_Packages ps <- getPackageInfo
ps' <- getPackageDetails ps return (concatMap extra_cc_opts ps)
return (concatMap extra_cc_opts ps')
getPackageExtraLdOpts :: IO [String] getPackageExtraLdOpts :: IO [String]
getPackageExtraLdOpts = do getPackageExtraLdOpts = do
ps <- getPackageInfo
return (concatMap extra_ld_opts ps)
getPackageInfo :: IO [Package]
getPackageInfo = do
ps <- readIORef v_Packages ps <- readIORef v_Packages
ps' <- getPackageDetails ps getPackageDetails ps
return (concatMap extra_ld_opts ps')
getPackageDetails :: [String] -> IO [Package] getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do getPackageDetails ps = do
......
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: DriverUtil.hs,v 1.6 2000/11/10 14:29:21 simonmar Exp $ -- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $
-- --
-- Utils for the driver -- Utils for the driver
-- --
...@@ -70,6 +70,7 @@ instance Typeable BarfKind where ...@@ -70,6 +70,7 @@ instance Typeable BarfKind where
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Reading OPTIONS pragmas -- Reading OPTIONS pragmas
getOptionsFromSource getOptionsFromSource
:: String -- input file :: String -- input file
-> IO [String] -- options, if any -> IO [String] -- options, if any
......
...@@ -14,7 +14,7 @@ import IO ( hPutStrLn, stderr ) ...@@ -14,7 +14,7 @@ import IO ( hPutStrLn, stderr )
import HsSyn import HsSyn
import StringBuffer ( hGetStringBuffer ) import StringBuffer ( hGetStringBuffer )
import Parser ( parse ) import Parser
import Lex ( PState(..), ParseResult(..) ) import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc ) import SrcLoc ( mkSrcLoc )
...@@ -263,7 +263,8 @@ myParseModule dflags src_filename ...@@ -263,7 +263,8 @@ myParseModule dflags src_filename
PFailed err -> do { hPutStrLn stderr (showSDoc err); PFailed err -> do { hPutStrLn stderr (showSDoc err);
return Nothing }; return Nothing };
POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
POk _ (PModule rdr_module@(HsModule mod_name _ _ _ _ _ _)) -> do {
dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;
......
{-# OPTIONS -W -fno-warn-incomplete-patterns #-} {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- $Id: Main.hs,v 1.22 2000/11/15 10:49:54 sewardj Exp $ -- $Id: Main.hs,v 1.23 2000/11/16 11:39:37 simonmar Exp $
-- --
-- GHC Driver program -- GHC Driver program
-- --
...@@ -16,6 +16,7 @@ module Main (main) where ...@@ -16,6 +16,7 @@ module Main (main) where
#include "HsVersions.h" #include "HsVersions.h"
import CompManager import CompManager
import InteractiveUI
import DriverPipeline import DriverPipeline
import DriverState import DriverState
import DriverFlags import DriverFlags
...@@ -281,25 +282,12 @@ beginMake pkg_details mods ...@@ -281,25 +282,12 @@ beginMake pkg_details mods
_ -> throwDyn (UsageError "only one module allowed with --make") _ -> throwDyn (UsageError "only one module allowed with --make")
beginInteractive pkg_details mods beginInteractive pkg_details mods
= do case mods of = do state <- cmInit pkg_details Interactive
[] -> return () case mods of
[mod] -> do state <- cmInit pkg_details Interactive [] -> return ()
cmLoadModule state (mkModuleName mod) [mod] -> do cmLoadModule state (mkModuleName mod); return ()
return () _ -> throwDyn (UsageError
_ -> throwDyn (UsageError
"only one module allowed with --interactive") "only one module allowed with --interactive")
interactiveUI interactiveUI state
interactiveUI :: IO ()
interactiveUI = do
hPutStr stdout ghciWelcomeMsg
throwDyn (OtherError "GHCi not implemented yet")
ghciWelcomeMsg = "\
\ _____ __ __ ____ ------------------------------------------------\n\
\(| || || (| |) GHCi: GHC Interactive, version 5.00 \n\
\|| __ ||___|| || () For Haskell 98. \n\
\|| |) ||---|| || // http://www.haskell.org/ghc \n\
\|| || || || || // Bug reports to: glasgow-haskell-bugs@haskell.org\n\
\(|___|| || || (|__|) (| ________________________________________________\n"
...@@ -123,6 +123,7 @@ data Token ...@@ -123,6 +123,7 @@ data Token
| ITccallconv | ITccallconv
| ITinterface -- interface keywords | ITinterface -- interface keywords
| ITexpr
| IT__export | IT__export
| ITdepends | ITdepends
| IT__forall | IT__forall
...@@ -295,6 +296,7 @@ ghcExtensionKeywordsFM = listToUFM $ ...@@ -295,6 +296,7 @@ ghcExtensionKeywordsFM = listToUFM $
-- interface keywords -- interface keywords
("__interface", ITinterface), ("__interface", ITinterface),
("__expr", ITexpr),
("__export", IT__export), ("__export", IT__export),
("__depends", ITdepends), ("__depends", ITdepends),
("__forall", IT__forall), ("__forall", IT__forall),
......
{- {-
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
$Id: Parser.y,v 1.47 2000/11/07 15:21:40 simonmar Exp $ $Id: Parser.y,v 1.48 2000/11/16 11:39:37 simonmar Exp $
Haskell grammar. Haskell grammar.
...@@ -9,7 +9,7 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 ...@@ -9,7 +9,7 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999
-} -}
{ {
module Parser ( parse ) where module Parser ( ParseStuff(..), parse ) where
import HsSyn import HsSyn
import HsTypes ( mkHsTupCon ) import HsTypes ( mkHsTupCon )
...@@ -113,6 +113,8 @@ Conflicts: 14 shift/reduce ...@@ -113,6 +113,8 @@ Conflicts: 14 shift/reduce
'{-# DEPRECATED' { ITdeprecated_prag } '{-# DEPRECATED' { ITdeprecated_prag }
'#-}' { ITclose_prag } '#-}' { ITclose_prag }
'__expr' { ITexpr }
{- {-
'__interface' { ITinterface } -- interface keywords '__interface' { ITinterface } -- interface keywords
'__export' { IT__export } '__export' { IT__export }
...@@ -201,6 +203,13 @@ Conflicts: 14 shift/reduce ...@@ -201,6 +203,13 @@ Conflicts: 14 shift/reduce
%tokentype { Token } %tokentype { Token }
%% %%
-----------------------------------------------------------------------------
-- Entry points
parse :: { ParseStuff }
: module { PModule $1 }
| '__expr' exp { PExpr $2 }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Module Header -- Module Header
...@@ -1096,6 +1105,8 @@ commas :: { Int } ...@@ -1096,6 +1105,8 @@ commas :: { Int }
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{ {
data ParseStuff = PModule RdrNameHsModule | PExpr RdrNameHsExpr
happyError :: P a happyError :: P a
happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc) happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
} }
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