module System.Console.Program
(
single
, interactive
, showUsage
) where
import System.Console.Command (Commands,Command,shorten)
import System.Console.ConfigFile (readFromFile)
import System.Console.Internal
(
run
, UserCommand
, options
, nonOptions
, ignoringOptions
, action
, description
, name
, ConsoleProgramException(UnknownCommand)
)
import Control.Applicative (Applicative,(<|>),(*>))
import Control.Arrow ((&&&),second)
import Control.Concurrent (myThreadId)
import Control.Exception (throwTo,AsyncException(UserInterrupt))
import Control.Monad (when,void)
import Control.Monad.IO.Class (MonadIO,liftIO)
import Control.Monad.Trans.Class (lift)
import Data.List (isPrefixOf)
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 System.Posix.Signals as Sig
import qualified Text.Parsec as P
import qualified Text.PrettyPrint.ANSI.Leijen as PP
parse :: (MonadIO m,Applicative m) => Commands m -> [String] -> m ()
parse commands args = do
let (commandString,command,restArgs) = select commands args
fileSettings <- readFromFile commands commandString
let (opts,nonOpts,errors) = GetOpt.getOpt
GetOpt.Permute
(options (action command) ++ ignoringOptions (action command))
restArgs
when (not $ null errors) . void $
traverse (liftIO . putStrLn) errors
let commandLineSettings = Map.fromList opts
settings = commandLineSettings `Map.union` fileSettings
run (action command) nonOpts settings
select :: Commands m -> [String] -> (UserCommand,Command m,[String])
select (Tree.Node root _ ) [] = ([],root,[])
select (Tree.Node root subs) (x : xs) = case lookup x subcommands of
Just cs -> descend cs
Nothing -> case shorten root of
True -> case filter (isPrefixOf x . fst) subcommands of
[(_,cs)] -> descend cs
_ -> commit
False -> commit
where
subcommands = map (name . Tree.rootLabel &&& id) subs
descend cs = let (xs',c,rest) = select cs xs in (x : xs',c,rest)
commit = ([],root,x : xs)
single :: (MonadIO m,Applicative m) => Commands m -> m ()
single commands = parse commands =<< liftIO getArgs
interactive :: (MonadIO m,Haskeline.MonadException m,Applicative m) => Commands m -> m ()
interactive commands = do
tid <- liftIO myThreadId
liftIO $ Sig.installHandler Sig.keyboardSignal (Sig.Catch $ throwTo tid UserInterrupt) Nothing
Haskeline.runInputT Haskeline.defaultSettings $ sequence_ . repeat $ one
where
one = getLine' >>= \ line -> case words' line of
Left e -> liftIO $ putStrLn e
Right ws -> lift (parse commands ws)
`Haskeline.catch` (\ (e :: ConsoleProgramException) -> liftIO $ print e)
`Haskeline.catch` (\ (e :: AsyncException) -> if e == UserInterrupt
then liftIO $ print e
else Haskeline.throwIO e)
getLine' = do
putStrBold $ name (Tree.rootLabel commands)
maybe (liftIO 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 :: (MonadIO m) => String -> m ()
putStrBold x = liftIO $ do
ANSI.setSGR [ANSI.SetConsoleIntensity ANSI.BoldIntensity]
putStr x
ANSI.setSGR [ANSI.Reset]
showUsage :: (MonadIO m) => Commands n -> m ()
showUsage = liftIO . PP.putDoc . (PP.<> PP.line) . usage
where
usage (Tree.Node c ns) = subcs ns . (PP.<> PP.line) . opts c . descr c . nonOpts c $
PP.bold (PP.text $ name c)
descr c
| null d = id
| otherwise = flip (PP.<$>) $ PP.string d
where
d = 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 id) (map (: []) short)
PP.<+> list 20 "--" (arg (PP.equals PP.<>)) long PP.<+> PP.string descr where
arg maybeEq = case a of
GetOpt.NoArg _ -> PP.empty
GetOpt.ReqArg _ x -> maybeEq $ PP.string x
GetOpt.OptArg _ x -> PP.brackets (maybeEq $ 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)