{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Monad.Try (
	-- * DATA TRY
	Try, maybeToTry,
	-- * RUN TRY
	runTry, gatherSuccess,
	-- * THROW AND CATCH ERROR
	throw, catch, rights,
	-- * WRITE AND GET LOG
	Set, tell, partial,
	-- * TOOL
	cons ) where

import Control.Applicative (Alternative(..))
import Control.Arrow (first)
import Control.Monad (MonadPlus)
import Data.Maybe (catMaybes)

---------------------------------------------------------------------------

-- * DATA TRY
--	+ DATA
--	+ INSTANCE
-- * RUN TRY
-- * THROW AND CATCH ERROR
-- * WRITE AND GET LOG
-- * TOOL

---------------------------------------------------------------------------
-- DATA TRY
---------------------------------------------------------------------------

-- DATA

data Try e w a = Try (Either e a) w deriving Int -> Try e w a -> ShowS
[Try e w a] -> ShowS
Try e w a -> String
(Int -> Try e w a -> ShowS)
-> (Try e w a -> String)
-> ([Try e w a] -> ShowS)
-> Show (Try e w a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e w a. (Show e, Show a, Show w) => Int -> Try e w a -> ShowS
forall e w a. (Show e, Show a, Show w) => [Try e w a] -> ShowS
forall e w a. (Show e, Show a, Show w) => Try e w a -> String
showList :: [Try e w a] -> ShowS
$cshowList :: forall e w a. (Show e, Show a, Show w) => [Try e w a] -> ShowS
show :: Try e w a -> String
$cshow :: forall e w a. (Show e, Show a, Show w) => Try e w a -> String
showsPrec :: Int -> Try e w a -> ShowS
$cshowsPrec :: forall e w a. (Show e, Show a, Show w) => Int -> Try e w a -> ShowS
Show

try :: (Either e a -> w -> b) -> Try e w a -> b
try :: (Either e a -> w -> b) -> Try e w a -> b
try Either e a -> w -> b
f (Try Either e a
ex w
w) = Either e a -> w -> b
f Either e a
ex w
w

maybeToTry :: Monoid w => e -> Maybe a -> Try e w a
maybeToTry :: e -> Maybe a -> Try e w a
maybeToTry e
e = Try e w a -> (a -> Try e w a) -> Maybe a -> Try e w a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Try e w a
forall w e a. Monoid w => e -> Try e w a
throw e
e) a -> Try e w a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- INSTANCE

instance Functor (Try e w) where
	fmap :: (a -> b) -> Try e w a -> Try e w b
fmap a -> b
f = (Either e a -> w -> Try e w b) -> Try e w a -> Try e w b
forall e a w b. (Either e a -> w -> b) -> Try e w a -> b
try ((Either e a -> w -> Try e w b) -> Try e w a -> Try e w b)
-> (Either e a -> w -> Try e w b) -> Try e w a -> Try e w b
forall a b. (a -> b) -> a -> b
$ (e -> w -> Try e w b)
-> (a -> w -> Try e w b) -> Either e a -> w -> Try e w b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try (Either e b -> w -> Try e w b)
-> (e -> Either e b) -> e -> w -> Try e w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e b
forall a b. a -> Either a b
Left) (Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try (Either e b -> w -> Try e w b)
-> (a -> Either e b) -> a -> w -> Try e w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> (a -> b) -> a -> Either e b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Monoid w => Applicative (Try e w) where
	pure :: a -> Try e w a
pure = (Either e a -> w -> Try e w a
forall e w a. Either e a -> w -> Try e w a
`Try` w
forall a. Monoid a => a
mempty) (Either e a -> Try e w a) -> (a -> Either e a) -> a -> Try e w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right
	Try (Left e
e) w
w <*> :: Try e w (a -> b) -> Try e w a -> Try e w b
<*> Try e w a
_ = Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try (e -> Either e b
forall a b. a -> Either a b
Left e
e) w
w
	Try (Right a -> b
f) w
w <*> Try e w a
mx = (\Either e b
ex -> Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try Either e b
ex (w -> Try e w b) -> (w -> w) -> w -> Try e w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<>)) (Either e b -> w -> Try e w b) -> Try e w b -> Try e w b
forall e a w b. (Either e a -> w -> b) -> Try e w a -> b
`try` (a -> b
f (a -> b) -> Try e w a -> Try e w b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Try e w a
mx)

