{- |
This module provides a stateful, IO-based interface to Haskeline, which may be easier to
integrate into some existing programs or libraries.

It is strongly recommended to use the safer, monadic API of
"System.Console.Haskeline", if possible, rather than the explicit state management
functions of this module.

The equivalent REPL example is:

@
import System.Console.Haskeline
import System.Console.Haskeline.IO
import Control.Concurrent

main = bracketOnError (initializeInput defaultSettings)
            cancelInput -- This will only be called if an exception such
                            -- as a SigINT is received.
            (\\hd -> loop hd >> closeInput hd)
    where
        loop :: InputState -> IO ()
        loop hd = do
            minput <- queryInput hd (getInputLine \"% \")
            case minput of
                Nothing -> return ()
                Just \"quit\" -> return ()
                Just input -> do queryInput hd $ outputStrLn
                                    $ \"Input was: \" ++ input
                                 loop hd
@


-}
module System.Console.Haskeline.IO(
                        InputState(),
                        initializeInput,
                        closeInput,
                        cancelInput,
                        queryInput
                        ) where

import System.Console.Haskeline hiding (completeFilename)
import Control.Concurrent

import Control.Exception (finally)
import Control.Monad.IO.Class

-- Providing a non-monadic API for haskeline
-- A process is forked off which runs the monadic InputT API
-- and actions to be run are passed to it through the following MVars.

data Request = forall a . Request (InputT IO a) (MVar a)

data InputState = HD {InputState -> ThreadId
forkedThread :: ThreadId,
                        InputState -> MVar (Maybe Request)
requestVar :: MVar (Maybe Request),
                        InputState -> MVar ()
subthreadFinished :: MVar ()
                    }

-- | Initialize a session of line-oriented user interaction.
initializeInput :: Settings IO -> IO InputState
initializeInput :: Settings IO -> IO InputState
initializeInput Settings IO
settings = do
    MVar (Maybe Request)
reqV <- IO (MVar (Maybe Request))
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
finished <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (Settings IO -> MVar (Maybe Request) -> MVar () -> IO ()
runHaskeline Settings IO
settings MVar (Maybe Request)
reqV MVar ()
finished)
    InputState -> IO InputState
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HD {requestVar :: MVar (Maybe Request)
requestVar = MVar (Maybe Request)
reqV, forkedThread :: ThreadId
forkedThread = ThreadId
tid,
                subthreadFinished :: MVar ()
subthreadFinished = MVar ()
finished}

runHaskeline :: Settings IO -> MVar (Maybe Request) -> MVar () -> IO ()
runHaskeline :: Settings IO -> MVar (Maybe Request) -> MVar () -> IO ()
runHaskeline Settings IO
settings MVar (Maybe Request)
reqV MVar ()
finished = Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
settings InputT IO ()
loop
                    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
finished ()
    where
        loop :: InputT IO ()
loop = do
            Maybe Request
mf <- IO (Maybe Request) -> InputT IO (Maybe Request)
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Request) -> InputT IO (Maybe Request))
-> IO (Maybe Request) -> InputT IO (Maybe Request)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe Request) -> IO (Maybe Request)
forall a. MVar a -> IO a
takeMVar MVar (Maybe Request)
reqV
            case Maybe Request
mf of
                Maybe Request
Nothing -> () -> InputT IO ()
forall a. a -> InputT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just (Request InputT IO a
f MVar a
var) -> InputT IO a
f InputT IO a -> (a -> InputT IO ()) -> InputT IO ()
forall a b. InputT IO a -> (a -> InputT IO b) -> InputT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> (a -> IO ()) -> a -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
var InputT IO () -> InputT IO () -> InputT IO ()
forall a b. InputT IO a -> InputT IO b -> InputT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InputT IO ()
loop

-- | Finish and clean up the line-oriented user interaction session.  Blocks on an
-- existing call to 'queryInput'.
closeInput :: InputState -> IO ()
closeInput :: InputState -> IO ()
closeInput InputState
hd = MVar (Maybe Request) -> Maybe Request -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (InputState -> MVar (Maybe Request)
requestVar InputState
hd) Maybe Request
forall a. Maybe a
Nothing IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (InputState -> MVar ()
subthreadFinished InputState
hd)

-- | Cancel and clean up the user interaction session.  Does not block on an existing
-- call to 'queryInput'.
cancelInput :: InputState -> IO ()
cancelInput :: InputState -> IO ()
cancelInput InputState
hd = ThreadId -> IO ()
killThread (InputState -> ThreadId
forkedThread InputState
hd) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (InputState -> MVar ()
subthreadFinished InputState
hd)

-- | Run one action (for example, 'getInputLine') as part of a session of user interaction.
--
-- For example, multiple calls to 'queryInput' using the same 'InputState' will share
-- the same input history.  In constrast, multiple calls to 'runInputT' will use distinct
-- histories unless they share the same history file.
--
-- This function should not be called on a closed or cancelled 'InputState'.
queryInput :: InputState -> InputT IO a -> IO a
queryInput :: forall a. InputState -> InputT IO a -> IO a
queryInput InputState
hd InputT IO a
f = do
    MVar a
var <- IO (MVar a)
forall a. IO (MVar a)
newEmptyMVar
    MVar (Maybe Request) -> Maybe Request -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (InputState -> MVar (Maybe Request)
requestVar InputState
hd) (Request -> Maybe Request
forall a. a -> Maybe a
Just (InputT IO a -> MVar a -> Request
forall a. InputT IO a -> MVar a -> Request
Request InputT IO a
f MVar a
var))
    MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
var