structured-cli-0.9.3.0: example/Main.hs

{-# LANGUAGE RecordWildCards, FlexibleContexts #-}
module Main where

import Control.Monad.Trans          (lift)
import Control.Monad.IO.Class       (liftIO)
import Control.Monad.State.Strict   (StateT, evalStateT, gets, modify)
import Data.Char                    (isSpace)
import Data.Default                 (def)
import Data.List                    (span)
import System.Console.StructuredCLI
import Text.Read                    (readMaybe)

data AppState = AppState { bars :: Int,
                           bazs :: Int }

type StateM = StateT AppState IO

root :: CommandsT StateM ()
root = do
  basic
  foo

basic :: CommandsT StateM ()
basic = do
  top $ Just "return to the top of the tree"
  exit $ Just "go back one level up"

foo :: CommandsT StateM ()
foo =
    command "foo" (Just "pity the foo") Nothing >+ do
      basic
      bar
      baz

bar :: CommandsT StateM ()
bar = param "bar" (Just "<number of bars>") parseBars Nothing >+ do
        basic
        frob

baz :: CommandsT StateM ()
baz = command "baz" (Just "do the baz thing") $ Just $ do
        n <- lift $ modify incBaz >> gets bazs
        liftIO . putStrLn $ "You have bazzed " ++ show n ++ " times"
        return 0
            where incBaz s@AppState{..} = s { bazs = bazs + 1 }

frob :: CommandsT StateM ()
frob = command "frob" (Just "frob this level") $ Just $ do
         n <- lift $ gets bars
         liftIO . putStrLn $ "frobbing " ++ show n ++ " bars"
         return 0

parseBars :: Parser StateM
parseBars = mkParser $ readNum "bar"

readNum :: String -> Bool -> String -> StateM ParseResult
readNum name _ ""    = return $ failure name
readNum name _ input = do
  let (x, remains) = span (not.isSpace) $ dropWhile isSpace input
  maybe (complain) (accept x remains) $ readMaybe x
    where complain = do
                  return $ failure name
          accept x remaining n = do
                  modify $ \s@AppState{..} -> s { bars = n }
                  return $ Done x remaining

failure :: String -> ParseResult
failure name = Fail name $ Just "<number of times to bar>"

main :: IO ()
main = evalStateT (runCLI "some CLI" (Just settings) root) $ AppState 0 0
    where settings = def { banner = "Some CLI Application\nTab completion is your friend!",
                           history = Just ".someCLI.history" }