{-# LANGUAGE CPP #-}

{-|
Module      : Control.FromSum
Copyright   : (c) Dennis Gosnell, 2016
License     : BSD-style (see LICENSE file)
Maintainer  : cdep.illabout@gmail.com
Stability   : experimental
Portability : POSIX

This Haskell module exports various \"from\" functions for 'Either' and
'Maybe'.
-}
module Control.FromSum
  ( -- * Monadic in return value
    fromEitherM
  , fromEitherOrM
  , fromEitherM_
  , fromEitherOrM_
  , fromMaybeM
  , fromMaybeOrM
  , fromMaybeM_
  , fromMaybeOrM_
    -- * Monadic in both return and sum-type value
  , fromEitherMM
  , fromEitherOrMM
  , fromMaybeMM
  , fromMaybeOrMM
    -- * Completely non-monadic functions
  , fromEither
  , fromEitherOr
  , fromMaybe
  , fromMaybeOr
    -- * Converting from 'Maybe' to 'Either'
  , maybeToEither
  , maybeToEitherOr
  , eitherToMaybe
    -- * Collapsing funtions
  , collapseEither
  , collapseExceptT
  , collapseErrExceptT
  , -- * Converting to 'ExceptT'
    liftEitherExceptT
  , fromEitherExceptT
  , fromEitherOrExceptT
  , fromEitherMExceptT
  , fromEitherOrMExceptT
  , fromMaybeExceptT
  , fromMaybeOrExceptT
  , fromMaybeMExceptT
  , fromMaybeOrMExceptT
  , guardExceptT
  , guardMExceptT
    -- * Example converting to 'ExceptT'
    -- $exampleExceptT
    -- * Doctests
    -- $setup
  ) where

#if __GLASGOW_HASKELL__ < 710
-- We don't need this import for GHC 7.10 as it exports all required functions
-- from Prelude
import Control.Applicative
#endif
import Control.Monad ((<=<))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE)
import Data.Maybe (fromMaybe)

-- $setup
--
-- The following is setup code for doctests in this module.
--
-- >>> import Data.Functor.Identity (Identity(Identity))


-- | A monadic version of 'fromEither'.
--
-- @
--  'fromEitherM' leftAction === 'either' leftAction 'pure'
-- @
--
-- >>> fromEitherM (\s -> [length s]) $ Right 5
-- [5]
-- >>> fromEitherM (\s -> [length s]) $ Left ("foo" :: String)
-- [3]
fromEitherM
  :: Applicative m
  => (e -> m a) -> Either e a -> m a
fromEitherM leftAction = either leftAction pure

-- | A 'flip'ed version of 'fromEitherM'.
--
-- >>> fromEitherOrM (Right 5) $ \s -> [length s]
-- [5]
--
-- This can be nice to use as an error handler.
--
-- >>> fromEitherOrM (Right 5) $ \s -> putStrLn ("error: " ++ s) >> undefined
-- 5
-- >>> fromEitherOrM (Left "foo") $ \s -> putStrLn ("error: " ++ s) >> undefined
-- error: foo
-- ...
fromEitherOrM
  :: Applicative m
  => Either e a -> (e -> m a) -> m a
fromEitherOrM = flip fromEitherM

-- | Similar to 'fromEitherM', but only run the monadic 'leftAction' if the
-- 'Either' argument is 'Left'.  Otherwise, return 'pure' 'mempty'.
--
-- @
--  'fromEitherM_' leftAction === 'either' leftAction ('const' '$' 'pure' 'mempty')
-- @
--
-- >>> fromEitherM_ (\err -> putStrLn err >> pure "bye") $ Right 5
-- ""
-- >>> fromEitherM_ (\err -> putStrLn err >> pure "bye") $ Left "there was an error"
-- there was an error
-- "bye"
--
-- This can be convenient when you want to run some sort of logging function
-- whenever an 'Either' is 'Left'.  If you imagine the logging function is
-- @b -> 'IO' '()'@, then the effective type of 'fromEitherM_' becomes
-- @'fromEitherM_' :: (e -> 'IO' '()') -> 'Either' e a -> 'IO' '()'@, because
-- '()' has a 'Monoid' instance, and 'IO', has an 'Applicative' instance.
--
-- >>> fromEitherM_ putStrLn $ Left "there was an error"
-- there was an error
fromEitherM_
  :: (Applicative m, Monoid b)
  => (e -> m b) -> Either e a -> m b
