[project @ 2003-07-02 14:59:00 by simonpj]

[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 5801a38..d8f291c 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
+{-# OPTIONS -#include "Linker.h" #-}

 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------

--- $Id: InteractiveUI.hs,v 1.139 2002/12/12 13:21:46 ross Exp $
+-- $Id: InteractiveUI.hs,v 1.155 2003/07/02 14:59:07 simonpj Exp $

 --
 -- GHC Interactive User Interface
 --
 --
 -- GHC Interactive User Interface
 --

@@ -8,7 +8,7 @@
 --
 -----------------------------------------------------------------------------
 module InteractiveUI ( 
 --
 -----------------------------------------------------------------------------
 module InteractiveUI ( 

-       interactiveUI,  -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO ()
+       interactiveUI,  -- :: CmState -> [FilePath] -> IO ()

        ghciWelcomeMsg
    ) where
 
        ghciWelcomeMsg
    ) where
 

@@ -17,19 +17,19 @@ module InteractiveUI (
 
 import CompManager
 import HscTypes                ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,
 
 import CompManager
 import HscTypes                ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable,

-                         isObjectLinkable )
+                         isObjectLinkable, GhciMode(..) )

 import HsSyn           ( TyClDecl(..), ConDecl(..), Sig(..) )
 import MkIface         ( ifaceTyThing )
 import DriverFlags
 import DriverState
 import HsSyn           ( TyClDecl(..), ConDecl(..), Sig(..) )
 import MkIface         ( ifaceTyThing )
 import DriverFlags
 import DriverState

-import DriverUtil      ( remove_spaces, handle )
-import Linker          ( initLinker, showLinkerState, linkLibraries )
-import Finder          ( flushFinderCache )
+import DriverUtil      ( remove_spaces )
+import Linker          ( showLinkerState, linkPackages )

 import Util
 import Util

-import Id              ( isRecordSelector, recordSelectorFieldLabel, 
-                         isDataConWrapId, isDataConId, idName )
+import IdInfo          ( GlobalIdDetails(..) )
+import Id              ( isImplicitId, idName, globalIdDetails )

 import Class           ( className )
 import TyCon           ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
 import Class           ( className )
 import TyCon           ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )

+import DataCon         ( dataConName )

 import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
 import Module          ( showModMsg, lookupModuleEnv )
 import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
 import Module          ( showModMsg, lookupModuleEnv )

@@ -41,11 +41,15 @@ import Packages
 import Outputable
 import CmdLineOpts     ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
                          restoreDynFlags, dopt_unset )
 import Outputable
 import CmdLineOpts     ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags,
                          restoreDynFlags, dopt_unset )

-import Panic           ( GhcException(..), showGhcException )
+import Panic           hiding ( showException )

 import Config
 
 import Config
 

-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS

 import System.Posix
 import System.Posix

+import DriverUtil( handle )
+#if __GLASGOW_HASKELL__ > 504
+       hiding (getEnv)
+#endif

 #endif
 
 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
 #endif
 
 #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS

