{-# LANGUAGE CPP #-}
module Graphics.Vty.UnicodeWidthTable.IO
  ( readUnicodeWidthTable
  , parseUnicodeWidthTable
  , writeUnicodeWidthTable
  )
where

import Control.Monad (when, forM)
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as BSL
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif

import Graphics.Vty.UnicodeWidthTable.Types

-- | Load a binary unicode width table from the specified file.
--
-- This either returns a successfully parsed table or a table parsing
-- error message. This does not handle I/O exceptions.
readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
readUnicodeWidthTable :: String -> IO (Either String UnicodeWidthTable)
readUnicodeWidthTable String
path = ByteString -> Either String UnicodeWidthTable
parseUnicodeWidthTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BSL.readFile String
path

-- | Parse a binary unicode width table.
parseUnicodeWidthTable :: BSL.ByteString -> Either String UnicodeWidthTable
parseUnicodeWidthTable :: ByteString -> Either String UnicodeWidthTable
parseUnicodeWidthTable ByteString
bs =
    case forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, String) (ByteString, Int64, a)
runGetOrFail Get UnicodeWidthTable
tableParser ByteString
bs of
        Left (ByteString
_, Int64
_, String
msg) ->
            forall a b. a -> Either a b
Left String
msg

        -- Even if we parsed a table, leftover bytes indicate something
        -- could be wrong.
        Right (ByteString
remainingBytes, Int64
_, UnicodeWidthTable
_) | Bool -> Bool
not (ByteString -> Bool
BSL.null ByteString
remainingBytes) ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (ByteString -> Int64
BSL.length ByteString
remainingBytes) forall a. Semigroup a => a -> a -> a
<>
                   String
" byte(s) left unconsumed"

        Right (ByteString
_, Int64
_, UnicodeWidthTable
table) ->
            forall a b. b -> Either a b
Right UnicodeWidthTable
table

-- | Write the unicode width table to the specified path.
--
-- This does not handle I/O exceptions.
writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable :: String -> UnicodeWidthTable -> IO ()
writeUnicodeWidthTable String
path UnicodeWidthTable
table = do
    let body :: ByteString
body = Put -> ByteString
runPut (UnicodeWidthTable -> Put
tableV1Writer UnicodeWidthTable
table)
    String -> ByteString -> IO ()
BSL.writeFile String
path ByteString
body

-- | Width table magic bytes for use in the binary format.
widthTableMagic :: Word32
widthTableMagic :: Word32
widthTableMagic = Word32
0xc1a9f7e0

tableParser :: Get UnicodeWidthTable
tableParser :: Get UnicodeWidthTable
tableParser = do
    Word32
magic <- Get Word32
getWord32le

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
magic forall a. Eq a => a -> a -> Bool
/= Word32
widthTableMagic) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Table magic number invalid"

    Word8
version <- Get Word8
getWord8

    case Word8
version of
        Word8
1 -> Get UnicodeWidthTable
tableV1Parser
        Word8
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Table version invalid"

tableV1Parser :: Get UnicodeWidthTable
tableV1Parser :: Get UnicodeWidthTable
tableV1Parser = do
    Word32
numRanges <- Get Word32
getWord32le

    let parseRange :: Get WidthTableRange
parseRange = do
            Word32
start <- Get Word32
getWord32le
            Word32
size <- Get Word32
getWord32le
            Word8
cols <- Get Word8
getWord8
            forall (m :: * -> *) a. Monad m => a -> m a
return WidthTableRange { rangeStart :: Word32
rangeStart = Word32
start
                                   , rangeSize :: Word32
rangeSize = Word32
size
                                   , rangeColumns :: Word8
rangeColumns = Word8
cols
                                   }

    [WidthTableRange]
ranges <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word32
1..Word32
numRanges] forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Get WidthTableRange
parseRange

    forall (m :: * -> *) a. Monad m => a -> m a
return UnicodeWidthTable { unicodeWidthTableRanges :: [WidthTableRange]
unicodeWidthTableRanges = [WidthTableRange]
ranges
                             }

tableV1Writer :: UnicodeWidthTable -> Put
tableV1Writer :: UnicodeWidthTable -> Put
tableV1Writer UnicodeWidthTable
table = do
    -- Magic bytes
    Word32 -> Put
putWord32le Word32
widthTableMagic

    -- Version
    Word8 -> Put
putWord8 Word8
1

    -- Number of ranges
    let ranges :: [WidthTableRange]
ranges = UnicodeWidthTable -> [WidthTableRange]
unicodeWidthTableRanges UnicodeWidthTable
table
    let numRanges :: Int
numRanges = forall (t :: * -> *) a. Foldable t => t a -> Int
length [WidthTableRange]
ranges
    Word32 -> Put
putWord32le (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numRanges)

    -- Ranges
    let putRange :: WidthTableRange -> Put
putRange WidthTableRange
r = do
            Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word32
rangeStart WidthTableRange
r
            Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word32
rangeSize WidthTableRange
r
            Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ WidthTableRange -> Word8
rangeColumns WidthTableRange
r

    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ WidthTableRange -> Put
putRange [WidthTableRange]
ranges