module System.Console.Haskeline.RunCommand (runCommandLoop) where

import System.Console.Haskeline.Command
import System.Console.Haskeline.Term
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Monads
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Key

import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.Catch (handle, throwM)

runCommandLoop :: (CommandMonad m, MonadState Layout m, LineState s)
    => TermOps -> Prefix -> KeyCommand m s a -> s -> m a
runCommandLoop :: forall (m :: * -> *) s a.
(CommandMonad m, MonadState Layout m, LineState s) =>
TermOps -> Prefix -> KeyCommand m s a -> s -> m a
runCommandLoop tops :: TermOps
tops@TermOps{evalTerm :: TermOps -> forall (m :: * -> *). CommandMonad m => EvalTerm m
evalTerm = forall (m :: * -> *). CommandMonad m => EvalTerm m
e} Prefix
prefix KeyCommand m s a
cmds s
initState
    = case EvalTerm m
forall (m :: * -> *). CommandMonad m => EvalTerm m
e of -- NB: Need to separate this case out from the above pattern
                -- in order to build on ghc-6.12.3
        EvalTerm forall a. n a -> m a
eval forall a. m a -> n a
liftE
            -> n a -> m a
forall a. n a -> m a
eval (n a -> m a) -> n a -> m a
forall a b. (a -> b) -> a -> b
$ TermOps
-> forall (m :: * -> *) a.
   CommandMonad m =>
   (m Event -> m a) -> m a
withGetEvent TermOps
tops
                ((n Event -> n a) -> n a) -> (n Event -> n a) -> n a
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> n a)
-> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event -> n a
forall (m :: * -> *) (n :: * -> *) s a.
(Term n, CommandMonad n, MonadState Layout m, LineState s) =>
(forall b. m b -> n b)
-> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event -> n a
runCommandLoop' forall a. m a -> n a
liftE TermOps
tops Prefix
prefix s
initState
                    KeyCommand m s a
cmds 

runCommandLoop' :: forall m n s a . (Term n, CommandMonad n,
        MonadState Layout m, LineState s)
        => (forall b . m b -> n b) -> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event
        -> n a
runCommandLoop' :: forall (m :: * -> *) (n :: * -> *) s a.
(Term n, CommandMonad n, MonadState Layout m, LineState s) =>
(forall b. m b -> n b)
-> TermOps -> Prefix -> s -> KeyCommand m s a -> n Event -> n a
runCommandLoop' forall b. m b -> n b
liftE TermOps
tops Prefix
prefix s
initState KeyCommand m s a
cmds n Event
getEvent = do
    let s :: LineChars
s = Prefix -> s -> LineChars
forall s. LineState s => Prefix -> s -> LineChars
lineChars Prefix
prefix s
initState
    LineChars -> n ()
forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s (((s -> CmdM m a) -> CmdM m (a, [Key]))
-> KeyCommand m s a -> KeyMap (CmdM m (a, [Key]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> (a, [Key])) -> CmdM m a -> CmdM m (a, [Key])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x,[])) (CmdM m a -> CmdM m (a, [Key]))
-> ((s -> CmdM m a) -> CmdM m a)
-> (s -> CmdM m a)
-> CmdM m (a, [Key])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((s -> CmdM m a) -> s -> CmdM m a
forall a b. (a -> b) -> a -> b
$ s
initState)) KeyCommand m s a
cmds)
  where
    readMoreKeys :: LineChars -> KeyMap (CmdM m (a,[Key])) -> n a
    readMoreKeys :: LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s KeyMap (CmdM m (a, [Key]))
next = do
        Event
event <- (SomeException -> n Event) -> n Event -> n Event
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(SomeException
e::SomeException) -> LineChars -> n ()
forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s n () -> n Event -> n Event
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> n Event
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e)
                    n Event
getEvent
        case Event
event of
                    ErrorEvent SomeException
e -> LineChars -> n ()
forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s n () -> n a -> n a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> n a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
                    Event
WindowResize -> do
                        (forall b. m b -> n b) -> TermOps -> LineChars -> n ()
forall (n :: * -> *) (m :: * -> *).
(Term n, MonadState Layout m) =>
(forall a. m a -> n a) -> TermOps -> LineChars -> n ()
drawReposition forall b. m b -> n b
liftE TermOps
tops LineChars
s
                        LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s KeyMap (CmdM m (a, [Key]))
next
                    KeyInput [Key]
ks -> do
                        [[Key]]
bound_ks <- (Key -> n [Key]) -> [Key] -> n [[Key]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Prefs -> [Key]) -> n [Key]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Prefs -> [Key]) -> n [Key])
-> (Key -> Prefs -> [Key]) -> Key -> n [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Prefs -> [Key]
lookupKeyBinding) [Key]
ks
                        LineChars -> CmdM m (a, [Key]) -> n a
