Current state of the interactive system; can load packages (in theory).
# -----------------------------------------------------------------------------
-# $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
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
, moduleString -- :: Module -> EncodedString
, moduleUserString -- :: Module -> UserString
- , moduleName -- :: Module -> ModuleName
, mkVanillaModule -- :: ModuleName -> Module
, mkPrelModule -- :: UserString -> Module
import CmStaticInfo ( PackageConfigInfo, GhciMode(..) )
import Module ( ModuleName, PackageName )
import Outputable ( SDoc )
+import FiniteMap
import Digraph ( SCC(..), flattenSCC )
import Outputable
import Panic ( panic )
= do putStrLn "LINKER(interactive): not yet implemented"
return (LinkOK pls1)
-
ppLinkableSCC :: SCC Linkable -> SDoc
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
--
--
-----------------------------------------------------------------------------
-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
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
" 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
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"
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
+
+
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
-- ---------------------------------------------------------------------------
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 ()
foreign import "resolveObjs" unsafe
c_resolveObjs :: IO Int
-
-#endif /* __GLASGOW_HASKELL__ <= 408 */
\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
--
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
-----------------------------------------------------------------------------
--- $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
--
-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas
+
getOptionsFromSource
:: String -- input file
-> IO [String] -- options, if any
import HsSyn
import StringBuffer ( hGetStringBuffer )
-import Parser ( parse )
+import Parser
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
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) ;
{-# 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
--
#include "HsVersions.h"
import CompManager
+import InteractiveUI
import DriverPipeline
import DriverState
import DriverFlags
_ -> 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
+
| ITccallconv
| ITinterface -- interface keywords
+ | ITexpr
| IT__export
| ITdepends
| IT__forall
-- interface keywords
("__interface", ITinterface),
+ ("__expr", ITexpr),
("__export", IT__export),
("__depends", ITdepends),
("__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.
-}
{
-module Parser ( parse ) where
+module Parser ( ParseStuff(..), parse ) where
import HsSyn
import HsTypes ( mkHsTupCon )
'{-# DEPRECATED' { ITdeprecated_prag }
'#-}' { ITclose_prag }
+ '__expr' { ITexpr }
+
{-
'__interface' { ITinterface } -- interface keywords
'__export' { IT__export }
%%
-----------------------------------------------------------------------------
+-- 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
-----------------------------------------------------------------------------
{
+data ParseStuff = PModule RdrNameHsModule | PExpr RdrNameHsExpr
+
happyError :: P a
happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc)
}
projects / ghc-hetmet.git / commitdiff