{-# 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
  { CLIHandler -> String
cliPrefix :: String
  , ()
cliExec   :: cmd -> IO ()
  , ()
cliParser :: Parser cmd
  , CLIHandler -> [String]
cliHelp   :: [String]
  }

data Command
    = Quit
    | Help
      deriving (Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Eq Command
Eq Command
-> (Command -> Command -> Ordering)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Bool)
-> (Command -> Command -> Command)
-> (Command -> Command -> Command)
-> Ord Command
Command -> Command -> Bool
Command -> Command -> Ordering
Command -> Command -> Command
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Command -> Command -> Command
$cmin :: Command -> Command -> Command
max :: Command -> Command -> Command
$cmax :: Command -> Command -> Command
>= :: Command -> Command -> Bool
$c>= :: Command -> Command -> Bool
> :: Command -> Command -> Bool
$c> :: Command -> Command -> Bool
<= :: Command -> Command -> Bool
$c<= :: Command -> Command -> Bool
< :: Command -> Command -> Bool
$c< :: Command -> Command -> Bool
compare :: Command -> Command -> Ordering
$ccompare :: Command -> Command -> Ordering
$cp1Ord :: Eq Command
Ord, ReadPrec [Command]
ReadPrec Command
Int -> ReadS Command
ReadS [Command]
(Int -> ReadS Command)
-> ReadS [Command]
-> ReadPrec Command
-> ReadPrec [Command]
-> Read Command
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Command]
$creadListPrec :: ReadPrec [Command]
readPrec :: ReadPrec Command
$creadPrec :: ReadPrec Command
readList :: ReadS [Command]
$creadList :: ReadS [Command]
readsPrec :: Int -> ReadS Command
$creadsPrec :: Int -> ReadS Command
Read, Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

pCommand :: Parser Command
pCommand :: Parser Command
pCommand =
    do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"quit" ParsecT String () Identity String
-> Parser Command -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Command -> Parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Quit
    Parser Command -> Parser Command -> Parser Command
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
    do String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"help" ParsecT String () Identity String
-> Parser Command -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Command -> Parser Command
forall (m :: * -> *) a. Monad m => a -> m a
return Command
Help

{-
    do string "user"
       skipMany1 space
       User <$> pUserCmd
    <|>
-}


loop :: [CLIHandler] -> IO () -- InputT IO ()
loop :: [CLIHandler] -> IO ()
loop [CLIHandler]
handlers' =
  let handlers :: Map String CLIHandler
handlers = [(String, CLIHandler)] -> Map String CLIHandler
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((CLIHandler -> (String, CLIHandler))
-> [CLIHandler] -> [(String, CLIHandler)]
forall a b. (a -> b) -> [a] -> [b]
map (\CLIHandler
h -> (CLIHandler -> String
cliPrefix CLIHandler
h, CLIHandler
h)) [CLIHandler]
handlers') in
  Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings (InputT IO () -> IO ()) -> InputT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ InputT IO () -> InputT IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (InputT IO () -> InputT IO ()) -> InputT IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$
  do Maybe String
minput <- String -> InputT IO (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
"% "
     case Maybe String
minput of
       Maybe String
Nothing -> () -> InputT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just String
input ->
         let (String
prefix, String
rest') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
input
             rest :: String
rest = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
rest'
         in case String
prefix of
           String
"help" -> IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> Command -> IO ()
execCommand (((String, CLIHandler) -> [String])
-> [(String, CLIHandler)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (CLIHandler -> [String]
cliHelp (CLIHandler -> [String])
-> ((String, CLIHandler) -> CLIHandler)
-> (String, CLIHandler)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, CLIHandler) -> CLIHandler
forall a b. (a, b) -> b
snd) (Map String CLIHandler -> [(String, CLIHandler)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map String CLIHandler
handlers)) Command
Help
           String
"quit" -> IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
forall a. IO a
exitSuccess
           String
_ -> case String -> Map String CLIHandler -> Maybe CLIHandler
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
prefix Map String CLIHandler
handlers of
                  Maybe CLIHandler
Nothing -> IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"unknow command prefix: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prefix
                  (Just (CLIHandler String
_ cmd -> IO ()
exec Parser cmd
parser [String]
_)) ->
                    do let r :: Either ParseError cmd
r = Parser cmd -> String -> String -> Either ParseError cmd
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser cmd
parser String
input String
rest
                       case Either ParseError cmd
r of
                         (Left ParseError
e) ->
                           do IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ ParseError -> IO ()
forall a. Show a => a -> IO ()
print ParseError
e
                         (Right cmd
cmd) ->
                           do IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ cmd -> IO ()
exec cmd
cmd

execCommand :: [String] -> Command -> IO ()
execCommand :: [String] -> Command -> IO ()
execCommand [String]
helps Command
Help =
    do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String]
helps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
showHelp)
       () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

showHelp :: [String]
showHelp :: [String]
showHelp =
    [ String
"quit                               - quit"
    , String
"help                               - show this help"
    ]