{-# OPTIONS_GHC -fglasgow-exts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Transformer.Error
-- Copyright   :  (c) Ross Paterson 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ross@soi.city.ac.uk
-- Stability   :  experimental
-- Portability :  non-portable (multi-parameter type classes)
--
-- An arrow transformer that adds error handling.
--
-- /TODO:/ the operations here are inconsistent with other arrow transformers.

module Control.Arrow.Transformer.Error(
		ErrorArrow,
		runError,
		ArrowAddError(..),
	) where

import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Data.Monoid

-- | An arrow that augments an existing arrow with possible errors.
-- The 'ArrowError' class contains methods for raising and handling
-- these errors.

newtype ErrorArrow ex a b c = ErrorArrow (a b (Either ex c))

rstrength :: (Either ex a, b) -> Either ex (a, b)
rstrength (Left ex, _) = Left ex
rstrength (Right a, b) = Right (a, b)

-- | Encapsulate an error-raising computation,
-- by completely handling any errors.
--
-- Typical usage in arrow notation:
--
-- >	proc p -> ...
-- >		body `runError` \ex -> handler

runError :: ArrowChoice a =>
	ErrorArrow ex a e b	-- ^ computation that may raise errors
	-> a (e,ex) b		-- ^ computation to handle errors
	-> a e b
runError (ErrorArrow f) h =
	arr id &&& f >>> arr strength >>> h ||| arr id
	where	strength (x, Left y) = Left (x, y)
		strength (_, Right z) = Right z

-- transformer

instance ArrowChoice a => ArrowTransformer (ErrorArrow ex) a where
	lift f = ErrorArrow (f >>> arr Right)

-- liftings of standard classes

instance ArrowChoice a => Arrow (ErrorArrow ex a) where
	arr f = ErrorArrow (arr (Right . f))
	ErrorArrow f >>> ErrorArrow g =
		ErrorArrow (f >>> right g >>> arr (either Left id))
	first (ErrorArrow f) = ErrorArrow (first f >>> arr rstrength)

instance ArrowChoice a => ArrowChoice (ErrorArrow ex a) where
	left (ErrorArrow f) = ErrorArrow (left f >>> arr assocsum)

assocsum :: Either (Either a b) c -> Either a (Either b c)
assocsum (Left (Left a)) = Left a
assocsum (Left (Right b)) = Right (Left b)
assocsum (Right c) = Right (Right c)

instance (ArrowChoice a, ArrowApply a) => ArrowApply (ErrorArrow ex a) where
        app = ErrorArrow (arr (\(ErrorArrow f, x) -> (f, x)) >>> app)

-- this instance has the right type, but it doesn't satisfy right
-- tightening, or sliding of non-strict functions.

instance (ArrowChoice a, ArrowLoop a) => ArrowLoop (ErrorArrow ex a) where
	loop (ErrorArrow f) = ErrorArrow (loop (f >>> arr dist))
		where	dist x = (fstRight x, snd $ fromRight x)
			fstRight (Left x) = Left x
			fstRight (Right (x,_)) = Right x
			fromRight (Left _) = error "fromRight"
			fromRight (Right y) = y

-- fresh instances

instance ArrowChoice a => ArrowError ex (ErrorArrow ex a) where
	raise = ErrorArrow (arr Left)
	handle (ErrorArrow f) (ErrorArrow h) =
		ErrorArrow (arr id &&& f >>> arr strength >>> h ||| arr Right)
		where	strength (x, Left y) = Left (x, y)
			strength (_, Right z) = Right z
	tryInUnless (ErrorArrow f) (ErrorArrow s) (ErrorArrow h) =
		ErrorArrow (arr id &&& f >>> arr distr >>> h ||| s)
		where	distr (b, Left ex) = Left (b, ex)
			distr (b, Right c) = Right (b, c)

instance ArrowChoice a => ArrowAddError ex (ErrorArrow ex a) a where
	liftError = lift
	elimError = runError

instance (Monoid ex, ArrowChoice a) => ArrowZero (ErrorArrow ex a) where
	zeroArrow = ErrorArrow (arr (const (Left mempty)))

instance (Monoid ex, ArrowChoice a) => ArrowPlus (ErrorArrow ex a) where
	f <+> g = handle f $ handle (arr fst >>> g) $
			ErrorArrow (arr (\((_,ex1), ex2) ->
				Left (ex1 `mappend` ex2)))

-- liftings of other arrow classes

-- specializations of general promotions

instance (ArrowReader r a, ArrowChoice a)
		 => ArrowReader r (ErrorArrow ex a) where
	readState = lift readState
	newReader (ErrorArrow f) = ErrorArrow (newReader f)

instance (ArrowState s a, ArrowChoice a) =>
                ArrowState s (ErrorArrow ex a) where
	fetch = lift fetch
	store = lift store

instance (ArrowWriter w a, ArrowChoice a) =>
		ArrowWriter w (ErrorArrow ex a) where
	write = lift write
	newWriter (ErrorArrow f) = ErrorArrow (newWriter f >>> arr rstrength)

-- promotions

instance (ArrowAddReader r a a', ArrowChoice a, ArrowChoice a') =>
		ArrowAddReader r (ErrorArrow ex a) (ErrorArrow ex a') where
	liftReader (ErrorArrow f) = ErrorArrow (liftReader f)
	elimReader (ErrorArrow f) = ErrorArrow (elimReader f)

instance (ArrowAddState s a a', ArrowChoice a, ArrowChoice a') =>
		ArrowAddState s (ErrorArrow ex a) (ErrorArrow ex a') where
	liftState (ErrorArrow f) = ErrorArrow (liftState f)
	elimState (ErrorArrow f) = ErrorArrow (elimState f >>> arr rstrength)

instance (ArrowAddWriter w a a', ArrowChoice a, ArrowChoice a') =>
		ArrowAddWriter w (ErrorArrow ex a) (ErrorArrow ex a') where
	liftWriter (ErrorArrow f) = ErrorArrow (liftWriter f)
	elimWriter (ErrorArrow f) = ErrorArrow (elimWriter f >>> arr rstrength)