@@ -71,11 +75,9 @@ import Control.Monad as Monad
 
 import GHC.Exts                ( unsafeCoerce# )
 
 
 import GHC.Exts                ( unsafeCoerce# )
 

-import Foreign         ( nullPtr )
-import Foreign.C.String        ( CString, peekCString, withCString )

 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 

-import GHC.Posix       ( setNonBlockingFD )
+import System.Posix.Internals ( setNonBlockingFD )

 
 -----------------------------------------------------------------------------
 
 
 -----------------------------------------------------------------------------
 

@@ -90,14 +92,14 @@ GLOBAL_VAR(commands, builtin_commands, [(String, String -> GHCi Bool)])
 
 builtin_commands :: [(String, String -> GHCi Bool)]
 builtin_commands = [
 
 builtin_commands :: [(String, String -> GHCi Bool)]
 builtin_commands = [

-  ("add",      keepGoing addModule),
+  ("add",      keepGoingPaths addModule),

   ("browse",    keepGoing browseCmd),
   ("cd",       keepGoing changeDirectory),
   ("def",      keepGoing defineMacro),
   ("help",     keepGoing help),
   ("?",                keepGoing help),
   ("info",      keepGoing info),
   ("browse",    keepGoing browseCmd),
   ("cd",       keepGoing changeDirectory),
   ("def",      keepGoing defineMacro),
   ("help",     keepGoing help),
   ("?",                keepGoing help),
   ("info",      keepGoing info),

-  ("load",     keepGoing loadModule),
+  ("load",     keepGoingPaths loadModule),

   ("module",   keepGoing setContext),
   ("reload",   keepGoing reloadModule),
   ("set",      keepGoing setCmd),
   ("module",   keepGoing setContext),
   ("reload",   keepGoing reloadModule),
   ("set",      keepGoing setCmd),

@@ -111,6 +113,9 @@ builtin_commands = [
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 

+keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
+keepGoingPaths a str = a (toArgs str) >> return False
+

 shortHelpText = "use :? for help.\n"
 
 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
 shortHelpText = "use :? for help.\n"
 
 -- NOTE: spaces at the end of each line to workaround CPP/string gap bug.

@@ -150,16 +155,14 @@ helpText = "\
 \                         (eg. -v2, -fglasgow-exts, etc.)\n\ 
 \"
 
 \                         (eg. -v2, -fglasgow-exts, etc.)\n\ 
 \"
 

-interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO ()
-interactiveUI cmstate paths cmdline_objs = do
-   hFlush stdout
-   hSetBuffering stdout NoBuffering
-
+interactiveUI :: [FilePath] -> IO ()
+interactiveUI srcs = do

    dflags <- getDynFlags
 
    dflags <- getDynFlags
 

-       -- packages are loaded "on-demand" now
-   initLinker
-   linkLibraries dflags cmdline_objs
+   cmstate <- cmInit Interactive;
+
+   hFlush stdout
+   hSetBuffering stdout NoBuffering

 
        -- Initialise buffering for the *interpreted* I/O system
    cmstate <- initInterpBuffering cmstate dflags
 
        -- Initialise buffering for the *interpreted* I/O system
    cmstate <- initInterpBuffering cmstate dflags

@@ -175,10 +178,10 @@ interactiveUI cmstate paths cmdline_objs = do
    Readline.initialize
 #endif
 
    Readline.initialize
 #endif
 

-   startGHCi (runGHCi paths dflags) 
+   startGHCi (runGHCi srcs dflags) 

        GHCiState{ progname = "<interactive>",
                   args = [],
        GHCiState{ progname = "<interactive>",
                   args = [],

-                  targets = paths,
+                  targets = srcs,

                   cmstate = cmstate,
                   options = [] }
 
                   cmstate = cmstate,
                   options = [] }
 

@@ -221,14 +224,14 @@ runGHCi paths dflags = do
                  Left e    -> return ()
                  Right hdl -> fileLoop hdl False
 
                  Left e    -> return ()
                  Right hdl -> fileLoop hdl False
 

-  -- perform a :load for files given on the GHCi command line
+  -- Perform a :load for files given on the GHCi command line

   when (not (null paths)) $
      ghciHandle showException $
   when (not (null paths)) $
      ghciHandle showException $

-       loadModule (unwords paths)
+       loadModule paths

 
   -- enter the interactive loop
 
   -- enter the interactive loop

-#if defined(mingw32_TARGET_OS)
-   -- always show prompt, since hIsTerminalDevice returns True for Consoles
+#if defined(mingw32_HOST_OS)
+   -- Always show prompt, since hIsTerminalDevice returns True for Consoles

    -- only, which we may or may not be running under (cf. Emacs sub-shells.)
   interactiveLoop True
 #else
    -- only, which we may or may not be running under (cf. Emacs sub-shells.)
   interactiveLoop True
 #else

@@ -241,7 +244,7 @@ runGHCi paths dflags = do
 
 
 interactiveLoop is_tty = do
 
 
 interactiveLoop is_tty = do

-  -- ignore ^C exceptions caught here
+  -- Ignore ^C exceptions caught here

   ghciHandleDyn (\e -> case e of 
                        Interrupted -> ghciUnblock (interactiveLoop is_tty)
                        _other      -> return ()) $ do
   ghciHandleDyn (\e -> case e of 
                        Interrupted -> ghciUnblock (interactiveLoop is_tty)
                        _other      -> return ()) $ do

@@ -267,7 +270,7 @@ interactiveLoop is_tty = do
 
 checkPerms :: String -> IO Bool
 checkPerms name =
 
 checkPerms :: String -> IO Bool
 checkPerms name =

-#ifdef mingw32_TARGET_OS
+#ifdef mingw32_HOST_OS

   return True
 #else
   DriverUtil.handle (\_ -> return False) $ do
   return True
 #else
   DriverUtil.handle (\_ -> return False) $ do

@@ -349,6 +352,7 @@ runCommand c = ghciHandle handler (doCommand c)
 handler :: Exception -> GHCi Bool
 handler exception = do
   flushInterpBuffers
 handler :: Exception -> GHCi Bool
 handler exception = do
   flushInterpBuffers

+  io installSignalHandlers

   ghciHandle handler (showException exception >> return False)
 
 showException (DynException dyn) =
   ghciHandle handler (showException exception >> return False)
 
 showException (DynException dyn) =

@@ -390,6 +394,7 @@ finishEvalExpr names
       when b (mapM_ (showTypeOfName cmstate) names)
 
       flushInterpBuffers
       when b (mapM_ (showTypeOfName cmstate) names)
 
       flushInterpBuffers

+      io installSignalHandlers

       b <- isOptionSet RevertCAFs
       io (when b revertCAFs)
       return True
       b <- isOptionSet RevertCAFs
       io (when b revertCAFs)
       return True

@@ -489,11 +494,13 @@ info s = do
        | fix == defaultFixity = empty
        | otherwise            = ppr fix <+> 
                                 (if isSymOcc (nameOccName name)
        | fix == defaultFixity = empty
        | otherwise            = ppr fix <+> 
                                 (if isSymOcc (nameOccName name)

-                                       then ppr name
-                                       else char '`' <> ppr name <> char '`')
+                                 then ppr name
+                                 else char '`' <> ppr name <> char '`')

 
     showTyThing (AClass cl)
        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
 
     showTyThing (AClass cl)
        = hcat [ppr cl, text " is a class", showSrcLoc (className cl)]

+    showTyThing (ADataCon dc)
+       = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]

     showTyThing (ATyCon ty)
        | isPrimTyCon ty
        = hcat [ppr ty, text " is a primitive type constructor"]
     showTyThing (ATyCon ty)
        | isPrimTyCon ty
        = hcat [ppr ty, text " is a primitive type constructor"]

@@ -503,13 +510,10 @@ info s = do
        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 
     idDescr id
        = hcat [ppr id, text " is a ", idDescr id, showSrcLoc (idName id)]
 
     idDescr id

-       | isRecordSelector id = 
-               case tyConClass_maybe (fieldLabelTyCon (
-                               recordSelectorFieldLabel id)) of
-                       Nothing -> text "record selector"
-                       Just c  -> text "method in class " <> ppr c
-       | isDataConWrapId id  = text "data constructor"
-       | otherwise           = text "variable"
+       = case globalIdDetails id of
+           RecordSelId lbl -> text "record selector for type" <+> ppr (fieldLabelTyCon lbl)
+           ClassOpId cls   -> text "method in class" <+> ppr cls
+                   otherwise       -> text "variable"

 
        -- also print out the source location for home things
     showSrcLoc name
 
        -- also print out the source location for home things
     showSrcLoc name

@@ -523,12 +527,12 @@ info s = do
   setCmState cms
   return ()
 
   setCmState cms
   return ()
 

-addModule :: String -> GHCi ()
-addModule str = do
-  let files = words str
+addModule :: [FilePath] -> GHCi ()
+addModule files = do

   state <- getGHCiState
   dflags <- io (getDynFlags)
   io (revertCAFs)                      -- always revert CAFs on load/add.
   state <- getGHCiState
   dflags <- io (getDynFlags)
   io (revertCAFs)                      -- always revert CAFs on load/add.

+  files <- mapM expandPath files

   let new_targets = files ++ targets state 
   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)
   let new_targets = files ++ targets state 
   graph <- io (cmDepAnal (cmstate state) dflags new_targets)
   (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph)

@@ -537,10 +541,9 @@ addModule str = do
   modulesLoadedMsg ok mods dflags
 
 changeDirectory :: String -> GHCi ()
   modulesLoadedMsg ok mods dflags
 
 changeDirectory :: String -> GHCi ()

-changeDirectory ('~':d) = do
-   tilde <- io (getEnv "HOME") -- will fail if HOME not defined
-   io (setCurrentDirectory (tilde ++ '/':d))
-changeDirectory d = io (setCurrentDirectory d)
+changeDirectory dir = do
+  dir <- expandPath dir
+  io (setCurrentDirectory dir)

 
 defineMacro :: String -> GHCi ()
 defineMacro s = do
 
 defineMacro :: String -> GHCi ()
 defineMacro s = do

@@ -587,14 +590,17 @@ undefineMacro macro_name = do
   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 
 
   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 
 

-loadModule :: String -> GHCi ()
-loadModule str = timeIt (loadModule' str)
+loadModule :: [FilePath] -> GHCi ()
+loadModule fs = timeIt (loadModule' fs)

 
 

-loadModule' str = do
-  let files = words str
+loadModule' :: [FilePath] -> GHCi ()
+loadModule' files = do

   state <- getGHCiState
   dflags <- io getDynFlags
 
   state <- getGHCiState
   dflags <- io getDynFlags
 

+  -- expand tildes
+  files <- mapM expandPath files
+

   -- do the dependency anal first, so that if it fails we don't throw
   -- away the current set of modules.
   graph <- io (cmDepAnal (cmstate state) dflags files)
   -- do the dependency anal first, so that if it fails we don't throw
   -- away the current set of modules.
   graph <- io (cmDepAnal (cmstate state) dflags files)

@@ -699,8 +705,9 @@ browseModule m exports_only = do
 
       things' = filter wantToSee things
 
 
       things' = filter wantToSee things
 

-      wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
-      wantToSee _ = True
+      wantToSee (AnId id)    = not (isImplicitId id)
+      wantToSee (ADataCon _) = False   -- They'll come via their TyCon
+      wantToSee _           = True

 
       thing_names = map getName things
 
 
       thing_names = map getName things
 

@@ -833,9 +840,9 @@ setOptions wds =
       mapM_ setOpt plus_opts
 
       -- now, the GHC flags
       mapM_ setOpt plus_opts
 
       -- now, the GHC flags

-      pkgs_before <- io (readIORef v_Packages)
+      pkgs_before <- io (readIORef v_ExplicitPackages)

       leftovers   <- io (processArgs static_flags minus_opts [])
       leftovers   <- io (processArgs static_flags minus_opts [])

-      pkgs_after  <- io (readIORef v_Packages)
+      pkgs_after  <- io (readIORef v_ExplicitPackages)

 
       -- update things if the users wants more packages
       let new_packages = pkgs_after \\ pkgs_before
 
       -- update things if the users wants more packages
       let new_packages = pkgs_after \\ pkgs_before

@@ -910,9 +917,10 @@ newPackages new_pkgs = do  -- The new packages are already in v_Packages
   dflags   <- io getDynFlags
   cmstate1 <- io (cmUnload (cmstate state) dflags)
   setGHCiState state{ cmstate = cmstate1, targets = [] }
   dflags   <- io getDynFlags
   cmstate1 <- io (cmUnload (cmstate state) dflags)
   setGHCiState state{ cmstate = cmstate1, targets = [] }

+  io (linkPackages dflags new_pkgs)

   setContextAfterLoad []
 
   setContextAfterLoad []
 

------------------------------------------------------------------------------
+-- ---------------------------------------------------------------------------

 -- code for `:show'
 
 showCmd str =
 -- code for `:show'
 
 showCmd str =

@@ -1058,3 +1066,15 @@ revertCAFs = do
 
 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
        -- Make it "safe", just in case
 
 foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
        -- Make it "safe", just in case

+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+expandPath :: String -> GHCi String
+expandPath path = 
+  case dropWhile isSpace path of
+   ('~':d) -> do
+       tilde <- io (getEnv "HOME")     -- will fail if HOME not defined
+       return (tilde ++ '/':d)
+   other -> 
+       return other