anaphora.hs

z   (x, _) = x
s n (_, h) = n h

-- NEW: indexed depositors
dz   x ((), r) = (x, r) -- novelty; () ~> _ = destructive updates
ds n x (y , r) = (y, n x r)

-- NEW: combinators for preallocating context
cinit = ()
cz    = cs cinit
cs n  = ((),n)

class IxFunctor f where
    imap :: (a -> b) -> f i o a -> f i o b

class IxFunctor m => IxApplicative m where
    {-# MINIMAL ireturn, ((</>) | (<\>)) #-}
    ireturn :: a -> m i i a
    (</>) :: m i j (a -> b) -> m j o a -> m i o b
    m </> n = m <\> imap (flip ($)) n
    (<\>) :: m i j a -> m j o (a -> b) -> m i o b
    m <\> n = imap (flip ($)) m </> n
infixr </>, <\>

class IxApplicative m => IxMonad m where
    {-# MINIMAL (>>>=) | ijoin #-}
    (>>>=) :: m i j a -> (a -> m j o b) -> m i o b
    m >>>= f = ijoin $ imap f m
    ijoin :: m i j (m j o a) -> m i o a
    ijoin m = m >>>= id
infixl 1 >>>=

class IxMonad m => IxMonadState m where
    iget :: m i i i
    iput :: o -> m i o ()

imodify :: IxMonadState m => (i -> o) -> m i o ()
imodify f = iget >>>= iput . f

igets :: IxMonadState m => (i -> a) -> m i i a
igets f = iget >>>= ireturn . f

-- NEW: indexed pushes
ipush :: IxMonadState m => (a -> i -> o) -> a -> m i o a
ipush n x = imodify (n x) >>>= \_ -> ireturn x

{- Nondeterministic indexed state illustration -}

newtype IxDy i o a = IxDy { unIxDy :: i -> [(a, o)] }

instance IxFunctor IxDy where
    imap f m = m >>>= \x -> ireturn $ f x

instance IxApplicative IxDy where
    ireturn x = IxDy $ \i -> [(x, i)]
    m </> n = m >>>= \f -> n >>>= \x -> ireturn $ f x

instance IxMonad IxDy where
    m >>>= f = IxDy $ \i -> concat [unIxDy (f x) o | (x, o) <- unIxDy m i]

instance IxMonadState IxDy where
    iget   = IxDy $ \i -> [(i , i)]
    iput o = IxDy $ \i -> [((), o)]

type E = String
type T = String

saw :: E -> E -> T
saw  x y = y ++ " saw "  ++ x

conj :: T -> T -> T
conj r l = l ++ " and " ++ r

p :: IxDy ((), ((), a)) (E, (E, a)) T
p = let aLing = IxDy (\i -> [("John", i), ("Bill", i)]) >>>= ipush dz in
    aLing <\> ireturn saw </> ipush (ds dz) "Mary"

q :: IxDy (E, (E, i)) (E, (E, i)) T
q = igets (s z) <\> ireturn saw </> igets z

p_and_q :: IxDy ((), ((), a)) (E, (E, a)) T
p_and_q = p <\> ireturn conj </> q

test1 :: [(T, (E, (E, ())))]
test1 = unIxDy p_and_q (cs cz)