Retrieving the datacon of an arbitrary closure

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 8a20fb1..b4c1f6e 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -3,7 +3,7 @@
 --
 -- GHC Interactive User Interface
 --
 --
 -- GHC Interactive User Interface
 --

--- (c) The GHC Team 2005
+-- (c) The GHC Team 2005-2006

 --
 -----------------------------------------------------------------------------
 module InteractiveUI ( 
 --
 -----------------------------------------------------------------------------
 module InteractiveUI ( 

@@ -17,47 +17,40 @@ module InteractiveUI (
 import GHC.Exts         ( Int(..), Ptr(..), int2Addr# )
 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
 import System.IO.Unsafe ( unsafePerformIO )
 import GHC.Exts         ( Int(..), Ptr(..), int2Addr# )
 import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
 import System.IO.Unsafe ( unsafePerformIO )

-import Var              ( Id, globaliseId, idName, idType )
-import HscTypes         ( Session(..), InteractiveContext(..), HscEnv(..)
-                        , extendTypeEnvWithIds )
-import RdrName          ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
-import NameEnv          ( delListFromNameEnv )
-import TcType           ( tidyTopType )
-import qualified Id     ( setIdType )
-import IdInfo           ( GlobalIdDetails(..) )
-import Linker           ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker  )
-import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
+import Var
+import HscTypes
+import RdrName
+import NameEnv
+import TcType
+import qualified Id
+import IdInfo
+import PrelNames

 #endif
 
 -- The GHC interface
 import qualified GHC
 #endif
 
 -- The GHC interface
 import qualified GHC

-import GHC             ( Session, dopt, DynFlag(..), Target(..),
-                         TargetId(..), DynFlags(..),
-                         pprModule, Type, Module, ModuleName, SuccessFlag(..),
-                         TyThing(..), Name, LoadHowMuch(..), Phase,
-                         GhcException(..), showGhcException,
-                         CheckedModule(..), SrcLoc )
-import DynFlags         ( allFlags )
-import Packages                ( PackageState(..) )
-import PackageConfig   ( InstalledPackageInfo(..) )
-import UniqFM          ( eltsUFM )
+import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
+                          Type, Module, ModuleName, TyThing(..), Phase )
+import DynFlags
+import Packages
+import PackageConfig
+import UniqFM

 import PprTyThing
 import Outputable
 
 import PprTyThing
 import Outputable
 

--- for createtags (should these come via GHC?)
-import Name            ( nameSrcLoc, nameModule, nameOccName )
-import OccName         ( pprOccName )
-import SrcLoc          ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+-- for createtags
+import Name
+import OccName
+import SrcLoc

 
 -- Other random utilities
 
 -- Other random utilities

-import Digraph         ( flattenSCCs )
-import BasicTypes      ( failed, successIf )
-import Panic           ( panic, installSignalHandlers )
+import Digraph
+import BasicTypes
+import Panic hiding (showException)

 import Config
 import Config

-import StaticFlags     ( opt_IgnoreDotGhci )
-import Linker          ( showLinkerState )
-import Util            ( removeSpaces, handle, global, toArgs,
-                         looksLikeModuleName, prefixMatch, sortLe )
+import StaticFlags
+import Linker
+import Util

 
 #ifndef mingw32_HOST_OS
 import System.Posix
 
 #ifndef mingw32_HOST_OS
 import System.Posix

@@ -67,6 +60,7 @@ import System.Posix
 #else
 import GHC.ConsoleHandler ( flushConsole )
 import System.Win32      ( setConsoleCP, setConsoleOutputCP )
 #else
 import GHC.ConsoleHandler ( flushConsole )
 import System.Win32      ( setConsoleCP, setConsoleOutputCP )

+import qualified System.Win32

 #endif
 
 #ifdef USE_READLINE
 #endif
 
 #ifdef USE_READLINE

@@ -83,7 +77,7 @@ import Data.Dynamic
 import Numeric
 import Data.List
 import Data.Int                ( Int64 )
 import Numeric
 import Data.List
 import Data.Int                ( Int64 )

-import Data.Maybe      ( isJust, fromMaybe, catMaybes )
+import Data.Maybe      ( isJust, isNothing, fromMaybe, catMaybes )

 import System.Cmd
 import System.CPUTime
 import System.Environment
 import System.Cmd
 import System.CPUTime
 import System.Environment

@@ -122,6 +116,9 @@ builtin_commands = [
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("def",      keepGoing defineMacro,          False, completeIdentifier),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("def",      keepGoing defineMacro,          False, completeIdentifier),

+  ("e",        keepGoing editFile,             False, completeFilename),
+       -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+  ("edit",     keepGoing editFile,             False, completeFilename),

   ("help",     keepGoing help,                 False, completeNone),
   ("?",                keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("help",     keepGoing help,                 False, completeNone),
   ("?",                keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),

@@ -158,6 +155,8 @@ helpText =
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++

+ "   :edit <file>                edit file\n" ++
+ "   :edit                       edit last module\n" ++

  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++

@@ -169,12 +168,13 @@ helpText =
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++

+ "   :set editor <cmd>           set the command used for :edit\n" ++

  "\n" ++
  "   :show modules               show the currently loaded modules\n" ++
  "   :show bindings              show the current bindings made at the prompt\n" ++
  "\n" ++
  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
  "\n" ++
  "   :show modules               show the currently loaded modules\n" ++
  "   :show bindings              show the current bindings made at the prompt\n" ++
  "\n" ++
  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++

- "   :etags [<file>]                    create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++

  "   :type <expr>                show the type of <expr>\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++

@@ -241,11 +241,13 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b
          writeIORef ref (hsc_env { hsc_IC = new_ic })
          is_tty <- hIsTerminalDevice stdin
          prel_mod <- GHC.findModule session prel_name Nothing
          writeIORef ref (hsc_env { hsc_IC = new_ic })
          is_tty <- hIsTerminalDevice stdin
          prel_mod <- GHC.findModule session prel_name Nothing

+        default_editor <- findEditor

          withExtendedLinkEnv (zip names hValues) $
            startGHCi (interactiveLoop is_tty True)
                      GHCiState{ progname = "<interactive>",
                                 args = [],
                                 prompt = location++"> ",
          withExtendedLinkEnv (zip names hValues) $
            startGHCi (interactiveLoop is_tty True)
                      GHCiState{ progname = "<interactive>",
                                 args = [],
                                 prompt = location++"> ",

+                               editor = default_editor,

                                 session = session,
                                 options = [],
                                 prelude =  prel_mod }
                                 session = session,
                                 options = [],
                                 prelude =  prel_mod }

@@ -254,6 +256,16 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b
          return b
 #endif
 
          return b
 #endif
 

+findEditor = do
+  getEnv "EDITOR" 
+    `IO.catch` \_ -> do
+#if mingw32_HOST_OS
+       win <- System.Win32.getWindowsDirectory
+       return (win `joinFileName` "notepad.exe")
+#else
+       return ""
+#endif
+

 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 interactiveUI session srcs maybe_expr = do
 #if defined(GHCI) && defined(BREAKPOINT)
 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 interactiveUI session srcs maybe_expr = do
 #if defined(GHCI) && defined(BREAKPOINT)

@@ -273,15 +285,19 @@ interactiveUI session srcs maybe_expr = do
    newStablePtr stdout
    newStablePtr stderr
 
    newStablePtr stdout
    newStablePtr stderr
 

-   hFlush stdout
-   hSetBuffering stdout NoBuffering
-

        -- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 
        -- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 

+   when (isNothing maybe_expr) $ do
+       -- Only for GHCi (not runghc and ghc -e):
+       -- Turn buffering off for the compiled program's stdout/stderr
+       turnOffBuffering
+       -- Turn buffering off for GHCi's stdout
+       hFlush stdout
+       hSetBuffering stdout NoBuffering

        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.
        -- We don't want the cmd line to buffer any input that might be
        -- intended for the program, so unbuffer stdin.

-   hSetBuffering stdin NoBuffering
+       hSetBuffering stdin NoBuffering

 
        -- initial context is just the Prelude
    prel_mod <- GHC.findModule session prel_name Nothing
 
        -- initial context is just the Prelude
    prel_mod <- GHC.findModule session prel_name Nothing

@@ -301,10 +317,13 @@ interactiveUI session srcs maybe_expr = do
    Readline.setCompleterWordBreakCharacters word_break_chars
 #endif
 
    Readline.setCompleterWordBreakCharacters word_break_chars
 #endif
 

+   default_editor <- findEditor
+

    startGHCi (runGHCi srcs maybe_expr)
        GHCiState{ progname = "<interactive>",
                   args = [],
                    prompt = "%s> ",
    startGHCi (runGHCi srcs maybe_expr)
        GHCiState{ progname = "<interactive>",
                   args = [],
                    prompt = "%s> ",

+                  editor = default_editor,

                   session = session,
                   options = [],
                    prelude = prel_mod }
                   session = session,
                   options = [],
                    prelude = prel_mod }

@@ -485,8 +504,8 @@ mkPrompt toplevs exports prompt
         f (x:xs) = char x <> f xs
         f [] = empty
     
         f (x:xs) = char x <> f xs
         f [] = empty
     

-        perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
-                 hsep (map pprModule exports)
+        perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+                 hsep (map (ppr . GHC.moduleName) exports)

              
 
 #ifdef USE_READLINE
              
 
 #ifdef USE_READLINE

@@ -633,7 +652,7 @@ GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 
 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
             " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
 
 no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
             " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"

-flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
+flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr"

 
 initInterpBuffering :: Session -> IO ()
 initInterpBuffering session
 
 initInterpBuffering :: Session -> IO ()
 initInterpBuffering session

@@ -648,8 +667,6 @@ initInterpBuffering session
        Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
        _         -> panic "interactiveUI:flush"
 
        Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
        _         -> panic "interactiveUI:flush"
 

-      turnOffBuffering -- Turn it off right now
-

       return ()
 
 
       return ()
 
 

@@ -692,7 +709,8 @@ info s  = do { let names = words s
 filterOutChildren :: [Name] -> [Name]
 filterOutChildren names = filter (not . parent_is_there) names
  where parent_is_there n 
 filterOutChildren :: [Name] -> [Name]
 filterOutChildren names = filter (not . parent_is_there) names
  where parent_is_there n 

-        | Just p <- GHC.nameParent_maybe n = p `elem` names
+--      | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- ToDo!!

         | otherwise                       = False
 
 pprInfo exts (thing, fixity, insts)
         | otherwise                       = False
 
 pprInfo exts (thing, fixity, insts)

@@ -736,6 +754,27 @@ changeDirectory dir = do
   dir <- expandPath dir
   io (setCurrentDirectory dir)
 
   dir <- expandPath dir
   io (setCurrentDirectory dir)
 

+editFile :: String -> GHCi ()
+editFile str
+  | null str  = do
+       -- find the name of the "topmost" file loaded
+     session <- getSession
+     graph0 <- io (GHC.getModuleGraph session)
+     graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
+     let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
+     case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
+       Just file -> do_edit file
+       Nothing   -> throwDyn (CmdLineError "unknown file name")
+  | otherwise = do_edit str
+  where
+       do_edit file = do
+          st <- getGHCiState
+          let cmd = editor st
+          when (null cmd) $ 
+               throwDyn (CmdLineError "editor not set, use :set editor")
+          io $ system (cmd ++ ' ':file)
+           return ()
+

 defineMacro :: String -> GHCi ()
 defineMacro s = do
   let (macro_name, definition) = break isSpace s
 defineMacro :: String -> GHCi ()
 defineMacro s = do
   let (macro_name, definition) = break isSpace s

@@ -817,7 +856,7 @@ checkModule m = do
   case result of
     Nothing -> io $ putStrLn "Nothing"
     Just r  -> io $ putStrLn (showSDoc (
   case result of
     Nothing -> io $ putStrLn "Nothing"
     Just r  -> io $ putStrLn (showSDoc (

-       case checkedModuleInfo r of
+       case GHC.checkedModuleInfo r of

           Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
                let
                    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
           Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
                let
                    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope

@@ -1166,11 +1205,13 @@ setCmd ""
                   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
           ))
 setCmd str
                   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
           ))
 setCmd str

-  = case words str of
+  = case toArgs str of

        ("args":args) -> setArgs args
        ("prog":prog) -> setProg prog
        ("args":args) -> setArgs args
        ("prog":prog) -> setProg prog

-        ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
+        ("prompt":prompt) -> setPrompt (after 6)
+        ("editor":cmd) -> setEditor (after 6)

        wds -> setOptions wds
        wds -> setOptions wds

+   where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str

 
 setArgs args = do
   st <- getGHCiState
 
 setArgs args = do
   st <- getGHCiState

@@ -1182,6 +1223,10 @@ setProg [prog] = do
 setProg _ = do
   io (hPutStrLn stderr "syntax: :set prog <progname>")
 
 setProg _ = do
   io (hPutStrLn stderr "syntax: :set prog <progname>")
 

+setEditor cmd = do
+  st <- getGHCiState
+  setGHCiState st{ editor = cmd }
+

 setPrompt value = do
   st <- getGHCiState
   if null value
 setPrompt value = do
   st <- getGHCiState
   if null value

@@ -1198,21 +1243,28 @@ setOptions wds =
 
       -- then, dynamic flags
       dflags <- getDynFlags
 
       -- then, dynamic flags
       dflags <- getDynFlags

+      let pkg_flags = packageFlags dflags

       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts

-      setDynFlags dflags'
-
-        -- update things if the users wants more packages
-{- TODO:
-        let new_packages = pkgs_after \\ pkgs_before
-        when (not (null new_packages)) $
-          newPackages new_packages
--}

 
       if (not (null leftovers))
                then throwDyn (CmdLineError ("unrecognised flags: " ++ 
                                                unwords leftovers))
                else return ()
 
 
       if (not (null leftovers))
                then throwDyn (CmdLineError ("unrecognised flags: " ++ 
                                                unwords leftovers))
                else return ()
 

+      new_pkgs <- setDynFlags dflags'
+
+      -- if the package flags changed, we should reset the context
+      -- and link the new packages.
+      dflags <- getDynFlags
+      when (packageFlags dflags /= pkg_flags) $ do
+        io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
+        session <- getSession
+        io (GHC.setTargets session [])
+        io (GHC.load session LoadAllTargets)
+        io (linkPackages dflags new_pkgs)
+        setContextAfterLoad session []
+      return ()
+

 
 unsetOptions :: String -> GHCi ()
 unsetOptions str
 
 unsetOptions :: String -> GHCi ()
 unsetOptions str

@@ -1259,16 +1311,6 @@ optToStr ShowTiming = "s"
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"
 
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"
 

-{- ToDo
-newPackages new_pkgs = do      -- The new packages are already in v_Packages
-  session <- getSession
-  io (GHC.setTargets session [])
-  io (GHC.load session Nothing)
-  dflags   <- getDynFlags
-  io (linkPackages dflags new_pkgs)
-  setContextAfterLoad []
--}
-

 -- ---------------------------------------------------------------------------
 -- code for `:show'
 
 -- ---------------------------------------------------------------------------
 -- code for `:show'
 

@@ -1431,6 +1473,7 @@ data GHCiState = GHCiState
        progname       :: String,
        args           :: [String],
         prompt         :: String,
        progname       :: String,
        args           :: [String],
         prompt         :: String,

+       editor         :: String,

        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: Module
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: Module