Merge branch 'UTF-16LE_b'

Author: hasufell

Generate.hs

@@ -48,12 +48,12 @@ main = do
         ,"import qualified System.OsPath.Windows as AFP_W"
         ,"import qualified System.OsPath.Posix as AFP_P"
 #endif
-        ,"instance IsString WindowsString where fromString = WS . either (error . show) id . encodeWith (mkUTF16le TransliterateCodingFailure)"
-        ,"instance IsString PosixString where fromString = PS . either (error . show) id . encodeWith (mkUTF8 TransliterateCodingFailure)"
+        ,"instance IsString WindowsString where fromString = WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
+        ,"instance IsString PosixString where fromString = PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
         ,"#if defined(mingw32_HOST_OS) || defined(__MINGW32__)"
-        ,"instance IsString OsString where fromString = OsString . WS . either (error . show) id . encodeWith (mkUTF16le TransliterateCodingFailure)"
+        ,"instance IsString OsString where fromString = OsString . WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
         ,"#else"
-        ,"instance IsString OsString where fromString = OsString . PS . either (error . show) id . encodeWith (mkUTF8 TransliterateCodingFailure)"
+        ,"instance IsString OsString where fromString = OsString . PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
         ,"#endif"
         ,"tests :: [(String, Property)]"
         ,"tests ="] ++

System/FilePath/Internal.hs

@@ -127,7 +127,7 @@ import Data.List(stripPrefix, isSuffixOf, uncons)
 #define FILEPATH FilePath
 #else
 import Prelude (fromIntegral)
-import System.OsPath.Encoding ( encodeWith )
+import System.OsPath.Encoding ( encodeWithTE )
 import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )
 import qualified Data.Char as C
 #ifdef WINDOWS
@@ -1180,10 +1180,10 @@ snoc str = \c -> str <> [c]
 #else
 #ifdef WINDOWS
 fromString :: P.String -> STRING
-fromString = P.either (P.error . P.show) P.id . encodeWith (mkUTF16le ErrorOnCodingFailure)
+fromString = P.either (P.error . P.show) P.id . encodeWithTE (mkUTF16le ErrorOnCodingFailure)
 #else
 fromString :: P.String -> STRING
-fromString = P.either (P.error . P.show) P.id . encodeWith (mkUTF8 ErrorOnCodingFailure)
+fromString = P.either (P.error . P.show) P.id . encodeWithTE (mkUTF8 ErrorOnCodingFailure)
 #endif
 
 _a, _z, _A, _Z, _period, _quotedbl, _backslash, _slash, _question, _U, _N, _C, _colon, _semicolon, _US, _less, _greater, _bar, _asterisk, _nul, _space, _underscore :: CHAR

System/OsPath/Common.hs

@@ -40,32 +40,21 @@ module System.OsPath
   , OsChar
 #endif
   -- * Filepath construction
+  , PS.encodeUtf
+  , PS.encodeWith
+  , PS.encodeFS
 #if defined(WINDOWS) || defined(POSIX)
-  , toPlatformStringUtf
-  , toPlatformStringEnc
-  , toPlatformStringFS
   , pstr
-  , packPlatformString
 #else
-  , toOsPathUtf
-  , toOsPathEnc
-  , toOsPathFS
   , osp
-  , packOsPath
 #endif
+  , PS.pack
 
   -- * Filepath deconstruction
-#if defined(WINDOWS) || defined(POSIX)
-  , fromPlatformStringUtf
-  , fromPlatformStringEnc
-  , fromPlatformStringFS
-  , unpackPlatformString
-#else
-  , fromOsPathUtf
-  , fromOsPathEnc
-  , fromOsPathFS
-  , unpackOsPath
-#endif
+  , PS.decodeUtf
+  , PS.decodeWith
+  , PS.decodeFS
+  , PS.unpack
 
   -- * Word construction
   , unsafeFromChar
@@ -119,53 +108,53 @@ where
 
 #ifdef WINDOWS
 import System.OsPath.Types
