{-# OPTIONS -fglasgow-exts #-}

{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}

-- Needed for the same reasons as in Reader, State etc

-- the ListX and ListTX monads provide the same functionality as the
-- [] and ListT monads.  Since [] is so deeply ingrained into the
-- language itself, it is problematic to use any of the helper
-- functions provided that involve lists anywhere.  I don't know how
-- useful an indexed List monad is for that reason, but I've tried to
-- provide it in case anyone else can find a use for it.  But buyer
-- beware, this is very poorly supported, as I have little to no
-- experience using the list monad to any degree.

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ListX
-- Stability   :  experimental
-- Portability :  non-portable (multi-parameter type classes)
-----------------------------------------------------------------------------

module Control.Monad.ListX (
    MonadListX,
    runListX,
    runListTX,
    ListTX(..),
    mapListTX,
    module Control.Monad,
    module Control.Monad.Trans,
    module Control.Monad.Index
  ) where

import Control.Monad
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.List
import Control.Monad.Trans

import Control.Monad.Index

import Control.Monad.ErrorX.Class
import Control.Monad.ReaderX.Class
import Control.Monad.StateX.Class


import Control.Monad.Fix
import Data.Monoid
import Test.QuickCheck

-- ---------------------------------------------------------------------------

newtype ListX ix a = ListX {runListX' :: [a]}
mkListX :: (Index ix) => ix -> [a] -> ListX ix a
mkListX _ xs = ListX xs
runListX :: (Index ix) => ix -> ListX ix a -> [a]
runListX _ m = runListX' m
unListX :: (Index ix) => ix -> ListX ix a -> [a]
unListX ix m = runListX ix m
unListX' :: ListX ix a -> [a]
unListX' m = runListX' m

class (Index ix, Monad m, MonadPlus m) => MonadListX ix a m | ix m -> a where
-- what would MonadList have?  My guess is nothing, that we merely use
-- it to keep different uses separate until we run it by discarding
-- the indexing information, and retrieve the list.  At first I'd
-- thought maybe it should have some of the basic list operators, or
-- things used with lists as monadic computations.  consX :: ix -> a
-- -> ListX ix a -> ListX ix a concatX :: ix -> ListX ix a -> ListX ix
-- a -> ListX ix a sequenceX :: (Monad m) => ix -> ListX ix (m a) -> m
-- (ListX ix a)

instance (Index ix) => MonadListX ix a (ListX ix) where

headX :: (Index ix) => ListX ix a -> a
headX ((ListX xs)::(ListX ix a)) = head xs

tailX :: (Index ix) => ListX ix a -> ListX ix a
tailX ((ListX xs)::(ListX ix a)) = mkListX (getVal::ix) $ tail xs

consX :: (Index ix) => ix -> a -> ListX ix a -> ListX ix a
consX (_::ix) a ((ListX as)::(ListX ix a)) = mkListX (getVal::ix) $ a:as

concatX :: (Index ix) => ix -> ListX ix a -> ListX ix a -> ListX ix a
concatX (_::ix) ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) = mkListX (getVal::ix) $ a++b

concatMapX :: (Index ix) => (a -> ListX ix b) ->  ListX ix a -> ListX ix b
concatMapX f ((ListX as)::(ListX ix a)) = foldr ((concatX (getVal::ix)) . f) (mkListX (getVal::ix) []) as

--sequenceX :: (Monad m, Index ix) => ListX ix (m a) -> m (ListX ix a)
--sequenceX (ListX []    ) = return $ mkListX (getVal::ix) []
--sequenceX (ListX (x:xs)) = do
--          x'  <- x
--          xs' <- sequenceX $ mkListX (getVal::ix) xs
--          return $ consX (getVal::ix) x' xs'

instance (Index ix) => Monad (ListX ix) where
     return a = mkListX (getVal::ix) $ [a]
     v@((ListX {-(_::ix)-} _)::(ListX ix a)) >>= f = concatMapX f v
     fail s = mkListX (getVal::ix) []

instance (Index ix) => MonadFix (ListX ix) where
   mfix (f:: a -> ListX ix a) = 
           case fix (f . (headX :: ListX ix a -> a)) of
               (ListX [   ]) -> mkListX (getVal::ix) []
               (ListX (x:_)) -> consX (getVal::ix) x (mfix (tailX . f))

instance (Index ix) => Monoid (ListX ix a) where
   mempty = mkListX (getVal::ix) []
   mappend a b = concatX (getVal::ix) a b
   mconcat (xs::[ListX ix a]) = foldr (concatX (getVal::ix)) (mkListX (getVal::ix) []) xs

instance (Index ix, Arbitrary a) => Arbitrary (ListX ix a) where
  arbitrary = sized $ \n -> do
              k <- choose (0,n)
              xs <- arbitrary :: Gen [a]
              return $ mkListX (getVal::ix) xs
--  coarbitrary (ListX (_::ix) [])     = variant 0
--  coarbitrary (ListX (_::ix) (x:xs)) = variant (-1) . coarbitrary (x,xs)

instance (Index ix) => MonadPlus (ListX ix) where
  mzero = mkListX (getVal::ix) []
  mplus ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) = mkListX (getVal::ix) $ a++b

