{-# LANGUAGE OverloadedStrings #-}
module Foundation.Conduit.Textual
    ( lines
    , words
    , fromBytes
    , toBytes
    ) where

import           Basement.Imports hiding (throw)
import           Basement.UArray (UArray)
import           Foundation.String (String)
import           Foundation.Collection
import qualified Basement.String as S
import           Foundation.Conduit.Internal
import           Foundation.Monad
import           Data.Char (isSpace)

-- | Split conduit of string to its lines
--
-- This is very similar to Prelude lines except
-- it work directly on Conduit
--
-- Note that if the newline character is not ever appearing in the stream,
-- this function will keep accumulating data until OOM
--
-- TODO: make a size-limited function
lines :: Monad m => Conduit String String m ()
lines = await >>= maybe (finish []) (go False [])
  where
    mconcatRev = mconcat . reverse

    finish l = if null l then return () else yield (mconcatRev l)

    go prevCR prevs nextBuf = do
        case S.breakLine nextBuf of
            Right (line, next)
                | S.null line && prevCR -> yield (mconcatRev (line : stripCRFromHead prevs)) >> go False mempty next
                | otherwise             -> yield (mconcatRev (line : prevs)) >> go False mempty next
            Left lastCR ->
                let nextCurrent = nextBuf : prevs
                 in await >>= maybe (finish nextCurrent) (go lastCR nextCurrent)
    stripCRFromHead []     = []
    stripCRFromHead (x:xs) = S.revDrop 1 x:xs

words :: Monad m => Conduit String String m ()
words = await >>= maybe (finish []) (go [])
  where
    mconcatRev = mconcat . reverse

    finish l = if null l then return () else yield (mconcatRev l)

    go prevs nextBuf =
        case S.dropWhile isSpace next' of
            rest' 
                | null rest' ->
                    let nextCurrent = nextBuf : prevs
                     in await >>= maybe (finish nextCurrent) (go nextCurrent)
                | otherwise  -> yield (mconcatRev (line : prevs)) >> go mempty rest'
      where (line, next') = S.break isSpace nextBuf

fromBytes :: MonadThrow m => S.Encoding -> Conduit (UArray Word8) String m ()
fromBytes encoding = loop mempty
  where
    loop r = await >>= maybe (finish r) (go r)
    finish buf | null buf  = return ()
               | otherwise = case S.fromBytes encoding buf of
                                    (s, Nothing, _)  -> yield s
                                    (_, Just err, _) -> throw err
    go current nextBuf =
        case S.fromBytes encoding (current `mappend` nextBuf) of
            (s, Nothing           , r) -> yield s >> loop r
            (s, Just S.MissingByte, r) -> yield s >> loop r
            (_, Just err          , _) -> throw err

toBytes :: Monad m => S.Encoding -> Conduit String (UArray Word8) m ()
toBytes encoding = awaitForever $ \a -> pure (S.toBytes encoding a) >>= yield