Introduce ide-backend RTS. Closes #24.

The problem with #24 was already described in the issue; we now load a module
'IdeBackendRTS' into the ghc session on start up. As part of the RTS we define
a function 'run' which, amongst other things, resets the stdout, stderr and
stdin handles. This rather low-level coding though, so may be a bit fragile to
changes in the ghc RTS. Until we have proper GHC support for this, however, I
don't think there is a way around that.

I'm not merging this with master just yet because there is one integration test
failing ("Maintain list of compiled modules"). I looked at this for a while but
it seems a genuine bug somewhere other than the new RTS. I can't make sense of
it yet.

GhcRun.hs

@@ -88,6 +88,8 @@ data RunResult =
 -- respectively (or does an explicit flush). However, you can specify a timeout
 -- in addition to the buffering mode; if you set this to @Just n@, the buffer
 -- will be flushed every @n@ microseconds.
+--
+-- NOTE: This is duplicated in the IdeBackendRTS (defined in IdeSession)
 data RunBufferMode =
     RunNoBuffering
   | RunLineBuffering  { runBufferTimeout :: Maybe Int }
@@ -240,9 +242,7 @@ runInGhc (m, fun) outBMode errBMode = do
 -- TODO: these debug statements break tests currently:
 --    _debugPpContext flags "context before setContext"
     setContext $ [ IIDecl $ simpleImportDecl $ mkModuleName (MN.toString m)
-                 , IIDecl $ simpleImportDecl $ mkModuleName "System.IO"
-                 , IIDecl $ simpleImportDecl $ mkModuleName "Data.Maybe"
-                 , IIDecl $ simpleImportDecl $ mkModuleName "Control.Concurrent"
+                 , IIDecl $ simpleImportDecl $ mkModuleName "IdeBackendRTS"
                  ]
 --    _debugPpContext flags "context after setContext"
 --    liftIO $ writeFile "/Users/fpco/fpco/ide-backend/RunStmt.hs" expr
@@ -260,50 +260,25 @@ runInGhc (m, fun) outBMode errBMode = do
           error "checkModule: RunBreak"
   where
     expr :: String
-    expr = setBuffering     "System.IO.stdout" outBMode
-         . setBuffering     "System.IO.stderr" errBMode
-         . setBufferTimeout "System.IO.stdout" outBMode
-         . setBufferTimeout "System.IO.stderr" errBMode
-         $ MN.toString m ++ "." ++ fun
-
-    setBuffering :: String -> RunBufferMode -> String -> String
-    setBuffering h mode code = unlines [
-        "do {"
-      , "System.IO.hSetBuffering " ++ h ++ " " ++ fqnBMode mode ++ ";"
-      , code ++ ";"
-      , "System.IO.hFlush " ++ h
-      , "}"
-      ]
-
-    setBufferTimeout :: String -> RunBufferMode -> String -> String
-    setBufferTimeout h (RunLineBuffering (Just n)) code =
-      bufferTimeout h n code
-    setBufferTimeout h (RunBlockBuffering _ (Just n)) code =
-      bufferTimeout h n code
-    setBufferTimeout _ _ code =
-      code
-
-    fqnBMode :: RunBufferMode -> String
-    fqnBMode RunNoBuffering =
-      "System.IO.NoBuffering"
-    fqnBMode (RunLineBuffering _) =
-      "System.IO.LineBuffering"
-    fqnBMode (RunBlockBuffering Nothing _) =
-      "(System.IO.BlockBuffering Data.Maybe.Nothing)"
-    fqnBMode (RunBlockBuffering (Just i) _) =
-      "(System.IO.BlockBuffering (Data.Maybe.Just " ++ show i ++ "))"
-
-    bufferTimeout :: String -> Int -> String -> String
-    bufferTimeout h n code = unlines [
-        "do {"
-      , "tid <- forkIO (let go = do {"
-      , "         Control.Concurrent.threadDelay " ++ show n ++ "; "
-      , "         System.IO.hFlush " ++ h ++ ";"
-      , "         go } in go);"
-      , code ++ ";"
-      , "killThread tid"
-      , "}"
-      ]
+    expr = fqn "run "
+        ++ "(" ++ fqBMode outBMode ++ ")"
+        ++ "(" ++ fqBMode errBMode ++ ")"
+        ++ "(" ++ MN.toString m ++ "." ++ fun ++ ")"
+
+    fqn :: String -> String
+    fqn = (++) "IdeBackendRTS."
+
+    fqBMode :: RunBufferMode -> String
+    fqBMode RunNoBuffering =
+      fqn "RunNoBuffering"
+    fqBMode (RunLineBuffering t) =
+      fqn "RunLineBuffering (" ++ fqMInt t ++ ")"
+    fqBMode (RunBlockBuffering sz t) =
+      fqn "RunBlockBuffering (" ++ fqMInt sz ++ ") (" ++ fqMInt t ++ ")"
+
+    fqMInt :: Maybe Int -> String
+    fqMInt Nothing  = fqn "Nothing"
+    fqMInt (Just n) = fqn "Just " ++ show n
 
     handleError :: Show a => a -> Ghc RunResult
     handleError = return . RunGhcException . show

