Distribution/Parsec/FieldLineStream.hs

    {-# 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 Show

    fieldLineStreamEnd :: FieldLineStream
    fieldLineStreamEnd = FLSLast mempty

    -- | Convert 'String' to 'FieldLineStream'.
    --
    -- /Note:/ inefficient!
    fieldLineStreamFromString :: String -> FieldLineStream
    fieldLineStreamFromString = FLSLast . toUTF8BS

    fieldLineStreamFromBS :: ByteString -> FieldLineStream
    fieldLineStreamFromBS = FLSLast

    instance Monad m => Parsec.Stream FieldLineStream m Char where
        uncons (FLSLast bs) = return $ case BS.uncons bs of
            Nothing       -> Nothing
            Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd)

        uncons (FLSCons bs s) = return $ case BS.uncons bs of
            -- as lines are glued with '\n', we return '\n' here!
            Nothing -> Just ('\n', s)
            Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s)

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

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

        moreBytes byteCount overlong bs' acc = case BS.uncons bs' of
            Nothing                   -> (replacementChar, f bs')
            Just (cn, bs1)
                | cn .&. 0xC0 == 0x80 -> moreBytes
                    (byteCount-1)
                    overlong
                    bs1
                    ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
                | otherwise           -> (replacementChar, f bs1)

    replacementChar :: Char
    replacementChar = '\xfffd'