{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

module Data.Partial where

import Prelude hiding ((.),id)
import Data.Monoid
import Control.Category
import Control.Applicative
import Control.Monad.Error
import Control.Arrow

newtype Partial e a b = Partial {apply :: a -> Either e b}

applyTo :: a -> Partial e a b -> Either e b
applyTo a f = apply f a

instance (Error e, Monoid b) => Monoid (Either e b) where
    mempty = Right mempty
    mappend (Left e) _ = Left e
    mappend _ (Left e) = Left e
    mappend (Right b1) (Right b2) = Right (mappend b1 b2)

instance Error e => Applicative (Either e) where
    pure = Right
    (Left e) <*> _ = Left e
    _ <*> (Left e) = Left e
    (Right f) <*> (Right b) = Right (f b)

instance Error e => Alternative (Either e) where
    empty = throwError (strMsg "Alternative.empty") -- Is that going to come back to haunt me?
    (Left _) <|> a = a
    a <|> _ = a

instance Error e => Category (Partial e) where
    id = Partial (return . id)
    (Partial f) . (Partial g) = Partial (\a-> g a >>= f)

instance Error e => Functor (Partial e a) where
    fmap f (Partial g) = Partial (\a-> fmap f (g a))

instance (Error e, Monoid b) => Monoid (Partial e a b) where
    mempty = Partial (\_-> mempty)
    mappend (Partial f) (Partial g) = Partial (\a-> (mappend f g) a)

instance Error e => Applicative (Partial e a) where
    pure b = Partial (\_-> pure b)
    (Partial f) <*> (Partial g) = Partial (\a-> (f a) <*> (g a)) -- worth doing par?

instance Error e => Alternative (Partial e a) where
    empty = Partial (\_-> empty)
    (Partial f) <|> (Partial g) = Partial (\a-> (f a) <|> (g a))

instance Error e => Monad (Partial e a) where
    return b = Partial (\_ -> return b)
    f >>= g = Partial (\a-> (applyTo a f) >>= (applyTo a . g) )
    fail msg = Partial (\_-> fail msg )

instance Error e => MonadError e (Partial e a) where
    throwError e = Partial (\_ -> throwError e)
    catchError f g = Partial (\a-> catchError (applyTo a f) (applyTo a . g))

instance Error e => MonadPlus (Partial e a) where
    mzero = Partial (\_-> mzero)
    mplus (Partial f) (Partial g) = Partial (\a-> mplus (f a) (g a))

instance Error e => Arrow (Partial e) where
    arr f = Partial (pure . f)
    first (Partial f)  = Partial (\(c,d)-> (,) <$> f c <*> pure d)
    second (Partial f) = Partial (\(c,d)-> (,) <$> pure c <*> f d)
    (Partial f) *** (Partial g) = Partial (\(c,d)-> (,) <$> f c <*> g d)
    (Partial f) &&& (Partial g) = Partial (\a-> (,) <$> f a <*> g a)

instance Error e => ArrowChoice (Partial e) where
    left (Partial f) = Partial (\a->
        case a of
            (Left l)  -> Left  <$> f l
            (Right r) -> Right <$> pure r )
    right (Partial f) = Partial (\a->
        case a of
            (Left l)  -> Left  <$> pure l
            (Right r) -> Right <$> f r )
    (Partial f) +++ (Partial g) = Partial (\a->
        case a of
            (Left l)  -> Left  <$> f l
            (Right r) -> Right <$> g r )
    (Partial f) ||| (Partial g) = Partial (\a->
        case a of
            (Left l)  -> f l
            (Right r) -> g r )

instance Error e => ArrowApply (Partial e) where
    app = Partial (\(b,a) -> applyTo a b)