{-# 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

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

data ListX ix a = ListX ix [a] deriving (Show, Read, Eq)
runListX :: (Index ix) => ix -> ListX ix a -> [a]
runListX (_::ix) (ListX (_::ix) a) = a

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 (_::ix) xs) = head xs

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

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

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

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

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

instance (Index ix) => Monad (ListX ix) where
     return a = ListX (getVal::ix) $ [a]
     v@(ListX (_::ix) _) >>= f = concatMapX f v
     fail s = ListX (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 (_::ix) [   ]) -> ListX (getVal::ix) []
               (ListX (_::ix) (x:_)) -> consX (getVal::ix) x (mfix (tailX . f))

instance (Index ix) => Monoid (ListX ix a) where
   mempty = ListX (getVal::ix) []
   mappend a b = concatX (getVal::ix) a b
   mconcat (xs::[ListX ix a]) = foldr (concatX (getVal::ix)) (ListX (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 $ ListX (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 = ListX (getVal::ix) []
  mplus (ListX (_::ix) a) (ListX (_::ix) b) = ListX (getVal::ix) $ a++b

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

instance (Ord a, Eq ix, Index ix) => Ord (ListX ix a) where
    compare (ListX (_::ix) a) (ListX (_::ix) b) = compare a b
    (ListX (_::ix) a) <  (ListX (_::ix) b) = a <  b
    (ListX (_::ix) a) >= (ListX (_::ix) b) = a >= b
    (ListX (_::ix) a) >  (ListX (_::ix) b) = a >  b
    (ListX (_::ix) a) <= (ListX (_::ix) b) = a <= b
    max (ListX (_::ix) a) (ListX (_::ix) b) = ListX (getVal::ix) $ max a b
    min (ListX (_::ix) a) (ListX (_::ix) b) = ListX (getVal::ix) $ min a b

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

data (Index ix) => ListTX ix m a = ListTX ix (m [a])
runListTX :: (Index ix) => ix -> ListTX ix m a -> m [a]
runListTX (_::ix) (ListTX (_::ix) m) = m
--instead of... newtype ListT m a = ListT { runListT :: m [a] }

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 = ListTX ixv $ f (runListTX ixv m)

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

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

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

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

instance (Index ix) => MonadTrans (ListTX ix) where
    lift m = ListTX (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 = ListTX (getVal::ix) $
        callCC $ \c ->
        runListTX (getVal::ix) (f (\a -> ListTX (getVal::ix) $ c [a]))




-- Error
instance (MonadError e m, Index ix) => MonadError e (ListTX ix m) where
    throwError       = lift . throwError
    m `catchError` h = ListTX (getVal::ix) $ runListTX (getVal::ix) m
        `catchError` \e -> runListTX (getVal::ix) (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 = ListTX (getVal::ixl) $ 
                        catchErrorx
                        (ixv::ixe)
                        (runListTX (getVal::ixl) m)
                        (\e -> runListTX (getVal::ixl) (h e))




-- Reader
instance (MonadReader s m, Index ix) => MonadReader s (ListTX ix m) where
    ask       = lift ask
    local f m = ListTX (getVal::ix) $ local f (runListTX (getVal::ix) 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 = ListTX (getVal::ixl) $ 
                            localx ixv f (runListTX (getVal::ixl) 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