[project @ 2003-02-21 13:02:58 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..ab52f34 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.147 2003/02/20 13:12:40 simonpj Exp $

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

@@ -23,13 +23,14 @@ import MkIface              ( ifaceTyThing )
 import DriverFlags
 import DriverState
 import DriverUtil      ( remove_spaces, handle )
 import DriverFlags
 import DriverState
 import DriverUtil      ( remove_spaces, handle )

-import Linker          ( initLinker, showLinkerState, linkLibraries )
-import Finder          ( flushFinderCache )
+import Linker          ( initLinker, showLinkerState, linkLibraries, 
+                         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,7 +42,7 @@ 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
 
 #ifndef mingw32_TARGET_OS
 import Config
 
 #ifndef mingw32_TARGET_OS

@@ -71,8 +72,6 @@ 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 GHC.Posix       ( setNonBlockingFD )
 import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
 
 import GHC.Posix       ( setNonBlockingFD )

@@ -90,14 +89,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 +110,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.

@@ -157,8 +159,13 @@ interactiveUI cmstate paths cmdline_objs = do
 
    dflags <- getDynFlags
 
 
    dflags <- getDynFlags
 

-       -- packages are loaded "on-demand" now

    initLinker
    initLinker

+
+       -- link packages requested explicitly on the command-line
+   expl <- readIORef v_ExplicitPackages
+   linkPackages dflags expl
+
+       -- link libraries from the command-line

    linkLibraries dflags cmdline_objs
 
        -- Initialise buffering for the *interpreted* I/O system
    linkLibraries dflags cmdline_objs
 
        -- Initialise buffering for the *interpreted* I/O system

@@ -224,7 +231,7 @@ runGHCi paths dflags = do
   -- perform a :load for files given on the GHCi command line
   when (not (null paths)) $
      ghciHandle showException $
   -- perform a :load for files given on the GHCi command line
   when (not (null paths)) $
      ghciHandle showException $

-       loadModule (unwords paths)
+       loadModule paths

 
   -- enter the interactive loop
 #if defined(mingw32_TARGET_OS)
 
   -- enter the interactive loop
 #if defined(mingw32_TARGET_OS)

@@ -349,6 +356,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 +398,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

@@ -494,6 +503,8 @@ info s = do
 
     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 +514,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,9 +531,8 @@ 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.

@@ -587,11 +594,11 @@ 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
 

@@ -699,8 +706,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 +841,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 +918,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 =