composewell / streamly / 2956

-- |

-- Module      : Streamly.Data.Internal.Unicode.Stream

-- Copyright   : (c) 2018 Composewell Technologies

--               (c) Bjoern Hoehrmann 2008-2009

--

-- License     : BSD3

-- Maintainer  : streamly@composewell.com

-- Stability   : experimental

-- Portability : GHC

--

#include "inline.hs"

module Streamly.Internal.Data.Unicode.Stream

    (

    -- * Construction (Decoding)

      decodeLatin1

    , decodeUtf8

    , decodeUtf8Lax

    , DecodeError(..)

    , DecodeState

    , CodePoint

    , decodeUtf8Either

    , resumeDecodeUtf8Either

    , decodeUtf8Arrays

    , decodeUtf8ArraysLenient

    -- * Elimination (Encoding)

    , encodeLatin1

    , encodeLatin1Lax

    , encodeUtf8

    {-

    -- * Operations on character strings

    , strip -- (dropAround isSpace)

    , stripEnd

    -}

    -- * StreamD UTF8 Encoding / Decoding transformations.

    , decodeUtf8D

    , encodeUtf8D

    , decodeUtf8LenientD

    , decodeUtf8EitherD

    , resumeDecodeUtf8EitherD

    , decodeUtf8ArraysD

    , decodeUtf8ArraysLenientD

    -- * Transformation

    , stripStart

    , lines

    , words

    , unlines

    , unwords

    )

where

import Control.Monad.IO.Class (MonadIO, liftIO)

import Data.Bits (shiftR, shiftL, (.|.), (.&.))

import Data.Char (ord)

import Data.Word (Word8)

import Foreign.ForeignPtr (touchForeignPtr)

import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

import Foreign.Storable (Storable(..))

import GHC.Base (assert, unsafeChr)

import GHC.ForeignPtr (ForeignPtr (..))

import GHC.IO.Encoding.Failure (isSurrogate)

import GHC.Ptr (Ptr (..), plusPtr)

import Prelude hiding (String, lines, words, unlines, unwords)

import System.IO.Unsafe (unsafePerformIO)

import Streamly (IsStream)

import Streamly.Data.Fold (Fold)

import Streamly.Memory.Array (Array)

import Streamly.Internal.Data.Unfold (Unfold)

import Streamly.Internal.Data.SVar (adaptState)

import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))