fromEitherM_ leftAction = either leftAction (const $ pure mempty)

-- | A 'flip'ed version of 'fromEitherM_'.
fromEitherOrM_
  :: (Applicative m, Monoid b)
  => Either e a -> (e -> m b) -> m b
fromEitherOrM_ = flip fromEitherM_

-- | A monadic version of 'fromMaybe'.
--
-- @
--  'fromMaybeM' nothingAction === 'maybe' nothingAction 'pure'
-- @
--
-- >>> fromMaybeM [] $ Just 5
-- [5]
-- >>> fromMaybeM [] Nothing
-- []
fromMaybeM
  :: Applicative m
  => m a -> Maybe a -> m a
fromMaybeM nothingAction = maybe nothingAction pure

-- | A 'flip'ed version of 'fromMaybeM'.
--
-- >>> fromMaybeOrM (Just 5) []
-- [5]
--
-- This can be nice to use as an error handler.
--
-- >>> fromMaybeOrM (Just 5) $ putStrLn "some error occurred" >> undefined
-- 5
-- >>> fromMaybeOrM (Nothing) $ putStrLn "some error occurred" >> undefined
-- some error occurred
-- ...
fromMaybeOrM
  :: Applicative m
  => Maybe a -> m a -> m a
fromMaybeOrM = flip fromMaybeM

-- | Similar to 'fromMaybeM', but only run the monadic 'nothingAction' if the
-- 'Maybe' argument is 'Nothing'.  Otherwise, return 'pure' 'mempty'.
--
-- @
--  'fromMaybeM_' nothingAction === 'maybe' nothingAction ('const' '$' 'pure' 'mempty')
-- @
--
-- >>> fromMaybeM_ (putStrLn "hello" >> pure "bye") $ Just 5
-- ""
-- >>> fromMaybeM_ (putStrLn "hello" >> pure "bye") Nothing
-- hello
-- "bye"
--
-- This can be convenient when you want to run some sort of logging function
-- whenever a 'Maybe' is 'Nothing'.  If you imagine the logging function is
-- @'IO' '()'@, then the effective type of 'fromMaybeM_' becomes
-- @'fromMaybeM_' :: 'IO' '()' -> 'Maybe' a -> 'IO' '()'@, because '()' has a
-- 'Monoid' instance, and 'IO', has an 'Applicative' instance.
--
-- >>> fromMaybeM_ (putStrLn "hello") Nothing
-- hello
fromMaybeM_
  :: (Applicative m, Monoid b)
  => m b -> Maybe a -> m b
fromMaybeM_ nothingAction = maybe nothingAction (const $ pure mempty)

-- | A 'flip'ed version of 'fromMaybeM'.
fromMaybeOrM_
  :: (Applicative m, Monoid b)
  => Maybe a -> m b -> m b
fromMaybeOrM_ = flip fromMaybeM_

-- | Similar to 'fromEitherM' but the 'Either' argument is also a monadic value.
--
-- >>> fromEitherMM (\s -> [length s]) [Right 5, Right 10]
-- [5,10]
-- >>> fromEitherMM (\s -> [length s]) [Left ("foo" :: String), Right 100]
-- [3,100]
--
-- __NOTE__: I don't particularly like the name of this function.  If you have a
-- suggestion for a better name, please submit a PR or issue.
fromEitherMM
  :: Monad m
  => (e -> m a) -> m (Either e a) -> m a
fromEitherMM eitherAction mEither = fromEitherM eitherAction =<< mEither

-- | A 'flip'ed version of 'fromEitherMM'.
fromEitherOrMM
  :: Monad m
  => m (Either e a) -> (e -> m a) -> m a
fromEitherOrMM = flip fromEitherMM

