Args.hs

{-# LANGUAGE Arrows #-}
module Util.Args.Args (parseArgs) where

import Util.Args.ArgDescr (ArgDescr(..), KnownArgs)
import Util.Args.ArgArrow (ArgArrow, runArgArrow, askArgs, getKnownArgs, addKnownArg)
import Util.Args.RawArgs (Args(..), parseArguments)
import Control.Arrow ((>>>), returnA, arr)
import System.Environment (getArgs)
import System.IO (stderr, hPutStrLn)
import System.Exit (exitFailure, exitSuccess)
import Data.Maybe (catMaybes)
import Util.Args.Usage (usage)

-- cli arg parsing result
data ArgParseResult a = Usage
                      | Help
                      | Error String
                      | Version
                      | OK a

-- wraps a cli arg parsing computation to add few standard
-- arguments: --help (and -h) and --version
-- and allows to distinguish them in the result
helperArgArrow :: ArgArrow a b -> ArgArrow a (ArgParseResult b)
helperArgArrow arrow = proc x -> do
  addKnownArg knargs -< ()
  args <- askArgs -< ()
  if "help" `elem` switches args || 'h' `elem` shortSwitches args then
    returnA -< Help
   else if "usage" `elem` switches args then
    returnA -< Usage
   else if "version" `elem` switches args then
    returnA -< Version
   else
    arrow >>> arr OK -< x
    where knargs = [versionOpt, helpOpt]
          helpOpt = SwitchDescr "help" "Show this help message" (Just 'h')
          versionOpt = SwitchDescr "version" "Show version string" Nothing

-- prints a msg to stderr and exits program with return value 1
failWith :: String -> IO a
failWith s = hPutStrLn stderr s >> exitFailure

-- validates provided cli arguments against known argument descriptions
-- handles unknown arguments, and currently forbids positional arguments
validateArguments :: Args -> KnownArgs -> IO ()
validateArguments args knArgs
    | not $ null $ positionals args = failWith "Positional arguments are not allowed"
    | otherwise =
        either failWith return $ do
          mapM_ (validate "short switch" "-" knShortSwitches (:"")) $ shortSwitches args
          mapM_ (validate "switch" "--" knSwitches id) $ switches args
          mapM_ (validate "option" "--" knKeys id . fst) $ valArgs args
    where knShortSwitches = catMaybes $ flip map knArgs $ \x -> case x of
                               SwitchDescr _ _ c -> c
                               _ -> Nothing
          knSwitches = catMaybes $ flip map knArgs $ \x -> case x of
                               SwitchDescr name _ _ -> Just name
                               _ -> Nothing
          knKeys = catMaybes $ flip map knArgs $ \x -> case x of
                               ValArg name _ _ _ -> Just name
                               _ -> Nothing
          validate xName prefix knownXs showX x =
              if x `elem` knownXs then
                  Right ()
              else
                  Left $ "Unknown " ++ xName ++ " '" ++ prefix ++ showX x ++ "'"

-- takes a cli arg parsing computation, version string and usage msg footer
-- runs the computation on program cli arguments
-- and returns the result. if arguments validation fails,
-- prints usage message and exits with failure
parseArgs :: ArgArrow () a -> String -> String -> IO a
parseArgs arrgArr version outro = do
  args <- getArgs
  case parseArguments args of
    Left s -> failWith s
    Right parsedArgs -> do
      validateArguments parsedArgs $ getKnownArgs arrgArr'
      result <- runArgArrow arrgArr' parsedArgs
      case result of
        OK a -> return a
        Error s -> failWith s
        Version -> putStrLn version >> exitSuccess
        _ -> usage arrgArr' outro >>= putStr >> exitSuccess
  where arrgArr' = helperArgArrow arrgArr