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-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- The coiterative comonad generated by a comonad
----------------------------------------------------------------------------
module Control.Comonad.Trans.Coiter
  (
  -- * The coiterative comonad transformer
    CoiterT(..)
  -- * The coiterative comonad
  , Coiter, coiter, runCoiter
  -- * Generating coiterative comonads
  , unfold
  -- * Cofree comonads
  , ComonadCofree(..)
  ) 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 coiterative comonad generated by a comonad
newtype CoiterT w a = CoiterT { runCoiterT :: w (a, CoiterT w a) }

-- | The coiterative comonad
type Coiter = CoiterT Identity

coiter :: a -> Coiter a -> Coiter a
coiter a as = CoiterT $ Identity (a,as)
{-# INLINE coiter #-}

runCoiter :: Coiter a -> (a, Coiter a)
runCoiter = runIdentity . runCoiterT
{-# INLINE runCoiter #-}

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
  {-# INLINE extract #-}
  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
  {-# INLINE unwrap #-}

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
  {-# INLINE (==) #-}

instance Ord (w (a, CoiterT w a)) => Ord (CoiterT w a) where
  compare (CoiterT a) (CoiterT b) = compare a b
  {-# INLINE compare #-}

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