content: 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)
  
  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 qualified GHC.IO.FD as FD
  
  run :: RunBufferMode -> RunBufferMode -> IO a -> IO ()
  run outBMode errBMode io = do
    let resetHandles = do
          resetStdin  IO.utf8
          resetStdout IO.utf8
          resetStderr IO.utf8
    let io' = do _result <- io ; return () -- Throw away any snippet result
    withBuffering IO.stdout outBMode (withBuffering IO.stderr errBMode io')
      `Ex.finally` resetHandles
  
  {-------------------------------------------------------------------------------
    Buffer modes
  -------------------------------------------------------------------------------}
  
  data RunBufferMode =
      RunNoBuffering
    | RunLineBuffering (Maybe Int)
    | RunBlockBuffering (Maybe Int) (Maybe Int)
    deriving Read
  
  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 . ignoreIOExceptions . 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.TextEncoding -> IO ()
  resetStdin enc = do
    new <- mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)
             nativeNewlineMode{-translate newlines-}
             (Just stdHandleFinalizer) Nothing
    swapFileHandles new IO.stdin
  
  resetStdout :: IO.TextEncoding -> IO ()
  resetStdout enc = do
    new <- mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)
             nativeNewlineMode{-translate newlines-}
             (Just stdHandleFinalizer) Nothing
    swapFileHandles new IO.stdout
  
  resetStderr :: IO.TextEncoding -> IO ()
  resetStderr enc = do
    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)
  