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 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
            -> forall a. n a -> m a
eval forall a b. (a -> b) -> a -> b
$ TermOps
-> forall (m :: * -> *) a.
   CommandMonad m =>
   (m Event -> m a) -> m a
withGetEvent TermOps
tops
                forall a b. (a -> b) -> a -> b
$ 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 = forall s. LineState s => Prefix -> s -> LineChars
lineChars Prefix
prefix s
initState
    forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    LineChars -> KeyMap (CmdM m (a, [Key])) -> n a
readMoreKeys LineChars
s (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a
x -> (a
x,[])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\(SomeException
e::SomeException) -> forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e)
                    n Event
getEvent
        case Event
event of
                    ErrorEvent SomeException
e -> forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
                    Event
WindowResize -> do
                        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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks 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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
[Key] -> KeyMap (CmdM m (a, [Key])) -> CmdM m (a, [Key])
applyKeysToMap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Key]]
bound_ks) KeyMap (CmdM m (a, [Key]))
next
                    ExternalPrint String
str -> do
                        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 <- 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) = forall b. m b -> n b
liftE m (CmdM m (a, [Key]))
next 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
                                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TermOps -> [Key] -> IO ()
saveUnusedKeys TermOps
tops [Key]
ks)
                                    forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s
                                    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
    forall (m :: * -> *). Term m => LineChars -> m ()
clearLine LineChars
s
    forall (m :: * -> *). Term m => [String] -> m ()
printLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
str
    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 <- forall a. m a -> n a
liftE forall s (m :: * -> *). MonadState s m => m s
get
    Layout
newLayout <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TermOps -> IO Layout
getLayout TermOps
tops)
    forall a. m a -> n a
liftE (forall s (m :: * -> *). MonadState s m => s -> m ()
put Layout
newLayout)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Layout
oldLayout forall a. Eq a => a -> a -> Bool
/= Layout
newLayout) forall a b. (a -> b) -> a -> b
$ 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
    forall (m :: * -> *). Term m => LineChars -> LineChars -> m ()
drawLineDiff LineChars
s LineChars
t
    forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
t
drawEffect Prefix
_ LineChars
s Effect
ClearScreen = do
    forall (m :: * -> *). Term m => m ()
clearLayout
    forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
s
drawEffect Prefix
_ LineChars
s (PrintLines [String]
ls) = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LineChars
s forall a. Eq a => a -> a -> Bool
/= ([],[])) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Term m => LineChars -> m ()
moveToNextLine LineChars
s
    forall (m :: * -> *). Term m => [String] -> m ()
printLines [String]
ls
    forall (m :: * -> *). Term m => LineChars -> m ()
drawLine LineChars
s
    forall (m :: * -> *) a. Monad m => a -> m a
return LineChars
s
drawEffect Prefix
_ LineChars
s Effect
RingBell = forall (m :: * -> *). (Term m, MonadReader Prefs m) => m ()
actBell forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Prefs -> BellStyle
bellStyle
    case BellStyle
style of
        BellStyle
NoBell -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        BellStyle
VisualBell -> forall (m :: * -> *). Term m => Bool -> m ()
ringBell Bool
False
        BellStyle
AudibleBell -> 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 = 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 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 -> forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
RingBell forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey KeyMap (CmdM m (a, [Key]))
next
    Just (Consumed CmdM m (a, [Key])
cmd) -> 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) -> forall (m :: * -> *) a.
Monad m =>
[Key] -> CmdM m (a, [Key]) -> CmdM m (a, [Key])
applyKeysToCmd (Key
kforall 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) = 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) = forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
e (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) = forall (m :: * -> *) a. m (CmdM m a) -> CmdM m a
CmdM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (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)) = forall (m :: * -> *) a. a -> CmdM m a
Result (a
x,[Key]
ysforall a. [a] -> [a] -> [a]
++[Key]
ks) -- use in the next input line