-- | Decoration: a one-hole functor.

module BNFC.Utils.Decoration where

import Prelude (id, (.), ($), Eq, Ord, Show, Functor(..), (<$>), Foldable, Traversable)

import Control.Applicative ( Const(Const), getConst )

import Data.Bifunctor
import Data.Functor.Identity
import Data.Functor.Compose

-- | A decoration is a functor that is traversable into any functor.
--
--   The 'Functor' superclass is given because of the limitations
--   of the Haskell class system.
--   @traverseF@ actually implies functoriality.
--
--   Minimal complete definition: @traverseF@ or @distributeF@.
class Functor t => Decoration t where

  -- | @traverseF@ is the defining property.
  traverseF :: Functor m => (a -> m b) -> t a -> m (t b)
  traverseF f = distributeF . fmap f

  -- | Decorations commute into any functor.
  distributeF :: Functor m => t (m a) -> m (t a)
  distributeF = traverseF id

  traverseF2 :: Bifunctor m => (a -> m b c) -> t a -> m (t b) (t c)
  traverseF2 f = distributeF2 . fmap f

  -- | Decorations commute into any bifunctor.
  distributeF2 :: Bifunctor m => t (m a b) -> m (t a) (t b)
  distributeF2 = traverseF2 id

  {-# MINIMAL (traverseF | distributeF) , ( traverseF2 | distributeF2) #-}

-- | Any decoration is traversable with @traverse = traverseF@.
--   Just like any 'Traversable' is a functor, so is
--   any decoration, given by just @traverseF@, a functor.
dmap :: Decoration t => (a -> b) -> t a -> t b
dmap f = runIdentity . traverseF (Identity . f)

-- | Any decoration is a lens.  @set@ is a special case of @dmap@.
dget :: Decoration t => t a -> a
dget = getConst . traverseF Const

-- | The identity functor is a decoration.
instance Decoration Identity where
  traverseF  f (Identity x) = Identity <$> f x
  traverseF2 f (Identity x) = bimap Identity Identity $ f x

-- | Decorations compose.  (Thus, they form a category.)
instance (Decoration d, Decoration t) => Decoration (Compose d t) where
  -- traverseF . traverseF :: Functor m => (a -> m b) -> d (t a) -> m (d (t a))
  traverseF  f (Compose x) = Compose <$> traverseF (traverseF f) x
  traverseF2 f (Compose x) = bimap Compose Compose $ traverseF2 (traverseF2 f) x

-- Not a decoration are:
--
-- * The constant functor.
-- * Maybe.  Can only be traversed into pointed functors.
-- * Other disjoint sum types, like lists etc.
--   (Can only be traversed into Applicative.)

-- | A typical decoration is pairing with some stuff.
instance Decoration ((,) a) where
  traverseF  f (a, x) = (a,) <$> f x
  traverseF2 f (a, x) = bimap (a,) (a,) $ f x

-- | A proper name for a generic decoration.
data DecorationT d a = DecorationT
  { decoration :: d
  , decorated  :: a
  }
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

instance Decoration (DecorationT d) where
  traverseF  f (DecorationT d x) = DecorationT d <$> f x
  traverseF2 f (DecorationT d x) = bimap (DecorationT d) (DecorationT d) $ f x