
{-# LANGUAGE RankNTypes #-}

module Mire.Pipes where

import Mire.Prelude
import Mire.Data.Flow
import Mire.Data.Style
import Mire.Telnet
import Mire.Data.Text (utf8)

import Pipes as P
import Pipes.Safe (catchAll)
import System.IO hiding (print, utf8)

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BB

import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import System.Timeout

import Data.ByteString.Internal (w2c)

unpackP :: Monad m => Pipe ByteString Word8 m r
unpackP = forever $ B.unpack <$> await >>= mapM_ yield

fromHandleNet :: (MonadIO m, MonadCatch m) => Handle -> Producer Word8 m ()
fromHandleNet h = fromHandleBS h >-> unpackP

fromHandleBS :: (MonadIO m, MonadCatch m) => Handle -> Producer' ByteString m ()
fromHandleBS h = catchAll go (\_ -> liftIO (hClose h)) >> liftIO (hClose h) where
   go = do
      ready <- liftIO (hWaitForInput h 50)
      when ready (liftIO (B.hGetSome h 1024) >>= yield)
      go

mirePipe :: Monad m => Producer Word8 m () -> Consumer Net m () -> Effect m ()
mirePipe p c = p >-> telnet >-> telnetUtf8 >-> ansiPipe >-> dummyTelnetToNet >-> c

data Ansi = AnsiText { ansiText :: Char, ansiStyle :: [StyleStream] }
          | AnsiMeta Meta
          deriving (Show, Eq)

ansiPipe :: Monad m => Pipe (Either Meta Char) Ansi m ()
ansiPipe = run [] where
   run s = do
      a <- await
      case a of
         Left m -> yield (AnsiMeta m) >> run s
         Right t ->
            case t of
               '\ESC' -> do
                  _ <- await -- Wait for [
                  s' <- gatherAnsi s
                  run s'
               c -> yield (AnsiText c s) >> run s
   gatherAnsi :: Monad m => [StyleStream] -> Pipe (Either Meta Char) Ansi m [StyleStream]
   gatherAnsi s = do
      a <- await
      case a of
         Left m -> yield (AnsiMeta m) >> gatherAnsi s
         Right t ->
            if isEndChar t
               then return s
               else gatherAnsi s
   isEndChar :: Char -> Bool
   isEndChar = flip elem ansiEndChars
   ansiEndChars :: [Char]
   ansiEndChars = w2c <$> [64..126]
   ansiEndCharMods :: [Char]
   ansiEndCharMods = w2c <$> [32..47]
   ansiContents :: [Char]
   ansiContents = w2c <$> [48..63]

telnetUtf8 :: Monad m => Pipe Telnet (Either Meta Char) m ()
telnetUtf8 = await' >~ P.for utf8 yield' where
   yield' = yield . Right
   await' = await >>= \case
      TelnetText a -> return a
      TelnetMeta m -> yield (Left m) >> await'

dummyTelnetToNet :: Monad m => Pipe Ansi Net m ()
dummyTelnetToNet = forever $ do
   await >>= \case
      AnsiText a s -> yield (NetText a s)
      AnsiMeta m -> yield (NetMeta m)

--applyTextFlow :: Monad m => Pipe a b m r -> (b -> Flow c) -> Pipe (Flow a) (Flow c) m r
--applyTextFlow p f = await' >~ for p yield' where
--   yield' b = yield (f b)
--   await' = await >>= \case
--      FlowText a -> return a
--      FlowMeta a -> yield (FlowMeta a) >> await'
--      FlowStyle a -> yield (FlowStyle a) >> await'
--      FlowFormat a -> yield (FlowFormat a) >> await'
--      FlowLink a -> yield (FlowLink a) >> await'

runNetPipe :: Handle -> TChan Net -> IO ()
runNetPipe h outchan =
   let consumer = forever (await >>= lift . atomically . writeTChan outchan)
       producer = fromHandleNet h
       pipe = mirePipe producer consumer
   in void (runEffect pipe)