-import System.OsString.Windows
+import System.OsString.Windows as PS
     ( unsafeFromChar
     , toChar
-    , fromPlatformStringUtf
-    , fromPlatformStringEnc
-    , fromPlatformStringFS
-    , packPlatformString
+    , decodeUtf
+    , decodeWith
+    , decodeFS
+    , pack
     , pstr
-    , toPlatformStringUtf
-    , toPlatformStringEnc
-    , toPlatformStringFS
-    , unpackPlatformString
+    , encodeUtf
+    , encodeWith
+    , encodeFS
+    , unpack
     )
 import Data.Bifunctor ( bimap )
 import qualified System.OsPath.Windows.Internal as C
 
 #elif defined(POSIX)
 
 import System.OsPath.Types
-import System.OsString.Posix
+import System.OsString.Posix as PS
     ( unsafeFromChar
     , toChar
-    , fromPlatformStringUtf
-    , fromPlatformStringEnc
-    , fromPlatformStringFS
-    , packPlatformString
+    , decodeUtf
+    , decodeWith
+    , decodeFS
+    , pack
     , pstr
-    , toPlatformStringUtf
-    , toPlatformStringEnc
-    , toPlatformStringFS
-    , unpackPlatformString
+    , encodeUtf
+    , encodeWith
+    , encodeFS
+    , unpack
     )
 import Data.Bifunctor ( bimap )
 import qualified System.OsPath.Posix.Internal as C
 
 #else
 
-import System.OsPath.Internal
+import System.OsPath.Internal as PS
     ( osp
-    , fromOsPathUtf
-    , fromOsPathEnc
-    , fromOsPathFS
-    , packOsPath
-    , toOsPathUtf
-    , toOsPathEnc
-    , toOsPathFS
-    , unpackOsPath
+    , decodeUtf
+    , decodeWith
+    , decodeFS
+    , pack
+    , encodeUtf
+    , encodeWith
+    , encodeFS
+    , unpack
     )
 import System.OsPath.Types
     ( OsPath )

System/OsPath/Encoding.hs

@@ -12,9 +12,17 @@ module System.OsPath.Encoding
   , ucs2le_decode
   , ucs2le_encode
 
+  -- * UTF-16LE_b
+  , utf16le_b
+  , mkUTF16le_b
+  , utf16le_b_DF
+  , utf16le_b_EF
+  , utf16le_b_decode
+  , utf16le_b_encode
+
   -- * base encoding
-  , encodeWith
-  , decodeWith
+  , encodeWithTE
+  , decodeWithTE
   , encodeWithBasePosix
   , decodeWithBasePosix
   , encodeWithBaseWindows

System/OsPath/Encoding/Internal.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude
            , BangPatterns
            , TypeApplications
