module System.Console.Program
(
single
, interactive
, showUsage
) where
import System.Console.Command (Commands,Command)
import System.Console.ConfigFile (readFromFile)
import System.Console.Internal (run,options,nonOptions,ignoringOptions,action,description,name)
import Control.Applicative ((<|>),(*>))
import Control.Arrow ((&&&),second)
import Control.Monad (when,void)
import Control.Monad.Trans.Class (lift)
import qualified Data.Map as Map
import Data.Traversable (traverse)
import qualified Data.Tree as Tree
import qualified System.Console.ANSI as ANSI
import qualified System.Console.GetOpt as GetOpt
import qualified System.Console.Haskeline as Haskeline
import System.Environment (getArgs)
import System.Exit (exitSuccess)
import System.IO (readFile)
import qualified Text.Parsec as P
import qualified Text.PrettyPrint.ANSI.Leijen as PP
parse :: Commands -> [String] -> IO ()
parse commands args = do
let (commandString,command,restArgs) = select commands args
fileArgs <- readFromFile commands commandString
let (opts,nonOpts,errors) = GetOpt.getOpt
GetOpt.Permute
(options (action command) ++ ignoringOptions (action command))
(fileArgs ++ restArgs)
when (not $ null errors) . void $
traverse putStrLn errors
run (action command) nonOpts $ Map.fromList opts
select :: Commands -> [String] -> ([String],Command,[String])
select (Tree.Node root _ ) [] = ([],root,[])
select (Tree.Node root subs) (x : xs) = case lookup x $ map (name . Tree.rootLabel &&& id) subs of
Nothing -> ([],root,x : xs)
Just cs -> let (xs',c,rest) = select cs xs in (x : xs',c,rest)
single :: Commands -> IO ()
single commands = parse commands =<< getArgs
interactive :: Commands -> IO ()
interactive commands = do
Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one
where
one = getLine' >>= \ line -> case words' line of
Left e -> lift $ putStrLn e
Right ws -> lift $ parse commands ws
getLine' = do
lift . putStrBold $ name (Tree.rootLabel commands)
maybe (lift exitSuccess) return =<< Haskeline.getInputLine ": "
words' :: String -> Either String [String]
words' = either (Left . show) Right . P.parse p "" where
p = P.optional space *> P.sepEndBy (quoted <|> unquoted) space
unquoted = P.many1 $ P.noneOf [' ']
space = P.many1 $ P.char ' '
quoted = P.between quote quote . P.many $
P.try (escaped quote) <|> escaped escape <|> P.noneOf ['"','\\']
quote = P.char '"'
escape = P.char '\\'
escaped x = escape *> x
putStrBold :: String -> IO ()
putStrBold x = do
ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
putStr x
ANSI.setSGR [ANSI.Reset]
showUsage :: Commands -> IO ()
showUsage = PP.putDoc . usage
where
usage (Tree.Node c ns) = (PP.<> PP.line) . subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $ PP.bold (PP.text $ name c)
descr c = flip (PP.<$>) $ PP.string (description c)
nonOpts c = let n = nonOptions $ action c in if null n
then id
else flip (PP.<+>) $ PP.cat . PP.punctuate PP.space . map PP.text $ n
opts c = let o = options $ action c in if null o
then id
else flip (PP.<$>) . PP.indent 2 . PP.vsep . map opt $ o
opt (GetOpt.Option short long a descr) = list 5 "-" arg (map (: []) short)
PP.<+> list 20 "--" arg long PP.<+> PP.string descr where
arg = case a of
GetOpt.NoArg _ -> PP.empty
GetOpt.ReqArg _ x -> PP.equals PP.<> PP.string x
GetOpt.OptArg _ x -> PP.brackets (PP.equals PP.<> PP.string x)
list i p a = PP.fill i . PP.cat . PP.punctuate PP.comma . map (\ x -> PP.text p PP.<> PP.text x PP.<> a)
subcs ns = if null ns then id else flip (PP.<$>) $ PP.indent 2 (PP.vsep $ map usage ns)