module Control.Arrow.Improve(ImproveArrow, lowerImprove, getFunction) where
import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Zip
import Control.Arrow.Transformer
import Control.Arrow.Operations
import Data.Profunctor
import Data.Semigroupoid
import Data.Functor.Plus
import Data.Functor.Bind
import Data.Pointed
import Data.Monoid
import Data.String
data ImproveArrow a b c where
IArr :: (b -> c) -> ImproveArrow a b c
IArrow :: (i -> b) -> a b c -> (c -> o) -> ImproveArrow a i o
lowerImprove :: (Arrow a) => ImproveArrow a b c -> a b c
lowerImprove (IArrow f a g) = f ^>> a >>^ g
lowerImprove (IArr f) = arr f
getFunction :: ImproveArrow a b c -> Maybe (b -> c)
getFunction (IArr f) = Just f
getFunction (IArrow _ _ _) = Nothing
instance (Arrow a) => Category (ImproveArrow a) where
id = arr id
IArr f . IArr g = IArr (f . g)
IArr h . IArrow f a g = IArrow f a (h . g)
IArrow f a g . IArr h = IArrow (f . h) a g
IArrow f a g . IArrow h b i = IArrow h (b >>> arr (f . i) >>> a) g
instance (Arrow a) => Arrow (ImproveArrow a) where
arr = IArr
first (IArr f) = IArr (first f)
first (IArrow f a g) = IArrow (first f) (first a) (first g)
second (IArr f) = IArr (second f)
second (IArrow f a g) = IArrow (second f) (second a) (second g)
IArr f *** IArr g = IArr (f *** g)
IArr h *** IArrow f a g = IArrow (second f) (second a) (h *** g)
IArrow f a g *** IArr h = IArrow (first f) (first a) (g *** h)
IArrow f a g *** IArrow h b i = IArrow (f *** h) (a *** b) (g *** i)
IArr f &&& IArr g = IArr (f &&& g)
IArrow f a g &&& IArr h = IArrow (f &&& h) (first a) (first g)
IArr h &&& IArrow f a g = IArrow (h &&& f) (second a) (second g)
IArrow f a g &&& IArrow h b i = IArrow (f &&& h) (a *** b) (g *** i)
instance (ArrowZero a) => ArrowZero (ImproveArrow a) where
zeroArrow = lift zeroArrow
instance (ArrowPlus a) => ArrowPlus (ImproveArrow a) where
f <+> g = lift (lowerImprove f <+> lowerImprove g)
instance (ArrowChoice a) => ArrowChoice (ImproveArrow a) where
left (IArr f) = IArr (left f)
left (IArrow f a g) = IArrow (left f) (left a) (left g)
right (IArr f) = IArr (right f)
right (IArrow f a g) = IArrow (right f) (right a) (right g)
IArr f +++ IArr g = IArr (f +++ g)
IArrow f a g +++ IArr h = IArrow (left f) (left a) (g +++ h)
IArr h +++ IArrow f a g = IArrow (right f) (right a) (h +++ g)
IArrow f a g +++ IArrow h b i = IArrow (f +++ h) (a +++ b) (g +++ i)
IArr f ||| IArr g = IArr (f ||| g)
IArrow f a g ||| IArr h = IArrow (left f) (left a) (g ||| h)
IArr h ||| IArrow f a g = IArrow (right f) (right a) (h ||| g)
IArrow f a g ||| IArrow h b i = IArrow (f +++ h) (a +++ b) (g ||| i)
instance (ArrowApply a) => ArrowApply (ImproveArrow a) where
app = lift $ first lowerImprove ^>> app
instance (ArrowLoop a) => ArrowLoop (ImproveArrow a) where
loop (IArr f) = IArr f'
where f' x = let (y, k) = f (x, k) in y
loop (IArrow f a g) = lift (loop (f ^>> a >>^ g))
instance (ArrowCircuit a) => ArrowCircuit (ImproveArrow a) where
delay = lift . delay
instance (ArrowState s a) => ArrowState s (ImproveArrow a) where
fetch = lift fetch
store = lift store
instance (ArrowReader r a) => ArrowReader r (ImproveArrow a) where
readState = lift readState
newReader (IArr f) = lift $ newReader $ arr f
newReader (IArrow f a g) = IArrow id (newReader (f ^>> a)) g
instance (Monoid w, ArrowWriter w a) => ArrowWriter w (ImproveArrow a) where
write = lift write
newWriter (IArr f) = IArr ((\x -> (x, mempty)) . f)
newWriter (IArrow f a g) = IArrow f (newWriter (a >>^ g)) id
instance (ArrowError ex a) => ArrowError ex (ImproveArrow a) where
raise = lift raise
handle (IArr f) _ = IArr f
handle a@(IArrow _ _ _) e = lift (handle (lowerImprove a) (lowerImprove e))
tryInUnless (IArr g) f _ = IArr (\x -> (x, g x)) >>> f
tryInUnless a@(IArrow _ _ _) f e = lift (tryInUnless (lowerImprove a)
(lowerImprove f)
(lowerImprove e))
newError (IArr f) = IArr (Right . f)
newError a@(IArrow _ _ _) = lift (newError (lowerImprove a))
instance (Arrow a) => Functor (ImproveArrow a b) where
fmap f = (>>^ f)
instance (Arrow a) => Applicative (ImproveArrow a b) where
pure k = IArr (\_ -> k)
f <*> x = (f &&& x) >>^ uncurry id
instance (ArrowPlus a) => Alternative (ImproveArrow a b) where
empty = zeroArrow
(<|>) = (<+>)
instance (ArrowApply a) => Monad (ImproveArrow a b) where
return = pure
x >>= f = ((x >>^ f) &&& id) >>> app
instance (ArrowPlus a, ArrowApply a) => MonadPlus (ImproveArrow a b) where
mzero = zeroArrow
mplus = (<+>)
instance (ArrowApply a) => MonadZip (ImproveArrow a b) where
mzip = (&&&)
instance (Arrow a) => Profunctor (ImproveArrow a) where
dimap f g x = f ^>> x >>^ g
lmap f x = f ^>> x
rmap g x = x >>^ g
instance (Arrow a) => Strong (ImproveArrow a) where
first' = first
second' = second
instance (ArrowChoice a) => Choice (ImproveArrow a) where
left' = left
right' = right
instance (Arrow a) => Pointed (ImproveArrow a b) where
point = pure
instance (Arrow a) => Semigroupoid (ImproveArrow a) where
o = (.)
instance (ArrowPlus a) => Alt (ImproveArrow a b) where
(<!>) = (<+>)
instance (Arrow a) => Apply (ImproveArrow a b) where
(<.>) = (<*>)
instance (ArrowApply a) => Bind (ImproveArrow a b) where
(>>-) = (>>=)
instance (ArrowPlus a) => Plus (ImproveArrow a b) where
zero = zeroArrow
instance (ArrowPlus a) => Monoid (ImproveArrow a b c) where
mempty = zeroArrow
mappend = (<+>)
instance (Arrow a, Num c) => Num (ImproveArrow a b c) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
negate = fmap negate
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance (Arrow a, Fractional c) => Fractional (ImproveArrow a b c) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance (Arrow a, Floating c) => Floating (ImproveArrow a b c) where
pi = pure pi
exp = fmap exp
log = fmap log
sqrt = fmap sqrt
(**) = liftA2 (**)
logBase = liftA2 logBase
sin = fmap sin
cos = fmap cos
tan = fmap tan
asin = fmap asin
acos = fmap acos
atan = fmap atan
sinh = fmap sinh
cosh = fmap cosh
tanh = fmap tanh
asinh = fmap asinh
acosh = fmap acosh
atanh = fmap atanh
instance (Arrow a, IsString c) => IsString (ImproveArrow a b c) where
fromString = pure . fromString
instance (Arrow a) => ArrowTransformer ImproveArrow a where
lift x = IArrow id x id