    {-# 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 :: FilePath -> IO (Either FilePath UnicodeWidthTable)
    readUnicodeWidthTable path :: FilePath
    path = ByteString -> Either FilePath UnicodeWidthTable
    parseUnicodeWidthTable (ByteString -> Either FilePath UnicodeWidthTable)
    -> IO ByteString -> IO (Either FilePath UnicodeWidthTable)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO ByteString
    BSL.readFile FilePath
    path

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

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

            Right (_, _, table :: UnicodeWidthTable
    table) ->
                UnicodeWidthTable -> Either FilePath UnicodeWidthTable
    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 :: FilePath -> UnicodeWidthTable -> IO ()
    writeUnicodeWidthTable path :: FilePath
    path table :: UnicodeWidthTable
    table = do
        let body :: ByteString
    body = Put -> ByteString
    runPut (UnicodeWidthTable -> Put
    tableV1Writer UnicodeWidthTable
    table)
        FilePath -> ByteString -> IO ()
    BSL.writeFile FilePath
    path ByteString
    body

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

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

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

        Word8
    version <- Get Word8
    getWord8

        case Word8
    version of
            1 -> Get UnicodeWidthTable
    tableV1Parser
            _ -> FilePath -> Get UnicodeWidthTable
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail "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
                WidthTableRange -> Get WidthTableRange
    forall (m :: * -> *) a. Monad m => a -> m a
    return WidthTableRange :: Word32 -> Word32 -> Word8 -> WidthTableRange
    WidthTableRange { rangeStart :: Word32
    rangeStart = Word32
    start
                                       , rangeSize :: Word32
    rangeSize = Word32
    size
                                       , rangeColumns :: Word8
    rangeColumns = Word8
    cols
                                       }

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

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

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

        -- Version
        Word8 -> Put
    putWord8 1

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

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

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