{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}

-- | Module      : Control.Monad.Sharing
-- | Copyright   : Sebastian Fischer
-- | License     : PublicDomain
-- |
-- | Maintainer  : Sebastian Fischer (sebf@informatik.uni-kiel.de)
-- | Stability   : experimental
-- |
-- | This library provides an interface to monads that support explicit
-- | sharing.
module Control.Monad.Sharing (

  module Control.Monad,

  -- * Classes

  Sharing(..), Trans(..),

  -- $predefined

  -- * Evaluation

  eval,

  -- * Monadic lists

  List(..), nil, cons, isEmpty, first, rest

 ) where

import Control.Monad

-- | Interface of monads that support explicit sharing.
class Sharing m
 where
  -- | Yields an action that returns the same results as the given
  -- | action but whose effects are only executed once. Especially,
  -- | when the resulting action is duplicated it returns the same
  -- | result at every occurrence.
  share :: Trans m a a => m a -> m (m a)

-- | Interface to transform nested monadic data types. The provided
-- | function @trans@ is supposed to map the given function on every
-- | monadic argument. The result of @trans@ may be of the same type
-- | as the argument but can also be of a different type, e.g. to
-- | convert a value with nested monadic arguments to a corresponding
-- | value without.
class Trans m a b
 where
  trans :: (forall c d . Trans m c d => m c -> m (m d)) -> a -> m b

-- | Lifts all monadic effects in nested monadic values to the top
-- | level. If @m@ is a monad for non-determinism and the argument a
-- | data structure with nested non-determinism then the result
-- | corresponds to the normal form of the argument.
eval :: (Monad m, Trans m a b) => a -> m b
eval = trans (\a -> liftM return (a >>= eval))

-- $predefined 
--
-- We provide instances of the @Trans@ class for some predefined
-- Haskell types. For flat types the function @trans@ just returns its
-- argument which has no arguments to which the given function could
-- be applied.

instance Monad m => Trans m Bool Bool
 where
  trans _ = return

instance Monad m => Trans m Int Int
 where
  trans _ = return

instance Monad m => Trans m Char Char
 where
  trans _ = return

instance Monad m => Trans m Float Float
 where
  trans _ = return

instance Monad m => Trans m Double Double
 where
  trans _ = return

-- | An instance for lists with monadic elements.
instance (Monad m, Trans m a a) => Trans m [m a] [m a]
 where
  trans f = mapM f

-- | An instance for lists with monadic elements that lifts all
-- | monadic effects to the top level and yields a list with
-- | non-monadic elements.
instance (Monad m, Trans m a a) => Trans m [m a] [a]
 where
  trans f = mapM (join . f)

-- | Data type for lists where both the head and tail are monadic.
data List m a = Nil | Cons (m a) (m (List m a))

-- | The empty monadic list.
nil :: Monad m => m (List m a)
nil = return Nil

-- | Constructs a non-empty monadic list.
cons :: Monad m => m a -> m (List m a) -> m (List m a)
cons x xs = return (Cons x xs)

-- | Checks if monadic list is empty.
isEmpty :: Monad m => m (List m a) -> m Bool
isEmpty ml = do l <- ml
                case l of
                  Nil      -> return True
                  Cons _ _ -> return False

-- | Yields the head of a monadic list. Relies on @MonadPlus@ instance
-- | to provide a failing implementation of @fail@.
first :: MonadPlus m => m (List m a) -> m a
first ml = do Cons x _ <- ml; x

-- | Yields the tail of a monadic list. Relies on @MonadPlus@ instance
-- | to provide a failing implementation of @fail@.
rest :: MonadPlus m => m (List m a) -> m (List m a)
rest ml = do Cons _ xs <- ml; xs

instance (Monad m, Trans m a a) => Trans m (List m a) (List m a)
 where
  trans _ Nil         = return Nil
  trans f (Cons x xs) = return Cons `ap` f x `ap` f xs

instance (Monad m, Trans m a a) => Trans m (List m a) [a]
 where
  trans _ Nil         = return []
  trans f (Cons x xs) = return (:) `ap` join (f x) `ap` join (f xs)