module System.Console.Haskeline.InputT where
import System.Console.Haskeline.Command.History
import System.Console.Haskeline.Monads as Monads
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Command(Layout)
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)
data Settings m = Settings {complete :: CompletionFunc m,
historyFile :: Maybe FilePath,
handleSigINT :: Bool
}
setComplete :: CompletionFunc m -> Settings m -> Settings m
setComplete f s = s {complete = f}
newtype InputT m a = InputT {unInputT :: ReaderT RunTerm
(StateT History (ReaderT Prefs
(ReaderT (Settings m) m))) a}
deriving (Monad,MonadIO, MonadState History,
MonadReader Prefs, MonadReader (Settings m),
MonadReader RunTerm)
instance Monad m => Functor (InputT m) where
fmap = liftM
instance Monad m => Applicative (InputT m) where
pure = return
(<*>) = ap
instance MonadTrans InputT where
lift = InputT . lift . lift . lift . lift
instance MonadException m => MonadException (InputT m) where
block = InputT . block . unInputT
unblock = InputT . unblock . unInputT
catch f h = InputT $ Monads.catch (unInputT f) (unInputT . h)
type InputCmdT m = ReaderT Layout (StateT HistLog (ReaderT Prefs (ReaderT (Settings m) m)))
instance MonadIO m => MonadLayout (InputCmdT m) where
runInputCmdT :: forall m a . MonadIO m => TermOps -> InputCmdT m a -> InputT m a
runInputCmdT tops f = InputT $ do
layout <- liftIO $ getLayout tops
lift $ runHistLog $ runReaderT' layout f
liftCmdT :: Monad m => m a -> InputCmdT m a
liftCmdT = lift . lift . lift . lift
runInputTWithPrefs :: MonadException m => Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs prefs settings (InputT f) = bracket (liftIO myRunTerm)
(liftIO . closeTerm)
$ \run -> runReaderT' settings $ runReaderT' prefs
$ runHistoryFromFile (historyFile settings) (maxHistorySize prefs)
$ runReaderT f run
runInputT :: MonadException m => Settings m -> InputT m a -> m a
runInputT settings f = do
prefs <- liftIO readPrefsFromHome
runInputTWithPrefs prefs settings f
readPrefsFromHome :: IO Prefs
readPrefsFromHome = handle (\_ -> return defaultPrefs) $ do
home <- getHomeDirectory
readPrefs (home </> ".haskeline")