module Data.Fun (Fun(..), apply) where
import Data.Monoid (Monoid(..))
import Control.Applicative (Applicative(..))
import qualified Control.Category (Category, (.), id)
import Control.Arrow (Arrow, arr, first, second, (***), (>>>))
data Fun t a = K a
| Fun (t -> a)
apply :: Fun t a -> (t -> a)
apply (K a) = const a
apply (Fun f) = f
instance Monoid a => Monoid (Fun t a) where
mempty = K mempty
K a `mappend` K a' = K (a `mappend` a')
funa `mappend` funb = Fun (apply funa `mappend` apply funb)
instance Functor (Fun t) where
fmap f (K a) = K (f a)
fmap f (Fun g) = Fun (f.g)
instance Applicative (Fun t) where
pure = K
K f <*> K x = K (f x)
cf <*> cx = Fun (apply cf <*> apply cx)
instance Monad (Fun t) where
return = pure
K a >>= h = h a
Fun f >>= h = Fun (f >>= apply . h)
instance Control.Category.Category Fun where
id = arr id
K b . _ = K b
Fun g . K a = K (g a)
Fun f . Fun g = Fun (f . g)
instance Arrow Fun where
arr = Fun
first = Fun . first . apply
second = Fun . second . apply
K a' *** K b' = K (a',b')
f *** g = first f >>> second g