module Traces where

data Trace i o a = Return a | Get (i -> Trace i o a) | Put o (Trace i o a)

instance Monad (Trace i o) where
    return = Return
    (Return a) >>= f = f a
    (Get g) >>= f = Get (\ i -> g i >>= f)
    (Put o p) >>= f = Put o (p >>= f)

class MArrow r where 
    mpure :: (i -> o) -> r i o a
    (>>>>) :: r i h a -> r h o a -> r i o a
    mleft :: r i o a -> r (Either i c) (Either o c) a
--    mfirst :: r i o a -> r (i,c) (o,c) a

instance MArrow Trace where
    mpure f = Get (\ i -> Put (f i) (mpure f))
    Return a >>>> q = Return a
    Get f >>>> q = Get (\ i -> f i >>>> q)
    Put h p >>>> Return a = Return a
    Put h p >>>> Get f = p >>>> f h
    Put h p >>>> Put o q = Put o (Put h p >>>> q)
    mleft (Return a) = Return a
    mleft (Get f) = Get (\ ic -> case ic of Left i -> mleft (f i)
		                            Right c -> Put (Right c) (mleft (Get f)))
    mleft (Put i p) = Put (Left i) (mleft p)

{-
-- alternative: demand driven
     p >>>> Return a = Return a
     p >>>> Put o q = Put o (p >>>> q)
     Return a >>>> Get f = Return a
     Put h p >>>> Get f = p >>>> f h
     Get f >>>> Get f' = Get (\ i -> f i >>>> Get f')
     Put h p >>>> Put o q = Put o (Put h p >>>> q)
-}

data Tip b a = Tip a | b :< Tip b a

newtype Run i o a = Run {unRun ::[i] -> Tip o a}

run :: Trace i o a -> Run i o a
run (Return a) = Run (\ is -> Tip a)
run (Get g) = Run (\ (i:is) -> unRun (run (g i)) is) 
run (Put o p) = Run (\ is -> o :< unRun (run p) is)