{-# LANGUAGE ScopedTypeVariables, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ImpredicativeTypes #-}

-- 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 too little experiece
-- using the list monad to confidently test multiple listx indexed monads
-- at the same time.

{-
Module      :  examples/ListX
Copyright   :  (c) Mark Snyder 2012.
License     :  BSD-style
Maintainer  :  Mark Snyder, msnyde14@gmu.edu
Stability   :  experimental
Portability :  non-portable (multi-param classes, functional dependencies)
-}

module ListX (
    ListX(..),
    mkListX,
    MonadListX,
    runListX,
    headX,
    tailX,
    consX,
    concatX,
    concatMapX,
    runListTX,
    ListTX(..),
    mapListTX,
    unListX, unListX',
    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 X1 = X1 deriving (Show, Eq)
instance Index X1 where getVal = X1

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

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

getIndex :: (Index ix) => ListX ix a -> ix
getIndex (xv :: ListX ix a) = getVal::ix

class (Index ix, Monad 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) => ix -> ListX ix a -> a
headX ixv lv = head $ unListX ixv lv

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

--  mkListX :: ix -> [a] -> ListX ix a
--  mkListX ixv xs = ListX 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 (ixv::ix) ((ListX a)::(ListX ix a)) ((ListX b)::(ListX ix a)) = mkListX ixv $ 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

foldrX :: (Index ix) => ix -> (a->b->b) -> b -> ListX ix a -> b
foldrX ixv f z listx = let the_list = unListX ixv listx
                       in foldr f z the_list


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) => Functor (ListX ix) where
   fmap f ((ListX xs)::(ListX ix a)) = mkListX (getVal::ix) $ map f xs



instance (Show a, Show ix, Index ix) => Show (ListX ix a) where
    show val = "(ListX<"++show (getVal::ix)++">"++show (unListX (getVal::ix) val)++")"


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, 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