    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE NoImplicitPrelude #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  GHC.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.IO.Encoding.Failure (
        CodingFailureMode(..), codingFailureModeSuffix,
        isSurrogate,
        recoverDecode, recoverEncode
      ) where

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

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

    --import System.Posix.Internals

    -- | The 'CodingFailureMode' is used to construct '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 (Show)
           -- 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 Registery
    -- 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 won'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 have
    -- to do the inverse process.
    --
    -- The user of String would never see these lone surrogates, but it
    -- ensures that iconv will throw an error when encountering them.  We
    -- use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.

    codingFailureModeSuffix :: CodingFailureMode -> String
    codingFailureModeSuffix ErrorOnCodingFailure       = ""
    codingFailureModeSuffix IgnoreCodingFailure        = "//IGNORE"
    codingFailureModeSuffix TransliterateCodingFailure = "//TRANSLIT"
    codingFailureModeSuffix RoundtripFailure           = "//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 = '\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 c = (0xD800 <= x && x <= 0xDBFF)
                 || (0xDC00 <= x && x <= 0xDFFF)
      where x = ord c

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

    -- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8)
    {-# INLINE unescapeRoundtripCharacterSurrogate #-}
    unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8
    unescapeRoundtripCharacterSurrogate c
        | 0xDC80 <= x && x < 0xDD00 = Just (fromIntegral x) -- Discard high byte
        | otherwise                 = Nothing
      where x = ord c

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

    recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8
                  -> IO (Buffer Char, Buffer Word8)
    recoverEncode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }
                      output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do
      (c,ir') <- readCharBuf iraw ir
      --puts $ "recoverEncode " ++ show ir ++ " " ++ show ir'
      case cfm of
        IgnoreCodingFailure        -> return (input { bufL=ir' }, output)
        TransliterateCodingFailure -> do
            if c == '?'
             then return (input { bufL=ir' }, 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' <- writeCharBuf iraw ir '?'
              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 })
        RoundtripFailure | Just x <- unescapeRoundtripCharacterSurrogate c -> do
            writeWord8Buf oraw ow x
            return (input { bufL=ir' }, output { bufR=ow+1 })
        _                          -> ioe_encodingError

    ioe_decodingError :: IO a
    ioe_decodingError = ioException
        (IOError Nothing InvalidArgument "recoverDecode"
            "invalid byte sequence" Nothing Nothing)

    ioe_encodingError :: IO a
    ioe_encodingError = ioException
        (IOError Nothing InvalidArgument "recoverEncode"
            "invalid character" Nothing Nothing)