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 :: s -> Effect
lineChange = (Prefix -> LineChars) -> Effect
LineChange ((Prefix -> LineChars) -> Effect)
-> (s -> Prefix -> LineChars) -> s -> Effect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Prefix -> s -> LineChars) -> s -> Prefix -> LineChars
forall a b c. (a -> b -> c) -> b -> a -> c
flip Prefix -> s -> LineChars
forall s. LineState s => Prefix -> s -> LineChars
lineChars

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

data KeyConsumed a = NotConsumed a | Consumed a

instance Functor KeyMap where
    fmap :: (a -> b) -> KeyMap a -> KeyMap b
fmap a -> b
f KeyMap a
km = (Key -> Maybe (KeyConsumed b)) -> KeyMap b
forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap ((Key -> Maybe (KeyConsumed b)) -> KeyMap b)
-> (Key -> Maybe (KeyConsumed b)) -> KeyMap b
forall a b. (a -> b) -> a -> b
$ (KeyConsumed a -> KeyConsumed b)
-> Maybe (KeyConsumed a) -> Maybe (KeyConsumed b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> KeyConsumed a -> KeyConsumed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Maybe (KeyConsumed a) -> Maybe (KeyConsumed b))
-> (Key -> Maybe (KeyConsumed a)) -> Key -> Maybe (KeyConsumed b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap a -> Key -> Maybe (KeyConsumed a)
forall a. KeyMap a -> Key -> Maybe (KeyConsumed a)
lookupKM KeyMap a
km

instance Functor KeyConsumed where
    fmap :: (a -> b) -> KeyConsumed a -> KeyConsumed b
fmap a -> b
f (NotConsumed a
x) = b -> KeyConsumed b
forall a. a -> KeyConsumed a
NotConsumed (a -> b
f a
x)
    fmap a -> b
f (Consumed a
x) = b -> KeyConsumed b
forall a. a -> KeyConsumed a
Consumed (a -> b
f a
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 :: (a -> b) -> CmdM m a -> CmdM m b
fmap = (a -> b) -> CmdM m a -> CmdM m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad m => Applicative (CmdM m) where
    pure :: a -> CmdM m a
pure  = a -> CmdM m a
forall (m :: * -> *) a. a -> CmdM m a
Result
    <*> :: CmdM m (a -> b) -> CmdM m a -> CmdM m b
(<*>) = CmdM m (a -> b) -> CmdM m a -> CmdM m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (CmdM m) where
    return :: a -> CmdM m a
return = a -> CmdM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    GetKey KeyMap (CmdM m a)
km >>= :: CmdM m a -> (a -> CmdM m b) -> CmdM m b
>>= a -> CmdM m b
g = KeyMap (CmdM m b) -> CmdM m b
forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey (KeyMap (CmdM m b) -> CmdM m b) -> KeyMap (CmdM m b) -> CmdM m b
forall a b. (a -> b) -> a -> b
$ (CmdM m a -> CmdM m b) -> KeyMap (CmdM m a) -> KeyMap (CmdM m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CmdM m a -> (a -> CmdM m b) -> CmdM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CmdM m b
g) KeyMap (CmdM m a)
km
    DoEffect Effect
e CmdM m a
f >>= a -> CmdM m b
g = Effect -> CmdM m b -> CmdM m b
forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
e (CmdM m a
f CmdM m a -> (a -> CmdM m b) -> CmdM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CmdM m b
g)
    CmdM m (CmdM m a)
f >>= a -> CmdM m b
g = m (CmdM m b) -> CmdM m b
forall (m :: * -> *) a. m (CmdM m a) -> CmdM m a
CmdM (m (CmdM m b) -> CmdM m b) -> m (CmdM m b) -> CmdM m b
forall a b. (a -> b) -> a -> b
$ (CmdM m a -> CmdM m b) -> m (CmdM m a) -> m (CmdM m b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (CmdM m a -> (a -> CmdM m b) -> CmdM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> CmdM m b
g) m (CmdM m a)
f
    Result a
x >>= a -> CmdM m b
g = a -> CmdM m b
g a
x

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

instance MonadTrans CmdM where
    lift :: m a -> CmdM m a
lift m a
m = m (CmdM m a) -> CmdM m a
forall (m :: * -> *) a. m (CmdM m a) -> CmdM m a
CmdM (m (CmdM m a) -> CmdM m a) -> m (CmdM m a) -> CmdM m a
forall a b. (a -> b) -> a -> b
$ do
        a
x <- m a
m
        CmdM m a -> m (CmdM m a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdM m a -> m (CmdM m a)) -> CmdM m a -> m (CmdM m a)
forall a b. (a -> b) -> a -> b
$ a -> CmdM m a
forall (m :: * -> *) a. a -> CmdM m a
Result a
x

keyCommand :: KeyCommand m s t -> Command m s t
keyCommand :: KeyCommand m s t -> Command m s t
keyCommand KeyCommand m s t
km = \s
s -> KeyMap (CmdM m t) -> CmdM m t
forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey (KeyMap (CmdM m t) -> CmdM m t) -> KeyMap (CmdM m t) -> CmdM m t
forall a b. (a -> b) -> a -> b
$ (Command m s t -> CmdM m t)
-> KeyCommand m s t -> KeyMap (CmdM m t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command m s t -> Command m s t
forall a b. (a -> b) -> a -> b
$ s
s) KeyCommand m s t
km

useKey :: Key -> a -> KeyMap a
useKey :: Key -> a -> KeyMap a
useKey Key
k a
x = (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap ((Key -> Maybe (KeyConsumed a)) -> KeyMap a)
-> (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a b. (a -> b) -> a -> b
$ \Key
k' -> if Key
kKey -> Key -> Bool
forall a. Eq a => a -> a -> Bool
==Key
k' then KeyConsumed a -> Maybe (KeyConsumed a)
forall a. a -> Maybe a
Just (a -> KeyConsumed a
forall a. a -> KeyConsumed a
Consumed a
x) else Maybe (KeyConsumed a)
forall a. Maybe a
Nothing

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

withoutConsuming :: Command m s t -> KeyCommand m s t
withoutConsuming :: Command m s t -> KeyCommand m s t
withoutConsuming = (Key -> Maybe (KeyConsumed (Command m s t))) -> KeyCommand m s t
forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap ((Key -> Maybe (KeyConsumed (Command m s t))) -> KeyCommand m s t)
-> (Command m s t -> Key -> Maybe (KeyConsumed (Command m s t)))
-> Command m s t
-> KeyCommand m s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (KeyConsumed (Command m s t))
-> Key -> Maybe (KeyConsumed (Command m s t))
forall a b. a -> b -> a
const (Maybe (KeyConsumed (Command m s t))
 -> Key -> Maybe (KeyConsumed (Command m s t)))
-> (Command m s t -> Maybe (KeyConsumed (Command m s t)))
-> Command m s t
-> Key
-> Maybe (KeyConsumed (Command m s t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyConsumed (Command m s t) -> Maybe (KeyConsumed (Command m s t))
forall a. a -> Maybe a
Just (KeyConsumed (Command m s t)
 -> Maybe (KeyConsumed (Command m s t)))
-> (Command m s t -> KeyConsumed (Command m s t))
-> Command m s t
-> Maybe (KeyConsumed (Command m s t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command m s t -> KeyConsumed (Command m s t)
forall a. a -> KeyConsumed a
NotConsumed

choiceCmd :: [KeyMap a] -> KeyMap a
choiceCmd :: [KeyMap a] -> KeyMap a
choiceCmd = (KeyMap a -> KeyMap a -> KeyMap a)
-> KeyMap a -> [KeyMap a] -> KeyMap a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl KeyMap a -> KeyMap a -> KeyMap a
forall a. KeyMap a -> KeyMap a -> KeyMap a
orKM KeyMap a
forall a. KeyMap a
nullKM
    where
        nullKM :: KeyMap a
nullKM = (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap ((Key -> Maybe (KeyConsumed a)) -> KeyMap a)
-> (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a b. (a -> b) -> a -> b
$ Maybe (KeyConsumed a) -> Key -> Maybe (KeyConsumed a)
forall a b. a -> b -> a
const Maybe (KeyConsumed a)
forall a. Maybe a
Nothing
        orKM :: KeyMap a -> KeyMap a -> KeyMap a
orKM (KeyMap Key -> Maybe (KeyConsumed a)
f) (KeyMap Key -> Maybe (KeyConsumed a)
g) = (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap ((Key -> Maybe (KeyConsumed a)) -> KeyMap a)
-> (Key -> Maybe (KeyConsumed a)) -> KeyMap a
forall a b. (a -> b) -> a -> b
$ \Key
k -> Key -> Maybe (KeyConsumed a)
f Key
k Maybe (KeyConsumed a)
-> Maybe (KeyConsumed a) -> Maybe (KeyConsumed a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Key -> Maybe (KeyConsumed a)
g Key
k

keyChoiceCmd :: [KeyCommand m s t] -> Command m s t
keyChoiceCmd :: [KeyCommand m s t] -> Command m s t
keyChoiceCmd = KeyCommand m s t -> Command m s t
forall (m :: * -> *) s t. KeyCommand m s t -> Command m s t
keyCommand (KeyCommand m s t -> Command m s t)
-> ([KeyCommand m s t] -> KeyCommand m s t)
-> [KeyCommand m s t]
-> Command m s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyCommand m s t] -> KeyCommand m s t
forall a. [KeyMap a] -> KeyMap a
choiceCmd

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

infixr 6 >|>
(>|>) :: Monad m => Command m s t -> Command m t u -> Command m s u
Command m s t
f >|> :: Command m s t -> Command m t u -> Command m s u
>|> Command m t u
g = \s
x -> Command m s t
f s
x CmdM m t -> Command m t u -> CmdM m u
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Command m t u
g

infixr 6 >+>
(>+>) :: Monad m => KeyCommand m s t -> Command m t u -> KeyCommand m s u
KeyCommand m s t
km >+> :: KeyCommand m s t -> Command m t u -> KeyCommand m s u
>+> Command m t u
g = (Command m s t -> Command m s u)
-> KeyCommand m s t -> KeyCommand m s u
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command m s t -> Command m t u -> Command m s u
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> Command m t u
g) KeyCommand m s t
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 :: KeyCommand m s s -> Command m s s
try KeyCommand m s s
f = [KeyCommand m s s] -> Command m s s
forall (m :: * -> *) s t. [KeyCommand m s t] -> Command m s t
keyChoiceCmd [KeyCommand m s s
f,Command m s s -> KeyCommand m s s
forall (m :: * -> *) s t. Command m s t -> KeyCommand m s t
withoutConsuming Command m s s
forall (m :: * -> *) a. Monad m => a -> m a
return]

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

finish :: (Monad m, Result s) => Command m s (Maybe String)
finish :: Command m s (Maybe String)
finish = Maybe String -> CmdM m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> CmdM m (Maybe String))
-> (s -> Maybe String) -> Command m s (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> (s -> String) -> s -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> String
forall s. Result s => s -> String
toResult

failCmd :: Monad m => Command m s (Maybe a)
failCmd :: Command m s (Maybe a)
failCmd s
_ = Maybe a -> CmdM m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

effect :: Effect -> CmdM m ()
effect :: Effect -> CmdM m ()
effect Effect
e = Effect -> CmdM m () -> CmdM m ()
forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
e (CmdM m () -> CmdM m ()) -> CmdM m () -> CmdM m ()
forall a b. (a -> b) -> a -> b
$ () -> CmdM m ()
forall (m :: * -> *) a. a -> CmdM m a
Result ()

clearScreenCmd :: Command m s s
clearScreenCmd :: Command m s s
clearScreenCmd = Effect -> CmdM m s -> CmdM m s
forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
ClearScreen (CmdM m s -> CmdM m s) -> Command m s s -> Command m s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command m s s
forall (m :: * -> *) a. a -> CmdM m a
Result

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

charCommand :: (LineState s, Monad m) => (Char -> s -> m (Either Effect s))
                    -> KeyCommand m s s
charCommand :: (Char -> s -> m (Either Effect s)) -> KeyCommand m s s
charCommand Char -> s -> m (Either Effect s)
f = (Char -> Command m s s) -> KeyCommand m s s
forall (m :: * -> *) s t.
(Char -> Command m s t) -> KeyCommand m s t
useChar ((Char -> Command m s s) -> KeyCommand m s s)
-> (Char -> Command m s s) -> KeyCommand m s s
forall a b. (a -> b) -> a -> b
$ (s -> m (Either Effect s)) -> Command m s s
forall s (m :: * -> *).
(LineState s, Monad m) =>
(s -> m (Either Effect s)) -> Command m s s
simpleCommand ((s -> m (Either Effect s)) -> Command m s s)
-> (Char -> s -> m (Either Effect s)) -> Char -> Command m s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> s -> m (Either Effect s)
f

setState :: (Monad m, LineState s) => Command m s s
setState :: Command m s s
setState s
s = Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect (s -> Effect
forall s. LineState s => s -> Effect
lineChange s
s) CmdM m () -> CmdM m s -> CmdM m s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Command m s s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s

change :: (LineState t, Monad m) => (s -> t) -> Command m s t
change :: (s -> t) -> Command m s t
change = (Command m t t
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState Command m t t -> (s -> t) -> Command m s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t
changeFromChar :: (Char -> s -> t) -> KeyCommand m s t
changeFromChar Char -> s -> t
f = (Char -> Command m s t) -> KeyCommand m s t
forall (m :: * -> *) s t.
(Char -> Command m s t) -> KeyCommand m s t
useChar ((Char -> Command m s t) -> KeyCommand m s t)
-> (Char -> Command m s t) -> KeyCommand m s t
forall a b. (a -> b) -> a -> b
$ (s -> t) -> Command m s t
forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change ((s -> t) -> Command m s t)
-> (Char -> s -> t) -> Char -> Command m s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> s -> t
f

doBefore :: Monad m => Command m s t -> KeyCommand m t u -> KeyCommand m s u
doBefore :: Command m s t -> KeyCommand m t u -> KeyCommand m s u
doBefore Command m s t
cmd = (Command m t u -> Command m s u)
-> KeyCommand m t u -> KeyCommand m s u
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command m s t
cmd Command m s t -> Command m t u -> Command m s u
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|>)