module FudgetIO where
import Fudget
import EitherUtils(Cont(..))
import Message(stripLow,stripHigh)

{-
The purpose of the FudgetIO class is to allow the many IO operations that
can be performed from both fudgets and fudget kernels, e.g., createGC,
loadQueryFont and allocNamedColor, to use one overloaded name instead of
two separate names.
-}

class FudgetIO f where
  waitForMsg :: (KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
  putMsg :: KCommand ho -> f hi ho -> f hi ho

  -- Less useful methods:
  --nullMsg :: f hi ho -- name ?!
  --getMsg :: (KEvent hi -> f hi ho) -> f hi ho

putMsgs :: t (KCommand ho) -> f hi ho -> f hi ho
putMsgs t (KCommand ho)
msgs f hi ho
k = (KCommand ho -> f hi ho -> f hi ho)
-> f hi ho -> t (KCommand ho) -> f hi ho
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KCommand ho -> f hi ho -> f hi ho
forall (f :: * -> * -> *) ho hi.
FudgetIO f =>
KCommand ho -> f hi ho -> f hi ho
putMsg f hi ho
k t (KCommand ho)
msgs
putHigh :: ho -> f hi ho -> f hi ho
putHigh ho
x = (KCommand ho -> f hi ho -> f hi ho
forall (f :: * -> * -> *) ho hi.
FudgetIO f =>
KCommand ho -> f hi ho -> f hi ho
putMsg (KCommand ho -> f hi ho -> f hi ho)
-> (ho -> KCommand ho) -> ho -> f hi ho -> f hi ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ho -> KCommand ho
forall a b. b -> Message a b
High) ho
x
putLow :: FRequest -> f hi ho -> f hi ho
putLow FRequest
x = (KCommand ho -> f hi ho -> f hi ho
forall (f :: * -> * -> *) ho hi.
FudgetIO f =>
KCommand ho -> f hi ho -> f hi ho
putMsg (KCommand ho -> f hi ho -> f hi ho)
-> (FRequest -> KCommand ho) -> FRequest -> f hi ho -> f hi ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FRequest -> KCommand ho
forall a b. a -> Message a b
Low) FRequest
x
putLows :: t FRequest -> f hi ho -> f hi ho
putLows t FRequest
lows f hi ho
k = (FRequest -> f hi ho -> f hi ho)
-> f hi ho -> t FRequest -> f hi ho
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FRequest -> f hi ho -> f hi ho
forall (f :: * -> * -> *) hi ho.
FudgetIO f =>
FRequest -> f hi ho -> f hi ho
putLow f hi ho
k t FRequest
lows

getHigh :: (ans -> f ans ho) -> f ans ho
getHigh ans -> f ans ho
x = (KEvent ans -> Maybe ans) -> (ans -> f ans ho) -> f ans ho
forall (f :: * -> * -> *) hi ans ho.
FudgetIO f =>
(KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
waitForMsg KEvent ans -> Maybe ans
forall a1 a2. Message a1 a2 -> Maybe a2
stripHigh ans -> f ans ho
x
getLow :: (FResponse -> f b ho) -> f b ho
getLow FResponse -> f b ho
x = (KEvent b -> Maybe FResponse) -> (FResponse -> f b ho) -> f b ho
forall (f :: * -> * -> *) hi ans ho.
FudgetIO f =>
(KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
waitForMsg KEvent b -> Maybe FResponse
forall a b. Message a b -> Maybe a
stripLow FResponse -> f b ho
x

cmdContMsg :: KCommand ho
-> (KEvent hi -> Maybe ans) -> (ans -> f hi ho) -> f hi ho
cmdContMsg KCommand ho
msg KEvent hi -> Maybe ans
expected = KCommand ho -> f hi ho -> f hi ho
forall (f :: * -> * -> *) ho hi.
FudgetIO f =>
KCommand ho -> f hi ho -> f hi ho
putMsg KCommand ho
msg (f hi ho -> f hi ho)
-> ((ans -> f hi ho) -> f hi ho) -> (ans -> f hi ho) -> f hi ho
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KEvent hi -> Maybe ans) -> (ans -> f hi ho) -> f hi ho
forall (f :: * -> * -> *) hi ans ho.
FudgetIO f =>
(KEvent hi -> Maybe ans) -> Cont (f hi ho) ans
waitForMsg KEvent hi -> Maybe ans
expected

cmdContLow :: FRequest -> (FResponse -> Maybe ans) -> (ans -> f b ho) -> f b ho
cmdContLow FRequest
cmd FResponse -> Maybe ans
expected = KCommand ho -> (KEvent b -> Maybe ans) -> (ans -> f b ho) -> f b ho
forall (f :: * -> * -> *) ho hi ans.
FudgetIO f =>
KCommand ho
-> (KEvent hi -> Maybe ans) -> (ans -> f hi ho) -> f hi ho
cmdContMsg (FRequest -> KCommand ho
forall a b. a -> Message a b
Low FRequest
cmd) KEvent b -> Maybe ans
forall b. Message FResponse b -> Maybe ans
expectLow
  where expectLow :: Message FResponse b -> Maybe ans
expectLow Message FResponse b
msg = Message FResponse b -> Maybe FResponse
forall a b. Message a b -> Maybe a
stripLow Message FResponse b
msg Maybe FResponse -> (FResponse -> Maybe ans) -> Maybe ans
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FResponse -> Maybe ans
expected