{-# 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 Show

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

maybeToTry :: Monoid w => e -> Maybe a -> Try e w a
maybeToTry e = maybe (throw e) pure

-- INSTANCE

instance Functor (Try e w) where
	fmap f = try $ either (Try . Left) (Try . Right . f)

instance Monoid w => Applicative (Try e w) where
	pure = (`Try` mempty) . Right
	Try (Left e) w <*> _ = Try (Left e) w
	Try (Right f) w <*> mx = (\ex -> Try ex . (w <>)) `try` (f <$> mx)

instance Monoid w => Alternative (Try w w) where
	empty = Try (Left mempty) mempty
	Try (Left e) w <|> t = tell w >> tell e >> t
	t@(Try (Right _) _) <|> _ = t

instance Monoid w => Monad (Try e w) where
	Try (Left e) w >>= _ = Try (Left e) w
	Try (Right x) w >>= f = (\ex -> Try ex . (w <>)) `try` f x

instance Monoid w => MonadPlus (Try w w)

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

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

gatherSuccess :: (Monoid w, Set w w) => [Try w w a] -> ([a], w)
gatherSuccess = (either (const []) id `first`) . runTry . rights

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

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

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

rights :: (Monoid w, Set w w) => [Try w w a] -> Try w w [a]
rights = (catMaybes <$>) . mapM ((`catch` (Nothing <$) . tell) . (Just <$>))

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

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

instance Set x x where set = id
instance Monoid xs => Set x (x, xs) where set x = (x, mempty)

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

tell :: Set w ws => w -> Try e ws ()
tell = Try (Right ()) . set

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

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

cons :: (Monoid w, Set w w) => Either w a -> [a] -> Try w w [a]
cons = either (flip (<$) . tell) ((pure .) . (:))