{-# LANGUAGE NoImplicitPrelude
           , BangPatterns
           , TypeApplications
           , MultiWayIf
  #-}
{-# OPTIONS_GHC  -funbox-strict-fields #-}


module System.OsPath.Encoding.Internal where

import qualified System.OsPath.Data.ByteString.Short as BS8
import qualified System.OsPath.Data.ByteString.Short.Word16 as BS16

import GHC.Base
import GHC.Real
import GHC.Num
-- import GHC.IO
import GHC.IO.Buffer
import GHC.IO.Encoding.Failure
import GHC.IO.Encoding.Types
import Data.Bits
import Control.Exception (SomeException, try, Exception (displayException), evaluate)
import qualified GHC.Foreign as GHC
import Data.Either (Either)
import GHC.IO (unsafePerformIO)
import Control.DeepSeq (force, NFData (rnf))
import Data.Bifunctor (first)
import Data.Data (Typeable)
import GHC.Show (Show (show))
import Numeric (showHex)
import Foreign.C (CStringLen)
import Data.Char (chr)
import Foreign
import Prelude (FilePath)
import GHC.IO.Encoding (getFileSystemEncoding)

-- -----------------------------------------------------------------------------
-- UCS-2 LE
--

ucs2le :: TextEncoding
ucs2le :: TextEncoding
ucs2le = CodingFailureMode -> TextEncoding
mkUcs2le CodingFailureMode
ErrorOnCodingFailure

mkUcs2le :: CodingFailureMode -> TextEncoding
mkUcs2le :: CodingFailureMode -> TextEncoding
mkUcs2le CodingFailureMode
cfm = TextEncoding { textEncodingName :: String
textEncodingName = String
"UCS-2LE",
                              mkTextDecoder :: IO (TextDecoder ())
mkTextDecoder = CodingFailureMode -> IO (TextDecoder ())
ucs2le_DF CodingFailureMode
cfm,
                              mkTextEncoder :: IO (TextEncoder ())
mkTextEncoder = CodingFailureMode -> IO (TextEncoder ())
ucs2le_EF CodingFailureMode
cfm }

ucs2le_DF :: CodingFailureMode -> IO (TextDecoder ())
ucs2le_DF :: CodingFailureMode -> IO (TextDecoder ())
ucs2le_DF CodingFailureMode
cfm =
  forall (m :: * -> *) a. Monad m => a -> m a
return (BufferCodec {
             encode :: CodeBuffer Word8 Char
encode   = CodeBuffer Word8 Char
ucs2le_decode,
             recover :: Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recover  = CodingFailureMode
-> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recoverDecode CodingFailureMode
cfm,
             close :: IO ()
close    = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             getState :: IO ()
getState = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             setState :: () -> IO ()
setState = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
          })

ucs2le_EF :: CodingFailureMode -> IO (TextEncoder ())
ucs2le_EF :: CodingFailureMode -> IO (TextEncoder ())
ucs2le_EF CodingFailureMode
cfm =
  forall (m :: * -> *) a. Monad m => a -> m a
return (BufferCodec {
             encode :: CodeBuffer Char Word8
encode   = CodeBuffer Char Word8
ucs2le_encode,
             recover :: Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recover  = CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
cfm,
             close :: IO ()
close    = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             getState :: IO ()
getState = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             setState :: () -> IO ()
setState = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
          })


ucs2le_decode :: DecodeBuffer
ucs2le_decode :: CodeBuffer Word8 Char
ucs2le_decode
  input :: Buffer Word8
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Word8
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir0, bufR :: forall e. Buffer e -> Int
bufR=Int
iw,  bufSize :: forall e. Buffer e -> Int
bufSize=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
ow0, bufSize :: forall e. Buffer e -> Int
bufSize=Int
os }
 = let
       loop :: Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop !Int
ir !Int
ow
         | Int
ow forall a. Ord a => a -> a -> Bool
>= Int
os     = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
OutputUnderflow Int
ir Int
ow
         | Int
ir forall a. Ord a => a -> a -> Bool
>= Int
iw     = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow
         | Int
ir forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
iw = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow
         | Bool
otherwise = do
              Word8
c0 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw Int
ir
              Word8
c1 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw (Int
irforall a. Num a => a -> a -> a
+Int
1)
              let x1 :: Int
x1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c1 forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c0
              Int
ow' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
oraw Int
ow (Int -> Char
unsafeChr Int
x1)
              Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop (Int
irforall a. Num a => a -> a -> a
+Int
2) Int
ow'

       -- lambda-lifted, to avoid thunks being built in the inner-loop:
       done :: a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done a
why !Int
ir !Int
ow = forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                  if Int
ir forall a. Eq a => a -> a -> Bool
== Int
iw then Buffer Word8
input{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
                                              else Buffer Word8
input{ bufL :: Int
bufL=Int
ir },
                                  Buffer Char
output{ bufR :: Int
bufR=Int
ow })
    in
    Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop Int
ir0 Int
ow0


ucs2le_encode :: EncodeBuffer
ucs2le_encode :: CodeBuffer Char Word8
ucs2le_encode
  input :: Buffer Char
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir0, bufR :: forall e. Buffer e -> Int
bufR=Int
iw,  bufSize :: forall e. Buffer e -> Int
bufSize=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
ow0, bufSize :: forall e. Buffer e -> Int
bufSize=Int
os }
 = let
      done :: a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done a
