    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