
  0 | module ContAction
  1 | 
  2 | import Cont
  3 | import UTF8
  4 | import Data.Buffer.Indexed -- bufferL
  5 | 
  6 | public export
  7 | data Act = ActSend (List Bits8) | ActReceive
  8 | 
  9 | export
 10 | Show Act where
 11 |   show (ActSend _) = "ActSend <data not shown>"
 12 |   show ActReceive = "ActReceive"
 13 | 
 14 | public export
 15 | data Response = RSent | RReceived (List Bits8)
 16 | 
 17 | export
 18 | Show Response where
 19 |   show RSent = "RSent"
 20 |   show (RReceived dat) = "RReceived " <+> show (utf8Decode (bufferL dat))
 21 | 
 22 | export
 23 | collectSends : DIterator Response Act i2 o2 r -> (List Bits8, DIterator Response Act i2 o2 r)
 24 | collectSends r@(Result _) = ([], r)
 25 | collectSends r@(Susp2 _ _) = ([], r)
 26 | collectSends r@(Susp ActReceive _) = ([], r)
 27 | collectSends r@(Susp (ActSend firstSend) k) =
 28 |   let
 29 |     (laterSends, newIter) = collectSends (k RSent)
 30 |   in
 31 |     (firstSend <+> laterSends, newIter)
 32 | 
 33 | export
 34 | sendMuchM : Monad m => (List Bits8 -> m Unit) -> DIterator Response Act i2 o2 r -> m (DIterator Response Act i2 o2 r)
 35 | sendMuchM sender it = do
 36 |   let (sends, newIter) = collectSends it
 37 |   case sends of
 38 |     [] => pure ()
 39 |     nonEmpty => sender nonEmpty
 40 |   pure newIter
 41 | 
 42 | yieldUntilRecv: List Response -> Cont (DIterator Response Act altOut altIn a) (Pair (List Bits8) (List Response))
 43 | yieldUntilRecv (RReceived bytes :: xs) = pure $ MkPair bytes xs
 44 | yieldUntilRecv (RSent :: xs) =
 45 |   yieldUntilRecv xs
 46 | yieldUntilRecv [] = do
 47 |   resp <- yieldGet ActReceive
 48 |   yieldUntilRecv [resp]
 49 | 
 50 | export
 51 | mkSendRecvIterator : DIterator (List Bits8) (List Bits8) altOut altIn a
 52 |                   -> DIterator Response Act altOut altIn a
 53 | mkSendRecvIterator initialState =
 54 |   toIterator (loop initialState [])
 55 |   where
 56 |     loop: DIterator (List Bits8) (List Bits8) altOut altIn a -> List Response -> Cont (DIterator Response Act altOut altIn a) a
 57 |     loop (Result a) resps = pure a
 58 |     loop (Susp2 sql cont) resps = do
 59 |       dataRows <- yieldGet2 sql
 60 |       loop (cont dataRows) resps
 61 |     loop (Susp toSend cont) resps =
 62 |       case toSend of
 63 |         [] => do
 64 |           MkPair bytes xs <- yieldUntilRecv resps
 65 |           loop (cont $ toList bytes) xs
 66 |         nonEmpty => do
 67 |           newResp <- yieldGet (ActSend nonEmpty)
 68 |           loop (cont []) (newResp :: resps)
 69 |