IdeSession.hs

@@ -203,6 +203,7 @@ import qualified Data.ByteString.Lazy.Char8 as BSL
 import qualified Data.ByteString as BSS
 import Data.List (delete)
 import Data.Monoid (Monoid (..))
+import Data.Maybe (fromJust)
 import System.Directory
 import System.FilePath (splitFileName, takeDirectory, (<.>), (</>))
 import qualified System.FilePath.Find as Find
@@ -352,7 +353,21 @@ initSession ideConfig'@SessionConfig{configStaticOpts} = do
                         , _ideGhcServer
                         }
   let ideStaticInfo = IdeStaticInfo{..}
-  return IdeSession{..}
+  let session = IdeSession{..}
+
+  sessionLoadRTS session
+
+  return session
+
+-- | Load the RTS into the session
+sessionLoadRTS :: IdeSession -> IO ()
+sessionLoadRTS session = do
+  codeGen <- getCodeGeneration session
+  mapM_ (\upd -> updateSession session upd (const $ return ())) [
+      updateCodeGeneration True
+    , updateModule (fromJust (MN.fromString "IdeBackendRTS")) ideBackendRTS
+    , updateCodeGeneration codeGen
+    ]
 
 -- | Close a session down, releasing the resources.
 --
@@ -401,16 +416,17 @@ shutdownSession IdeSession{ideState, ideStaticInfo} = do
 -- (We don't automatically recompile the code using the new session, because
 -- what would we do with the progress messages?)
 restartSession :: IdeSession -> IO ()
-restartSession IdeSession{ideStaticInfo, ideState} =
-  $modifyMVar_ ideState $ \state ->
-    case state of
-      IdeSessionIdle idleState ->
-        restart idleState
-      IdeSessionRunning runActions idleState -> do
-        forceCancel runActions
-        restart idleState
-      IdeSessionShutdown ->
-        fail "Shutdown session cannot be restarted."
+restartSession session@IdeSession{ideStaticInfo, ideState} = do
+    $modifyMVar_ ideState $ \state ->
+      case state of
+        IdeSessionIdle idleState ->
+          restart idleState
+        IdeSessionRunning runActions idleState -> do
+          forceCancel runActions
+          restart idleState
+        IdeSessionShutdown ->
+          fail "Shutdown session cannot be restarted."
+    sessionLoadRTS session
   where
     restart :: IdeIdleState -> IO IdeSessionState
     restart idleState = do
@@ -714,6 +730,18 @@ getLoadedModules IdeSession{ideState} =
       Just Computed{..} -> return computedLoadedModules
       Nothing -> fail "This session state does not admit queries."
 
+-- | Is code generation currently enabled?
+getCodeGeneration :: Query Bool
+getCodeGeneration IdeSession{ideState} =
+  $withMVar ideState $ \st ->
+    case st of
+      IdeSessionIdle idleState ->
+        return $ idleState ^. ideGenerateCode
+      IdeSessionRunning _ idleState ->
+        return $ idleState ^. ideGenerateCode
+      IdeSessionShutdown ->
+        fail "Session already shut down."
+
 -- | Get the list of all data files currently available to the session:
 -- both the files copied via an update and files created by user code.
 getAllDataFiles :: Query [FilePath]
@@ -791,3 +819,131 @@ getGhcServer IdeSession{ideState} =
         return $! idleState ^. ideGhcServer
       IdeSessionShutdown ->
         fail "Session already shut down."