-- | Similar to 'fromMaybeM' but the 'Maybe' argument is also a monadic value.
--
-- >>> fromMaybeMM [] [Just 6, Just 5]
-- [6,5]
-- >>> fromMaybeMM [] [Just 6, Nothing, Just 7]
-- [6,7]
--
-- __NOTE__: I don't particularly like the name of this function.  If you have a
-- suggestion for a better name, please submit a PR or issue.
fromMaybeMM
  :: Monad m
  => m a -> m (Maybe a) -> m a
fromMaybeMM nothingAction mMaybe = fromMaybeM nothingAction =<< mMaybe

-- | A 'flip'ed version of 'fromMaybeMM'.
fromMaybeOrMM
  :: Monad m
  => m (Maybe a) -> m a -> m a
fromMaybeOrMM = flip fromMaybeMM

-- | Similar to 'fromMaybe'.
--
-- >>> fromEither show $ Left 5
-- "5"
-- >>> fromEither show $ Right "hello"
-- "hello"
fromEither :: (e -> a) -> Either e a -> a
fromEither f = either f id

-- | A 'flip'ed version of 'fromEither'.
fromEitherOr :: Either e a -> (e -> a) -> a
fromEitherOr = flip fromEither

-- | A 'flip'ed version of 'fromMaybe'.
fromMaybeOr :: Maybe a -> a -> a
fromMaybeOr = flip fromMaybe

-- | Collapse an @'Either' a a@ to an @a@.  Defined as @'fromEither' 'id'@.
--
-- Note: Other libraries export this function as @fromEither@, but our
-- 'fromEither' function is slightly more general.
--
-- >>> collapseEither (Right 3)
-- 3
-- >>> collapseEither (Left "hello")
-- "hello"
collapseEither :: Either a a -> a
collapseEither = fromEither id

-- | Similar to 'collapseEither', but for 'ExceptT'.
--
-- >>> collapseExceptT (ExceptT $ pure (Right 3))
-- 3
-- >>> collapseExceptT (ExceptT $ pure (Left "hello"))
-- "hello"
collapseExceptT :: Monad m => ExceptT a m a -> m a
collapseExceptT = pure . collapseEither <=< runExceptT

-- | Collapse an 'ExceptT' where the error returns the same type as the whole
-- computation.
--
-- >>> let exceptTOne = pure 3 :: ExceptT (IO Int) IO Int
-- >>> collapseErrExceptT exceptTOne :: IO Int
-- 3
--
-- This is helpful when writing short-circuiting computations where you
-- throw errors that match the type of the underlying computation.
--
-- >>> :{
-- let go :: Int -> ExceptT (IO ()) IO ()
--     go x = do
--       bar <-
--         if x < 10
--         then
--           pure "hello"
--         else
--           throwE (putStrLn "Error occurred, x too big!")
--       lift $ putStrLn $ bar ++ " world"
-- :}
--
-- >>> collapseErrExceptT (go 100) :: IO ()
-- Error occurred, x too big!
-- >>> collapseErrExceptT (go 3) :: IO ()
-- hello world
--
-- In this example, the error type in the 'ExceptT' is @'IO' ()@.
-- This allows us to easily short-circuit the remaining computations.
-- In this example, the remaining computation is just printing
-- @bar '++' \" world\"@.
collapseErrExceptT :: Monad m => ExceptT (m a) m a -> m a
collapseErrExceptT exceptT = do
  res <- runExceptT exceptT
  case res of
    Left errHandler -> errHandler
    Right success -> pure success

-- | Convert a 'Maybe' to an 'Either'.
--
-- If the 'Maybe' is 'Just', then return the value in 'Right'.
--
-- >>> maybeToEither 3 $ Just "hello"
-- Right "hello"
--
-- If the 'Maybe' is 'Nothing', then use the given @e@ as 'Left'.
--
-- >>> maybeToEither 3 Nothing
-- Left 3
maybeToEither :: e -> Maybe a -> Either e a
maybeToEither e Nothing = Left e
maybeToEither _ (Just a) = Right a

