----------------------------------------------------------------------
-- |
-- Module      :  Data.Fun
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Functions, with constant functions optimized.  With instances of
-- 'Functor', 'Applicative', 'Monad', and 'Arrow'
----------------------------------------------------------------------

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, (***), (>>>))

-- | Constant-optimized functions
data Fun t a = K a                      -- ^ constant function
             | Fun (t -> a)             -- ^ non-constant function

-- | 'Fun' as a function
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)
  -- Or use
  --  fmap f = (pure f <*>)

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