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

Current state of the interactive system; can load packages (in theory).

11 files changed, 105 insertions, 101 deletions

diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index 0cdd97a443..a10ac7df29 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
 # -----------------------------------------------------------------------------
-# $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 = ..
 include $(TOP)/mk/boilerplate.mk
@@ -175,12 +175,12 @@ SRC_HC_OPTS += \
 ghc_407_at_least = $(shell expr "$(GhcMinVersion)" \>= 7)
 ifeq "$(ghc_407_at_least)" "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
-SRC_HC_OPTS += -package concurrent -package text
+SRC_HC_OPTS += -package concurrent -package text -package util
 endif
 else
-SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc
+SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc -syslib util
 endif
 
 SRC_CC_OPTS += -Iparser -I. -I$(TOP)/includes -O
diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs
index b12ba5da6f..5676bc29a9 100644
--- a/ghc/compiler/basicTypes/Module.lhs
+++ b/ghc/compiler/basicTypes/Module.lhs
@@ -33,7 +33,6 @@ module Module
 
     , moduleString		-- :: Module -> EncodedString
     , moduleUserString		-- :: Module -> UserString
-    , moduleName		-- :: Module -> ModuleName
 
     , mkVanillaModule	        -- :: ModuleName -> Module
     , mkPrelModule		-- :: UserString -> Module
diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 9940ecae46..811601b1f6 100644
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -18,6 +18,7 @@ import Interpreter
 import CmStaticInfo	( PackageConfigInfo, GhciMode(..) )
 import Module		( ModuleName, PackageName )
 import Outputable	( SDoc )
+import FiniteMap
 import Digraph		( SCC(..), flattenSCC )
 import Outputable
 import Panic		( panic )
@@ -145,7 +146,6 @@ link doLink Interactive batch_attempt_linking linkables pls1
    = do putStrLn "LINKER(interactive): not yet implemented"
         return (LinkOK pls1)
 
-
 ppLinkableSCC :: SCC Linkable -> SDoc
 ppLinkableSCC = ppr . flattenSCC
 
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index fd7f542212..f4193fcf0f 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $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
 --
@@ -7,14 +7,20 @@
 --
 -----------------------------------------------------------------------------
 
-module InteractiveUI where
+module InteractiveUI (interactiveUI) where
 
 import CompManager
+import CmStaticInfo
+import DriverUtil
+import DriverState
+import Linker
 import Module
 import Panic
 import Util
 
+import Exception
 import Readline
+import IOExts
 
 import System
 import Directory
@@ -61,9 +67,14 @@ helpText = "\
 
 interactiveUI :: CmState -> IO ()
 interactiveUI st = do
-   hPutStr stdout ghciWelcomeMsg
+   hPutStrLn stdout ghciWelcomeMsg
    hFlush stdout
    hSetBuffering stdout NoBuffering
+
+   -- link in the available packages
+   pkgs <- getPackageInfo
+   linkPackages (reverse pkgs)
+
 #ifndef NO_READLINE
    Readline.initialize
 #endif
@@ -108,7 +119,7 @@ specialCommand str = do
 			    	       " matches multiple commands (" ++ 
 	         	     	       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
@@ -131,7 +142,7 @@ reloadModule :: String -> GHCi ()
 reloadModule "" = do
   state <- getGHCiState
   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))
   			setGHCiState state{cmstate=new_cmstate}  
 reloadModule _ = noArgs ":reload"
@@ -169,4 +180,34 @@ setGHCiState s = GHCi $ \_ -> return (s,())
 
 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
+
+
diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs
index 440ff11506..c876b0a7f9 100644
--- a/ghc/compiler/ghci/Linker.lhs
+++ b/ghc/compiler/ghci/Linker.lhs
@@ -10,47 +10,13 @@ module Linker (
    unloadObj,    -- :: String -> IO ()
    lookupSymbol, -- :: String -> IO (Maybe Addr)
    resolveObjs,  -- :: IO ()
-   linkPrelude -- tmp
   )  where
 
-import IO
-import Exception
 import Addr
 import PrelByteArr
 import PrelPack 	(packString)
 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
 -- ---------------------------------------------------------------------------
@@ -64,19 +30,19 @@ lookupSymbol str = do
 loadObj str = do
    r <- c_loadObj (packString str)
    if (r == 0)
-	then error "loadObj: failed"
+	then panic "loadObj: failed"
 	else return ()
 
 unloadObj str = do
    r <- c_unloadObj (packString str)
    if (r == 0)
-	then error "unloadObj: failed"
+	then panic "unloadObj: failed"
 	else return ()
 
 resolveObjs = do
    r <- c_resolveObjs
    if (r == 0)
-	then error "resolveObjs: failed"
+	then panic "resolveObjs: failed"
 	else return ()
 
 
@@ -93,6 +59,4 @@ foreign import "unloadObj" unsafe
 
 foreign import "resolveObjs" unsafe
    c_resolveObjs :: IO Int
-
-#endif /* __GLASGOW_HASKELL__ <= 408 */
 \end{code}
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index d6ee6d025c..4b94d287e9 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $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
 --
