module System.Console.Haskeline.Command(
Effect(..),
KeyMap(),
lookupKM,
KeyAction(..),
CmdAction(..),
(>=>),
Command(),
runCommand,
continue,
(>|>),
(>+>),
acceptKey,
acceptKeyM,
acceptKeyOrFail,
loopUntil,
try,
finish,
failCmd,
simpleCommand,
charCommand,
change,
changeFromChar,
changeWithoutKey,
clearScreenCmd,
(+>),
choiceCmd,
withState
) where
import Data.Char(isPrint)
import Control.Monad(mplus)
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Key
data Effect s = Change {effectState :: s}
| PrintLines {linesToPrint :: [String], effectState :: s}
| Redraw {shouldClearScreen :: Bool, effectState :: s}
| RingBell {effectState :: s}
newtype KeyMap m s = KeyMap {lookupKM :: Key -> Maybe
(s -> Either (Maybe String) (m (KeyAction m)))}
useKey :: Key -> (s -> Either (Maybe String) (m (KeyAction m))) -> KeyMap m s
useKey k f = KeyMap $ \k' -> if k==k' then Just f else Nothing
data KeyAction m = forall t . LineState t => KeyAction (Effect t) (KeyMap m t)
nullKM :: KeyMap m s
nullKM = KeyMap $ const Nothing
orKM :: KeyMap m s -> KeyMap m s -> KeyMap m s
orKM (KeyMap m) (KeyMap n) = KeyMap $ \k -> m k `mplus` n k
choiceKM :: [KeyMap m s] -> KeyMap m s
choiceKM = foldl orKM nullKM
newtype Command m s t = Command (KeyMap m t -> KeyMap m s)
runCommand :: Command m s s -> KeyMap m s
runCommand (Command f) = let m = f m in m
continue :: Command m s s
continue = Command id
infixl 6 >|>
(>|>) :: Command m s t -> Command m t u -> Command m s u
Command f >|> Command g = Command (f . g)
infixl 6 >+>
(>+>) :: (Monad m, LineState s) => Key -> Command m s t -> Command m s t
k >+> f = k +> change id >|> f
data CmdAction m s = forall t . LineState t => CmdAction (Effect t) (Command m t s)
(>=>) :: LineState t => Effect t -> Command m t s -> CmdAction m s
(>=>) = CmdAction
acceptKey :: (Monad m) => (s -> CmdAction m t) -> Key -> Command m s t
acceptKey f = acceptKeyFull (Just . return . f)
acceptKeyM :: Monad m => (s -> m (CmdAction m t)) -> Key -> Command m s t
acceptKeyM f = acceptKeyFull (Just . f)
acceptKeyFull :: Monad m => (s -> Maybe (m (CmdAction m t)))
-> Key -> Command m s t
acceptKeyFull f k = Command $ \next -> useKey k $ \s -> case f s of
Nothing -> Left Nothing
Just act -> Right $ do
CmdAction effect (Command g) <- act
return (KeyAction effect (g next))
acceptKeyOrFail :: Monad m => (s -> Maybe (CmdAction m t)) -> Key
-> Command m s t
acceptKeyOrFail f = acceptKeyFull (fmap return . f)
loopUntil :: Command m s s -> Command m s t -> Command m s t
loopUntil f g = choiceCmd [g, f >|> loopUntil f g]
try :: Command m s s -> Command m s s
try (Command f) = Command $ \next -> f next `orKM` next
finish :: forall s m t . (Result s, Monad m) => Key -> Command m s t
finish k = Command $ \_-> useKey k (Left . Just . toResult)
failCmd :: forall s m t . (LineState s, Monad m) => Key -> Command m s t
failCmd k = Command $ \_-> useKey k (const $ Left Nothing)
simpleCommand :: (LineState t, Monad m) => (s -> m (Effect t))
-> Key -> Command m s t
simpleCommand f = acceptKeyM $ \s -> do
act <- f s
return (act >=> continue)
charCommand :: (LineState t, Monad m) => (Char -> s -> m (Effect t))
-> Command m s t
charCommand f = Command $ \next -> KeyMap $ \k -> case k of
Key m (KeyChar c) | isPrint c && m==noModifier-> Just $ \s -> Right $ do
effect <- f c s
return (KeyAction effect next)
_ -> Nothing
change :: (LineState t, Monad m) => (s -> t) -> Key -> Command m s t
change f = simpleCommand (return . Change . f)
changeFromChar :: (Monad m, LineState t) => (Char -> s -> t) -> Command m s t
changeFromChar f = charCommand (\c s -> return $ Change (f c s))
changeWithoutKey :: (s -> t) -> Command m s t
changeWithoutKey f = Command $ \(KeyMap next) -> KeyMap $ fmap (. f) . next
clearScreenCmd :: (LineState s, Monad m) => Key -> Command m s s
clearScreenCmd k = k +> simpleCommand (\s -> return (Redraw True s))
infixl 7 +>
(+>) :: Key -> (Key -> a) -> a
k +> f = f k
choiceCmd :: [Command m s t] -> Command m s t
choiceCmd cmds = Command $ \next ->
choiceKM $ map (\(Command f) -> f next) cmds
withState :: Monad m => (s -> m a) -> Command m s t -> Command m s t
withState act (Command thisCmd) = Command $ \next -> KeyMap $ \k ->
case lookupKM (thisCmd next) k of
Nothing -> Nothing
Just f -> Just $ \s -> case f s of
Left r -> Left r
Right effect -> Right $ act s >> effect