{-# OPTIONS -fglasgow-exts #-}
{-# OPTIONS -fallow-undecidable-instances #-}
{-# OPTIONS -fallow-overlapping-instances #-}

{- Deep Monadic Join

 The regular `join' function, defined in Control.Monad, has the
 signature 
	join :: Monad m => m (m a) -> m a

 Paolo Martini (in his message on Apr 26, 2006) posed the problem of
 a deep join function:
        deep'join :: Monad m => m (m (m (... a ...))) -> m a
 Note, generally speaking we cannot remove the last 'm': some monads, for
 example IO, do not provide any function of the type |m a -> a|.

 One may say that deep'join is a `folded' join. For the List monad,
 deep join is list flattening.
 
 The idea of the code is explained in typecast.html
 in this directory.
-}

import Control.Monad (join)
import Data.IORef -- needed for tests only

class Monad m => DeepJoin mv m a | mv -> m a where
    deep'join :: mv -> m a

instance (IsNestedMonad mv flag, Monad m, DeepJoin' flag mv m a)
    => DeepJoin mv m a where
    deep'join = deep'join' (undefined::flag) 

class Monad m => DeepJoin' flag mv m a | flag mv -> m a where
    deep'join' :: flag -> mv -> m a

instance Monad m => DeepJoin' HFalse (m a) m a where
    deep'join' _ = id

instance (Monad m, DeepJoin (m mv) m a)
    => DeepJoin' HTrue (m (m mv)) m a where
    deep'join' _ = deep'join . join


-- The following is almost equivalent to IsFunction.lhs

data HTrue
data HFalse

class IsNestedMonad m b | m -> b
instance TypeCast f HTrue => IsNestedMonad (m (m a)) f
instance TypeCast f HFalse => IsNestedMonad m f

class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b
class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b
class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b
instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x
instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''
instance TypeCast'' () a a where typeCast'' _ x  = x


------------------------------------------ Tests

testv1 = returnIO (returnIO (returnIO (newIORef True)))
    where returnIO :: forall a. a -> IO a
	  returnIO = return

-- :t testv1
-- testv1 :: IO (IO (IO (IO (IORef Bool))))

test1 = deep'join testv1 >>= readIORef >>= print


-- The following understandably doesn't work: the literal 1 actually
-- represents fromInteger 1, whose result may well be a list
-- (one can define an instance of Num for a list). So, deep'join can't figure
-- out to what extent flatten the list (that is, the monad). Some help 
-- is needed.
-- test2 = deep'join [[[[1],[]]]]

-- For example, we can instantiate types...
test3 = deep'join [[[[1::Int],[2],[3,4]],[[5],[6]]]]

-- The following demonstrates that if enough type information is available
-- to figure out the extent of the deep joining, we can handle polymorphic
-- monads.
test4 :: [Maybe a] -- signature is needed for the monomorphism restriction
test4 :: [Maybe a] = deep'join [[[[Nothing::Maybe a]]]]