-- | A 'flip'ed version of 'maybeToEither'.
--
-- >>> maybeToEitherOr (Just "hello") 3
-- Right "hello"
--
-- >>> maybeToEitherOr Nothing 3
-- Left 3
maybeToEitherOr :: Maybe a -> e -> Either e a
maybeToEitherOr = flip maybeToEither

-- | Convert an 'Either' to a 'Maybe'.
--
-- A 'Right' value becomes 'Just'.
--
-- >>> eitherToMaybe $ Right 3
-- Just 3
--
-- A 'Left' value becomes 'Nothing'.
--
-- >>> eitherToMaybe $ Left "bye"
-- Nothing
eitherToMaybe :: Either e a -> Maybe a
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right a) = Just a

-- | Lift an 'Either' into an 'ExceptT'.
--
-- This is the same as 'Control.Monad.Except.liftEither', but the return type
-- is specialized for 'ExceptT'.
--
-- >>> liftEitherExceptT (Right 3) :: ExceptT String Identity Int
-- ExceptT (Identity (Right 3))
--
-- Note that if you want to lift @m ('Either' e a)@ to @'ExceptT' e m a@,
-- just use 'ExceptT':
--
-- >>> action = Identity (Left "error") :: Identity (Either String Int)
-- >>> ExceptT action :: ExceptT String Identity Int
-- ExceptT (Identity (Left "error"))
liftEitherExceptT :: Applicative m => Either e a -> ExceptT e m a
liftEitherExceptT = ExceptT . pure

-- | Lift an 'Either' to an 'ExceptT' with a handler for transforming the error
-- value.
--
-- If the input 'Either' is 'Right', then just return it like normal:
--
-- >>> let rightEither = Right () :: Either String ()
-- >>> fromEitherExceptT (\str -> length str) rightEither :: ExceptT Int Identity ()
-- ExceptT (Identity (Right ()))
--
-- If the input 'Either' is 'Left', then pass the value to the handler:
--
-- >>> let leftEither = Left "hello" :: Either String ()
-- >>> fromEitherExceptT (\str -> length str) leftEither :: ExceptT Int Identity ()
-- ExceptT (Identity (Left 5))
fromEitherExceptT :: Monad m => (e -> x) -> Either e a -> ExceptT x m a
fromEitherExceptT handler eith = fromEitherMExceptT handler (pure eith)

-- | Just like 'fromEitherExceptT', but the arguments are flipped.
fromEitherOrExceptT :: Monad m => Either e a -> (e -> x) -> ExceptT x m a
fromEitherOrExceptT eith handler = fromEitherExceptT handler eith

-- | Similar to 'fromEitherExceptT' but the 'Either' value is lifted in a
-- 'Monad'.
--
-- >>> let identityLeft = Identity (Left "hello") :: Identity (Either String ())
-- >>> fromEitherMExceptT (\str -> length str) identityLeft :: ExceptT Int Identity ()
-- ExceptT (Identity (Left 5))
--
-- This is similar to 'Control.Monad.Trans.Except.withExceptT', but the second
-- argument is the unwrapped 'ExceptT' computation.
fromEitherMExceptT :: Monad m => (e -> x) -> m (Either e a) -> ExceptT x m a
fromEitherMExceptT handler action = do
  res <- lift action
  case res of
    Left e -> throwE (handler e)
    Right a -> pure a

-- | Just like 'fromEitherOrMExceptT', but the arguments are flipped.
fromEitherOrMExceptT :: Monad m => m (Either e a) -> (e -> x) -> ExceptT x m a
fromEitherOrMExceptT action handler = fromEitherMExceptT handler action

-- | Lift a 'Maybe' to an 'ExceptT' with a default value for the case when
-- the 'Maybe' is 'Nothing'.
--
-- If the 'Maybe' is 'Just', then just return the value like normal:
--
-- >>> let justVal = Just True :: Maybe Bool
-- >>> fromMaybeExceptT 5 justVal :: ExceptT Int Identity Bool
-- ExceptT (Identity (Right True))
--
-- If the 'Maybe' is 'Nothing', then use the default value as the error value:
--
-- >>> let nothingVal = Nothing :: Maybe Bool
-- >>> fromMaybeExceptT 5 nothingVal :: ExceptT Int Identity Bool
-- ExceptT (Identity (Left 5))
fromMaybeExceptT :: Monad m => x -> Maybe a -> ExceptT x m a
fromMaybeExceptT handler mayb = fromMaybeMExceptT handler (pure mayb)

