Indexed.hs

module Indexed where

import Prelude hiding ((>>=), (>>))

class IxFunctor f where
  imap :: (a -> b) -> f j k a -> f j k b

class IxFunctor f => IxPointed f where
  ireturn :: a -> f i i a

class IxPointed m => IxApplicative m where
  iap :: m i j (a -> b) -> m j k a -> m i k b

class IxApplicative m => IxMonad m where
  ibind :: (a -> m j k b) -> m i j a -> m i k b

newtype IxState i j a = IxState { runIxState :: i -> (a, j) }

instance IxFunctor IxState where
  imap f x = IxState $ \i -> let (a, j) = runIxState x i
                             in (f a, j)

instance IxPointed IxState where
  ireturn x = IxState $ \i -> (x, i)

instance IxApplicative IxState where
  iap f x = IxState $ \i -> let (af, j) = runIxState f i
                                (ax, k) = runIxState x j
                            in (af ax, k)

instance IxMonad IxState where
  ibind f x = IxState $ \i -> let (ax, j) = runIxState x i
                              in runIxState (f ax) j

instance Show a => Show (IxState p r a) where
  show = show . fst . flip runIxState undefined

get :: IxState i i i
get = IxState $ \x -> (x, x)

put :: a -> IxState i a ()
put v = IxState $ \_ -> ((), v)

x >>= f = ibind f x
x >> y = x >>= \_ -> y

testLength2 =
  put "test" >>
  get >>= \x ->
  put $ length x

Indexed2.hs

{-# LANGUAGE TupleSections, MultiParamTypeClasses, FunctionalDependencies, 
    FlexibleInstances, NoMonomorphismRestriction, OverlappingInstances, 
    UndecidableInstances #-}
module Indexed2 where

import Control.Monad (liftM)

class MonadTrans t where
  lift :: Monad m => m a -> t m a

newtype Id x = Id { unId :: x }

instance Functor Id where
  fmap f (Id x) = Id $ f x

instance Monad Id where
  return = Id
  Id x >>= f = f x

newtype StateT s m a = StateT { runStateT :: s -> m (s, a) }

instance MonadTrans (StateT s) where
  lift x = StateT $ \s -> liftM (s,) x

instance Monad m => Monad (StateT s m) where
  return x = StateT $ \s -> return (s, x)
  x >>= f = StateT $ \s -> do (s', mx) <- runStateT x s
                              runStateT (f mx) s'

type State s = StateT s Id

class Monad m => MonadState s m | m -> s where
  get :: m s
  put :: s -> m ()

instance Monad m => MonadState s (StateT s m) where
  get = StateT $ \s -> return (s, s)
  put s = StateT $ \_ -> return (s, ())

runState :: State s a -> s -> (s, a)
runState s x = unId $ runStateT s x

class Index ix where
  ixValue :: ix

{-
newtype StateX ix s a = StateX { runStateX :: s -> (s, a) }

instance Index ix => Monad (StateX ix s) where
  return x = StateX $ \s -> (s, x)
  x >>= f = StateX $ \s -> let (s', sx) = runStateX x s
                           in runStateX (f sx) s'
-}

data CounterI = CounterI
instance Index CounterI where
  ixValue = CounterI

data ValueI = ValueI
instance Index ValueI where
  ixValue = ValueI

newtype StateTX ix s m a = StateTX { runStateTX :: s -> m (s, a) }

type StateX ix s = StateTX ix s Id
runStateX x s = unId $ runStateTX x s

instance MonadTrans (StateTX ix s) where
  lift v = StateTX $ \s -> liftM (s,) v

instance Monad m => Monad (StateTX ix s m) where
  return x = StateTX $ \s -> return (s, x)
  x >>= f = StateTX $ \s -> do (s', mx) <- runStateTX x s
                               runStateTX (f mx) s'

class (Monad m, Index ix) => MonadStateX ix s m | m ix -> s where
  getx :: ix -> m s
  putx :: ix -> s -> m ()

{-
instance Index ix => MonadStateX ix s (StateX ix s) where
  getx _ = StateX $ \s -> (s, s)
  putx _ s = StateX $ \_ -> (s, ())
-}

instance (Index ix, Monad m) => MonadStateX ix s (StateTX ix s m) where
  getx _ = StateTX $ \s -> return (s, s)
  putx _ s = StateTX $ \s -> return (s, ())

instance (Monad m, Index ix1, Index ix2, MonadStateX ix1 s1 m)
         => MonadStateX ix1 s1 (StateTX ix2 s2 m) where
  getx ix1 = StateTX $ \s2 -> do v1 <- getx ix1
                                 return (s2, v1)
  putx ix1 s1 = StateTX $ \s2 -> do putx ix1 s1
                                    return (s2, ())
  

test :: StateTX ValueI Double (StateX CounterI Integer) Double
test = do
  putx CounterI 1
  putx ValueI 3.4
  addValue 5.8
  addValue 9.0
  getAverage

test1 :: StateX CounterI Integer Integer
test1 = do
  putx CounterI 1
  getx CounterI

addValue x = do
  c <- getx CounterI
  v <- getx ValueI
  putx CounterI (c + 1)
  putx ValueI (v + x)

getAverage = do
  c <- getx CounterI
  v <- getx ValueI
  return $ v / fromInteger c