{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module AdaptServer where

import Data.IORef
import Debug.Trace
import Data.HList
-- import Network.Socket (Socket)
import qualified Data.ByteString.Lazy.Char8 as L
import ByteStringOperators

adaptStartCon start sock st = do
    rsRef <- newIORef ""
    st' <- start sock st
    return (HCons rsRef st')

adaptDoCon showlex (dropTill,lex,parse) g st bs cont = do
    putStrLn $ "packet: " ++ show bs
    let (HCons rsRef st') = st
    rs <- readIORef rsRef

    let contR rem v = do
            writeIORef rsRef rem
            cont v
    let loop rem lexemes@(_:_) = do
          let (e,rs') = parse lexemes
          case e of
              Left err -> if null rs'
                            then contR "" ()
                            else -- trace ("parse error "++show (err,bs,showlex lexemes,showlex rs')) $ do
                                    contR rem ()
              Right e -> do
                -- writeIORef rsRef rs'
                g st' e (\() -> do { {- putStrLn ("LOOP "++showlex rs'); -} loop (dropTill rem rs') rs' })
        loop rem [] = contR "" ()
    let buf = rs <++> bs
    when (L.length buf < 8192)
         (loop buf (lex buf))


adaptServer showlex (dropTill,lex,parse) (startCon,doCon) = (adaptStartCon startCon, adaptDoCon showlex (dropTill,lex,parse) doCon)