Program.hs

-- | This module contains functions to build a console program, that parses
-- the command line (and a configuration file), divides it into commands,
-- options and non-options, and executes the corresponding action from a tree
-- of available commands.
-- 
-- These commands can be constructed using the module "System.Console.Command".
module System.Console.Program
  (
  -- * Using a command tree to construct a program
    single
  , interactive
  , showUsage
  
  -- * Configuration file
  -- $configfile
  ) 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


-- $configfile
-- The configuration file is assumed to be in the user's home directory, and
-- to be named \".foobar\", where \"foobar\" is the name of the
-- root of the command tree (usually the name of the program).
-- 
-- Settings in this file are of the form
-- @
--   option-name=option-value
-- @
-- , see the documentation of the package fez-conf for details. The format of
-- the \"option-value\" part depends on the type of the option argument; see
-- "System.Console.Argument".
-- 
-- Sections can be defined for settings applying to a single command,
-- using the name of a command, enclosed in square brackets, as section header:
-- @
--   [command1]
--   option-for-command1=true
-- @.


-- Parse the given list of strings into a command, non-options and options.
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 the right command from the command tree, and return the rest of the command line.
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)

-- | Load the configuration file (if present), and run the command given on
-- the command line. Settings on the command line override the configuration
-- file.
-- 
-- You may use this function, applied to your tree of available commands, as your @main@ function.
single :: Commands -> IO ()
single commands = parse commands =<< getArgs

-- | Start an interactive session. Arguments to the program are ignored;
-- instead, the user may repeatedly enter a command, possibly with options,
-- which will be executed.
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]

-- | Print usage info for the program to stdout.
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 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)