why !Int
ir !Int
ow = forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                 if Int
ir forall a. Eq a => a -> a -> Bool
== Int
iw then Buffer Char
input{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
                                             else Buffer Char
input{ bufL :: Int
bufL=Int
ir },
                                 Buffer Word8
output{ bufR :: Int
bufR=Int
ow })
      loop :: Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop !Int
ir !Int
ow
        | Int
ir forall a. Ord a => a -> a -> Bool
>= Int
iw     =  forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
InputUnderflow Int
ir Int
ow
        | Int
os forall a. Num a => a -> a -> a
- Int
ow forall a. Ord a => a -> a -> Bool
< Int
2  =  forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
OutputUnderflow Int
ir Int
ow
        | Bool
otherwise = do
           (Char
c,Int
ir') <- RawBuffer Char -> Int -> IO (Char, Int)
readCharBuf RawBuffer Char
iraw Int
ir
           case Char -> Int
ord Char
c of
             Int
x | Int
x forall a. Ord a => a -> a -> Bool
< Int
0x10000 -> do
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw Int
ow     (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw (Int
owforall a. Num a => a -> a -> a
+Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
                     Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir' (Int
owforall a. Num a => a -> a -> a
+Int
2)
               | Bool
otherwise -> forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
InvalidSequence Int
ir Int
ow
    in
    Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir0 Int
ow0

-- -----------------------------------------------------------------------------
-- UTF-16b
--

-- | Mimics the base encoding for filesystem operations. This should be total on all inputs (word16 byte arrays).
--
-- Note that this has a subtle difference to 'encodeWithBaseWindows'/'decodeWithBaseWindows': it doesn't care for
-- the @0x0000@ end marker and will as such produce different results. Use @takeWhile (/= '\NUL')@ on the input
-- to recover this behavior.
utf16le_b :: TextEncoding
utf16le_b :: TextEncoding
utf16le_b = CodingFailureMode -> TextEncoding
mkUTF16le_b CodingFailureMode
ErrorOnCodingFailure

mkUTF16le_b :: CodingFailureMode -> TextEncoding
mkUTF16le_b :: CodingFailureMode -> TextEncoding
mkUTF16le_b CodingFailureMode
cfm = TextEncoding { textEncodingName :: String
textEncodingName = String
"UTF-16LE_b",
                                 mkTextDecoder :: IO (TextDecoder ())
mkTextDecoder = CodingFailureMode -> IO (TextDecoder ())
utf16le_b_DF CodingFailureMode
cfm,
                                 mkTextEncoder :: IO (TextEncoder ())
mkTextEncoder = CodingFailureMode -> IO (TextEncoder ())
utf16le_b_EF CodingFailureMode
cfm }

utf16le_b_DF :: CodingFailureMode -> IO (TextDecoder ())
utf16le_b_DF :: CodingFailureMode -> IO (TextDecoder ())
utf16le_b_DF CodingFailureMode
cfm =
  forall (m :: * -> *) a. Monad m => a -> m a
return (BufferCodec {
             encode :: CodeBuffer Word8 Char
encode   = CodeBuffer Word8 Char
utf16le_b_decode,
             recover :: Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recover  = CodingFailureMode
-> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recoverDecode CodingFailureMode
cfm,
             close :: IO ()
close    = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             getState :: IO ()
getState = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             setState :: () -> IO ()
setState = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
          })

utf16le_b_EF :: CodingFailureMode -> IO (TextEncoder ())
utf16le_b_EF :: CodingFailureMode -> IO (TextEncoder ())
utf16le_b_EF CodingFailureMode
cfm =
  forall (m :: * -> *) a. Monad m => a -> m a
return (BufferCodec {
             encode :: CodeBuffer Char Word8
encode   = CodeBuffer Char Word8
utf16le_b_encode,
             recover :: Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recover  = CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
cfm,
             close :: IO ()
close    = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             getState :: IO ()
getState = forall (m :: * -> *) a. Monad m => a -> m a
return (),
             setState :: () -> IO ()
setState = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
          })


utf16le_b_decode :: DecodeBuffer
utf16le_b_decode :: CodeBuffer Word8 Char
utf16le_b_decode
  input :: Buffer Word8
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Word8
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir0, bufR :: forall e. Buffer e -> Int
bufR=Int
iw,  bufSize :: forall e. Buffer e -> Int
bufSize=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
ow0, bufSize :: forall e. Buffer e -> Int
bufSize=Int
os }
 = let
       loop :: Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop !Int
ir !Int
ow
         | Int
ow forall a. Ord a => a -> a -> Bool
>= Int
os     = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
OutputUnderflow Int
ir Int
ow
         | Int
ir forall a. Ord a => a -> a -> Bool
>= Int
iw     = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow
         | Int
ir forall a. Num a => a -> a -> a
+ Int
1 forall a. Eq a => a -> a -> Bool
== Int
iw = forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow
         | Bool
otherwise = do
              Word8
c0 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw Int
ir
              Word8
c1 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw (Int
irforall a. Num a => a -> a -> a
+Int
1)
              let x1 :: Int
x1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c1 forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c0
              if | Int
iw forall a. Num a => a -> a -> a
- Int
ir forall a. Ord a => a -> a -> Bool
>= Int
4 -> do
                      Word8
c2 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw (Int
irforall a. Num a => a -> a -> a
+Int
2)
                      Word8
c3 <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw (Int
irforall a. Num a => a -> a -> a
+Int
3)
                      let x2 :: Int
x2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c3 forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c2
                      if | Int
0xd800 forall a. Ord a => a -> a -> Bool
<= Int
x1 Bool -> Bool -> Bool
&& Int
x1 forall a. Ord a => a -> a -> Bool
<= Int
0xdbff
                         , Int
0xdc00 forall a. Ord a => a -> a -> Bool
<= Int
x2 Bool -> Bool -> Bool
&& Int
x2 forall a. Ord a => a -> a -> Bool
<= Int
0xdfff -> do
                             Int
ow' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
oraw Int
ow (Int -> Char
unsafeChr ((Int
x1 forall a. Num a => a -> a -> a
- Int
0xd800)forall a. Num a => a -> a -> a
*Int
0x400 forall a. Num a => a -> a -> a
+ (Int
x2 forall a. Num a => a -> a -> a
- Int
0xdc00) forall a. Num a => a -> a -> a
+ Int
0x10000))
                             Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop (Int
irforall a. Num a => a -> a -> a
+Int
4) Int
ow'
                         | Bool
otherwise -> do
                             Int
ow' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
oraw Int
ow (Int -> Char
unsafeChr Int
x1)
                             Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop (Int
irforall a. Num a => a -> a -> a
+Int
2) Int
ow'
                 | Int
iw forall a. Num a => a -> a -> a
- Int
ir forall a. Ord a => a -> a -> Bool
>= Int
2 -> do
                        Int
ow' <- RawBuffer Char -> Int -> Char -> IO Int
writeCharBuf RawBuffer Char
oraw Int
ow (Int -> Char
unsafeChr Int
x1)
                        Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop (Int
irforall a. Num a => a -> a -> a
+Int
2) Int
ow'
                 | Bool
otherwise -> forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow

       -- lambda-lifted, to avoid thunks being built in the inner-loop:
       done :: a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done a
why !Int
ir !Int
ow = forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                  if Int
ir forall a. Eq a => a -> a -> Bool
== Int
iw then Buffer Word8
input{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
                                              else Buffer Word8
input{ bufL :: Int
bufL=Int
ir },
                                  Buffer Char
output{ bufR :: Int
bufR=Int
ow })
    in
    Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop Int
ir0 Int
ow0


utf16le_b_encode :: EncodeBuffer
utf16le_b_encode :: CodeBuffer Char Word8
utf16le_b_encode
  input :: Buffer Char
input@Buffer{  bufRaw :: forall e. Buffer e -> RawBuffer e
bufRaw=RawBuffer Char
iraw, bufL :: forall e. Buffer e -> Int
bufL=Int
ir0, bufR :: forall e. Buffer e -> Int
bufR=Int
iw,  bufSize :: forall e. Buffer e -> Int
bufSize=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
ow0, bufSize :: forall e. Buffer e -> Int
bufSize=Int
os }
 = let
      done :: a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done a
why !Int
ir !Int
ow = forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                 if Int
ir forall a. Eq a => a -> a -> Bool
== Int
iw then Buffer Char
input{ bufL :: Int
bufL=Int
0, bufR :: Int
bufR=Int
0 }
                                             else Buffer Char
input{ bufL :: Int
bufL=Int
ir },
                                 Buffer Word8
output{ bufR :: Int
bufR=Int
ow })
      loop :: Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop !Int
