{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE Trustworthy #-}

module GHC.Internal.IO.Encoding.CodePage(
#if defined(mingw32_HOST_OS)
                        codePageEncoding, mkCodePageEncoding,
                        localeEncoding, mkLocaleEncoding, CodePage,
                        getCurrentCodePage
#endif
                            ) where

#if !defined(mingw32_HOST_OS)

-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base
import GHC.Types ()

#else
import GHC.Internal.Base
import GHC.Internal.Show
import GHC.Internal.Num
import GHC.Internal.Enum
import GHC.Internal.Word
import GHC.Internal.IO (unsafePerformIO)
import GHC.Internal.IO.Encoding.Failure
import GHC.Internal.IO.Encoding.Types
import GHC.Internal.IO.Buffer
import GHC.Internal.Data.Bits
import GHC.Internal.Data.Maybe
import GHC.Internal.Data.OldList (lookup)

import qualified GHC.Internal.IO.Encoding.CodePage.API as API
import GHC.Internal.IO.Encoding.CodePage.Table

import GHC.Internal.IO.Encoding.UTF8 (mkUTF8)
import GHC.Internal.IO.Encoding.UTF16 (mkUTF16le, mkUTF16be)
import GHC.Internal.IO.Encoding.UTF32 (mkUTF32le, mkUTF32be)

import GHC.Internal.Windows (DWORD)

#include "windows_cconv.h"

type CodePage = DWORD

-- note CodePage = UInt which might not work on Win64.  But the Win32 package
-- also has this issue.
getCurrentCodePage :: IO CodePage
getCurrentCodePage :: IO Word32
getCurrentCodePage = do
    conCP <- IO Word32
getConsoleCP
    if conCP > 0
        then return conCP
        else getACP

-- Since the Win32 package depends on base, we have to import these ourselves:
foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCP"
    getConsoleCP :: IO Word32

foreign import WINDOWS_CCONV unsafe "windows.h GetACP"
    getACP :: IO Word32

{-# NOINLINE currentCodePage #-}
currentCodePage :: Word32
currentCodePage :: Word32
currentCodePage = IO Word32 -> Word32
forall a. IO a -> a
unsafePerformIO IO Word32
getCurrentCodePage

localeEncoding :: TextEncoding
localeEncoding :: TextEncoding
localeEncoding = CodingFailureMode -> TextEncoding
mkLocaleEncoding CodingFailureMode
ErrorOnCodingFailure

mkLocaleEncoding :: CodingFailureMode -> TextEncoding
mkLocaleEncoding :: CodingFailureMode -> TextEncoding
mkLocaleEncoding CodingFailureMode
cfm = CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding CodingFailureMode
cfm Word32
currentCodePage


codePageEncoding :: Word32 -> TextEncoding
codePageEncoding :: Word32 -> TextEncoding
codePageEncoding = CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding CodingFailureMode
ErrorOnCodingFailure

mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding
mkCodePageEncoding CodingFailureMode
cfm Word32
65001 = CodingFailureMode -> TextEncoding
mkUTF8 CodingFailureMode
cfm
mkCodePageEncoding CodingFailureMode
cfm Word32
1200 = CodingFailureMode -> TextEncoding
mkUTF16le CodingFailureMode
cfm
mkCodePageEncoding CodingFailureMode
cfm Word32
1201 = CodingFailureMode -> TextEncoding
mkUTF16be CodingFailureMode
cfm
mkCodePageEncoding CodingFailureMode
cfm Word32
12000 = CodingFailureMode -> TextEncoding
mkUTF32le CodingFailureMode
cfm
mkCodePageEncoding CodingFailureMode
cfm Word32
12001 = CodingFailureMode -> TextEncoding
mkUTF32be CodingFailureMode
cfm
mkCodePageEncoding CodingFailureMode
cfm Word32
cp = TextEncoding
-> (CodePageArrays -> TextEncoding)
-> Maybe CodePageArrays
-> TextEncoding
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CodingFailureMode -> Word32 -> TextEncoding
API.mkCodePageEncoding CodingFailureMode
cfm Word32
cp) (CodingFailureMode -> Word32 -> CodePageArrays -> TextEncoding
buildEncoding CodingFailureMode
cfm Word32
cp) (Word32 -> [(Word32, CodePageArrays)] -> Maybe CodePageArrays
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word32
cp [(Word32, CodePageArrays)]
codePageMap)

buildEncoding :: CodingFailureMode -> Word32 -> CodePageArrays -> TextEncoding
buildEncoding :: CodingFailureMode -> Word32 -> CodePageArrays -> TextEncoding
buildEncoding CodingFailureMode
cfm Word32
cp SingleByteCP {decoderArray :: CodePageArrays -> ConvArray Char
decoderArray = ConvArray Char
dec, encoderArray :: CodePageArrays -> CompactArray Char Word8
encoderArray = CompactArray Char Word8
enc}
  = TextEncoding {
      textEncodingName :: String
textEncodingName = String
"CP" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
cp
    , mkTextDecoder :: IO (TextDecoder ())
mkTextDecoder = TextDecoder () -> IO (TextDecoder ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TextDecoder () -> IO (TextDecoder ()))
-> TextDecoder () -> IO (TextDecoder ())
forall a b. (a -> b) -> a -> b
$ (Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char))
-> (Buffer Word8
    -> Buffer Char -> IO (CodingProgress, Buffer Word8, Buffer Char))
-> TextDecoder ()
forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Buffer from
    -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to))