@@ -439,56 +439,53 @@ addPackage package
 
 getPackageImportPath   :: IO [String]
 getPackageImportPath = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (nub (concat (map import_dirs ps')))
+  ps <- getPackageInfo
+  return (nub (concat (map import_dirs ps)))
 
 getPackageIncludePath   :: IO [String]
 getPackageIncludePath = do
-  ps <- readIORef v_Packages 
-  ps' <- getPackageDetails ps
-  return (nub (filter (not.null) (concatMap include_dirs ps')))
+  ps <- getPackageInfo
+  return (nub (filter (not.null) (concatMap include_dirs ps)))
 
 	-- includes are in reverse dependency order (i.e. rts first)
 getPackageCIncludes   :: IO [String]
 getPackageCIncludes = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (reverse (nub (filter (not.null) (concatMap c_includes ps'))))
+  ps <- getPackageInfo
+  return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
 
 getPackageLibraryPath  :: IO [String]
 getPackageLibraryPath = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (nub (concat (map library_dirs ps')))
+  ps <- getPackageInfo
+  return (nub (concat (map library_dirs ps)))
 
 getPackageLibraries    :: IO [String]
 getPackageLibraries = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
+  ps <- getPackageInfo
   tag <- readIORef v_Build_tag
   let suffix = if null tag then "" else '_':tag
   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 = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (concatMap extra_ghc_opts ps')
+  ps <- getPackageInfo
+  return (concatMap extra_ghc_opts ps)
 
 getPackageExtraCcOpts  :: IO [String]
 getPackageExtraCcOpts = do
-  ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (concatMap extra_cc_opts ps')
+  ps <- getPackageInfo
+  return (concatMap extra_cc_opts ps)
 
 getPackageExtraLdOpts  :: IO [String]
 getPackageExtraLdOpts = do
+  ps <- getPackageInfo
+  return (concatMap extra_ld_opts ps)
+
+getPackageInfo :: IO [Package]
+getPackageInfo = do
   ps <- readIORef v_Packages
-  ps' <- getPackageDetails ps
-  return (concatMap extra_ld_opts ps')
+  getPackageDetails ps
 
 getPackageDetails :: [String] -> IO [Package]
 getPackageDetails ps = do
diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 821599667f..7d6e6eb665 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $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
 --
@@ -70,6 +70,7 @@ instance Typeable BarfKind where
 
 -----------------------------------------------------------------------------
 -- Reading OPTIONS pragmas
+
 getOptionsFromSource 
 	:: String		-- input file
 	-> IO [String]		-- options, if any
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 467306c603..3ba9df3ea7 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -14,7 +14,7 @@ import IO		( hPutStrLn, stderr )
 import HsSyn
 
 import StringBuffer	( hGetStringBuffer )
-import Parser		( parse )
+import Parser
 import Lex		( PState(..), ParseResult(..) )
 import SrcLoc		( mkSrcLoc )
 
@@ -263,7 +263,8 @@ myParseModule dflags src_filename
 
 	PFailed err -> do { hPutStrLn stderr (showSDoc err);
                             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) ;
       
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 109af75d91..8283eb5a86 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# 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
 --
@@ -16,6 +16,7 @@ module Main (main) where
 #include "HsVersions.h"
 
 import CompManager
+import InteractiveUI
 import DriverPipeline
 import DriverState
 import DriverFlags
@@ -281,25 +282,12 @@ beginMake pkg_details mods
 	 _     -> throwDyn (UsageError "only one module allowed with --make")
 
 beginInteractive pkg_details mods
-  = do case mods of
-	 []    -> return ()
-	 [mod] -> do state <- cmInit pkg_details Interactive
-		     cmLoadModule state (mkModuleName mod)
-		     return ()
-	 _     -> throwDyn (UsageError 
+  = do state <- cmInit pkg_details Interactive
+       case mods of
+	   []    -> return ()
+	   [mod] -> do cmLoadModule state (mkModuleName mod); return ()
+	   _     -> throwDyn (UsageError 
 				"only one module allowed with --interactive")
-       interactiveUI
-
-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"
+       interactiveUI state
+
 
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 6c69738d9f..9cd6567c50 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -123,6 +123,7 @@ data Token
   | ITccallconv
 
   | ITinterface			-- interface keywords
+  | ITexpr
   | IT__export
   | ITdepends
   | IT__forall
@@ -295,6 +296,7 @@ ghcExtensionKeywordsFM = listToUFM $
 
 	-- interface keywords
         ("__interface",		ITinterface),
+        ("__expr",		ITexpr),
 	("__export",		IT__export),
 	("__depends",		ITdepends),
 	("__forall",		IT__forall),
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 779c235abe..9dc85a293c 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
-$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.
 
@@ -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 HsTypes		( mkHsTupCon )
@@ -113,6 +113,8 @@ Conflicts: 14 shift/reduce
  '{-# DEPRECATED'  { ITdeprecated_prag }
  '#-}'		   { ITclose_prag }
 
+ '__expr'	{ ITexpr }
+
 {-
  '__interface'	{ ITinterface }			-- interface keywords
  '__export'	{ IT__export }
@@ -202,6 +204,13 @@ Conflicts: 14 shift/reduce
 %%
 
 -----------------------------------------------------------------------------
+-- Entry points
+
+parse   :: { ParseStuff }
+	:  module				{ PModule $1 }
+	|  '__expr' exp				{ PExpr   $2 }
+
+-----------------------------------------------------------------------------
 -- Module Header
 
 -- The place for module deprecation is really too restrictive, but if it
@@ -1096,6 +1105,8 @@ commas :: { Int }
 -----------------------------------------------------------------------------
 
 {
+data ParseStuff = PModule RdrNameHsModule | PExpr RdrNameHsExpr
+
 happyError :: P a
 happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
 }