loopCmd LineChars
s (CmdM m (a, [Key]) -> n a) -> CmdM m (a, [Key]) -> n a
forall a b. (a -> b) -> a -> b
$ [Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
applyKeysToMap ([[Key]] -> [Key]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key]]
bound_ks) KeyMap (CmdM m (a, [Key]))
next
                    ExternalPrint String
str -> do
                        LineChars -> String -> n ()
forall (m :: * -> *). Term m => LineChars -> String -> m ()
printPreservingLineChars LineChars
s String
str
                        LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s KeyMap (CmdM m (a, [Key]))
next

    loopCmd :: LineChars -> CmdM m (a,[Key]) -> n a
    loopCmd :: LineChars -> CmdM m (a, [Key]) -> n a
loopCmd LineChars
s (GetKey KeyMap (CmdM m (a, [Key]))
next) = LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s KeyMap (CmdM m (a, [Key]))
next
    -- If there are multiple consecutive LineChanges, only render the diff
    -- to the last one, and skip the rest. This greatly improves speed when
    -- a large amount of text is pasted in at once.
    loopCmd LineChars
s (DoEffect (LineChange Prefix -> LineChars
_)
                e :: CmdM m (a, [Key])
e@(DoEffect (LineChange Prefix -> LineChars
_) CmdM m (a, [Key])
_)) = LineChars -> CmdM m (a, [Key]) -> n a
loopCmd LineChars
s CmdM m (a, [Key])
e
    loopCmd LineChars
s (DoEffect Effect
e CmdM m (a, [Key])
next) = do
                                    LineChars
t <- Prefix -> LineChars -> Effect -> n LineChars
forall (m :: * -> *).
(Term m, MonadReader Prefs m) =>
Prefix -> LineChars -> Effect -> m LineChars
drawEffect Prefix
prefix LineChars
s Effect
e
                                    LineChars -> CmdM m (a, [Key]) -> n a
loopCmd LineChars
t CmdM m (a, [Key])
next
    loopCmd LineChars
s (CmdM m (CmdM m (a, [Key]))
next) = m (CmdM m (a, [Key])) -> n (CmdM m (a, [Key]))
forall b. m b -> n b
liftE m (CmdM m (a, [Key]))
next n (CmdM m (a, [Key])) -> (CmdM m (a, [Key]) -> n a) -> n a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LineChars -> CmdM m (a, [Key]) -> n a
loopCmd LineChars
s
    loopCmd LineChars
s (Result (a
x,[Key]
ks)) = do
                                    IO () -> n ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TermOps -> [Key] -> IO ()
saveUnusedKeys TermOps
tops [Key]
ks)
                                    LineChars -> n ()
forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s
                                    a -> n a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

printPreservingLineChars :: Term m => LineChars -> String -> m ()
printPreservingLineChars :: forall (m :: * -> *). Term m => LineChars -> String -> m ()
printPreservingLineChars LineChars
s String
str =  do
    LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> m ()
clearLine LineChars
s
    [String] -> m ()
forall (m :: * -> *). Term m => [String] -> m ()
printLines ([String] -> m ()) -> (String -> [String]) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
str
    LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s

drawReposition :: (Term n, MonadState Layout m)
    => (forall a . m a -> n a) -> TermOps -> LineChars -> n ()
drawReposition :: forall (n :: * -> *) (m :: * -> *).
(Term n, MonadState Layout m) =>
(forall a. m a -> n a) -> TermOps -> LineChars -> n ()
drawReposition forall a. m a -> n a
liftE TermOps
tops LineChars
s = do
    Layout
oldLayout <- m Layout -> n Layout
forall a. m a -> n a
liftE m Layout
forall s (m :: * -> *). MonadState s m => m s
get
    Layout
newLayout <- IO Layout -> n Layout
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TermOps -> IO Layout
getLayout TermOps
tops)
    m () -> n ()
forall a. m a -> n a
liftE (Layout -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Layout
newLayout)
    Bool -> n () -> n ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Layout
oldLayout Layout -> Layout -> Bool
forall a. Eq a => a -> a -> Bool
/= Layout
newLayout) (n () -> n ()) -> n () -> n ()
forall a b. (a -> b) -> a -> b
$ Layout -> LineChars -> n ()
forall (m :: * -> *). Term m => Layout -> LineChars -> m ()
reposition Layout
oldLayout LineChars
s

drawEffect :: (Term m, MonadReader Prefs m)
    => Prefix -> LineChars -> Effect -> m LineChars
drawEffect :: forall (m :: * -> *).
(Term m, MonadReader Prefs m) =>
Prefix -> LineChars -> Effect -> m LineChars
drawEffect Prefix
prefix LineChars
s (LineChange Prefix -> LineChars
ch) = do
    let t :: LineChars