-- | Just like 'fromMaybeExceptT' but with the arguments flipped.
fromMaybeOrExceptT :: Monad m => Maybe a -> x -> ExceptT x m a
fromMaybeOrExceptT = flip fromMaybeExceptT

-- | Similar to 'fromMaybeExceptT' except the 'Maybe' value is lifted in a
-- 'Monad'.
--
-- >>> let identityNothing = Identity Nothing :: Identity (Maybe Bool)
-- >>> fromMaybeMExceptT 5 identityNothing :: ExceptT Int Identity Bool
-- ExceptT (Identity (Left 5))
fromMaybeMExceptT :: Monad m => x -> m (Maybe a) -> ExceptT x m a
fromMaybeMExceptT handler action = do
  res <- lift action
  case res of
    Nothing -> throwE handler
    Just a -> pure a

-- | Just like 'fromMaybeMExceptT' but with the arguments flipped.
fromMaybeOrMExceptT :: Monad m => m (Maybe a) -> x -> ExceptT x m a
fromMaybeOrMExceptT = flip fromMaybeMExceptT

-- | Similar to 'guard', but for 'ExceptT'.
--
-- If the 'Bool' is 'True', then do nothing.
--
-- >>> guardExceptT True "error occurred" :: ExceptT String Identity ()
-- ExceptT (Identity (Right ()))
--
-- If the 'Bool' is 'False', then return the error case:
--
-- >>> guardExceptT False "error occurred" :: ExceptT String Identity ()
-- ExceptT (Identity (Left "error occurred"))
guardExceptT :: Monad m => Bool -> x -> ExceptT x m ()
guardExceptT True _ = pure ()
guardExceptT False handler = throwE handler

-- | Just like 'guardExceptT' (and similar to 'guardM'), except the boolean is
-- lifted in a 'Monad'.
--
-- >>> guardMExceptT (Identity False) "error occurred" :: ExceptT String Identity ()
-- ExceptT (Identity (Left "error occurred"))
guardMExceptT :: Monad m => m Bool -> x -> ExceptT x m ()
guardMExceptT action handler = do
  res <- lift action
  guardExceptT res handler