instance (Index ix) => Functor (ListX ix) where
   fmap f ((ListX xs)::(ListX ix a)) = mkListX (getVal::ix) $ map f xs

instance (Index ix, Eq a) => Eq (ListX ix a) where
  ((ListX a)::(ListX ix a)) == ((ListX b)::(ListX ix a)) = a==b
  ((ListX a)::(ListX ix a)) /= ((ListX b)::(ListX ix a)) = a/=b


instance (Ord a, Eq ix, Index ix) => Ord (ListX ix a) where
    compare ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) = compare a b

    ((ListX a)::(ListX ix a)) <  ((ListX b)::(ListX ix a)) =  a <  b
    ((ListX a)::(ListX ix a)) >= ((ListX b)::(ListX ix a)) =  a >= b
    ((ListX a)::(ListX ix a)) >  ((ListX b)::(ListX ix a)) =  a >  b
    ((ListX a)::(ListX ix a)) <= ((ListX b)::(ListX ix a)) =  a <= b

    max ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) =  mkListX (getVal::ix) $ max a b
    min ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) =  mkListX (getVal::ix) $ min a b

----------------------------------------------------------------------
----------------------------------------------------------------------

newtype ListTX ix m a = ListTX { runListTX' :: m [a] }
mkListTX :: (Index ix) => ix -> m [a] -> ListTX ix m a
mkListTX _ m = ListTX m
runListTX :: (Index ix) => ix -> ListTX ix m a -> m [a]
runListTX _ m = runListTX' m

instance (Index ix, Monad m) => MonadListX ix a (ListTX ix m) where 

mapListTX :: (Index ix) => ix -> (m [a] -> n [b]) -> ListTX ix m a -> ListTX ix n b
mapListTX (ixv::ix) f m = mkListTX ixv $ f (runListTX' m)

instance (Monad m, Index ix) => Functor (ListTX ix m) where
    fmap f m = mkListTX (getVal::ix) $ do
        a <- runListTX' m
        return (map f a)

instance (Monad m, Index ix) => Monad (ListTX ix m) where
    return a = mkListTX (getVal::ix) $ return [a]
    m >>= k  = mkListTX (getVal::ix) $ do
        a <- runListTX' m
        b <- mapM (runListTX' . k) a
        return (concat b)
    fail _ = mkListTX (getVal::ix) $ return []

instance (Monad m, Index ix) => MonadPlus (ListTX ix m) where
    mzero       = mkListTX (getVal::ix) $ return []
    m `mplus` n = mkListTX (getVal::ix) $ do
        a <- runListTX' m
        b <- runListTX' n
        return (a ++ b)

-- ---------------------------------------------------------------------------
-- Instances for other mtl transformers

instance (Index ix) => MonadTrans (ListTX ix) where
    lift m = mkListTX (getVal::ix) $ do
        a <- m
        return [a]

instance (MonadIO m, Index ix) => MonadIO (ListTX ix m) where
    liftIO = lift . liftIO

instance (MonadCont m, Index ix) => MonadCont (ListTX ix m) where
    callCC f = mkListTX (getVal::ix) $
        callCC $ \c ->
        runListTX' (f (\a -> mkListTX (getVal::ix) $ c [a]))

-- Error
instance (MonadError e m, Index ix) => MonadError e (ListTX ix m) where
    throwError       = lift . throwError
    m `catchError` h = mkListTX (getVal::ix) $ runListTX' m
        `catchError` \e -> runListTX' (h e)



-- ErrorX
instance (MonadErrorX ixe e m, Index ixe, Index ixl) => MonadErrorX ixe e (ListTX ixl m) where
    throwErrorx (ixv::ixe)     = lift . throwErrorx ixv
    catchErrorx (ixv::ixe) m h = mkListTX (getVal::ixl) $ 
                        catchErrorx
                        (ixv::ixe)
                        (runListTX' m)
                        (\e -> runListTX' (h e))



-- Reader
instance (MonadReader s m, Index ix) => MonadReader s (ListTX ix m) where
    ask       = lift ask
    local f m = mkListTX (getVal::ix) $ local f (runListTX' m)




-- ReaderX
instance (Index ixr, MonadReaderX ixr s m, Index ixl) 
  => MonadReaderX ixr s (ListTX ixl m) where
    askx   (ixv::ixr)     = lift $ askx ixv
    localx (ixv::ixr) f m = mkListTX (getVal::ixl) $ 
                            localx ixv f (runListTX' m)




-- State
instance (MonadState s m, Index ix) => MonadState s (ListTX ix m) where
    get = lift get
    put = lift . put




-- StateX
instance (Index ixs, MonadStateX ixs s m, Index ixl)
    => MonadStateX ixs s (ListTX ixl m) where
    getx (ixv::ixs) = lift $ getx ixv
    putx (ixv::ixs) = lift . putx ixv