t = Prefix -> LineChars
ch Prefix
prefix
    LineChars -> LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> LineChars -> m ()
drawLineDiff LineChars
s LineChars
t
    LineChars -> m LineChars
forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
t
drawEffect Prefix
_ LineChars
s Effect
ClearScreen = do
    m ()
forall (m :: * -> *). Term m => m ()
clearLayout
    LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    LineChars -> m LineChars
forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
s
drawEffect Prefix
_ LineChars
s (PrintLines [String]
ls) = do
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LineChars
s LineChars -> LineChars -> Bool
forall a. Eq a => a -> a -> Bool
/= ([],[])) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s
    [String] -> m ()
forall (m :: * -> *). Term m => [String] -> m ()
printLines [String]
ls
    LineChars -> m ()
forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    LineChars -> m LineChars
forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
s
drawEffect Prefix
_ LineChars
s Effect
RingBell = m ()
forall (m :: * -> *). (Term m, MonadReader Prefs m) => m ()
actBell m () -> m LineChars -> m LineChars
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LineChars -> m LineChars
forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
s

actBell :: (Term m, MonadReader Prefs m) => m ()
actBell :: forall (m :: * -> *). (Term m, MonadReader Prefs m) => m ()
actBell = do
    BellStyle
style <- (Prefs -> BellStyle) -> m BellStyle
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Prefs -> BellStyle
bellStyle
    case BellStyle
style of
        BellStyle
NoBell -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        BellStyle
VisualBell -> Bool -> m ()
forall (m :: * -> *). Term m => Bool -> m ()
ringBell Bool
False
        BellStyle
AudibleBell -> Bool -> m ()
forall (m :: * -> *). Term m => Bool -> m ()
ringBell Bool
True


---------------
-- Traverse through the tree of keybindings, using the given keys.
-- Remove as many GetKeys as possible.
-- Returns any unused keys (so that they can be applied at the next getInputLine).
applyKeysToMap :: Monad m => [Key] -> KeyMap (CmdM m (a,[Key]))
                                -> CmdM m (a,[Key])
applyKeysToMap :: forall (m :: * -> *) a.
Monad m =>
[Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
applyKeysToMap [] KeyMap (CmdM m (a, [Key]))
next = KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey KeyMap (CmdM m (a, [Key]))
next
applyKeysToMap (Key
k:[Key]
ks) KeyMap (CmdM m (a, [Key]))
next = case KeyMap (CmdM m (a, [Key]))
-> Key -> Maybe (KeyConsumed (CmdM m (a, [Key])))
forall a. KeyMap a -> Key -> Maybe (KeyConsumed a)
lookupKM KeyMap (CmdM m (a, [Key]))
next Key
k of
    Maybe (KeyConsumed (CmdM m (a, [Key])))
Nothing -> Effect -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
RingBell (CmdM m (a, [Key]) -> CmdM m (a, [Key]))
-> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall a b. (a -> b) -> a -> b
$ KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey KeyMap (CmdM m (a, [Key]))
next
    Just (Consumed CmdM m (a, [Key])
cmd) -> [Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd [Key]
ks CmdM m (a, [Key])
cmd
    Just (NotConsumed CmdM m (a, [Key])
cmd) -> [Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd (Key
kKey -> [Key] -> [Key]
forall a. a -> [a] -> [a]
:[Key]
ks) CmdM m (a, [Key])
cmd

applyKeysToCmd :: Monad m => [Key] -> CmdM m (a,[Key])
                                -> CmdM m (a,[Key])
applyKeysToCmd :: forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd [Key]
ks (GetKey KeyMap (CmdM m (a, [Key]))
next) = [Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
applyKeysToMap [Key]
ks KeyMap (CmdM m (a, [Key]))
next
applyKeysToCmd [Key]
ks (DoEffect Effect
e CmdM m (a, [Key])
next) = Effect -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
e ([Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd [Key]
ks CmdM m (a, [Key])
next)
applyKeysToCmd [Key]
ks (CmdM m (CmdM m (a, [Key]))
next) = m (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall (m :: * -> *) a. m (CmdM m a) -> CmdM m a
CmdM (m (CmdM m (a, [Key])) -> CmdM m (a, [Key]))
-> m (CmdM m (a, [Key])) -> CmdM m (a, [Key])
forall a b. (a -> b) -> a -> b
$ (CmdM m (a, [Key]) -> CmdM m (a, [Key]))
-> m (CmdM m (a, [Key])) -> m (CmdM m (a, [Key]))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd [Key]
ks) m (CmdM m (a, [Key]))
next
applyKeysToCmd [Key]
ks (Result (a
x,[Key]
ys)) = (a, [Key]) -> CmdM m (a, [Key])
forall (m :: * -> *) a. a -> CmdM m a
Result (a
x,[Key]
ys[Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++[Key]
ks) -- use in the next input line