-- $exampleExceptT
--
-- Functions like 'fromMaybeExceptT' and 'fromEitherExceptT' are convenient
-- when paired with 'collapseErrExceptT'.  This section explains how
-- you can use these functions together.
--
-- Imagine you're writing a function that pulls user names from a database,
-- reads the first character of the name, and prints it to the console.
-- The functions for reading names from a database, and for
-- parsing the first character of the name could fail, so we will
-- handle these errors by logging to the console.
--
-- Here's the function we will be using for pulling user names from
-- the database.  If we pass @0@, it returns @\"SPJ\"@.  If we pass @1@,
-- it returns an empty string.  Otherwise it returns 'Nothing':
--
-- >>> :{
--   let getUserNameFromDb :: Int -> Maybe String
--       getUserNameFromDb 0 = Just "SPJ"
--       getUserNameFromDb 1 = Just ""
--       getUserNameFromDb _ = Nothing
-- :}
--
-- Here's the function we will be using for parsing the first character
-- of a user name.  If the user name is an empty string, we return
-- 'Left' with an error message.  Otherwise we return the first
-- character of the user name:
--
-- >>> :{
--   let parseFirstCharFromName :: String -> Either String Char
--       parseFirstCharFromName [] = Left "user name is empty"
--       parseFirstCharFromName (h:_) = Right h
-- :}
--
-- Now let's write our function.  If you didn't have the combinators from above
-- like 'fromEitherExceptT' and 'collapseErrExceptT', you might be tempted to
-- write nested @case@ patterns:
--
-- >>> :{
--   let nestedPrintFirstCharOfUserName :: Int -> IO ()
--       nestedPrintFirstCharOfUserName i =
--         -- Try to get the username for id i.
--         case getUserNameFromDb i of
--           -- If we couldn't get the user name from the database
--           -- print an error to the console.
--           Nothing -> putStrLn $ "ERROR: couldn't get user name for user " ++ show i
--           Just name ->
--             -- Try to parse the first character of the user name.
--             case parseFirstCharFromName name of
--               -- If we couldn't parse the first character of the user name,
--               -- print an error to the console.
--               Left err -> putStrLn $ "ERROR: " ++ err
--               Right firstChar ->
--                 -- Print the first character of the user name to the console.
--                 putStrLn $
--                   "Got first character of name for id " ++ show i ++ ": " ++ [firstChar]
-- :}
--
-- Here's an example of using this function, including the error cases:
--
-- >>> nestedPrintFirstCharOfUserName 100
-- ERROR: couldn't get user name for user 100
-- >>> nestedPrintFirstCharOfUserName 1
-- ERROR: user name is empty
-- >>> nestedPrintFirstCharOfUserName 0
-- Got first character of name for id 0: S
--
-- This works, and is understandable, but it gets unwieldy when there
-- are even more parsing steps.  You can get very deeply nested cases.
--
-- In order to write this without deeply nested error handling, you need a
-- short-circuiting 'Monad'.  Two popular examples are 'MaybeT' and 'ExceptT'.
--
-- Using 'collapseErrExceptT' (and 'ExcepT'), it is possible to write this
-- function by short-circuiting on errors:
--
-- >>> :{
--   let printFirstCharOfUserName :: Int -> IO ()
--       printFirstCharOfUserName i =
--         -- The argument to collapseErrExceptT is @ExceptT (IO ()) IO ()@.
--         -- This can be thought of as an action that can short-circuit
--         -- with @IO ()@ error-handling actions.
--         --
--         -- The error-handling actions below just log to the console.
--         collapseErrExceptT $ do
--           -- Get the user name from the db.
--           -- If getUserNameFromDb returns Nothing, then this whole
--           -- block will short circuit and collapseErrExceptT will
--           -- run our error handler.
--           --
--           -- Note that for the type of the error handler to work
--           -- correctly with @collapseErrExceptT@, the error
--           -- handler has to return @IO ()@.
--           name <-
--             fromMaybeOrExceptT (getUserNameFromDb i) $
--               putStrLn $ "ERROR: couldn't get user name for user " ++ show i
--           -- Parse out the first character from the user name.
--           -- If parseFirstCharFromName returns Left, then this whole
--           -- block will short circuit and collapseErrExceptT will
--           -- run our error handler.
--           firstChar <-
--             fromEitherOrExceptT (parseFirstCharFromName name) $ \err ->
--               putStrLn $ "ERROR: " ++ err
--           -- Print the first character of the name.
--           -- This needs to be 'lift'ed because this whole block is
--           -- actually @ExceptT (IO ()) IO ()@.
--           lift $
--             putStrLn $
--               "Got first character of name for id " ++ show i ++ ": " ++ [firstChar]
-- :}
--
-- The main good point here is that using the short-circuiting functionality of
-- 'ExceptT', we can write everything without nesting.
--
-- Here's a few examples of calling @printFirstCharOfUserName@.
--
-- Here we pass a user id that doesn't exist, so @getUserNameFromDb@ will
-- return 'Nothing'.  This causes the function to short-circuit and the
-- first error handler to be called.
--
-- >>> printFirstCharOfUserName 100
-- ERROR: couldn't get user name for user 100
--
-- Here we pass a user id that does exist, but the user name for this user id
-- is empty.  This causes the function to short-circuit and the
-- second error handler to be called.
--
-- >>> printFirstCharOfUserName 1
-- ERROR: user name is empty
--
-- This time the function succeeds:
--
-- >>> printFirstCharOfUserName 0
-- Got first character of name for id 0: S
--
-- In real code, the functions @getUserNameFromDb@ and @parseFirstCharFromName@
-- will have monadic return values.  In that case, you can use
-- 'fromMaybeOrMExceptT' and 'fromEitherOrMExceptT'.