FIX BUILD

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 045cf63..74310a3 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -103,8 +103,8 @@ type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 cmdName :: Command -> String
 cmdName (n,_,_,_) = n
 
 cmdName :: Command -> String
 cmdName (n,_,_,_) = n
 

-commands :: IORef [Command]
-GLOBAL_VAR(commands, builtin_commands, [Command])
+macros_ref :: IORef [Command]
+GLOBAL_VAR(macros_ref, [], [Command])

 
 builtin_commands :: [Command]
 builtin_commands = [
 
 builtin_commands :: [Command]
 builtin_commands = [

@@ -121,7 +121,8 @@ builtin_commands = [
   ("continue",  keepGoing continueCmd,          False, completeNone),
   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("continue",  keepGoing continueCmd,          False, completeNone),
   ("cmd",       keepGoing cmdCmd,               False, completeIdentifier),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),

-  ("def",      keepGoing defineMacro,          False, completeIdentifier),
+  ("def",      keepGoing (defineMacro False),  False, completeIdentifier),
+  ("def!",     keepGoing (defineMacro True),   False, completeIdentifier),

   ("delete",    keepGoing deleteCmd,            False, completeNone),
   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("delete",    keepGoing deleteCmd,            False, completeNone),
   ("e",        keepGoing editFile,             False, completeFilename),
   ("edit",     keepGoing editFile,             False, completeFilename),

@@ -699,7 +700,8 @@ specialCommand str = do
 
 lookupCommand :: String -> IO (Maybe Command)
 lookupCommand str = do
 
 lookupCommand :: String -> IO (Maybe Command)
 lookupCommand str = do

-  cmds <- readIORef commands
+  macros <- readIORef macros_ref
+  let cmds = builtin_commands ++ macros

   -- look for exact match first, then the first prefix match
   case [ c | c <- cmds, str == cmdName c ] of
      c:_ -> return (Just c)
   -- look for exact match first, then the first prefix match
   case [ c | c <- cmds, str == cmdName c ] of
      c:_ -> return (Just c)

@@ -796,7 +798,7 @@ addModule files = do
   session <- getSession
   io (mapM_ (GHC.addTarget session) targets)
   ok <- io (GHC.load session LoadAllTargets)
   session <- getSession
   io (mapM_ (GHC.addTarget session) targets)
   ok <- io (GHC.load session LoadAllTargets)

-  afterLoad ok session
+  afterLoad ok session Nothing

 
 changeDirectory :: String -> GHCi ()
 changeDirectory dir = do
 
 changeDirectory :: String -> GHCi ()
 changeDirectory dir = do

@@ -854,18 +856,24 @@ chooseEditFile =
   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
         fromTarget _ = Nothing -- when would we get a module target?
 
   where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
         fromTarget _ = Nothing -- when would we get a module target?
 

-defineMacro :: String -> GHCi ()
-defineMacro s = do
+defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro overwrite s = do

   let (macro_name, definition) = break isSpace s
   let (macro_name, definition) = break isSpace s

-  cmds <- io (readIORef commands)
+  macros <- io (readIORef macros_ref)
+  let defined = map cmdName macros

   if (null macro_name) 
   if (null macro_name) 

-       then throwDyn (CmdLineError "invalid macro name") 
+       then if null defined
+                then io $ putStrLn "no macros defined"
+                else io $ putStr ("the following macros are defined:\n" ++
+                                  unlines defined)

        else do
        else do

-  if (macro_name `elem` map cmdName cmds)
+  if (not overwrite && macro_name `elem` defined)

        then throwDyn (CmdLineError 
        then throwDyn (CmdLineError 

-               ("command '" ++ macro_name ++ "' is already defined"))
+               ("macro '" ++ macro_name ++ "' is already defined"))

        else do
 
        else do
 

+  let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+

   -- give the expression a type signature, so we can be sure we're getting
   -- something of the right type.
   let new_expr = '(' : definition ++ ") :: String -> IO String"
   -- give the expression a type signature, so we can be sure we're getting
   -- something of the right type.
   let new_expr = '(' : definition ++ ") :: String -> IO String"

@@ -875,8 +883,8 @@ defineMacro s = do
   maybe_hv <- io (GHC.compileExpr cms new_expr)
   case maybe_hv of
      Nothing -> return ()
   maybe_hv <- io (GHC.compileExpr cms new_expr)
   case maybe_hv of
      Nothing -> return ()

-     Just hv -> io (writeIORef commands --
-                   (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
+     Just hv -> io (writeIORef macros_ref --
+                   (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))

 
 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 runMacro fun s = do
 
 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 runMacro fun s = do

@@ -885,17 +893,14 @@ runMacro fun s = do
   return False
 
 undefineMacro :: String -> GHCi ()
   return False
 
 undefineMacro :: String -> GHCi ()

-undefineMacro macro_name = do
-  cmds <- io (readIORef commands)
-  if (macro_name `elem` map cmdName builtin_commands) 
-       then throwDyn (CmdLineError
-               ("command '" ++ macro_name ++ "' cannot be undefined"))
-       else do
-  if (macro_name `notElem` map cmdName cmds) 
-       then throwDyn (CmdLineError 
-               ("command '" ++ macro_name ++ "' not defined"))
-       else do
-  io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+undefineMacro str = mapM_ undef (words str) 
+ where undef macro_name = do
+        cmds <- io (readIORef macros_ref)
+        if (macro_name `notElem` map cmdName cmds) 
+          then throwDyn (CmdLineError 
+               ("macro '" ++ macro_name ++ "' is not defined"))
+          else do
+            io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))

 
 cmdCmd :: String -> GHCi ()
 cmdCmd str = do
 
 cmdCmd :: String -> GHCi ()
 cmdCmd str = do

@@ -936,7 +941,7 @@ loadModule' files = do
   -- as a ToDo for now.
 
   io (GHC.setTargets session targets)
   -- as a ToDo for now.
 
   io (GHC.setTargets session targets)

-  doLoad session LoadAllTargets
+  doLoad session False LoadAllTargets

 
 checkModule :: String -> GHCi ()
 checkModule m = do
 
 checkModule :: String -> GHCi ()
 checkModule m = do

@@ -954,30 +959,43 @@ checkModule m = do
                        (text "global names: " <+> ppr global) $$
                        (text "local  names: " <+> ppr local)
           _ -> empty))
                        (text "global names: " <+> ppr global) $$
                        (text "local  names: " <+> ppr local)
           _ -> empty))

