System/Console/Haskeline/Command.hs

    module System.Console.Haskeline.Command(
                            -- * Commands
                            Effect(..),
                            KeyMap(..),
                            CmdM(..),
                            Command,
                            KeyCommand,
                            KeyConsumed(..),
                            withoutConsuming,
                            keyCommand,
                            (>|>),
                            (>+>),
                            try,
                            effect,
                            clearScreenCmd,
                            finish,
                            failCmd,
                            simpleCommand,
                            charCommand,
                            setState,
                            change,
                            changeFromChar,
                            (+>),
                            useChar,
                            choiceCmd,
                            keyChoiceCmd,
                            keyChoiceCmdM,
                            doBefore
                            ) where

    import Data.Char(isPrint)
    import Control.Applicative(Applicative(..))
    import Control.Monad(ap, mplus, liftM)
    import Control.Monad.Trans.Class
    import System.Console.Haskeline.LineState
    import System.Console.Haskeline.Key

    data Effect = LineChange (Prefix -> LineChars)
                  | PrintLines [String]
                  | ClearScreen
                  | RingBell

    lineChange :: LineState s => s -> Effect
    lineChange = LineChange . flip lineChars

    data KeyMap a = KeyMap {lookupKM :: Key -> Maybe (KeyConsumed a)}

    data KeyConsumed a = NotConsumed a | Consumed a

    instance Functor KeyMap where
        fmap f km = KeyMap $ fmap (fmap f) . lookupKM km

    instance Functor KeyConsumed where
        fmap f (NotConsumed x) = NotConsumed (f x)
        fmap f (Consumed x) = Consumed (f x)

    data CmdM m a   = GetKey (KeyMap (CmdM m a))
                    | DoEffect Effect (CmdM m a)
                    | CmdM (m (CmdM m a))
                    | Result a

    type Command m s t = s -> CmdM m t

    instance Monad m => Functor (CmdM m) where
        fmap = liftM

    instance Monad m => Applicative (CmdM m) where
        pure  = return
        (<*>) = ap

    instance Monad m => Monad (CmdM m) where
        return = Result

        GetKey km >>= g = GetKey $ fmap (>>= g) km
        DoEffect e f >>= g = DoEffect e (f >>= g)
        CmdM f >>= g = CmdM $ liftM (>>= g) f
        Result x >>= g = g x

    type KeyCommand m s t = KeyMap (Command m s t)

    instance MonadTrans CmdM where
        lift m = CmdM $ do
            x <- m
            return $ Result x

    keyCommand :: KeyCommand m s t -> Command m s t
    keyCommand km = \s -> GetKey $ fmap ($ s) km

    useKey :: Key -> a -> KeyMap a
    useKey k x = KeyMap $ \k' -> if k==k' then Just (Consumed x) else Nothing

    -- TODO: could just be a monadic action that returns a Char.
    useChar :: (Char -> Command m s t) -> KeyCommand m s t
    useChar act = KeyMap $ \k -> case k of
                        Key m (KeyChar c) | isPrint c && m==noModifier
                            -> Just $ Consumed (act c)
                        _ -> Nothing

    withoutConsuming :: Command m s t -> KeyCommand m s t
    withoutConsuming = KeyMap . const . Just . NotConsumed

    choiceCmd :: [KeyMap a] -> KeyMap a
    choiceCmd = foldl orKM nullKM
        where
            nullKM = KeyMap $ const Nothing
            orKM (KeyMap f) (KeyMap g) = KeyMap $ \k -> f k `mplus` g k

    keyChoiceCmd :: [KeyCommand m s t] -> Command m s t
    keyChoiceCmd = keyCommand . choiceCmd

    keyChoiceCmdM :: [KeyMap (CmdM m a)] -> CmdM m a
    keyChoiceCmdM = GetKey . choiceCmd

    infixr 6 >|>
    (>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u
    f >|> g = \x -> f x >>= g

    infixr 6 >+>
    (>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u
    km >+> g = fmap (>|> g) km

    -- attempt to run the command (predicated on getting a valid key); but if it fails, just keep
    -- going.
    try :: Monad m => KeyCommand m s s -> Command m s s
    try f = keyChoiceCmd [f,withoutConsuming return]

    infixr 6 +>
    (+>) :: Key -> a -> KeyMap a
    (+>) = useKey

    finish :: (Monad m, Result s) => Command m s (Maybe String)
    finish = return . Just . toResult

    failCmd :: Monad m => Command m s (Maybe a)
    failCmd _ = return Nothing

    effect :: Effect -> CmdM m ()
    effect e = DoEffect e $ Result ()

    clearScreenCmd :: Command m s s
    clearScreenCmd = DoEffect ClearScreen . Result

    simpleCommand :: (LineState s, Monad m) => (s -> m (Either Effect s))
            -> Command m s s
    simpleCommand f = \s -> do
        et <- lift (f s)
        case et of
            Left e -> effect e >> return s
            Right t -> setState t

    charCommand :: (LineState s, Monad m) => (Char -> s -> m (Either Effect s))
                        -> KeyCommand m s s
    charCommand f = useChar $ simpleCommand . f

    setState :: (Monad m, LineState s) => Command m s s
    setState s = effect (lineChange s) >> return s

    change :: (LineState t, Monad m) => (s -> t) -> Command m s t
    change = (setState .)

    changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t
    changeFromChar f = useChar $ change . f

    doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u
    doBefore cmd = fmap (cmd >|>)