ir !Int
ow
        | Int
ir forall a. Ord a => a -> a -> Bool
>= Int
iw     =  forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
InputUnderflow Int
ir Int
ow
        | Int
os forall a. Num a => a -> a -> a
- Int
ow forall a. Ord a => a -> a -> Bool
< Int
2  =  forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
OutputUnderflow Int
ir Int
ow
        | Bool
otherwise = do
           (Char
c,Int
ir') <- RawBuffer Char -> Int -> IO (Char, Int)
readCharBuf RawBuffer Char
iraw Int
ir
           case Char -> Int
ord Char
c of
             Int
x | Int
x forall a. Ord a => a -> a -> Bool
< Int
0x10000 -> do
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw Int
ow     (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw (Int
owforall a. Num a => a -> a -> a
+Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
                     Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir' (Int
owforall a. Num a => a -> a -> a
+Int
2)
               | Bool
otherwise ->
                     if Int
os forall a. Num a => a -> a -> a
- Int
ow forall a. Ord a => a -> a -> Bool
< Int
4 then forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
OutputUnderflow Int
ir Int
ow else do
                     let x' :: Int
x' = Int
x forall a. Num a => a -> a -> a
- Int
0x10000
                         w1 :: Int
w1 = Int
x' forall a. Integral a => a -> a -> a
`div` Int
0x400 forall a. Num a => a -> a -> a
+ Int
0xd800
                         w2 :: Int
w2 = Int
x' forall a. Integral a => a -> a -> a
`mod` Int
0x400 forall a. Num a => a -> a -> a
+ Int
0xdc00
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw Int
ow     (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w1)
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw (Int
owforall a. Num a => a -> a -> a
+Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w1 forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw (Int
owforall a. Num a => a -> a -> a
+Int
2) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w2)
                     RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw (Int
owforall a. Num a => a -> a -> a
+Int
3) (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w2 forall a. Bits a => a -> Int -> a
`shiftR` Int
8))
                     Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir' (Int
owforall a. Num a => a -> a -> a
+Int
4)
    in
    Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir0 Int
