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

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

data KeyConsumed a = NotConsumed a | Consumed a

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

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

instance Monad m => Applicative (CmdM m) where
    pure :: forall a. a -> CmdM m a
pure  = forall (m :: * -> *) a. a -> CmdM m a
Result
    <*> :: forall a 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 :: forall a. a -> CmdM m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    GetKey KeyMap (CmdM m a)
km >>= :: forall a b. CmdM m a -> (a -> CmdM m b) -> CmdM m b
>>= a -> CmdM m b
g = forall (m :: * -> *) a. KeyMap (CmdM m a) -> CmdM m a
GetKey forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall (m :: * -> *) a. Effect -> CmdM m a -> CmdM m a
DoEffect Effect
e (CmdM m a
f 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 = 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 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 :: forall (m :: * -> *) a. Monad m => m a -> CmdM m a
lift m a
m = forall (m :: * -> *) a. m (CmdM m a) -> CmdM m a
CmdM forall a b. (a -> b) -> a -> b
$ do
        a
x <- m a
m
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. a -> CmdM m a
Result a
x

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

useKey :: Key -> a -> KeyMap a
useKey :: forall a. Key -> a -> KeyMap a
useKey Key
k a
x = forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap forall a b. (a -> b) -> a -> b
$ \Key
k' -> if Key
kforall a. Eq a => a -> a -> Bool
==Key
k' then forall a. a -> Maybe a
Just (forall a. a -> KeyConsumed a
Consumed a
x) else 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 :: forall (m :: * -> *) s t.
(Char -> Command m s t) -> KeyCommand m s t
useChar Char -> Command m s t
act = forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap 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
mforall a. Eq a => a -> a -> Bool
==Modifier
noModifier
                        -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> KeyConsumed a
Consumed (Char -> Command m s t
act Char
c)
                    Key
_ -> forall a. Maybe a
Nothing

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

choiceCmd :: [KeyMap a] -> KeyMap a
choiceCmd :: forall a. [KeyMap a] -> KeyMap a
choiceCmd = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}. KeyMap a -> KeyMap a -> KeyMap a
orKM forall {a}. KeyMap a
nullKM
    where
        nullKM :: KeyMap a
nullKM = forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const 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) = forall a. (Key -> Maybe (KeyConsumed a)) -> KeyMap a
KeyMap forall a b. (a -> b) -> a -> b
$ \Key
k -> Key -> Maybe (KeyConsumed a)
f Key
k 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 :: forall (m :: * -> *) s t. [KeyCommand m s t] -> Command m s t
keyChoiceCmd = forall (m :: * -> *) s t. KeyCommand m s t -> Command m s t
keyCommand forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [KeyMap a] -> KeyMap a
choiceCmd

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

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

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

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

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

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

simpleCommand :: (LineState s, Monad m) => (s -> m (Either Effect s))
        -> Command m s s
simpleCommand :: forall s (m :: * -> *).
(LineState s, Monad m) =>
(s -> m (Either Effect s)) -> Command m s s
simpleCommand s -> m (Either Effect s)
f = \s
s -> do
    Either Effect s
et <- 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 -> forall (m :: * -> *). Effect -> CmdM m ()
effect Effect
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return s
s
        Right s
t -> 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 :: forall s (m :: * -> *).
(LineState s, Monad m) =>
(Char -> s -> m (Either Effect s)) -> KeyCommand m s s
charCommand Char -> s -> m (Either Effect s)
f = forall (m :: * -> *) s t.
(Char -> Command m s t) -> KeyCommand m s t
useChar forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *).
(LineState s, Monad m) =>
(s -> m (Either Effect s)) -> Command m s s
simpleCommand 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 :: forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState s
s = forall (m :: * -> *). Effect -> CmdM m ()
effect (forall s. LineState s => s -> Effect
lineChange s
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return s
s

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

changeFromChar :: (LineState t, Monad m) => (Char -> s -> t) -> KeyCommand m s t
changeFromChar :: forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(Char -> s -> t) -> KeyCommand m s t
changeFromChar Char -> s -> t
f = forall (m :: * -> *) s t.
(Char -> Command m s t) -> KeyCommand m s t
useChar forall a b. (a -> b) -> a -> b
$ forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change 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 :: forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> KeyCommand m t u -> KeyCommand m s u
doBefore Command m s t
cmd = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Command m s t
cmd forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|>)