Coiter.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 707
{-# LANGUAGE DeriveDataTypeable #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Comonad.Trans.Coiter
-- Copyright   :  (C) 2008-2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- The iterative comonad generated by a comonad
----------------------------------------------------------------------------
module Control.Comonad.Trans.Coiter
  ( CoiterT(..)
  , ComonadCofree(..)
  , coiterT
  ) where

import Control.Arrow
import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Cofree.Class
import Control.Category
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.Foldable
import Data.Functor.Identity
import Data.Traversable
import Prelude hiding (id,(.))

#if defined(GHC_TYPEABLE) || __GLASGOW_HASKELL__ >= 707
import Data.Data
#endif

-- | This is the (co?)iterative comonad generated by a comonad
newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) }

instance Functor w => Functor (CoiterT w) where
  fmap f = CoiterT . fmap (bimap f (fmap f)) . runCoiterT

instance Comonad w => Comonad (CoiterT w) where
  extract = fst . extract . runCoiterT
  extend f = CoiterT . extend (\w -> (f (CoiterT w), extend f $ snd $ extract w)) . runCoiterT

instance Foldable w => Foldable (CoiterT w) where
  foldMap f = foldMap (bifoldMap f (foldMap f)) . runCoiterT

instance Traversable w => Traversable (CoiterT w) where
  traverse f = fmap CoiterT . traverse (bitraverse f (traverse f)) . runCoiterT

instance ComonadTrans CoiterT where
  lower = fmap fst . runCoiterT

instance Comonad w => ComonadCofree Identity (CoiterT w) where
  unwrap = Identity . snd . extract . runCoiterT

instance Show (w (a, CoiterT w a)) => Show (CoiterT w a) where
  showsPrec d w = showParen (d > 10) $
    showString "CoiterT " . showsPrec 11 w

instance Read (w (a, CoiterT w a)) => Read (CoiterT w a) where
  readsPrec d = readParen (d > 10) $ \r ->
     [(CoiterT w, t) | ("CoiterT", s) <- lex r, (w, t) <- readsPrec 11 s]

instance Eq (w (a, CoiterT w a)) => Eq (CoiterT w a) where
  CoiterT a == CoiterT b = a == b

instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where
  compare (CoiterT a) (CoiterT b) = compare a b

-- | Unfold a @CoiterT@ comonad transformer from a cokleisli arrow and an initial comonadic seed.
coiterT :: Comonad w => (w a -> a) -> w a -> CoiterT w a
coiterT psi = CoiterT . extend (extract &&& coiterT psi . extend psi)

#if defined(GHC_TYPEABLE) && __GLASGOW_HASKELL__ < 707

instance Typeable1 w => Typeable1 (CoiterT w) where
  typeOf1 t = mkTyConApp coiterTTyCon [typeOf1 (w t)] where
    w :: CoiterT w a -> w a
    w = undefined

coiterTTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
coiterTTyCon = mkTyCon "Control.Comonad.Trans.Coiter.CoiterT"
#else
coiterTTyCon = mkTyCon3 "free" "Control.Comonad.Trans.Coiter" "CoiterT"
#endif
{-# NOINLINE coiterTTyCon #-}

instance
  ( Typeable1 w, Typeable a
  , Data (w (a, CoiterT w a))
  , Data a
  ) => Data (CoiterT w a) where
    gfoldl f z (CoiterT w) = z CoiterT `f` w
    toConstr _ = coiterTConstr
    gunfold k z c = case constrIndex c of
        1 -> k (z CoiterT)
        _ -> error "gunfold"
    dataTypeOf _ = coiterTDataType
    dataCast1 f = gcast1 f

coiterTConstr :: Constr
coiterTConstr = mkConstr coiterTDataType "CoiterT" [] Prefix
{-# NOINLINE coiterTConstr #-}

coiterTDataType :: DataType
coiterTDataType = mkDataType "Control.Comonad.Trans.Coiter.CoiterT" [coiterTConstr]
{-# NOINLINE coiterTDataType #-}
#endif