ow0

-- -----------------------------------------------------------------------------
-- Windows encoding (ripped off from base)
--

cWcharsToChars_UCS2 :: [Word16] -> [Char]
cWcharsToChars_UCS2 :: [Word16] -> String
cWcharsToChars_UCS2 = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral)


-- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.

-- coding errors generate Chars in the surrogate range
cWcharsToChars :: [Word16] -> [Char]
cWcharsToChars :: [Word16] -> String
cWcharsToChars = forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
fromUTF16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral
 where
  fromUTF16 :: [Int] -> [Int]
  fromUTF16 :: [Int] -> [Int]
fromUTF16 (Int
c1:Int
c2:[Int]
wcs)
    | Int
0xd800 forall a. Ord a => a -> a -> Bool
<= Int
c1 Bool -> Bool -> Bool
&& Int
c1 forall a. Ord a => a -> a -> Bool
<= Int
0xdbff Bool -> Bool -> Bool
&& Int
0xdc00 forall a. Ord a => a -> a -> Bool
<= Int
c2 Bool -> Bool -> Bool
&& Int
c2 forall a. Ord a => a -> a -> Bool
<= Int
0xdfff =
      ((Int
c1 forall a. Num a => a -> a -> a
- Int
0xd800)forall a. Num a => a -> a -> a
*Int
0x400 forall a. Num a => a -> a -> a
+ (Int
c2 forall a. Num a => a -> a -> a
- Int
0xdc00) forall a. Num a => a -> a -> a
+ Int
0x10000) forall a. a -> [a] -> [a]
: [Int] -> [Int]
fromUTF16 [Int]
wcs
  fromUTF16 (Int
c:[Int]
wcs) = Int
c forall a. a -> [a] -> [a]
: [Int] -> [Int]
fromUTF16 [Int]
wcs
  fromUTF16 [] = []

