module System.Console.Haskeline.InputT where
import System.Console.Haskeline.History
import System.Console.Haskeline.Command.History
import System.Console.Haskeline.Command.Undo
import System.Console.Haskeline.Command.KillRing
import System.Console.Haskeline.Monads as Monads
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Completion
import System.Console.Haskeline.Backend
import System.Console.Haskeline.Term
import System.Directory(getHomeDirectory)
import System.FilePath
import Control.Applicative
import Control.Monad (liftM, ap)
import Control.Monad.Fix
import System.IO
import Data.IORef
data Settings m = Settings {complete :: CompletionFunc m,
historyFile :: Maybe FilePath,
autoAddHistory :: Bool
}
setComplete :: CompletionFunc m -> Settings m -> Settings m
setComplete f s = s {complete = f}
newtype InputT m a = InputT {unInputT ::
ReaderT RunTerm
(ReaderT (IORef History)
(ReaderT (IORef KillRing)
(ReaderT Prefs
(ReaderT (Settings m) m)))) a}
deriving (Functor, Applicative, Monad, MonadIO, MonadException)
instance MonadTrans InputT where
lift = InputT . lift . lift . lift . lift . lift
instance ( MonadFix m ) => MonadFix (InputT m) where
mfix f = InputT (mfix (unInputT . f))
getHistory :: MonadIO m => InputT m History
getHistory = InputT get
putHistory :: MonadIO m => History -> InputT m ()
putHistory = InputT . put
modifyHistory :: MonadIO m => (History -> History) -> InputT m ()
modifyHistory = InputT . modify
type InputCmdT m = StateT Layout (UndoT (StateT HistLog (ReaderT (IORef KillRing)
(ReaderT Prefs (ReaderT (Settings m) m)))))
runInputCmdT :: MonadIO m => TermOps -> InputCmdT m a -> InputT m a
runInputCmdT tops f = InputT $ do
layout <- liftIO $ getLayout tops
history <- get
lift $ lift $ evalStateT' (histLog history) $ runUndoT $ evalStateT' layout f
instance MonadException m => CommandMonad (InputCmdT m) where
runCompletion lcs = do
settings <- ask
lift $ lift $ lift $ lift $ lift $ lift $ complete settings lcs
runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs = runInputTBehaviorWithPrefs defaultBehavior
runInputT :: MonadException m => Settings m -> InputT m a -> m a
runInputT = runInputTBehavior defaultBehavior
haveTerminalUI :: Monad m => InputT m Bool
haveTerminalUI = InputT $ asks isTerminalStyle
data Behavior = Behavior (IO RunTerm)
withBehavior :: MonadException m => Behavior -> (RunTerm -> m a) -> m a
withBehavior (Behavior run) f = bracket (liftIO run) (liftIO . closeTerm) f
runInputTBehavior :: MonadException m => Behavior -> Settings m -> InputT m a -> m a
runInputTBehavior behavior settings f = withBehavior behavior $ \run -> do
prefs <- if isTerminalStyle run
then liftIO readPrefsFromHome
else return defaultPrefs
execInputT prefs settings run f
runInputTBehaviorWithPrefs :: MonadException m
=> Behavior -> Prefs -> Settings m -> InputT m a -> m a
runInputTBehaviorWithPrefs behavior prefs settings f
= withBehavior behavior $ flip (execInputT prefs settings) f
execInputT :: MonadException m => Prefs -> Settings m -> RunTerm
-> InputT m a -> m a
execInputT prefs settings run (InputT f)
= runReaderT' settings $ runReaderT' prefs
$ runKillRing
$ runHistoryFromFile (historyFile settings) (maxHistorySize prefs)
$ runReaderT f run
mapInputT :: (forall b . m b -> m b) -> InputT m a -> InputT m a
mapInputT f = InputT . mapReaderT (mapReaderT (mapReaderT
(mapReaderT (mapReaderT f))))
. unInputT
defaultBehavior :: Behavior
defaultBehavior = Behavior defaultRunTerm
useFileHandle :: Handle -> Behavior
useFileHandle = Behavior . fileHandleRunTerm
useFile :: FilePath -> Behavior
useFile file = Behavior $ do
h <- openBinaryFile file ReadMode
rt <- fileHandleRunTerm h
return rt { closeTerm = closeTerm rt >> hClose h}
preferTerm :: Behavior
preferTerm = Behavior terminalRunTerm
readPrefsFromHome :: IO Prefs
readPrefsFromHome = handle (\(_::IOException) -> return defaultPrefs) $ do
home <- getHomeDirectory
readPrefs (home </> ".haskeline")