module Main (main) where

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import System.IO

infixl 8 >>.

main :: IO ()
main = do runXIOState XIOState readDocument
          return ()

data XIOState us    = XIOState

newtype IOSLA s a b = IOSLA { runIOSLA :: s -> a -> IO (s, [b]) }

instance Arrow (IOSLA s) where
    arr f       = IOSLA $ \ s x -> return (s, [f x])

    first (IOSLA f) = IOSLA $ \ s (x1, x2) -> do
                               (s', ys1) <- f s x1
                               return (s', [ (y1, x2) | y1 <- ys1 ])

instance ArrowPlus (IOSLA s) where
    IOSLA f <+> IOSLA g = IOSLA $ \ s x -> do
                                           (s1, rs1) <- f s  x
                                           (s2, rs2) <- g s1 x
                                           return (s2, rs1 ++ rs2)
instance ArrowApply (IOSLA s) where
    app                 = IOSLA $ \ s (IOSLA f, x) -> f s x

instance ArrowZero (IOSLA s) where
    zeroArrow           = IOSLA $ \ s -> const (return (s, []))

instance Category (IOSLA s) where
    id                  = arr id

    IOSLA g . IOSLA f   = IOSLA $ \ s x -> do
                                           (s1, ys) <- f s x
                                           sequence' s1 ys
                                           where
                                           sequence' s' []       = return (s', [])
                                           sequence' s' (x':xs') = do
                                                                   (s1', ys') <- g s' x'
                                                                   (s2', zs') <- sequence' s1' xs'
                                                                   return (s2', ys' ++ zs')


instance ArrowList (IOSLA s) where
    constA c        = IOSLA $ \ s   -> const (return (s, [c]))
    IOSLA f >>. g   = IOSLA $ \ s x -> do
                           (s1, ys) <- f s x
                           return (s1, g ys)

instance ArrowIO (IOSLA s) where
    arrIO cmd       = IOSLA $ \ s x -> do
                       res <- cmd x
                       return (s, [res])

type IOStateArrow s b c = IOSLA (XIOState s) b c

runXIOState :: XIOState s -> IOStateArrow s () c -> IO [c]
runXIOState s0 f
    = do
      (_finalState, res) <- runIOSLA f s0 undefined
      return res

readDocument :: IOStateArrow s b ()
readDocument = trace "Foo 1" >>>
               returnA >>>
               trace "Foo 2" >>>
               error "XXX"

trace       :: String -> IOStateArrow s b b
trace msg
    = perform ( constA msg
                >>>
                arrIO (\ s -> do hPutStrLn stderr s
                                 hFlush stderr
                      )
              )

class (Arrow a, ArrowPlus a, ArrowZero a, ArrowApply a) => ArrowList a where
    constA      :: c -> a b c
    constA      = arr . const

    (>>.)       :: a b c -> ([c] -> [d]) -> a b d

    listA       :: a b c -> a b [c]
    listA af        = af >>.  (:[])

    this        :: a b b
    this        = returnA

    perform     :: a b c -> a b b
    perform f       = listA f &&& this >>> arr snd

class Arrow a => ArrowIO a where
    arrIO       :: (b -> IO c) -> a b c