+
+{-------------------------------------------------------------------------------
+  RTS
+-------------------------------------------------------------------------------}
+
+ideBackendRTS :: ByteString
+ideBackendRTS = BSL.pack . unlines $ [
+    "module IdeBackendRTS ("
+  , "    run"
+  , "  , RunBufferMode(..)"
+  , "  , Maybe(..)"
+  , "  ) where"
+
+  , "import Control.Concurrent (forkIO, threadDelay, killThread)"
+  , "import Control.Concurrent.MVar (MVar, takeMVar, putMVar)"
+  , "import qualified System.IO as IO"
+  , "import qualified Control.Exception as Ex"
+  , "import Control.Monad (forever)"
+
+  -- This requires access to the ghc package (needs to be exposed)
+  , "import GHC.IO.Handle.Types ("
+  , "    Handle(FileHandle)"
+  , "  , HandleType(ClosedHandle, ReadHandle, WriteHandle)"
+  , "  , nativeNewlineMode"
+  , "  , Handle__"
+  , "  , haType"
+  , "  )"
+  , "import GHC.IO.Handle.Internals ("
+  , "    mkHandle"
+  , "  , closeTextCodecs"
+  , "  , ioe_finalizedHandle"
+  , "  , flushWriteBuffer"
+  , "  )"
+  , "import GHC.IO.Encoding (getLocaleEncoding)"
+  , "import qualified GHC.IO.FD as FD"
+
+  , "data RunBufferMode ="
+  , "    RunNoBuffering"
+  , "  | RunLineBuffering (Maybe Int)"
+  , "  | RunBlockBuffering (Maybe Int) (Maybe Int)"
+  , "  deriving Read"
+
+  , "run :: RunBufferMode -> RunBufferMode -> IO a -> IO a"
+  , "run outBMode errBMode io = do"
+  , "  resetStdin"
+  , "  resetStdout"
+  , "  resetStderr"
+  , "  withBuffering IO.stdout outBMode $ withBuffering IO.stderr errBMode $ io"
+
+  , "withBuffering :: IO.Handle -> RunBufferMode -> IO a -> IO a"
+  , "withBuffering h mode io = do"
+  , "  IO.hSetBuffering h (bufferMode mode)"
+  , "  result <- withBufferTimeout h (bufferTimeout mode) io"
+  , "  ignoreIOExceptions $ IO.hFlush h"
+  , "  return result"
+
+  , "ignoreIOExceptions :: IO () -> IO ()"
+  , "ignoreIOExceptions = let handler :: Ex.IOException -> IO ()"
+  , "                         handler _ = return ()"
+  , "                     in Ex.handle handler"
+
+  , "bufferMode :: RunBufferMode -> IO.BufferMode"
+  , "bufferMode RunNoBuffering           = IO.NoBuffering"
+  , "bufferMode (RunLineBuffering _)     = IO.LineBuffering"
+  , "bufferMode (RunBlockBuffering sz _) = IO.BlockBuffering sz"
+
+  , "bufferTimeout :: RunBufferMode -> Maybe Int"
+  , "bufferTimeout RunNoBuffering          = Nothing"
+  , "bufferTimeout (RunLineBuffering t)    = t"
+  , "bufferTimeout (RunBlockBuffering _ t) = t"
+
+  , "withBufferTimeout :: IO.Handle -> Maybe Int -> IO a -> IO a"
+  , "withBufferTimeout _ Nothing  io = io"
+  , "withBufferTimeout h (Just n) io = do"
+  , "  tid <- forkIO . forever $ threadDelay n >> IO.hFlush h"
+  , "  result <- io"
+  , "  killThread tid"
+  , "  return result"
+
+  , "swapFileHandles :: Handle -> Handle -> IO ()"
+  , "swapFileHandles (FileHandle _ h1) (FileHandle _ h2) = Ex.mask_ $ do"
+  , "  h1' <- takeMVar h1"
+  , "  h2' <- takeMVar h2"
+  , "  putMVar h1 h2'"
+  , "  putMVar h2 h1'"
+  , "swapFileHandles _ _ ="
+  , "  Ex.throwIO (userError \"swapFileHandles: unsupported handles\")"
+
+  -- To reset the handle we duplicate the implementation of 'stdin', 'stdout'
+  -- or 'stderr' and then use 'swapFileHandles' to swap the MVar contents of
+  -- the real Handle
+
+  , "resetStdin :: IO ()"
+  , "resetStdin = do"
+  , "  enc <- getLocaleEncoding"
+  , "  new <- mkHandle FD.stdin \"<stdin>\" ReadHandle True (Just enc)"
+  , "           nativeNewlineMode{-translate newlines-}"
+  , "           (Just stdHandleFinalizer) Nothing"
+  , "  swapFileHandles new IO.stdin"
+
+  , "resetStdout :: IO ()"
+  , "resetStdout = do"
+  , "  enc <- getLocaleEncoding"
+  , "  new <- mkHandle FD.stdout \"<stdout>\" WriteHandle True (Just enc)"
+  , "           nativeNewlineMode{-translate newlines-}"
+  , "           (Just stdHandleFinalizer) Nothing"
+  , "  swapFileHandles new IO.stdout"
+
+  , "resetStderr :: IO ()"
+  , "resetStderr = do"
+  , "  enc <- getLocaleEncoding"
+  , "  new <- mkHandle FD.stderr \"<stderr>\" WriteHandle False{-stderr is unbuffered-}"
+  , "           (Just enc)"
+  , "           nativeNewlineMode{-translate newlines-}"
+  , "           (Just stdHandleFinalizer) Nothing"
+  , "  swapFileHandles new IO.stderr"
+
+  -- Taken directly from the GHC.IO.Handle.FD (not exported)
+
+  , "stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()"
+  , "stdHandleFinalizer fp m = do"
+  , "  h_ <- takeMVar m"
+  , "  flushWriteBuffer h_"
+  , "  case haType h_ of"
+  , "      ClosedHandle -> return ()"
+  , "      _other       -> closeTextCodecs h_"
+  , "  putMVar m (ioe_finalizedHandle fp)"
+  ]