-  afterLoad (successIf (isJust result)) session
+  afterLoad (successIf (isJust result)) session Nothing

 
 reloadModule :: String -> GHCi ()
 reloadModule m = do
   session <- getSession
 
 reloadModule :: String -> GHCi ()
 reloadModule m = do
   session <- getSession

-  doLoad session $ if null m then LoadAllTargets 
-                             else LoadUpTo (GHC.mkModuleName m)
+  doLoad session True $ if null m then LoadAllTargets 
+                                  else LoadUpTo (GHC.mkModuleName m)

   return ()
 
   return ()
 

-doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag
-doLoad session howmuch = do
+doLoad :: Session -> Bool -> LoadHowMuch -> GHCi SuccessFlag
+doLoad session retain_context howmuch = do

   -- turn off breakpoints before we load: we can't turn them off later, because
   -- the ModBreaks will have gone away.
   discardActiveBreakPoints
   -- turn off breakpoints before we load: we can't turn them off later, because
   -- the ModBreaks will have gone away.
   discardActiveBreakPoints

+  context <- io $ GHC.getContext session

   ok <- io (GHC.load session howmuch)
   ok <- io (GHC.load session howmuch)

-  afterLoad ok session
+  afterLoad ok session (if retain_context then Just context else Nothing)

   return ok
 
   return ok
 

-afterLoad :: SuccessFlag -> Session -> GHCi ()
-afterLoad ok session = do
+afterLoad :: SuccessFlag -> Session -> Maybe ([Module],[Module]) -> GHCi ()
+afterLoad ok session maybe_context = do

   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays
   loaded_mods <- getLoadedModules session
   io (revertCAFs)  -- always revert CAFs on load.
   discardTickArrays
   loaded_mods <- getLoadedModules session

-  setContextAfterLoad session loaded_mods
+
+  -- try to retain the old module context for :reload.  This might
+  -- not be possible, for example if some modules have gone away, so
+  -- we attempt to set the same context, backing off to the default
+  -- context if that fails.
+  case maybe_context of
+     Nothing -> setContextAfterLoad session loaded_mods
+     Just (as,bs) -> do
+        r <- io $ Exception.try (GHC.setContext session as bs)
+        case r of
+           Left _err -> setContextAfterLoad session loaded_mods
+           Right _   -> return ()
+

   modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
 
 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
   modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
 
 setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()

@@ -1179,14 +1197,10 @@ separate :: Session -> [String] -> [Module] -> [Module]
         -> GHCi ([Module],[Module])
 separate _       []             as bs = return (as,bs)
 separate session (('*':str):ms) as bs = do
         -> GHCi ([Module],[Module])
 separate _       []             as bs = return (as,bs)
 separate session (('*':str):ms) as bs = do

-   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
-   b <- io $ GHC.moduleIsInterpreted session m
-   if b then separate session ms (m:as) bs
-       else throwDyn (CmdLineError ("module '"
-                        ++ GHC.moduleNameString (GHC.moduleName m)
-                        ++ "' is not interpreted"))
+  m <- wantInterpretedModule str
+  separate session ms (m:as) bs

 separate session (str:ms) as bs = do
 separate session (str:ms) as bs = do

-  m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+  m <- lookupModule str

   separate session ms as (m:bs)
 
 newContext :: [String] -> GHCi ()
   separate session ms as (m:bs)
 
 newContext :: [String] -> GHCi ()

@@ -1533,13 +1547,13 @@ completeWord w start end = do
 
 completeCmd :: String -> IO [String]
 completeCmd w = do
 
 completeCmd :: String -> IO [String]
 completeCmd w = do

-  cmds <- readIORef commands
-  return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
+  cmds <- readIORef macros_ref
+  return (filter (w `isPrefixOf`) (map (':':) 
+             (map cmdName (builtin_commands ++ cmds))))

 
 completeMacro w = do
 
 completeMacro w = do

-  cmds <- readIORef commands
-  let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
-  return (filter (w `isPrefixOf`) cmds')
+  cmds <- readIORef macros_ref
+  return (filter (w `isPrefixOf`) (map cmdName cmds))

 
 completeIdentifier w = do
   s <- restoreSession
 
 completeIdentifier w = do
   s <- restoreSession