-> BufferCodec from to ()
simpleCodec (CodingFailureMode
-> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
recoverDecode CodingFailureMode
cfm) ((Buffer Word8
  -> Buffer Char -> IO (CodingProgress, Buffer Word8, Buffer Char))
 -> TextDecoder ())
-> (Buffer Word8
    -> Buffer Char -> IO (CodingProgress, Buffer Word8, Buffer Char))
-> TextDecoder ()
forall a b. (a -> b) -> a -> b
$ ConvArray Char
-> Buffer Word8
-> Buffer Char
-> IO (CodingProgress, Buffer Word8, Buffer Char)
decodeFromSingleByte ConvArray Char
dec
    , mkTextEncoder :: IO (TextEncoder ())
mkTextEncoder = TextEncoder () -> IO (TextEncoder ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TextEncoder () -> IO (TextEncoder ()))
-> TextEncoder () -> IO (TextEncoder ())
forall a b. (a -> b) -> a -> b
$ (Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8))
-> (Buffer Char
    -> Buffer Word8 -> IO (CodingProgress, Buffer Char, Buffer Word8))
-> TextEncoder ()
forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Buffer from
    -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to))
-> BufferCodec from to ()
simpleCodec (CodingFailureMode
-> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
recoverEncode CodingFailureMode
cfm) ((Buffer Char
  -> Buffer Word8 -> IO (CodingProgress, Buffer Char, Buffer Word8))
 -> TextEncoder ())
-> (Buffer Char
    -> Buffer Word8 -> IO (CodingProgress, Buffer Char, Buffer Word8))
-> TextEncoder ()
forall a b. (a -> b) -> a -> b
$ CompactArray Char Word8
-> Buffer Char
-> Buffer Word8
-> IO (CodingProgress, Buffer Char, Buffer Word8)
encodeToSingleByte CompactArray Char Word8
enc
    }

simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
            -> (Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to))
                -> BufferCodec from to ()
simpleCodec :: forall from to.
(Buffer from -> Buffer to -> IO (Buffer from, Buffer to))
-> (Buffer from
    -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to))
-> BufferCodec from to ()
simpleCodec Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
r Buffer from
-> Buffer to -> IO (CodingProgress, Buffer from, Buffer to)
f = BufferCodec {
    encode :: Buffer from
-> Buffer to -> IO (CodingProgress, Buffer from, Buffer to)
encode = Buffer from
-> Buffer to -> IO (CodingProgress, Buffer from, Buffer to)
f,
    recover :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover = Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
r,
    close :: IO ()
close = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (),
    getState :: IO ()
getState = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (),
    setState :: () -> IO ()
setState = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  }

decodeFromSingleByte :: ConvArray Char -> DecodeBuffer
decodeFromSingleByte :: ConvArray Char
-> Buffer Word8
-> Buffer Char
-> IO (CodingProgress, Buffer Word8, Buffer Char)
decodeFromSingleByte ConvArray Char
convArr
    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
        done :: a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done a
why !Int
ir !Int
ow = (a, Buffer Word8, Buffer Char) -> m (a, Buffer Word8, Buffer Char)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                   if Int
irInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
iw then Buffer Word8
input{ bufL=0, bufR=0}
                                             else Buffer Word8
input{ bufL=ir},
                                   Buffer Char
output {bufR=ow})
        loop :: Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop !Int
ir !Int
ow
            | Int
ow Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
os  = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
OutputUnderflow Int
ir Int
ow
            | Int
ir Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
iw  = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InputUnderflow Int
ir Int
ow
            | Bool
otherwise = do
                b <- RawBuffer Word8 -> Int -> IO Word8
readWord8Buf RawBuffer Word8
iraw Int
ir
                let c = ConvArray Char -> Word8 -> Char
lookupConv ConvArray Char
convArr Word8
b
                if c=='\0' && b /= 0 then invalid else do
                ow' <- writeCharBuf oraw ow c
                loop (ir+1) ow'
          where
            invalid :: IO (CodingProgress, Buffer Word8, Buffer Char)
