{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module WithCli.Result (
Result(..),
(|>),
handleResult,
sanitizeMessage,
sanitize,
) where
import Prelude ()
import Prelude.Compat
import Control.Arrow
import System.Exit
import System.IO
-- | Type to wrap results from 'WithCli.Pure.withCliPure'.
data Result a
= Success a
-- ^ The CLI was used correctly and a value of type @a@ was
-- successfully constructed.
| Errors String
-- ^ The CLI was used incorrectly. The 'Result' contains error messages.
--
-- It can also happen that the data type you're trying to use isn't
-- supported. See the
-- <https://github.com/zalora/getopt-generics#getopt-generics README> for
-- details.
| OutputAndExit String
-- ^ The CLI was used with @--help@. The 'Result' contains the help message.
deriving (Show, Eq, Ord, Functor)
instance Applicative Result where
pure = Success
OutputAndExit message <*> _ = OutputAndExit message
_ <*> OutputAndExit message = OutputAndExit message
Success f <*> Success x = Success (f x)
Errors a <*> Errors b = Errors (a ++ "\n" ++ b)
Errors err <*> Success _ = Errors err
Success _ <*> Errors err = Errors err
(|>) :: Result a -> Result b -> Result b
a |> b = a >>= const b
instance Monad Result where
return = pure
Success a >>= b = b a
Errors errs >>= _ = Errors errs
OutputAndExit message >>= _ = OutputAndExit message
(>>) = (*>)
-- | Handles an input of type @'Result' a@:
--
-- - On @'Success' a@ it returns the value @a@.
-- - On @'OutputAndExit' message@ it writes the message to 'stdout' and throws
-- 'ExitSuccess'.
-- - On @'Errors' errs@ it writes the error messages to 'stderr' and throws
-- @'ExitFailure' 1@.
--
-- This is used by 'WithCli.withCli' to handle parse results.
handleResult :: Result a -> IO a
handleResult result = case sanitize result of
Success a -> return a
OutputAndExit message -> do
putStr message
exitWith ExitSuccess
Errors err -> do
hPutStr stderr err
exitWith $ ExitFailure 1
sanitize :: Result a -> Result a
sanitize = \ case
Success a -> Success a
OutputAndExit message -> OutputAndExit $ sanitizeMessage message
Errors messages -> Errors $ sanitizeMessage messages
sanitizeMessage :: String -> String
sanitizeMessage =
lines >>>
map stripTrailingSpaces >>>
filter (not . null) >>>
map (++ "\n") >>>
concat
stripTrailingSpaces :: String -> String
stripTrailingSpaces =
reverse . inner . dropWhile (`elem` [' ', '\n']) . reverse
where
inner s = case s of
('\n' : ' ' : r) -> inner ('\n' : r)
(a : r) -> a : inner r
[] -> []