module SpIO(spIO) where
--import Command
--import Event
import Loopthrough
import Path(Path(..))
import Cont(getRightSP)
import ShowFailure
--import Sockets
import Spops
import SP(SP)
import Tables2
--import Xtypes
import DialogueSpIO
import DialogueIO hiding (IOError)
--import Table(Table) -- nhc bug workaround

spIO :: (SP (Path, Response) (Path, Request)) -> IO ()
spIO :: SP (Path, Response) (Path, Request) -> IO ()
spIO SP (Path, Response) (Path, Request)
mainSP = SP Response Request -> IO ()
dialogueSpIO (forall {a1} {b1} {a2} {b2}.
SP (Either a1 b1) (Either a2 b2) -> SP a2 a1 -> SP b1 b2
loopThroughRightSP SP
  (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequestsSP SP (Path, Response) (Path, Request)
mainSP)

tagRequestsSP :: SP
  (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequestsSP = DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable0
tagRequests :: DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable =
  forall a b. Cont (SP a b) a
getSP forall a b. (a -> b) -> a -> b
$ \Either (Path, Request) Response
msg ->
  case Either (Path, Request) Response
msg of
    Left (Path
path', Request
cmd) ->
      case Request
cmd of
	Select [Descriptor]
ds -> let dtable' :: DTable
dtable' = Path -> [Descriptor] -> DTable -> DTable
updateDe Path
path' [Descriptor]
ds DTable
dtable
		     in forall {a} {t} {a1} {a}.
a
-> (t -> SP (Either a1 t) (Either a a))
-> SP (Either a1 t) (Either a a)
doReqSP ([Descriptor] -> Request
Select (DTable -> [Descriptor]
listDe DTable
dtable')) forall a b. (a -> b) -> a -> b
$ \ Response
resp ->
			forall {p}. Response -> p -> p
checkErr Response
resp (DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable')
	XCommand (XDisplay, XWId, XCommand)
_ -> forall {a} {a} {a}. a -> SP a (Either a a) -> SP a (Either a a)
putReqSP Request
cmd forall a b. (a -> b) -> a -> b
$  -- \ resp ->
		      -- The response to an XCommand is always Success
		      -- and is not propagated to the originating fudget.
		      DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable
	Request
_ -> forall {a} {t} {a1} {a}.
a
-> (t -> SP (Either a1 t) (Either a a))
-> SP (Either a1 t) (Either a a)
doReqSP Request
cmd forall a b. (a -> b) -> a -> b
$ \ Response
resp ->
	     forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (Path
path', Response
resp)) forall a b. (a -> b) -> a -> b
$
	     DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable
    Right ai :: Response
ai@(AsyncInput (Descriptor
d, AEvent
i)) ->
      forall b a. b -> SP a b -> SP a b
putSP (forall a b. a -> Either a b
Left (DTable -> Descriptor -> Path
lookupDe DTable
dtable Descriptor
d, Response
ai)) forall a b. (a -> b) -> a -> b
$
      DTable
-> SP
     (Either (Path, Request) Response) (Either (Path, Response) Request)
tagRequests DTable
dtable
    Either (Path, Request) Response
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"tagRequests: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Either (Path, Request) Response
msg forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

checkErr :: Response -> p -> p
checkErr Response
resp p
cont =
    case Response
resp of
      Response
Success -> p
cont
      Failure IOError
ioerr -> forall a. HasCallStack => [Char] -> a
error ([Char]
"IOerror: " forall a. [a] -> [a] -> [a]
++ IOError -> [Char]
showFailure IOError
ioerr)

doReqSP :: a
-> (t -> SP (Either a1 t) (Either a a))
-> SP (Either a1 t) (Either a a)
doReqSP a
req = forall {a} {a} {a}. a -> SP a (Either a a) -> SP a (Either a a)
putReqSP a
req forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t} {a1} {b}.
(t -> SP (Either a1 t) b) -> SP (Either a1 t) b
getRespSP
  where
    getRespSP :: (t -> SP (Either a1 t) b) -> SP (Either a1 t) b
getRespSP = forall {t} {a1} {b}.
(t -> SP (Either a1 t) b) -> SP (Either a1 t) b
getRightSP

putReqSP :: a -> SP a (Either a a) -> SP a (Either a a)
putReqSP = forall b a. b -> SP a b -> SP a b
putSP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right