{-# 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
$cshowsPrec :: Int -> FieldLineStream -> ShowS
showsPrec :: Int -> FieldLineStream -> ShowS
$cshow :: FieldLineStream -> String
show :: FieldLineStream -> String
$cshowList :: [FieldLineStream] -> ShowS
showList :: [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 ByteString
bs) = Maybe (Char, FieldLineStream) -> m (Maybe (Char, FieldLineStream))
forall a. a -> m a
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
        Maybe (Word8, ByteString)
Nothing       -> Maybe (Char, FieldLineStream)
forall a. Maybe a
Nothing
        Just (Word8
c, 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' (\ByteString
bs'' -> ByteString -> FieldLineStream
FLSLast ByteString
bs'') FieldLineStream
fieldLineStreamEnd)

    uncons (FLSCons ByteString
bs FieldLineStream
s) = Maybe (Char, FieldLineStream) -> m (Maybe (Char, FieldLineStream))
forall a. a -> m a
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!
        Maybe (Word8, ByteString)
Nothing -> (Char, FieldLineStream) -> Maybe (Char, FieldLineStream)
forall a. a -> Maybe a
Just (Char
'\n', FieldLineStream
s)
        Just (Word8
c, 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' (\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 :: forall a.
Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar Word8
c0 ByteString
bs0 ByteString -> a
f a
next
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
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
<= Word8
0xBF = (Char
replacementChar, ByteString -> a
f ByteString
bs0)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xDF = (Char, a)
twoBytes
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xEF = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes Int
3 Int
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
.&. Word8
0xF)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xF7 = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes Int
4 Int
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
.&. Word8
0x7)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xFB = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes Int
5 Int
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
.&. Word8
0x3)
    | Word8
c0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xFD = Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes Int
6 Int
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
.&. Word8
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
$ String
"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
        Maybe (Word8, ByteString)
Nothing -> (Char
replacementChar, a
next)
        Just (Word8
c1, ByteString
bs1)
            | Word8
c1 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 ->
                if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
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
.&. Word8
0x1F) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
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
.&. Word8
0x3F)

    moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)
    moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes Int
1 Int
overlong ByteString
bs' 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
<= Int
0x10FFFF, Int
acc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xD800 Bool -> Bool -> Bool
|| Int
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 Int
byteCount Int
overlong ByteString
bs' Int
acc = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs' of
        Maybe (Word8, ByteString)
Nothing                   -> (Char
replacementChar, ByteString -> a
f ByteString
bs')
        Just (Word8
cn, ByteString
bs1)
            | Word8
cn Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xC0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x80 -> Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes
                (Int
byteCountInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
                Int
overlong
                ByteString
bs1
                ((Int
acc Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
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
.&. Int
0x3F)
            | Bool
otherwise           -> (Char
replacementChar, ByteString -> a
f ByteString
bs1)

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