{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.IO.Encoding.Failure
-- Copyright   :  (c) The University of Glasgow, 2008-2011
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Types for specifying how text encoding/decoding fails
--
-----------------------------------------------------------------------------

module GHC.Internal.IO.Encoding.Failure (
    CodingFailureMode(..), codingFailureModeSuffix,
    isSurrogate,
    recoverDecode, recoverEncode,
    recoverDecode#, recoverEncode#,
  ) where

import GHC.Internal.IO
import GHC.Internal.IO.Buffer
import GHC.Internal.IO.Exception

import GHC.Internal.Base
import GHC.Internal.Char
import GHC.Internal.Word
import GHC.Internal.Show
import GHC.Internal.Num
import GHC.Internal.Real ( fromIntegral )

--import GHC.Internal.System.Posix.Internals

-- | The 'CodingFailureMode' is used to construct 'System.IO.TextEncoding's,
-- and specifies how they handle illegal sequences.
data CodingFailureMode
  = ErrorOnCodingFailure
       -- ^ Throw an error when an illegal sequence is encountered
  | IgnoreCodingFailure
       -- ^ Attempt to ignore and recover if an illegal sequence is
       -- encountered
  | TransliterateCodingFailure
       -- ^ Replace with the closest visual match upon an illegal
       -- sequence
  | RoundtripFailure
       -- ^ Use the private-use escape mechanism to attempt to allow
       -- illegal sequences to be roundtripped.
  deriving ( Int -> CodingFailureMode -> ShowS
[CodingFailureMode] -> ShowS
CodingFailureMode -> String
(Int -> CodingFailureMode -> ShowS)
-> (CodingFailureMode -> String)
-> ([CodingFailureMode] -> ShowS)
-> Show CodingFailureMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodingFailureMode -> ShowS
showsPrec :: Int -> CodingFailureMode -> ShowS
$cshow :: CodingFailureMode -> String
show :: CodingFailureMode -> String
$cshowList :: [CodingFailureMode] -> ShowS
showList :: [CodingFailureMode] -> ShowS
Show -- ^ @since base-4.4.0.0
           )
       -- This will only work properly for those encodings which are
       -- strict supersets of ASCII in the sense that valid ASCII data
       -- is also valid in that encoding. This is not true for
       -- e.g. UTF-16, because ASCII characters must be padded to two
       -- bytes to retain their meaning.

-- Note [Roundtripping]
-- ~~~~~~~~~~~~~~~~~~~~
-- Roundtripping is based on the ideas of PEP383.
--
-- We used to use the range of private-use characters from 0xEF80 to
-- 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registry
-- to encode these characters.
--
-- However, people didn't like this because it means we don't get
-- guaranteed roundtripping for byte sequences that look like a UTF-8
-- encoded codepoint 0xEFxx.
--
-- So now like PEP383 we use lone surrogate codepoints 0xDCxx to escape
-- undecodable bytes, even though that may confuse Unicode processing
-- software written in Haskell. This guarantees roundtripping because
-- unicode input that includes lone surrogate codepoints is invalid by
-- definition.
--
--
-- When we used private-use characters there was a technical problem when it
-- came to encoding back to bytes using iconv. The iconv code will not fail when
-- it tries to encode a private-use character (as it would if trying to encode
-- a surrogate), which means that we wouldn't get a chance to replace it
-- with the byte we originally escaped.
--
-- To work around this, when filling the buffer to be encoded (in
-- writeBlocks/withEncodedCString/newEncodedCString), we replaced the
-- private-use characters with lone surrogates again! Likewise, when
-- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we had
-- to do the inverse process.
--
-- The user of String would never see these lone surrogates, but it
-- ensured that iconv will throw an error when encountering them.  We
-- used lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.

codingFailureModeSuffix :: CodingFailureMode -> String
codingFailureModeSuffix :: CodingFailureMode -> String
codingFailureModeSuffix CodingFailureMode
ErrorOnCodingFailure       = String
""
codingFailureModeSuffix CodingFailureMode
IgnoreCodingFailure        = String
"//IGNORE"
codingFailureModeSuffix CodingFailureMode
TransliterateCodingFailure = String
"//TRANSLIT"
codingFailureModeSuffix CodingFailureMode
RoundtripFailure           = String
"//ROUNDTRIP"

-- | In transliterate mode, we use this character when decoding
-- unknown bytes.
--
-- This is the defined Unicode replacement character:
-- <http://www.fileformat.info/info/unicode/char/0fffd/index.htm>
unrepresentableChar :: Char
unrepresentableChar :: Char
unrepresentableChar = Char
'\xFFFD'

-- It is extraordinarily important that this series of
-- predicates/transformers gets inlined, because they tend to be used
-- in inner loops related to text encoding. In particular,
-- surrogatifyRoundtripCharacter must be inlined (see #5536)

-- | Some characters are actually "surrogate" codepoints defined for
-- use in UTF-16. We need to signal an invalid character if we detect
-- them when encoding a sequence of 'Char's into 'Word8's because they
-- won't give valid Unicode.
--
-- We may also need to signal an invalid character if we detect them
-- when encoding a sequence of 'Char's into 'Word8's because the
-- 'RoundtripFailure' mode creates these to round-trip bytes through
-- our internal UTF-16 encoding.
{-# INLINE isSurrogate #-}
isSurrogate :: Char -> Bool
isSurrogate :: Char -> Bool
isSurrogate Char
c = (Int
0xD800 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDBFF)
             Bool -> Bool -> Bool
|| (Int
0xDC00 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF)
  where x :: Int
x = Char -> Int
ord Char
c

-- Bytes (in Buffer Word8) --> lone surrogates (in Buffer CharBufElem)
{-# INLINE escapeToRoundtripCharacterSurrogate #-}
escapeToRoundtripCharacterSurrogate :: Word8 -> Char
escapeToRoundtripCharacterSurrogate :: Word8 -> Char
escapeToRoundtripCharacterSurrogate Word8
b
  | Word8
b Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
128   = Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)
      -- Disallow 'smuggling' of ASCII bytes. For roundtripping to
      -- work, this assumes encoding is ASCII-superset.
  | Bool
otherwise = Int -> Char
chr (Int
0xDC00 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b)

-- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8)
{-# INLINE unescapeRoundtripCharacterSurrogate #-}
unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8
unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8
unescapeRoundtripCharacterSurrogate Char
c
    | Int
0xDC80 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0xDD00 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x) -- Discard high byte
    | Bool
otherwise                 = Maybe Word8
forall a. Maybe a
Nothing
  where x :: Int
x = Char -> Int
ord Char
c

recoverDecode# :: CodingFailureMode -> Buffer Word8 -> Buffer Char
               -> State# RealWorld -> (# State# RealWorld, Buffer Word8, Buffer Char #)
recoverDecode# :: CodingFailureMode
-> Buffer Word8
-> Buffer Char
-> State# RealWorld
-> (# State# RealWorld, Buffer Word8, Buffer Char #)
recoverDecode# CodingFailureMode
cfm Buffer Word8
input Buffer Char
output State# RealWorld
st =
  let !(# State# RealWorld
st', (Buffer Word8
bIn, Buffer Char
bOut) #) = IO (Buffer Word8, Buffer Char)
-> State# RealWorld
-> (# State# RealWorld, (Buffer Word8, Buffer Char) #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (CodingFailureMode
-> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recoverDecode CodingFailureMode
cfm Buffer Word8
input Buffer Char
output) State# RealWorld
st
  in (# State# RealWorld
st', Buffer Word8
bIn, Buffer Char
bOut #)

recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char
              -> IO (Buffer Word8, Buffer Char)
recoverDecode :: CodingFailureMode
-> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recoverDecode CodingFailureMode
cfm input :: Buffer Word8
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Word8
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir, bufR :: forall e. Buffer e -> Int
bufR=Int
_  }
                  output :: Buffer Char
output@Buffer{ bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
oraw, bufL :: forall e. Buffer e -> Int
bufL=Int
_,  bufR :: forall e. Buffer e -> Int
bufR=Int
ow } =
 --puts $ "recoverDecode " ++ show ir
 case CodingFailureMode
cfm of
  CodingFailureMode
ErrorOnCodingFailure       -> do
      b <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw Int
ir
      ioe_decodingError b
  CodingFailureMode
IgnoreCodingFailure        -> (Buffer Word8, Buffer Char) -> IO (Buffer Word8, Buffer Char)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Word8
input { bufL=ir+1 }, Buffer Char
output)
  CodingFailureMode
TransliterateCodingFailure -> do
      ow' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
oraw Int
ow Char
unrepresentableChar
      return (input { bufL=ir+1 }, output { bufR=ow' })
  CodingFailureMode
RoundtripFailure           -> do
      b <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw Int
ir
      ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b)
      return (input { bufL=ir+1 }, output { bufR=ow' })

recoverEncode# :: CodingFailureMode -> Buffer Char -> Buffer Word8
               -> State# RealWorld -> (# State# RealWorld, Buffer Char, Buffer Word8 #)
recoverEncode# :: CodingFailureMode
-> Buffer Char
-> Buffer Word8
-> State# RealWorld
-> (# State# RealWorld, Buffer Char, Buffer Word8 #)
recoverEncode# CodingFailureMode
cfm Buffer Char
input Buffer Word8
output State# RealWorld
st =
  let !(# State# RealWorld
st', (Buffer Char
bIn, Buffer Word8
bOut) #) = IO (Buffer Char, Buffer Word8)
-> State# RealWorld
-> (# State# RealWorld, (Buffer Char, Buffer Word8) #)
forall a. IO a -> State# RealWorld -> (# State# RealWorld, a #)
unIO (CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
cfm Buffer Char
input Buffer Word8
output) State# RealWorld
st
  in (# State# RealWorld
st', Buffer Char
bIn, Buffer Word8
bOut #)

recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8
              -> IO (Buffer Char, Buffer Word8)
recoverEncode :: CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
cfm input :: Buffer Char
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir, bufR :: forall e. Buffer e -> Int
bufR=Int
_  }
                  output :: Buffer Word8
output@Buffer{ bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Word8
oraw, bufL :: forall e. Buffer e -> Int
bufL=Int
_,  bufR :: forall e. Buffer e -> Int
bufR=Int
ow } = do
  (c,ir') <- RawBuffer Char -> Int -> IO (Char, Int)
readCharBuf RawBuffer Char
iraw Int
ir
  --puts $ "recoverEncode " ++ show ir ++ " " ++ show ir'
  case cfm of
    CodingFailureMode
IgnoreCodingFailure        -> (Buffer Char, Buffer Word8) -> IO (Buffer Char, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Char
input { bufL=ir' }, Buffer Word8
output)
    CodingFailureMode
TransliterateCodingFailure -> do
        if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'
         then (Buffer Char, Buffer Word8) -> IO (Buffer Char, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Char
input { bufL=ir' }, Buffer Word8
output)
         else do
          -- XXX: evil hack! To implement transliteration, we just
          -- poke an ASCII ? into the input buffer and tell the caller
          -- to try and decode again. This is *probably* safe given
          -- current uses of TextEncoding.
          --
          -- The "if" test above ensures we skip if the encoding fails
          -- to deal with the ?, though this should never happen in
          -- practice as all encodings are in fact capable of
          -- reperesenting all ASCII characters.
          _ir' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
iraw Int
ir Char
'?'
          return (input, output)

        -- This implementation does not work because e.g. UTF-16
        -- requires 2 bytes to encode a simple ASCII value
        --writeWord8Buf oraw ow unrepresentableByte
        --return (input { bufL=ir' }, output { bufR=ow+1 })
    CodingFailureMode
RoundtripFailure | Just Word8
x <- Char -> Maybe Word8
unescapeRoundtripCharacterSurrogate Char
c -> do
        RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw Int
ow Word8
x
        (Buffer Char, Buffer Word8) -> IO (Buffer Char, Buffer Word8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Char
input { bufL=ir' }, Buffer Word8
output { bufR=ow+1 })
    CodingFailureMode
_                          -> Char -> IO (Buffer Char, Buffer Word8)
forall a. Char -> IO a
ioe_encodingError Char
c

ioe_decodingError :: Word8 -> IO a
ioe_decodingError :: forall a. Word8 -> IO a
ioe_decodingError Word8
b = IOException -> IO a
forall a. HasCallStack => IOException -> IO a
ioException
    (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InvalidArgument String
"recoverDecode"
        (String
"cannot decode byte sequence starting from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
b) Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

ioe_encodingError :: Char -> IO a
ioe_encodingError :: forall a. Char -> IO a
ioe_encodingError Char
ch = IOException -> IO a
forall a. HasCallStack => IOException -> IO a
ioException
    (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
InvalidArgument String
"recoverEncode"
        -- This assumes that @show ch@ escapes non-ASCII symbols
        -- and thus does not cause recursive encoding failures.
        (String
"cannot encode character " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
ch) Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)