{-# 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 (Int -> Result a -> ShowS
[Result a] -> ShowS
Result a -> String
(Int -> Result a -> ShowS)
-> (Result a -> String) -> ([Result a] -> ShowS) -> Show (Result a)
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show, Result a -> Result a -> Bool
(Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool) -> Eq (Result a)
forall a. Eq a => Result a -> Result a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result a -> Result a -> Bool
$c/= :: forall a. Eq a => Result a -> Result a -> Bool
== :: Result a -> Result a -> Bool
$c== :: forall a. Eq a => Result a -> Result a -> Bool
Eq, Eq (Result a)
Eq (Result a) =>
(Result a -> Result a -> Ordering)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Bool)
-> (Result a -> Result a -> Result a)
-> (Result a -> Result a -> Result a)
-> Ord (Result a)
Result a -> Result a -> Bool
Result a -> Result a -> Ordering
Result a -> Result a -> Result a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Result a)
forall a. Ord a => Result a -> Result a -> Bool
forall a. Ord a => Result a -> Result a -> Ordering
forall a. Ord a => Result a -> Result a -> Result a
min :: Result a -> Result a -> Result a
$cmin :: forall a. Ord a => Result a -> Result a -> Result a
max :: Result a -> Result a -> Result a
$cmax :: forall a. Ord a => Result a -> Result a -> Result a
>= :: Result a -> Result a -> Bool
$c>= :: forall a. Ord a => Result a -> Result a -> Bool
> :: Result a -> Result a -> Bool
$c> :: forall a. Ord a => Result a -> Result a -> Bool
<= :: Result a -> Result a -> Bool
$c<= :: forall a. Ord a => Result a -> Result a -> Bool
< :: Result a -> Result a -> Bool
$c< :: forall a. Ord a => Result a -> Result a -> Bool
compare :: Result a -> Result a -> Ordering
$ccompare :: forall a. Ord a => Result a -> Result a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Result a)
Ord, a -> Result b -> Result a
(a -> b) -> Result a -> Result b
(forall a b. (a -> b) -> Result a -> Result b)
-> (forall a b. a -> Result b -> Result a) -> Functor Result
forall a b. a -> Result b -> Result a
forall a b. (a -> b) -> Result a -> Result b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Result b -> Result a
$c<$ :: forall a b. a -> Result b -> Result a
fmap :: (a -> b) -> Result a -> Result b
$cfmap :: forall a b. (a -> b) -> Result a -> Result b
Functor)

instance Applicative Result where
  pure :: a -> Result a
pure = a -> Result a
forall a. a -> Result a
Success
  OutputAndExit message :: String
message <*> :: Result (a -> b) -> Result a -> Result b
<*> _ = String -> Result b
forall a. String -> Result a
OutputAndExit String
message
  _ <*> OutputAndExit message :: String
message = String -> Result b
forall a. String -> Result a
OutputAndExit String
message
  Success f :: a -> b
f <*> Success x :: a
x = b -> Result b
forall a. a -> Result a
Success (a -> b
f a
x)
  Errors a :: String
a <*> Errors b :: String
b = String -> Result b
forall a. String -> Result a
Errors (String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b)
  Errors err :: String
err <*> Success _ = String -> Result b
forall a. String -> Result a
Errors String
err
  Success _ <*> Errors err :: String
err = String -> Result b
forall a. String -> Result a
Errors String
err

(|>) :: Result a -> Result b -> Result b
a :: Result a
a |> :: Result a -> Result b -> Result b
|> b :: Result b
b = Result a
a Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result b -> a -> Result b
forall a b. a -> b -> a
const Result b
b

instance Monad Result where
  return :: a -> Result a
return = a -> Result a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Success a :: a
a >>= :: Result a -> (a -> Result b) -> Result b
>>= b :: a -> Result b
b = a -> Result b
b a
a
  Errors errs :: String
errs >>= _ = String -> Result b
forall a. String -> Result a
Errors String
errs
  OutputAndExit message :: String
message >>= _ = String -> Result b
forall a. String -> Result a
OutputAndExit String
message

  >> :: Result a -> Result b -> Result b
(>>) = Result a -> Result b -> Result b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

-- | 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 a -> IO a
handleResult result :: Result a
result = case Result a -> Result a
forall a. Result a -> Result a
sanitize Result a
result of
  Success a :: a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
  OutputAndExit message :: String
message -> do
    String -> IO ()
putStr String
message
    ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess
  Errors err :: String
err -> do
    Handle -> String -> IO ()
hPutStr Handle
stderr String
err
    ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1

sanitize :: Result a -> Result a
sanitize :: Result a -> Result a
sanitize = \ case
  Success a :: a
a -> a -> Result a
forall a. a -> Result a
Success a
a
  OutputAndExit message :: String
message -> String -> Result a
forall a. String -> Result a
OutputAndExit (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ ShowS
sanitizeMessage String
message
  Errors messages :: String
messages -> String -> Result a
forall a. String -> Result a
Errors (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ ShowS
sanitizeMessage String
messages

sanitizeMessage :: String -> String
sanitizeMessage :: ShowS
sanitizeMessage =
  String -> [String]
lines (String -> [String]) -> ([String] -> String) -> ShowS
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
stripTrailingSpaces ([String] -> [String])
-> ([String] -> String) -> [String] -> String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> ([String] -> String) -> [String] -> String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n") ([String] -> [String])
-> ([String] -> String) -> [String] -> String
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>>
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat

stripTrailingSpaces :: String -> String
stripTrailingSpaces :: ShowS
stripTrailingSpaces =
  ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
inner ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [' ', '\n']) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
  where
    inner :: ShowS
inner s :: String
s = case String
s of
      ('\n' : ' ' : r :: String
r) -> ShowS
inner ('\n' Char -> ShowS
forall a. a -> [a] -> [a]
: String
r)
      (a :: Char
a : r :: String
r) -> Char
a Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
inner String
r
      [] -> []