charsToCWchars :: [Char] -> [Word16]
charsToCWchars :: String -> [Word16]
charsToCWchars = forall a b. (a -> b -> b) -> b -> [a] -> b
foldr (Int -> [Word16] -> [Word16]
utf16Char forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) []
 where
  utf16Char :: Int -> [Word16] -> [Word16]
  utf16Char :: Int -> [Word16] -> [Word16]
utf16Char Int
c [Word16]
wcs
    | Int
c forall a. Ord a => a -> a -> Bool
< Int
0x10000 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c forall a. a -> [a] -> [a]
: [Word16]
wcs
    | Bool
otherwise   = let c' :: Int
c' = Int
c forall a. Num a => a -> a -> a
- Int
0x10000 in
                    forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c' forall a. Integral a => a -> a -> a
`div` Int
0x400 forall a. Num a => a -> a -> a
+ Int
0xd800) forall a. a -> [a] -> [a]
:
                    forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c' forall a. Integral a => a -> a -> a
`mod` Int
0x400 forall a. Num a => a -> a -> a
+ Int
0xdc00) forall a. a -> [a] -> [a]
: [Word16]
wcs

-- -----------------------------------------------------------------------------

-- -----------------------------------------------------------------------------
-- FFI
--

withFilePathWin :: FilePath -> (Int -> Ptr Word16 -> IO a) -> IO a
withFilePathWin :: forall a. String -> (Int -> Ptr Word16 -> IO a) -> IO a
withFilePathWin = forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Word16]
charsToCWchars

peekFilePathWin :: (Ptr Word16, Int) -> IO FilePath
peekFilePathWin :: (Ptr Word16, Int) -> IO String
peekFilePathWin (Ptr Word16
cp, Int
l) = do
  [Word16]
cs <- forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray Int
l Ptr Word16
cp
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Word16] -> String
cWcharsToChars [Word16]
cs)

withFilePathPosix :: FilePath -> (CStringLen -> IO a) -> IO a
withFilePathPosix :: forall a. String -> (CStringLen -> IO a) -> IO a
withFilePathPosix String
fp CStringLen -> IO a
f = IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc -> forall a. TextEncoding -> String -> (CStringLen -> IO a) -> IO a
GHC.withCStringLen TextEncoding
enc String
fp CStringLen -> IO a
f

peekFilePathPosix :: CStringLen -> IO FilePath
peekFilePathPosix :: CStringLen -> IO String
peekFilePathPosix CStringLen
fp = IO TextEncoding
getFileSystemEncoding forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TextEncoding
enc -> TextEncoding -> CStringLen -> IO String
GHC.peekCStringLen TextEncoding
enc CStringLen
fp

-- | Decode with the given 'TextEncoding'.
decodeWithTE :: TextEncoding -> BS8.ShortByteString -> Either EncodingException String
decodeWithTE :: TextEncoding -> ShortByteString -> Either EncodingException String
decodeWithTE TextEncoding
enc ShortByteString
ba = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  Either SomeException String
r <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ forall a. ShortByteString -> (CStringLen -> IO a) -> IO a
BS8.useAsCStringLen ShortByteString
ba forall a b. (a -> b) -> a -> b
$ \CStringLen
fp -> TextEncoding -> CStringLen -> IO String
GHC.peekCStringLen TextEncoding
enc CStringLen
fp
  forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Maybe Word8 -> EncodingException
EncodingError forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> String
displayException) Either SomeException String
r

-- | Encode with the given 'TextEncoding'.
encodeWithTE :: TextEncoding -> String -> Either EncodingException BS8.ShortByteString
encodeWithTE :: TextEncoding -> String -> Either EncodingException ShortByteString
encodeWithTE TextEncoding
enc String
str = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  Either SomeException ShortByteString
r <- forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException forall a b. (a -> b) -> a -> b
$ forall a. TextEncoding -> String -> (CStringLen -> IO a) -> IO a
GHC.withCStringLen TextEncoding
enc String
str forall a b. (a -> b) -> a -> b
$ \CStringLen
cstr -> CStringLen -> IO ShortByteString
BS8.packCStringLen CStringLen
cstr
  forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ forall a. NFData a => a -> a
force forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Maybe Word8 -> EncodingException
EncodingError forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> String
displayException) Either SomeException ShortByteString
r

-- -----------------------------------------------------------------------------
-- Encoders / decoders
--

-- | This mimics the filepath decoder base uses on unix,
-- with the small distinction that we're not truncating at NUL bytes (because we're not at
-- the outer FFI layer).
decodeWithBasePosix :: BS8.ShortByteString -> IO String
decodeWithBasePosix :: ShortByteString -> IO String
decodeWithBasePosix ShortByteString
ba = forall a. ShortByteString -> (CStringLen -> IO a) -> IO a
BS8.useAsCStringLen ShortByteString
ba forall a b. (a -> b) -> a -> b
$ \CStringLen
fp -> CStringLen -> IO String
peekFilePathPosix CStringLen
fp

-- | This mimics the filepath dencoder base uses on unix,
-- with the small distinction that we're not truncating at NUL bytes (because we're not at
-- the outer FFI layer).
encodeWithBasePosix :: String -> IO BS8.ShortByteString
encodeWithBasePosix :: String -> IO ShortByteString
encodeWithBasePosix String
str = forall a. String -> (CStringLen -> IO a) -> IO a
withFilePathPosix String
str forall a b. (a -> b) -> a -> b
$ \CStringLen
cstr -> CStringLen -> IO ShortByteString
BS8.packCStringLen CStringLen
cstr

-- | This mimics the filepath decoder base uses on windows,
-- with the small distinction that we're not truncating at NUL bytes (because we're not at
-- the outer FFI layer).
decodeWithBaseWindows :: BS16.ShortByteString -> IO String
decodeWithBaseWindows :: ShortByteString -> IO String
decodeWithBaseWindows ShortByteString
ba = forall a. ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a
BS16.useAsCWStringLen ShortByteString
ba forall a b. (a -> b) -> a -> b
$ \(Ptr Word16, Int)
fp -> (Ptr Word16, Int) -> IO String
peekFilePathWin (Ptr Word16, Int)
fp

-- | This mimics the filepath dencoder base uses on windows,
-- with the small distinction that we're not truncating at NUL bytes (because we're not at
-- the outer FFI layer).
encodeWithBaseWindows :: String -> IO BS16.ShortByteString
encodeWithBaseWindows :: String -> IO ShortByteString
encodeWithBaseWindows String
str = forall a. String -> (Int -> Ptr Word16 -> IO a) -> IO a
withFilePathWin String
str forall a b. (a -> b) -> a -> b
$ \Int
l Ptr Word16
cstr -> (Ptr Word16, Int) -> IO ShortByteString
BS16.packCWStringLen (Ptr Word16
cstr, Int
l)


-- -----------------------------------------------------------------------------
-- Types
--

data EncodingException =
    EncodingError String (Maybe Word8)
    -- ^ Could not decode a byte sequence because it was invalid under
    -- the given encoding, or ran out of input in mid-decode.
    deriving (EncodingException -> EncodingException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EncodingException -> EncodingException -> Bool
$c/= :: EncodingException -> EncodingException -> Bool
== :: EncodingException -> EncodingException -> Bool
$c== :: EncodingException -> EncodingException -> Bool
Eq, Typeable)


showEncodingException :: EncodingException -> String
showEncodingException :: EncodingException -> String
showEncodingException (EncodingError String
desc (Just Word8
w))
    = String
"Cannot decode byte '\\x" forall a. [a] -> [a] -> [a]
++ forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w (String
"': " forall a. [a] -> [a] -> [a]
++ String
desc)
showEncodingException (EncodingError String
desc Maybe Word8
Nothing)
    = String
"Cannot decode input: " forall a. [a] -> [a] -> [a]
++ String
desc

instance Show EncodingException where
    show :: EncodingException -> String
show = EncodingException -> String
showEncodingException

instance Exception EncodingException

instance NFData EncodingException where
    rnf :: EncodingException -> ()
rnf (EncodingError String
desc Maybe Word8
w) = forall a. NFData a => a -> ()
rnf String
desc seq :: forall a b. a -> b -> b
`seq` forall a. NFData a => a -> ()
rnf Maybe Word8
w


-- -----------------------------------------------------------------------------
-- Words
--

wNUL :: Word16
wNUL :: Word16
wNUL = Word16
0x00