@@ -0,0 +1,117 @@
1+module Graphics.Vty.UnicodeWidthTable.IO
2+ ( readUnicodeWidthTable
3+ , writeUnicodeWidthTable
4+ )
5+where
6+
7+import Control.Monad (when, forM)
8+import Data.Binary
9+import Data.Binary.Get
10+import Data.Binary.Put
11+import qualified Data.ByteString.Lazy as BSL
12+
13+import Graphics.Vty.UnicodeWidthTable.Types
14+
15+-- | Load a binary unicode width table from the specified file.
16+--
17+-- This either returns a successfully parsed table or a table parsing
18+-- error message. This does not handle I/O exceptions.
19+readUnicodeWidthTable :: FilePath -> IO (Either String UnicodeWidthTable)
20+readUnicodeWidthTable path = do
21+ body <- BSL.readFile path
22+ case runGetOrFail tableParser body of
23+ Left (_, _, msg) ->
24+ return $ Left msg
25+
26+ -- Even if we parsed a table, leftover bytes indicate something
27+ -- could be wrong.
28+ Right (remainingBytes, _, _) | not (BSL.null remainingBytes) ->
29+ return $ Left $ "Error: " <> show (BSL.length remainingBytes) <>
30+ " byte(s) left unconsumed"
31+
32+ Right (_, _, table) ->
33+ return $ Right table
34+
35+-- | Write the unicode width table to the specified path.
36+--
37+-- This does not handle I/O exceptions.
38+writeUnicodeWidthTable :: FilePath -> UnicodeWidthTable -> IO ()
39+writeUnicodeWidthTable path table = do
40+ let body = runPut (tableV1Writer table)
41+ BSL.writeFile path body
42+
43+-- | Width table magic bytes for use in the binary format.
44+widthTableMagic :: Word32
45+widthTableMagic = 0xc1a9f7e0
46+
47+-- NB: This parsing code uses explicit types for parsing each value to
48+-- catch situations where someone changes the types of the fields of
49+-- WidthTableRange or other values and in doing so would silently break
50+-- the parser. If the parser used a style like
51+--
52+-- WidthTableRange <$> get <*> get <*> get
53+--
54+-- then that would result in valid Haskell code that would fail to read
55+-- files that it would have previously parsed. We want those errors
56+-- caught by GHc. At the time of this writing, the library data types
57+-- *happen* to match the binary layout of the version 1 format, but that
58+-- could definitely change in later formats. In those cases we should
59+-- deal with the difference by doing the appropriate conversions.
60+
61+tableParser :: Get UnicodeWidthTable
62+tableParser = do
63+ magic :: Word32
64+ <- getWord32le
65+
66+ when (magic /= widthTableMagic) $
67+ fail "Table magic number invalid"
68+
69+ version :: Word8
70+ <- get
71+
72+ case version of
73+ 1 -> tableV1Parser
74+ _ -> fail "Table version invalid"
75+
76+tableV1Parser :: Get UnicodeWidthTable
77+tableV1Parser = do
78+ numRanges :: Word32
79+ <- getWord32le
80+
81+ let parseRange = do
82+ start :: Word32
83+ <- getWord32le
84+ size :: Word32
85+ <- getWord32le
86+ cols :: Word8
87+ <- get
88+ return WidthTableRange { rangeStart = start
89+ , rangeSize = size
90+ , rangeColumns = cols
91+ }
92+
93+ ranges <- forM [1..numRanges] $ const parseRange
94+
95+ return UnicodeWidthTable { unicodeWidthTableRanges = ranges
96+ }
97+
98+tableV1Writer :: UnicodeWidthTable -> Put
99+tableV1Writer table = do
100+ -- Magic bytes
101+ putWord32le widthTableMagic
102+
103+ -- Version
104+ putWord8 1
105+
106+ -- Number of ranges
107+ let ranges = unicodeWidthTableRanges table
108+ let numRanges = length ranges
109+ putWord32le (fromIntegral numRanges)
110+
111+ -- Ranges
112+ let putRange r = do
113+ putWord32le $ rangeStart r
114+ putWord32le $ rangeSize r
115+ putWord8 $ rangeColumns r
116+
117+ mapM_ putRange ranges