NoSlow-0.2: NoSlow/Util/Opts.hs

module NoSlow.Util.Opts ( OptM, update, exit, error, parse, parseAll,
                          printError,
                          noArg, reqArg, readArg, helpArg, listArg,
                          selArg, matchName, matchLib, matchGroup )
where

import NoSlow.Util.Tag

import System.Console.GetOpt
import System.Exit
import System.Environment       ( getProgName )
import System.IO                ( stderr, hPutStrLn )

import Data.List ( foldl' )
import Data.Monoid
import Prelude hiding ( error, read )

data Result a = Ok a
              | Exit (IO ()) ExitCode
              | Error String

instance Functor Result where
  fmap f r = r >>= return . f

instance Monad Result where
  return = Ok

  Ok x     >>= f = f x
  Exit p c >>= _ = Exit p c
  Error s  >>= _ = Error s

newtype OptM a = OptM (a -> Result a)

instance Monoid (OptM a) where
  mempty             = OptM Ok
  mappend (OptM f) o = OptM (apply o . f)

result :: Result a -> OptM a
result = OptM . const

update :: (a -> a) -> OptM a
update f = OptM $ Ok . f

exit :: IO () -> ExitCode -> OptM a
exit p = result . Exit p

error :: String -> OptM a
error = result . Error

errorMsg :: String -> OptM a -> OptM a
errorMsg msg (OptM f) = OptM $ \x -> case f x of
                                       Error _ -> Error msg
                                       r       -> r

check :: Bool -> OptM a -> OptM a
check True  o = o
check False _ = error "invalid argument"

read :: Read a => (a -> OptM b) -> String -> OptM b
read f s = case reads s of
             [(x,"")] -> f x
             _        -> error "invalid argument"

require :: (a -> Bool) -> (a -> OptM b) -> a -> OptM b
require f g x = check (f x) (g x)

apply :: OptM a -> Result a -> Result a
apply (OptM f) r = r >>= f

chain :: Result a -> (a -> OptM b) -> OptM b
chain r o = OptM $ \x -> do { a <- r; run (o a) x }
                             
run :: OptM a -> a -> Result a
run (OptM f) x = f x

parse :: a -> [OptDescr (OptM a)] -> [String] -> IO (a, [String])
parse a options args
  = case getOpt Permute options args of
      (os, args', []) ->
        case run (mconcat os) a of
          Ok r     -> return (r, args')
          Exit p c -> do { p; exitWith c }
          Error s  -> printError s
      (_, _, (s : _)) -> printError s

parseAll :: a -> [OptDescr (OptM a)] -> [String] -> IO a
parseAll a options args
  = do
      (r, args') <- parse a options args
      case args' of
        []    -> return r
        s : _ -> printError $ "extra argument `" ++ s ++ "'" 

printError :: String -> IO a
printError msg
  = do
      prog <- getProgName
      hPutStrLn stderr $ "Error: " ++ msg
      hPutStrLn stderr $ "Run \"" ++ prog
                         ++ " --help\" for usage information"
      exitWith (ExitFailure 1)

noArg :: (a -> a) -> ArgDescr (OptM a)
noArg = NoArg . update

reqArg :: (String -> a -> a) -> String -> ArgDescr (OptM a)
reqArg f = ReqArg (update . f)

readArg :: Read a => String -> (a -> Bool) -> (a -> b -> b)
                       -> String -> ArgDescr (OptM b)
readArg s f g = ReqArg (errorMsg msg . (read $ require f $ update . g))
  where
    msg = "invalid " ++ s

helpArg :: IO () -> ArgDescr (OptM a)
helpArg p = NoArg (exit p ExitSuccess)

listArg :: (String -> Result a) -> ([a] -> b -> b)
              -> String -> ArgDescr (OptM b)
listArg f g = ReqArg $ \s -> chain (mapM f (split ',' s)) (update . g)

selArg :: (String -> Result (Tag -> Bool))
       -> ((Tag -> Bool) -> a -> a) -> String -> ArgDescr (OptM a)
selArg f g = listArg f (g . foldr or (const False))
  where
    or f g t = f t || g t

matchName :: String -> Result (Tag -> Bool)
matchName s = Ok $ \t -> tagName t == s

matchLib :: String -> Result (Tag -> Bool)
matchLib "" = Ok $ const False
matchLib s  = case split '/' s of
               [lib]     -> Ok $ \t -> tagLibrary t == lib
               [lib,sub] -> Ok $ \t -> tagLibrary t == lib
                                       && tagSubsystem t == sub
               _         -> Error $ "Invalid library " ++ s

matchGroup :: String -> Result (Tag -> Bool)
matchGroup grp = Ok $ \t -> tagGroup t == grp