{-# language ExistentialQuantification #-}
module Clckwrks.CLI.Core where
import Control.Applicative ((<$>), (<*>), (*>), pure)
import Control.Monad (forever)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Trans (liftIO)
import Data.Acid (AcidState)
import Data.Acid.Advanced (query', update')
import Data.Acid.Remote (openRemoteState, skipAuthenticationPerform)
import Data.Map (Map)
import qualified Data.Map as Map
import System.Environment
import System.Exit (exitSuccess)
import System.Console.Haskeline
import Text.Parsec
import Text.Parsec.String
data CLIHandler = forall cmd. CLIHandler
{ cliPrefix :: String
, cliExec :: cmd -> IO ()
, cliParser :: Parser cmd
, cliHelp :: [String]
}
data Command
= Quit
| Help
deriving (Eq, Ord, Read, Show)
pCommand :: Parser Command
pCommand =
do string "quit" *> return Quit
<|>
do string "help" *> return Help
loop :: [CLIHandler] -> IO ()
loop handlers' =
let handlers = Map.fromList (map (\h -> (cliPrefix h, h)) handlers') in
runInputT defaultSettings $ forever $
do minput <- getInputLine "% "
case minput of
Nothing -> return ()
Just input ->
let (prefix, rest') = span (/= ' ') $ dropWhile (== ' ') $ input
rest = dropWhile (== ' ') $ rest'
in case prefix of
"help" -> liftIO $ execCommand (concatMap (cliHelp . snd) (Map.toAscList handlers)) Help
"quit" -> liftIO $ exitSuccess
_ -> case Map.lookup prefix handlers of
Nothing -> liftIO $ putStrLn $ "unknow command prefix: " ++ prefix
(Just (CLIHandler _ exec parser _)) ->
do let r = parse parser input rest
case r of
(Left e) ->
do liftIO $ print e
(Right cmd) ->
do liftIO $ exec cmd
execCommand :: [String] -> Command -> IO ()
execCommand helps Help =
do putStrLn $ unlines $ (helps ++ showHelp)
return ()
showHelp :: [String]
showHelp =
[ "quit - quit"
, "help - show this help"
]