{-# 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
byteCount Int -> 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'