invalid = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Word8, Buffer Char)
done CodingProgress
InvalidSequence Int
ir Int
ow
    in Int -> Int -> IO (CodingProgress, Buffer Word8, Buffer Char)
loop Int
ir0 Int
ow0

encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer
encodeToSingleByte :: CompactArray Char Word8
-> Buffer Char
-> Buffer Word8
-> IO (CodingProgress, Buffer Char, Buffer Word8)
encodeToSingleByte CompactArray { encoderMax :: forall a b. CompactArray a b -> a
encoderMax = Char
maxChar,
                         encoderIndices :: forall a b. CompactArray a b -> ConvArray Int
encoderIndices = ConvArray Int
indices,
                         encoderValues :: forall a b. CompactArray a b -> ConvArray b
encoderValues = ConvArray Word8
values }
    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 = (a, Buffer Char, Buffer Word8) -> m (a, Buffer Char, Buffer Word8)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
why,
                                   if Int
irInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
iw then Buffer Char
input { bufL=0, bufR=0 }
                                             else Buffer Char
input { bufL=ir },
                                   Buffer Word8
output {bufR=ow})
        loop :: Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop !Int
ir !Int
ow
            | Int
ow Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
os  = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
OutputUnderflow Int
ir Int
ow
            | Int
ir Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
iw  = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
forall {m :: * -> *} {a}.
Monad m =>
a -> Int -> Int -> m (a, Buffer Char, Buffer Word8)
done CodingProgress
InputUnderflow Int
ir Int
ow
            | Bool
otherwise = do
                (c,ir') <- RawBuffer Char -> Int -> IO (Char, Int)
readCharBuf RawBuffer Char
iraw Int
ir
                case lookupCompact maxChar indices values c of
                    Maybe Word8
Nothing -> IO (CodingProgress, Buffer Char, Buffer Word8)
invalid
                    Just Word8
0 | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0' -> IO (CodingProgress, Buffer Char, Buffer Word8)
invalid
                    Just Word8
b -> do
                        RawBuffer Word8 -> Int -> Word8 -> IO ()
writeWord8Buf RawBuffer Word8
oraw Int
ow Word8
b
                        Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
loop Int
ir' (Int
owInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            where
                invalid :: IO (CodingProgress, Buffer Char, Buffer Word8)
invalid = CodingProgress
-> Int -> Int -> IO (CodingProgress, Buffer Char, Buffer Word8)
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


--------------------------------------------
-- Array access functions

-- {-# INLINE lookupConv #-}
lookupConv :: ConvArray Char -> Word8 -> Char
lookupConv :: ConvArray Char -> Word8 -> Char
lookupConv ConvArray Char
a = ConvArray Char -> Int -> Char
indexChar ConvArray Char
a (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum

{-# INLINE lookupCompact #-}
lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8
lookupCompact :: Char -> ConvArray Int -> ConvArray Word8 -> Char -> Maybe Word8
lookupCompact Char
maxVal ConvArray Int
indexes ConvArray Word8
values Char
x
    | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> Char
maxVal = Maybe Word8
forall a. Maybe a
Nothing
    | Bool
otherwise = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$ ConvArray Word8 -> Int -> Word8
indexWord8 ConvArray Word8
values (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
i Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask)
  where
    i :: Int
i = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
x
    mask :: Int
mask = (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
n) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    k :: Int
k = Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
n
    j :: Int
j = ConvArray Int -> Int -> Int
indexInt ConvArray Int
indexes Int
k
    n :: Int
n = Int
blockBitSize

{-# INLINE indexInt #-}
indexInt :: ConvArray Int -> Int -> Int
indexInt :: ConvArray Int -> Int -> Int
indexInt (ConvArray Addr#
p) (I# Int#
i) = Int# -> Int
I# (Int16# -> Int#
int16ToInt# (Addr# -> Int# -> Int16#
indexInt16OffAddr# Addr#
p Int#
i))

{-# INLINE indexWord8 #-}
indexWord8 :: ConvArray Word8 -> Int -> Word8
indexWord8 :: ConvArray Word8 -> Int -> Word8
indexWord8 (ConvArray Addr#
p) (I# Int#
i) = Word8# -> Word8
W8# (Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
p Int#
i)

{-# INLINE indexChar #-}
indexChar :: ConvArray Char -> Int -> Char
indexChar :: ConvArray Char -> Int -> Char
indexChar (ConvArray Addr#
p) (I# Int#
i) = Char# -> Char
C# (Int# -> Char#
chr# (Int16# -> Int#
int16ToInt# (Addr# -> Int# -> Int16#
indexInt16OffAddr# Addr#
p Int#
i)))

#endif