module System.Console.Command
(
Commands
, Command (Command,name,applicableNonOptions,applicableOptions,description,action)
, single
, showUsage
) where
import qualified System.Console.Action as Action
import qualified System.Console.Options as Options
import Control.Applicative ((<$>))
import Control.Arrow ((&&&),second)
import Control.Exception (tryJust)
import Control.Monad (guard,join)
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import Data.Foldable (foldMap)
import Data.Traversable (traverse)
import qualified Fez.Data.Conf as Conf
import qualified System.Console.GetOpt as GetOpt
import System.Directory (getHomeDirectory)
import System.Environment.UTF8 (getArgs)
import System.Exit (exitFailure)
import System.IO (readFile)
import System.IO.Error (isDoesNotExistError)
import qualified Text.PrettyPrint.ANSI.Leijen as PP
type Commands setting
= Tree.Tree (Command setting)
data Command s
= Command
{
name :: String
, applicableNonOptions :: [String]
, applicableOptions :: [GetOpt.OptDescr (Either String s)]
, description :: String
, action :: Action.Action (Options.Options s)
}
fromDisk :: String -> IO [String]
fromDisk configFile = do
home <- getHomeDirectory
result <- tryJust (guard . isDoesNotExistError) (readFile $ home ++ "/" ++ configFile)
return $ either (const []) Conf.parseToArgs result
load :: Commands s -> IO ([String],[s])
load commands = do
let options = Set.toList $ collectOptions commands
fileArgs <- fromDisk $ '.' : name (Tree.rootLabel commands)
(opts,nonOpts,errors) <- GetOpt.getOpt GetOpt.Permute options . (++) fileArgs <$> getArgs
if null errors
then either ((>> exitFailure) . putStrLn) (return . (,) nonOpts) $ sequence opts
else traverse putStrLn errors >> showUsage commands >> exitFailure
single :: (Options.Setting s) => Options.Options s -> Commands s -> IO ()
single defaults commands = uncurry (select commands) . second (flip Options.apply defaults) =<< load commands
select :: (Options.Setting s) => Commands s -> [String] -> Options.Options s -> IO ()
select (Tree.Node root _ ) [] = Action.run (action root) []
select (Tree.Node root forest) nos@(x : xs) = case lookup x $ map (name . Tree.rootLabel &&& id) forest of
Nothing -> Action.run (action root) nos
Just cs -> select cs xs
showUsage :: Commands o -> IO ()
showUsage = PP.putDoc . 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 = flip (PP.<$>) $ PP.string (description c)
nonOpts c = if null (applicableNonOptions c)
then id
else flip (PP.<+>) $ PP.cat . PP.punctuate PP.space . map PP.text $ applicableNonOptions c
opts c = if null (applicableOptions c)
then id
else flip (PP.<$>) . PP.indent 2 . PP.vsep . map opt $ applicableOptions c
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)
collectOptions :: Commands o -> Set.Set (GetOpt.OptDescr (Either String o))
collectOptions = foldMap (Set.fromList . applicableOptions)
instance Eq (GetOpt.OptDescr a) where
(GetOpt.Option _ x _ _) == (GetOpt.Option _ y _ _) = head x == head y
instance Ord (GetOpt.OptDescr a) where
(GetOpt.Option _ x _ _) `compare` (GetOpt.Option _ y _ _) = compare (head x) (head y)