import Streamly.Internal.Data.Strict (Tuple'(..))

#if __GLASGOW_HASKELL__ < 800

import Streamly.Internal.Data.Stream.StreamD (pattern Stream)

#endif

import qualified Streamly.Internal.Memory.Array.Types as A

import qualified Streamly.Internal.Prelude as S

import qualified Streamly.Internal.Data.Stream.StreamD as D

-------------------------------------------------------------------------------

-- Encoding/Decoding Unicode (UTF-8) Characters

-------------------------------------------------------------------------------

-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.

data WList = WCons !Word8 !WList | WNil

{-# INLINE ord2 #-}

ord2 :: Char -> WList

  where

{-# INLINE ord3 #-}

ord3 :: Char -> WList

  where

{-# INLINE ord4 #-}

ord4 :: Char -> WList

  where

data CodingFailureMode

    = TransliterateCodingFailure

    | ErrorOnCodingFailure

{-# INLINE replacementChar #-}

replacementChar :: Char

-- Int helps in cheaper conversion from Int to Char

type CodePoint = Int

type DecodeState = Word8

-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.

-- XXX Use names decodeSuccess = 0, decodeFailure = 12

decodeTable :: [Word8]

   -- The first part of the table maps bytes to character classes that

   -- to reduce the size of the transition table and create bitmasks.

   -- The second part is a transition table that maps a combination

   -- of a state of the automaton and a character class to a state.

  ]

{-# NOINLINE utf8d #-}

utf8d :: A.Array Word8

    -- Aligning to cacheline makes a barely noticeable difference

    -- XXX currently alignment is not implemented for unmanaged allocation

-- | Return element at the specified index without checking the bounds.

-- and without touching the foreign ptr.

{-# INLINE_NORMAL unsafePeekElemOff #-}

unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a

-- decode is split into two separate cases to avoid branching instructions.

-- From the higher level flow we already know which case we are in so we can

-- call the appropriate decode function.

--

-- When the state is 0

{-# INLINE decode0 #-}

decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint

    where

-- When the state is not 0

{-# INLINE decode1 #-}

decode1

    :: Ptr Word8

    -> DecodeState

    -> CodePoint

    -> Word8

    -> Tuple' DecodeState CodePoint

    -- Remember codep is Int type!

    -- Can it be unsafe to convert the resulting Int to Char?

    where

-- We can divide the errors in three general categories:

-- * A non-starter was encountered in a begin state

-- * A starter was encountered without completing a codepoint

-- * The last codepoint was not complete (input underflow)

--

data FreshPoint s a

    = FreshPointDecodeInit s

    | FreshPointDecodeInit1 s Word8

    | FreshPointDecodeFirst s Word8

    | FreshPointDecoding s !DecodeState !CodePoint

    | YieldAndContinue a (FreshPoint s a)

    | Done

-- XXX Add proper error messages

-- XXX Implement this in terms of decodeUtf8Either

{-# INLINE_NORMAL decodeUtf8WithD #-}

decodeUtf8WithD :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char

  where

    {-# INLINE transliterateOrError #-}

    {-# INLINE inputUnderflow #-}

            ErrorOnCodingFailure ->

    {-# INLINE_LATE step' #-}

        -- Note: It is important to use a ">" instead of a "<=" test

        -- here for GHC to generate code layout for default branch

        -- prediction for the common case. This is fragile and might

        -- change with the compiler versions, we need a more reliable

        -- "likely" primitive to control branch predication.

            False ->

            -- Using a separate state here generates a jump to a

            -- separate code block in the core which seems to perform

            -- slightly better for the non-ascii case.

    -- XXX should we merge it with FreshPointDecodeInit1?

                12 ->

    -- We recover by trying the new byte x a starter of a new codepoint.

    -- XXX need to use the same recovery in array decoding routine as well

                        12 ->

{-# INLINE decodeUtf8D #-}

decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char

{-# INLINE decodeUtf8LenientD #-}

decodeUtf8LenientD :: Monad m => Stream m Word8 -> Stream m Char

{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}

resumeDecodeUtf8EitherD

    :: Monad m

    => DecodeState

    -> CodePoint

    -> Stream m Word8

    -> Stream m (Either DecodeError Char)

  where

    {-# INLINE_LATE step' #-}

        -- Note: It is important to use a ">" instead of a "<=" test

        -- here for GHC to generate code layout for default branch

        -- prediction for the common case. This is fragile and might

        -- change with the compiler versions, we need a more reliable

        -- "likely" primitive to control branch predication.

            False ->

            -- Using a separate state here generates a jump to a

            -- separate code block in the core which seems to perform

            -- slightly better for the non-ascii case.

    -- XXX should we merge it with FreshPointDecodeInit1?

                12 ->

    -- We recover by trying the new byte x a starter of a new codepoint.

    -- XXX need to use the same recovery in array decoding routine as well

                        12 ->

{-# INLINE_NORMAL decodeUtf8EitherD #-}

decodeUtf8EitherD :: Monad m

    => Stream m Word8 -> Stream m (Either DecodeError Char)

data FlattenState s a

    = OuterLoop s !(Maybe (DecodeState, CodePoint))

    | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)

    | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8

    | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)

        !DecodeState !CodePoint

    | YAndC !Char (FlattenState s a) -- These constructors can be

                                     -- encoded in the FreshPoint

                                     -- type, I prefer to keep these

                                     -- flat even though that means

                                     -- coming up with new names

    | D

-- The normal decodeUtf8 above should fuse with flattenArrays

-- to create this exact code but it doesn't for some reason, as of now this

-- remains the fastest way I could figure out to decodeUtf8.

--

-- XXX Add Proper error messages

{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}

decodeUtf8ArraysWithD ::

       MonadIO m

    => CodingFailureMode

    -> Stream m (A.Array Word8)

    -> Stream m Char

  where

    {-# INLINE transliterateOrError #-}

    {-# INLINE inputUnderflow #-}

            ErrorOnCodingFailure ->

    {-# INLINE_LATE step' #-}

                Yield A.Array {..} s ->

                Yield A.Array {..} s ->

    step' _ _ (InnerLoopDecodeInit st startf p end)

        -- Note: It is important to use a ">" instead of a "<=" test here for

        -- GHC to generate code layout for default branch prediction for the

        -- common case. This is fragile and might change with the compiler

        -- versions, we need a more reliable "likely" primitive to control

        -- branch predication.

            False ->

            -- Using a separate state here generates a jump to a separate code

            -- block in the core which seems to perform slightly better for the

            -- non-ascii case.

                12 ->

    step' _ _ (InnerLoopDecoding st startf p end sv cp)

                0 ->

                12 ->

{-# INLINE decodeUtf8ArraysD #-}

decodeUtf8ArraysD ::

       MonadIO m

    => Stream m (A.Array Word8)

    -> Stream m Char

{-# INLINE decodeUtf8ArraysLenientD #-}

decodeUtf8ArraysLenientD ::

       MonadIO m

    => Stream m (A.Array Word8)

    -> Stream m Char

data EncodeState s = EncodeState s !WList

-- More yield points improve performance, but I am not sure if they can cause

-- too much code bloat or some trouble with fusion. So keeping only two yield

-- points for now, one for the ascii chars (fast path) and one for all other

-- paths (slow path).

{-# INLINE_NORMAL encodeUtf8D #-}

encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8

  where

    {-# INLINE_LATE step' #-}

                Yield c s ->

                        x

-- | Decode a stream of bytes to Unicode characters by mapping each byte to a

-- corresponding Unicode 'Char' in 0-255 range.

--

-- /Since: 0.7.0/

{-# INLINE decodeLatin1 #-}

decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char

-- | Encode a stream of Unicode characters to bytes by mapping each character

-- to a byte in 0-255 range. Throws an error if the input stream contains

-- characters beyond 255.

--

-- /Since: 0.7.0/

{-# INLINE encodeLatin1 #-}

encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8

    where

-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond

-- 255 to (incorrect) chars in 0-255 range. No error or exception is thrown

-- when such truncation occurs.

--

-- /Since: 0.7.0/

{-# INLINE encodeLatin1Lax #-}

encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8

-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

-- The incoming stream is truncated if an invalid codepoint is encountered.

--

-- /Since: 0.7.0/

{-# INLINE decodeUtf8 #-}

decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char

-- |

--

-- /Internal/

{-# INLINE decodeUtf8Arrays #-}

decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

-- Any invalid codepoint encountered is replaced with the unicode replacement

-- character.

--

-- /Since: 0.7.0/

{-# INLINE decodeUtf8Lax #-}

decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char

-- |

--

-- /Internal/

{-# INLINE decodeUtf8Either #-}

decodeUtf8Either :: (Monad m, IsStream t)

    => t m Word8 -> t m (Either DecodeError Char)

-- |

--

-- /Internal/

{-# INLINE resumeDecodeUtf8Either #-}

resumeDecodeUtf8Either

    :: (Monad m, IsStream t)

    => DecodeState

    -> CodePoint

    -> t m Word8

    -> t m (Either DecodeError Char)

-- |

--

-- /Internal/

{-# INLINE decodeUtf8ArraysLenient #-}

decodeUtf8ArraysLenient ::

       (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.

--

-- /Since: 0.7.0/

{-# INLINE encodeUtf8 #-}

encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8

{-

-------------------------------------------------------------------------------

-- Utility operations on strings

-------------------------------------------------------------------------------

strip :: IsStream t => t m Char -> t m Char

strip = undefined

stripEnd :: IsStream t => t m Char -> t m Char

stripEnd = undefined

-}

-- | Remove leading whitespace from a string.

--

-- > stripStart = S.dropWhile isSpace

--

-- /Internal/

{-# INLINE stripStart #-}

stripStart :: (Monad m, IsStream t) => t m Char -> t m Char

-- | Fold each line of the stream using the supplied 'Fold'

-- and stream the result.

--

-- >>> S.toList $ lines FL.toList (S.fromList "lines\nthis\nstring\n\n\n")

-- ["lines", "this", "string", "", ""]

--

-- > lines = S.splitOnSuffix (== '\n')

--

-- /Internal/

{-# INLINE lines #-}

lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b

foreign import ccall unsafe "u_iswspace"

  iswspace :: Int -> Int

-- | Code copied from base/Data.Char to INLINE it

{-# INLINE isSpace #-}

isSpace :: Char -> Bool

  where

-- | Fold each word of the stream using the supplied 'Fold'

-- and stream the result.

--

-- >>>  S.toList $ words FL.toList (S.fromList "fold these     words")

-- ["fold", "these", "words"]

--

-- > words = S.wordsBy isSpace

--

-- /Internal/

{-# INLINE words #-}

words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b

-- | Unfold a stream to character streams using the supplied 'Unfold'

-- and concat the results suffixing a newline character @\\n@ to each stream.

--

-- /Internal/

{-# INLINE unlines #-}

unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char

-- | Unfold the elements of a stream to character streams using the supplied

-- 'Unfold' and concat the results with a whitespace character infixed between

-- the streams.

--

-- /Internal/

{-# INLINE unwords #-}

unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char