@@ -15,6 +15,9 @@ module Streamly.Internal.Unicode.Stream
1515 decodeLatin1
1616
1717 -- ** UTF-8 Decoding
18+ , CodingFailureMode(..)
19+ , writeCharUtf8'
20+ , parseCharUtf8With
1821 , decodeUtf8
1922 , decodeUtf8'
2023 , decodeUtf8_
@@ -78,6 +81,7 @@ where
7881
7982#include "inline.hs"
8083
84+import Control.Monad.Catch (MonadThrow, MonadCatch)
8185import Control.Monad.IO.Class (MonadIO, liftIO)
8286import Data.Bits (shiftR, shiftL, (.|.), (.&.))
8387import Data.Char (chr, ord)
@@ -101,6 +105,9 @@ import Streamly.Internal.Data.Unfold.Type (Unfold(..))
101105import Streamly.Internal.System.IO (unsafeInlineIO)
102106
103107import qualified Streamly.Internal.Data.Unfold as Unfold
108+import qualified Streamly.Internal.Data.Parser as Parser
109+import qualified Streamly.Internal.Data.Parser.ParserD as ParserD
110+import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK
104111import qualified Streamly.Internal.Data.Stream.Serial as Serial
105112import qualified Streamly.Internal.Data.Array.Foreign as Array
106113import qualified Streamly.Internal.Data.Array.Foreign.Type as A
@@ -423,6 +430,96 @@ data CodingFailureMode
423430replacementChar :: Char
424431replacementChar = '\xFFFD'
425432
433+data UTF8CharDecodeState a
434+ = UTF8CharDecodeInit
435+ | UTF8CharDecoding !DecodeState !CodePoint
436+
437+{-# INLINE parseCharUtf8WithD #-}
438+parseCharUtf8WithD ::
439+ Monad m => CodingFailureMode -> ParserD.Parser m Word8 Char
440+parseCharUtf8WithD cfm =
441+ let A.Array _ ptr _ = utf8d
442+ in ParserD.Parser (step' ptr) initial extract
443+
444+ where
445+
446+ prefix = "Streamly.Internal.Data.Stream.parseCharUtf8WithD:"
447+
448+ {-# INLINE initial #-}
449+ initial = return $ ParserD.IPartial UTF8CharDecodeInit
450+
451+ handleError err souldBackTrack =
452+ case cfm of
453+ ErrorOnCodingFailure -> ParserD.Error err
454+ TransliterateCodingFailure ->
455+ case souldBackTrack of
456+ True -> ParserD.Done 1 replacementChar
457+ False -> ParserD.Done 0 replacementChar
458+ DropOnCodingFailure ->
459+ case souldBackTrack of
460+ True -> ParserD.Continue 1 UTF8CharDecodeInit
461+ False -> ParserD.Continue 0 UTF8CharDecodeInit
462+
463+ {-# INLINE step' #-}
464+ step' table UTF8CharDecodeInit x =
465+ -- Note: It is important to use a ">" instead of a "<=" test
466+ -- here for GHC to generate code layout for default branch
467+ -- prediction for the common case. This is fragile and might
468+ -- change with the compiler versions, we need a more reliable
469+ -- "likely" primitive to control branch predication.
470+ return $ case x > 0x7f of
471+ False -> ParserD.Done 0 $ unsafeChr $ fromIntegral x
472+ True ->
473+ let (Tuple' sv cp) = decode0 table x
474+ in case sv of
475+ 12 ->
476+ let msg = prefix
477+ ++ "Invalid first UTF8 byte" ++ show x
478+ in handleError msg False
479+ 0 -> ParserD.Error $ prefix ++ "unreachable state"
480+ _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp)
481+
482+ step' table (UTF8CharDecoding statePtr codepointPtr) x = return $
483+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
484+ in case sv of
485+ 0 -> ParserD.Done 0 $ unsafeChr cp
486+ 12 ->
487+ let msg = prefix
488+ ++ "Invalid subsequent UTF8 byte"
489+ ++ show x
490+ ++ "in state"
491+ ++ show statePtr
492+ ++ "accumulated value"
493+ ++ show codepointPtr
494+ in handleError msg True
495+ _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp)
496+
497+ {-# INLINE extract #-}
498+ extract _ = error $ prefix ++ "Not enough input"
499+
500+-- XXX This should ideally accept a "CodingFailureMode" and perform appropriate
501+-- error handling. This isn't possible now as "TransliterateCodingFailure"'s
502+-- workflow requires backtracking 1 element. This can be revisited once "Fold"
503+-- supports backtracking.
504+{-# INLINE writeCharUtf8' #-}
505+writeCharUtf8' :: MonadThrow m => Fold m Word8 Char
506+writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure)
507+
508+-- XXX The initial idea was to have "parseCharUtf8" and offload the error
509+-- handling to another parser. So, say we had "parseCharUtf8'",
510+--
511+-- >>> parseCharUtf8Smart = parseCharUtf8' <|> Parser.fromPure replacementChar
512+--
513+-- But unfortunately parseCharUtf8Smart used in conjunction with "parseMany" -
514+-- that is "parseMany parseCharUtf8Smart" on a stream causes the heap to
515+-- overflow. Even a heap size of 500 MB was not sufficient.
516+--
517+-- This needs to be investigated futher.
518+{-# INLINE parseCharUtf8With #-}
519+parseCharUtf8With ::
520+ MonadCatch m => CodingFailureMode -> Parser.Parser m Word8 Char
521+parseCharUtf8With = ParserK.toParserK . parseCharUtf8WithD
522+
426523-- XXX write it as a parser and use parseMany to decode a stream, need to check
427524-- if that preserves the same performance. Or we can use a resumable parser
428525-- that parses a chunk at a time.