module LayoutDoNow where
import Fudget
import FRequest
import Spops
import Path(here)
import LayoutRequest
import IsRequest
layoutDoNow :: F hi ho -> F hi ho
layoutDoNow (F FSP hi ho
sp) = FSP hi ho -> F hi ho
forall hi ho. FSP hi ho -> F hi ho
F (FSP hi ho -> FSP hi ho
forall a b b.
SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
layoutDoNow' FSP hi ho
sp)
layoutDoNow' :: SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
layoutDoNow' SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
f = Int
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
forall b a b.
Int
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
donow Int
0 (SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
forall a1 a2. SP a1 a2 -> ([a2], SP a1 a2)
pullSP SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
f) where
donow :: Int
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
donow Int
pendingreqs ([Message (Path, FRequest) b]
os,SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
f) =
[Message (Path, FRequest) b]
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
forall b a. [b] -> SP a b -> SP a b
putsSP [Message (Path, FRequest) b]
os (SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
forall a b. (a -> b) -> a -> b
$
let n' :: Int
n' = Int
pendingreqs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newreqs
newreqs :: Int
newreqs = [Message (Path, FRequest) b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Message (Path, FRequest) b -> Bool)
-> [Message (Path, FRequest) b] -> [Message (Path, FRequest) b]
forall a. (a -> Bool) -> [a] -> [a]
filter Message (Path, FRequest) b -> Bool
forall a b. Message (a, FRequest) b -> Bool
isReq [Message (Path, FRequest) b]
os)
isReq :: Message (a, FRequest) b -> Bool
isReq (Low (a
_,FRequest
c)) = FRequest -> Bool
isRequest FRequest
c
isReq Message (a, FRequest) b
_ = Bool
False
nResp :: Message (a, FResponse) b -> p
nResp (Low (a
_,FResponse
e)) | FResponse -> Bool
isResponse FResponse
e = p
1
nResp Message (a, FResponse) b
_ = p
0
in if Int
n' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Message (Path, FRequest) b
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
forall b a. b -> SP a b -> SP a b
putSP ((Path, FRequest) -> Message (Path, FRequest) b
forall a b. a -> Message a b
Low (Path
here,LayoutMessage -> FRequest
LCmd LayoutMessage
LayoutDoNow)) SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
f
else
Cont
(SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
(Message (a, FResponse) b)
forall a b. Cont (SP a b) a
getSP Cont
(SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
(Message (a, FResponse) b)
-> Cont
(SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
(Message (a, FResponse) b)
forall a b. (a -> b) -> a -> b
$ \Message (a, FResponse) b
msg -> Int
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
-> SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
donow (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Message (a, FResponse) b -> Int
forall p a b. Num p => Message (a, FResponse) b -> p
nResp Message (a, FResponse) b
msg) (SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
-> Message (a, FResponse) b
-> ([Message (Path, FRequest) b],
SP (Message (a, FResponse) b) (Message (Path, FRequest) b))
forall a1 a2. SP a1 a2 -> a1 -> ([a2], SP a1 a2)
walkSP SP (Message (a, FResponse) b) (Message (Path, FRequest) b)
f Message (a, FResponse) b
msg)