instance Monoid w => Alternative (Try w w) where
	empty :: Try w w a
empty = Either w a -> w -> Try w w a
forall e w a. Either e a -> w -> Try e w a
Try (w -> Either w a
forall a b. a -> Either a b
Left w
forall a. Monoid a => a
mempty) w
forall a. Monoid a => a
mempty
	Try (Left w
e) w
w <|> :: Try w w a -> Try w w a -> Try w w a
<|> Try w w a
t = w -> Try w w ()
forall w ws e. Set w ws => w -> Try e ws ()
tell w
w Try w w () -> Try w w () -> Try w w ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> w -> Try w w ()
forall w ws e. Set w ws => w -> Try e ws ()
tell w
e Try w w () -> Try w w a -> Try w w a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Try w w a
t
	t :: Try w w a
t@(Try (Right a
_) w
_) <|> Try w w a
_ = Try w w a
t

instance Monoid w => Monad (Try e w) where
	Try (Left e
e) w
w >>= :: Try e w a -> (a -> Try e w b) -> Try e w b
>>= a -> Try e w b
_ = Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try (e -> Either e b
forall a b. a -> Either a b
Left e
e) w
w
	Try (Right a
x) w
w >>= a -> Try e w b
f = (\Either e b
ex -> Either e b -> w -> Try e w b
forall e w a. Either e a -> w -> Try e w a
Try Either e b
ex (w -> Try e w b) -> (w -> w) -> w -> Try e w b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<>)) (Either e b -> w -> Try e w b) -> Try e w b -> Try e w b
forall e a w b. (Either e a -> w -> b) -> Try e w a -> b
`try` a -> Try e w b
f a
x

instance Monoid w => MonadPlus (Try w w)

---------------------------------------------------------------------------
-- RUN TRY
---------------------------------------------------------------------------

runTry :: Try e w a -> (Either e a, w)
runTry :: Try e w a -> (Either e a, w)
runTry (Try Either e a
ex w
w) = (Either e a
ex, w
w)

