Command.hs

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


-- | @Commands s@ is a tree of commands. It represents the whole set of
-- possible commands of a program.
type Commands setting
  = Tree.Tree (Command setting)

-- | A @Command s@ is an action, together with some descriptive information:
-- name (this is the textual command that invokes the action), description,
-- and lists of applicable options and non-options. @s@ is the type of 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 configuration file and parse the command line into settings
-- and non-options.
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

-- | Load the configuration file (if present), and run the action given on the command line.
single :: (Options.Setting s) => Options.Options s -> Commands s -> IO ()
single defaults commands = uncurry (select commands) . second (flip Options.apply defaults) =<< load commands

-- Select the right command from the command tree, given a list of non-options, and the options.
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

-- | Show usage info for the program.
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)