+           , MultiWayIf
   #-}
 {-# OPTIONS_GHC  -funbox-strict-fields #-}
 
@@ -114,11 +115,120 @@ ucs2le_encode
     in
     loop ir0 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 = mkUTF16le_b ErrorOnCodingFailure
+
+mkUTF16le_b :: CodingFailureMode -> TextEncoding
+mkUTF16le_b cfm = TextEncoding { textEncodingName = "UTF-16LE_b",
+                                 mkTextDecoder = utf16le_b_DF cfm,
+                                 mkTextEncoder = utf16le_b_EF cfm }
+
+utf16le_b_DF :: CodingFailureMode -> IO (TextDecoder ())
+utf16le_b_DF cfm =
+  return (BufferCodec {
+             encode   = utf16le_b_decode,
+             recover  = recoverDecode cfm,
+             close    = return (),
+             getState = return (),
+             setState = const $ return ()
+          })
+
+utf16le_b_EF :: CodingFailureMode -> IO (TextEncoder ())
+utf16le_b_EF cfm =
+  return (BufferCodec {
+             encode   = utf16le_b_encode,
+             recover  = recoverEncode cfm,
+             close    = return (),
+             getState = return (),
+             setState = const $ return ()
+          })
+
+
+utf16le_b_decode :: DecodeBuffer
+utf16le_b_decode
+  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
+  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
+ = let
+       loop !ir !ow
+         | ow >= os     = done OutputUnderflow ir ow
+         | ir >= iw     = done InputUnderflow ir ow
+         | ir + 1 == iw = done InputUnderflow ir ow
+         | otherwise = do
+              c0 <- readWord8Buf iraw ir
+              c1 <- readWord8Buf iraw (ir+1)
+              let x1 = fromIntegral c1 `shiftL` 8 + fromIntegral c0
+              if | iw - ir >= 4 -> do
+                      c2 <- readWord8Buf iraw (ir+2)
+                      c3 <- readWord8Buf iraw (ir+3)
+                      let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2
+                      if | 0xd800 <= x1 && x1 <= 0xdbff
+                         , 0xdc00 <= x2 && x2 <= 0xdfff -> do
+                             ow' <- writeCharBuf oraw ow (unsafeChr ((x1 - 0xd800)*0x400 + (x2 - 0xdc00) + 0x10000))
+                             loop (ir+4) ow'
+                         | otherwise -> do
+                             ow' <- writeCharBuf oraw ow (unsafeChr x1)
+                             loop (ir+2) ow'
+                 | iw - ir >= 2 -> do
+                        ow' <- writeCharBuf oraw ow (unsafeChr x1)
+                        loop (ir+2) ow'
+                 | otherwise -> done InputUnderflow ir ow
+
+       -- lambda-lifted, to avoid thunks being built in the inner-loop:
+       done why !ir !ow = return (why,
+                                  if ir == iw then input{ bufL=0, bufR=0 }
+                                              else input{ bufL=ir },
+                                  output{ bufR=ow })
+    in
+    loop ir0 ow0
+
+
+utf16le_b_encode :: EncodeBuffer
+utf16le_b_encode
+  input@Buffer{  bufRaw=iraw, bufL=ir0, bufR=iw,  bufSize=_  }
+  output@Buffer{ bufRaw=oraw, bufL=_,   bufR=ow0, bufSize=os }
+ = let
+      done why !ir !ow = return (why,
+                                 if ir == iw then input{ bufL=0, bufR=0 }
+                                             else input{ bufL=ir },
+                                 output{ bufR=ow })
+      loop !ir !ow
+        | ir >= iw     =  done InputUnderflow ir ow
+        | os - ow < 2  =  done OutputUnderflow ir ow
+        | otherwise = do
+           (c,ir') <- readCharBuf iraw ir
+           case ord c of
+             x | x < 0x10000 -> do
+                     writeWord8Buf oraw ow     (fromIntegral x)
+                     writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8))
+                     loop ir' (ow+2)
+               | otherwise ->
+                     if os - ow < 4 then done OutputUnderflow ir ow else do
+                     let x' = x - 0x10000
+                         w1 = x' `div` 0x400 + 0xd800
+                         w2 = x' `mod` 0x400 + 0xdc00
+                     writeWord8Buf oraw ow     (fromIntegral w1)
+                     writeWord8Buf oraw (ow+1) (fromIntegral (w1 `shiftR` 8))
+                     writeWord8Buf oraw (ow+2) (fromIntegral w2)
+                     writeWord8Buf oraw (ow+3) (fromIntegral (w2 `shiftR` 8))
+                     loop ir' (ow+4)
+    in
+    loop ir0 ow0
 
 -- -----------------------------------------------------------------------------
 -- Windows encoding (ripped off from base)
 --
 
+cWcharsToChars_UCS2 :: [Word16] -> [Char]
+cWcharsToChars_UCS2 = map (chr . fromIntegral)
 
 
 -- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding.
@@ -185,14 +295,14 @@ peekFilePathLenPosix fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen e
 --
 
 -- | Decode with the given 'TextEncoding'.
-decodeWith :: TextEncoding -> BS8.ShortByteString -> Either EncodingException String
-decodeWith enc ba = unsafePerformIO $ do
+decodeWithTE :: TextEncoding -> BS8.ShortByteString -> Either EncodingException String
+decodeWithTE enc ba = unsafePerformIO $ do
   r <- try @SomeException $ BS8.useAsCStringLen ba $ \fp -> GHC.peekCStringLen enc fp
   evaluate $ force $ first (flip EncodingError Nothing . displayException) r
 
 -- | Encode with the given 'TextEncoding'.
-encodeWith :: TextEncoding -> String -> Either EncodingException BS8.ShortByteString
-encodeWith enc str = unsafePerformIO $ do
+encodeWithTE :: TextEncoding -> String -> Either EncodingException BS8.ShortByteString
+encodeWithTE enc str = unsafePerformIO $ do
   r <- try @SomeException $ GHC.withCStringLen enc str $ \cstr -> BS8.packCStringLen cstr
   evaluate $ force $ first (flip EncodingError Nothing . displayException) r