gatherSuccess :: (Monoid w, Set w w) => [Try w w a] -> ([a], w)
gatherSuccess :: [Try w w a] -> ([a], w)
gatherSuccess = ((w -> [a]) -> ([a] -> [a]) -> Either w [a] -> [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([a] -> w -> [a]
forall a b. a -> b -> a
const []) [a] -> [a]
forall a. a -> a
id (Either w [a] -> [a]) -> (Either w [a], w) -> ([a], w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
`first`) ((Either w [a], w) -> ([a], w))
-> ([Try w w a] -> (Either w [a], w)) -> [Try w w a] -> ([a], w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Try w w [a] -> (Either w [a], w)
forall e w a. Try e w a -> (Either e a, w)
runTry (Try w w [a] -> (Either w [a], w))
-> ([Try w w a] -> Try w w [a]) -> [Try w w a] -> (Either w [a], w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Try w w a] -> Try w w [a]
forall w a. (Monoid w, Set w w) => [Try w w a] -> Try w w [a]
rights

---------------------------------------------------------------------------
-- THROW AND CATCH ERROR
---------------------------------------------------------------------------

throw :: Monoid w => e -> Try e w a
throw :: e -> Try e w a
throw = (Either e a -> w -> Try e w a
forall e w a. Either e a -> w -> Try e w a
`Try` w
forall a. Monoid a => a
mempty) (Either e a -> Try e w a) -> (e -> Either e a) -> e -> Try e w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left

catch :: Semigroup w => Try e w a -> (e -> Try e w a) -> Try e w a
Try (Left e
e) w
w catch :: Try e w a -> (e -> Try e w a) -> Try e w a
`catch` e -> Try e w a
h = (\Either e a
ex -> Either e a -> w -> Try e w a
forall e w a. Either e a -> w -> Try e w a
Try Either e a
ex (w -> Try e w a) -> (w -> w) -> w -> Try e w a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w
w w -> w -> w
forall a. Semigroup a => a -> a -> a
<>)) (Either e a -> w -> Try e w a) -> Try e w a -> Try e w a
forall e a w b. (Either e a -> w -> b) -> Try e w a -> b
`try` e -> Try e w a
h e
e
t :: Try e w a
t@(Try (Right a
_) w
_) `catch` e -> Try e w a
_ = Try e w a
t

rights :: (Monoid w, Set w w) => [Try w w a] -> Try w w [a]
rights :: [Try w w a] -> Try w w [a]
rights = ([Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe a] -> [a]) -> Try w w [Maybe a] -> Try w w [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Try w w [Maybe a] -> Try w w [a])
-> ([Try w w a] -> Try w w [Maybe a]) -> [Try w w a] -> Try w w [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Try w w a -> Try w w (Maybe a))
-> [Try w w a] -> Try w w [Maybe a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Try w w (Maybe a) -> (w -> Try w w (Maybe a)) -> Try w w (Maybe a)
forall w e a.
Semigroup w =>
Try e w a -> (e -> Try e w a) -> Try e w a
`catch` (Maybe a
forall a. Maybe a
Nothing Maybe a -> Try w w () -> Try w w (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Try w w () -> Try w w (Maybe a))
-> (w -> Try w w ()) -> w -> Try w w (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Try w w ()
forall w ws e. Set w ws => w -> Try e ws ()
tell) (Try w w (Maybe a) -> Try w w (Maybe a))
-> (Try w w a -> Try w w (Maybe a))
-> Try w w a
-> Try w w (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Try w w a -> Try w w (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>))

---------------------------------------------------------------------------
-- WRITE AND GET LOG
---------------------------------------------------------------------------

class Set x xs where set :: x -> xs

instance Set x x where set :: x -> x
set = x -> x
forall a. a -> a
id
instance Monoid xs => Set x (x, xs) where set :: x -> (x, xs)
set x
x = (x
x, xs
forall a. Monoid a => a
mempty)

instance {-# OVERLAPPABLE #-} (Monoid y, Set x xs) => Set x (y, xs) where
	set :: x -> (y, xs)
set x
x = (y
forall a. Monoid a => a
mempty, x -> xs
forall x xs. Set x xs => x -> xs
set x
x)

tell :: Set w ws => w -> Try e ws ()
tell :: w -> Try e ws ()
tell = Either e () -> ws -> Try e ws ()
forall e w a. Either e a -> w -> Try e w a
Try (() -> Either e ()
forall a b. b -> Either a b
Right ()) (ws -> Try e ws ()) -> (w -> ws) -> w -> Try e ws ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> ws
forall x xs. Set x xs => x -> xs
set

partial :: Try e (w, ws) a -> Try e ws (Either e a, w)
partial :: Try e (w, ws) a -> Try e ws (Either e a, w)
partial (Try Either e a
ex (w
w, ws
ws)) = Either e (Either e a, w) -> ws -> Try e ws (Either e a, w)
forall e w a. Either e a -> w -> Try e w a
Try ((Either e a, w) -> Either e (Either e a, w)
forall a b. b -> Either a b
Right (Either e a
ex, w
w)) ws
ws

---------------------------------------------------------------------------
-- TOOL
---------------------------------------------------------------------------

cons :: (Monoid w, Set w w) => Either w a -> [a] -> Try w w [a]
cons :: Either w a -> [a] -> Try w w [a]
cons = (w -> [a] -> Try w w [a])
-> (a -> [a] -> Try w w [a]) -> Either w a -> [a] -> Try w w [a]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (([a] -> Try w w () -> Try w w [a])
-> Try w w () -> [a] -> Try w w [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> Try w w () -> Try w w [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) (Try w w () -> [a] -> Try w w [a])
-> (w -> Try w w ()) -> w -> [a] -> Try w w [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Try w w ()
forall w ws e. Set w ws => w -> Try e ws ()
tell) (([a] -> Try w w [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Try w w [a]) -> ([a] -> [a]) -> [a] -> Try w w [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) (([a] -> [a]) -> [a] -> Try w w [a])
-> (a -> [a] -> [a]) -> a -> [a] -> Try w w [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:))