{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# OPTIONS_GHC -Wall -Werror #-}
module Distribution.Parsec.FieldLineStream (
    FieldLineStream (..),
    fieldLineStreamFromString,
    fieldLineStreamFromBS,
    fieldLineStreamEnd,
    ) where

import Data.Bits
import Data.ByteString             (ByteString)
import Distribution.Compat.Prelude
import Distribution.Utils.Generic  (toUTF8BS)
import Prelude ()

import qualified Data.ByteString as BS
import qualified Text.Parsec     as Parsec

-- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@.
data FieldLineStream
    = FLSLast !ByteString
    | FLSCons {-# UNPACK #-} !ByteString FieldLineStream
  deriving Int -> FieldLineStream -> ShowS
[FieldLineStream] -> ShowS
FieldLineStream -> String
(Int -> FieldLineStream -> ShowS)
-> (FieldLineStream -> String)
-> ([FieldLineStream] -> ShowS)
-> Show FieldLineStream
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldLineStream] -> ShowS
$cshowList :: [FieldLineStream] -> ShowS
show :: FieldLineStream -> String
$cshow :: FieldLineStream -> String
showsPrec :: Int -> FieldLineStream -> ShowS
$cshowsPrec :: Int -> FieldLineStream -> ShowS
Show

fieldLineStreamEnd :: FieldLineStream
fieldLineStreamEnd :: FieldLineStream
fieldLineStreamEnd = ByteString -> FieldLineStream
FLSLast ByteString
forall a. Monoid a => a
mempty

-- | Convert 'String' to 'FieldLineStream'.
--
-- /Note:/ inefficient!
fieldLineStreamFromString :: String -> FieldLineStream
fieldLineStreamFromString :: String -> FieldLineStream
fieldLineStreamFromString = ByteString -> FieldLineStream
FLSLast (ByteString -> FieldLineStream)
-> (String -> ByteString) -> String -> FieldLineStream
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
toUTF8BS

fieldLineStreamFromBS :: ByteString -> FieldLineStream
fieldLineStreamFromBS :: ByteString -> FieldLineStream
fieldLineStreamFromBS = ByteString -> FieldLineStream
FLSLast

instance Monad m => Parsec.Stream FieldLineStream m Char where
    uncons :: FieldLineStream -> m (Maybe (Char, FieldLineStream))
uncons (FLSLast bs :: ByteString
bs) = Maybe (Char, FieldLineStream) -> m (Maybe (Char, FieldLineStream))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Char, FieldLineStream)
 -> m (Maybe (Char, FieldLineStream)))
-> Maybe (Char, FieldLineStream)
-> m (Maybe (Char, FieldLineStream))
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
        Nothing       -> Maybe (Char, FieldLineStream)
forall a. Maybe a
Nothing
        Just (c :: Word8
c, bs' :: ByteString
bs') -> (Char, FieldLineStream) -> Maybe (Char, FieldLineStream)
forall a. a -> Maybe a
Just (Word8
-> ByteString
-> (ByteString -> FieldLineStream)
-> FieldLineStream
-> (Char, FieldLineStream)
forall a.
Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar Word8
c ByteString
bs' (\bs'' :: ByteString
bs'' -> ByteString -> FieldLineStream
FLSLast ByteString
bs'') FieldLineStream
fieldLineStreamEnd)

    uncons (FLSCons bs :: ByteString
bs s :: FieldLineStream
s) = Maybe (Char, FieldLineStream) -> m (Maybe (Char, FieldLineStream))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Char, FieldLineStream)
 -> m (Maybe (Char, FieldLineStream)))
-> Maybe (Char, FieldLineStream)
-> m (Maybe (Char, FieldLineStream))
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
        -- as lines are glued with '\n', we return '\n' here!
        Nothing -> (Char, FieldLineStream) -> Maybe (Char, FieldLineStream)
forall a. a -> Maybe a
Just ('\n', FieldLineStream
s)
        Just (c :: Word8
c, bs' :: ByteString
bs') -> (Char, FieldLineStream) -> Maybe (Char, FieldLineStream)
forall a. a -> Maybe a
Just (Word8
-> ByteString
-> (ByteString -> FieldLineStream)
-> FieldLineStream
-> (Char, FieldLineStream)
forall a.
Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar Word8
c ByteString
bs' (\bs'' :: ByteString
bs'' -> ByteString -> FieldLineStream -> FieldLineStream
FLSCons ByteString
bs'' FieldLineStream
s) FieldLineStream
s)

-- Based on implementation 'decodeStringUtf8'
unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar :: Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar c0 :: Word8
c0 bs0 :: ByteString
bs0 f :: ByteString -> a
f next :: a
next
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7F = (Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c0), ByteString -> a
f ByteString
bs0)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xBF = (Char
replacementChar, ByteString -> a
f ByteString
bs0)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xDF = (Char, a)
twoBytes
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xEF = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 3 0x800     ByteString
bs0 (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xF)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xF7 = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 4 0x10000   ByteString
bs0 (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xFB = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 5 0x200000  ByteString
bs0 (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0xFD = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 6 0x4000000 ByteString
bs0 (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Word8 -> Int
forall a b. (a -> b) -> a -> b
$ Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1)
    | Bool
otherwise = String -> (Char, a)
forall a. HasCallStack => String -> a
error (String -> (Char, a)) -> String -> (Char, a)
forall a b. (a -> b) -> a -> b
$ "not implemented " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
c0
  where
    twoBytes :: (Char, a)
twoBytes = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs0 of
        Nothing -> (Char
replacementChar, a
next)
        Just (c1 :: Word8
c1, bs1 :: ByteString
bs1)
            | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80 ->
                if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x80
                then  (Int -> Char
chr Int
d, ByteString -> a
f ByteString
bs1)
                else  (Char
replacementChar, ByteString -> a
f ByteString
bs1)
            | Bool
otherwise -> (Char
replacementChar, ByteString -> a
f ByteString
bs1)
          where
            d :: Int
d = (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1F) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3F)

    moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)
    moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 1 overlong :: Int
overlong bs' :: ByteString
bs' acc :: Int
acc
        | Int
overlong Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
acc, Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x10FFFF, Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0xD800 Bool -> Bool -> Bool
|| 0xDFFF Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
acc
            = (Int -> Char
chr Int
acc, ByteString -> a
f ByteString
bs')
        | Bool
otherwise
            = (Char
replacementChar, ByteString -> a
f ByteString
bs')

    moreBytes byteCount :: Int
byteCount overlong :: Int
overlong bs' :: ByteString
bs' acc :: Int
acc = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs' of
        Nothing                   -> (Char
replacementChar, ByteString -> a
f ByteString
bs')
        Just (cn :: Word8
cn, bs1 :: ByteString
bs1)
            | Word8
cn Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x80 -> Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes
                (Int
byteCountInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
                Int
overlong
                ByteString
bs1
                ((Int
acc Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 6) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
cn Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x3F)
            | Bool
otherwise           -> (Char
replacementChar, ByteString -> a
f ByteString
bs1)

replacementChar :: Char
replacementChar :: Char
replacementChar = '\xfffd'