From b1a60de8c81802c65302f37cc89546b184c2ea7c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 17 Dec 2019 18:54:45 -0500 Subject: [PATCH 01/12] Construct error messages directly. This is fallout of the `MonadFail` proposal, visible in ghc 8.8. --- Opentype/Fileformat/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index b7e5fa1..85506ff 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -84,7 +84,7 @@ putNameTable (NameTable records_) = do readNameTable :: Strict.ByteString -> Either String NameTable readNameTable bs = do version <- index16 bs 0 - when (version > 0) $ fail "Unsupported name table format." + when (version > 0) $ Left "Unsupported name table format." len <- index16 bs 1 storage <- index16 bs 2 records <- for [0..len-1] $ \i -> do From 4c050fc855627da8c8c11468e5a0a558207466ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 17 Dec 2019 18:59:08 -0500 Subject: [PATCH 02/12] Use Left instead of fail in Cmap.hs. --- Opentype/Fileformat/Cmap.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/Opentype/Fileformat/Cmap.hs b/Opentype/Fileformat/Cmap.hs index 548c2df..327001f 100644 --- a/Opentype/Fileformat/Cmap.hs +++ b/Opentype/Fileformat/Cmap.hs @@ -3,7 +3,6 @@ import Opentype.Fileformat.Types import Data.Binary import Data.Binary.Put import Data.List (sort, mapAccumL, foldl') -import Data.Either (either) import Control.Monad import Data.Traversable (for) import Data.Foldable (for_, traverse_) @@ -135,7 +134,7 @@ readCmapTable :: Strict.ByteString -> Either String CmapTable readCmapTable bs = do version <- index16 bs 0 when (version /= 0) $ - fail "unsupported cmap version." + Left "unsupported cmap version." n <- index16 bs 1 entries <- for [0..n-1] $ \i -> do pfID <- toPf =<< (index16 bs $ 2 + i*4) @@ -166,16 +165,15 @@ readCmap bs_ = do c <- index16 bs_ 0 let bs | (c >= 8 && c < 14) = Strict.drop 8 bs_ | otherwise = Strict.drop 4 bs_ - either fail return $ - case c of - 0 -> getMap0 bs - 2 -> getMap2 bs - 4 -> getMap4 bs - 6 -> getMap6 bs - 8 -> getMap8 bs - 10 -> getMap10 bs - 12 -> getMap12 bs - i -> fail $ "unsupported map encoding " ++ show i + case c of + 0 -> getMap0 bs + 2 -> getMap2 bs + 4 -> getMap4 bs + 6 -> getMap6 bs + 8 -> getMap8 bs + 10 -> getMap10 bs + 12 -> getMap12 bs + i -> Left $ "unsupported map encoding " ++ show i subIntMap :: Word32 -> Word32 -> WordMap GlyphID -> WordMap GlyphID subIntMap from to intMap = From c69d475309eecf9b4f132df9eadf818eaadd2986 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 17 Dec 2019 19:01:07 -0500 Subject: [PATCH 03/12] Fix an overflowing literal warning. --- Opentype/Fileformat/Cmap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Cmap.hs b/Opentype/Fileformat/Cmap.hs index 327001f..873f7b0 100644 --- a/Opentype/Fileformat/Cmap.hs +++ b/Opentype/Fileformat/Cmap.hs @@ -257,7 +257,7 @@ putMap2 cmap = do (fromIntegral hb `shift` 8 .|. 0xff) $ glyphMap cmap (fstCode, lstCode) - | M.null subMap = (0, -1) + | M.null subMap = (0, maxBound) | otherwise = (fst $ M.findMin subMap, fst $ M.findMax subMap) ec = lstCode - fstCode + 1 From 0a7a5520353be93ecedd8f4311237e733593872b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Dec 2019 11:20:01 -0500 Subject: [PATCH 04/12] Include details when records overflow the name table length. --- Opentype/Fileformat/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index 85506ff..ccbc6bb 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -98,7 +98,7 @@ readNameTable bs = do records2 <- for records $ \(offset, len2, r) -> if storage+offset+len2 > fromIntegral (Strict.length bs) - then Left "string storage bounds exceeded" + then Left $ "overflow error: name record at (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" else Right $ r (Strict.take (fromIntegral len2) $ Strict.drop (fromIntegral $ offset+storage) bs) return $ NameTable records2 From 3f3d19bf36cd8fdc41a2ba146625be591b7c4446 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Dec 2019 11:26:14 -0500 Subject: [PATCH 05/12] Show the storage index. --- Opentype/Fileformat/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index ccbc6bb..84469a1 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -98,7 +98,7 @@ readNameTable bs = do records2 <- for records $ \(offset, len2, r) -> if storage+offset+len2 > fromIntegral (Strict.length bs) - then Left $ "overflow error: name record at (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" + then Left $ "overflow error: name record in (" <> show storage <> ") at (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" else Right $ r (Strict.take (fromIntegral len2) $ Strict.drop (fromIntegral $ offset+storage) bs) return $ NameTable records2 From b0698124237dd3d90d88f9f71c751b2a52b945e0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Dec 2019 11:30:55 -0500 Subject: [PATCH 06/12] Be more specific about the storage/offset parts. --- Opentype/Fileformat/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index 84469a1..4135e11 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -98,7 +98,7 @@ readNameTable bs = do records2 <- for records $ \(offset, len2, r) -> if storage+offset+len2 > fromIntegral (Strict.length bs) - then Left $ "overflow error: name record in (" <> show storage <> ") at (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" + then Left $ "overflow error: name record in storage at (" <> show storage <> ") at offset (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" else Right $ r (Strict.take (fromIntegral len2) $ Strict.drop (fromIntegral $ offset+storage) bs) return $ NameTable records2 From a1b6967d895530ea691bd83084a2d85c588a6213 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sun, 22 Dec 2019 11:33:03 -0500 Subject: [PATCH 07/12] Convert the offsets & lengths to Int. --- Opentype/Fileformat/Name.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index 4135e11..aad0782 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -97,7 +97,7 @@ readNameTable bs = do Right (offset, len2, NameRecord pf enc lang nID) records2 <- for records $ \(offset, len2, r) -> - if storage+offset+len2 > fromIntegral (Strict.length bs) + if fromIntegral (storage+offset+len2) > Strict.length bs then Left $ "overflow error: name record in storage at (" <> show storage <> ") at offset (" <> show offset <> ") with length (" <> show len2 <> ") exceeds input length (" <> show (Strict.length bs) <> ")" else Right $ r (Strict.take (fromIntegral len2) $ Strict.drop (fromIntegral $ offset+storage) bs) From 5b045cb6b983648b9adc93061a045f37853c1941 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Sat, 18 Jul 2020 10:24:51 -0400 Subject: [PATCH 08/12] Add a dependency on base so the tests build. --- opentype.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/opentype.cabal b/opentype.cabal index db2eb42..3e6cac5 100644 --- a/opentype.cabal +++ b/opentype.cabal @@ -57,3 +57,4 @@ test-suite test main-is: test.hs buildable: True hs-source-dirs: tests + build-depends: base From 778f1c8cb5407bf94a8344dc1397fa8eb1c148b2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Oct 2024 12:26:50 -0400 Subject: [PATCH 09/12] :fire: redundant imports. --- Opentype/Fileformat/Cmap.hs | 31 +++++++++++++++---------------- Opentype/Fileformat/Name.hs | 12 ++++++------ 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/Opentype/Fileformat/Cmap.hs b/Opentype/Fileformat/Cmap.hs index 873f7b0..858f084 100644 --- a/Opentype/Fileformat/Cmap.hs +++ b/Opentype/Fileformat/Cmap.hs @@ -2,7 +2,7 @@ module Opentype.Fileformat.Cmap where import Opentype.Fileformat.Types import Data.Binary import Data.Binary.Put -import Data.List (sort, mapAccumL, foldl') +import Data.List (sort, mapAccumL) import Control.Monad import Data.Traversable (for) import Data.Foldable (for_, traverse_) @@ -27,7 +27,7 @@ import Data.Int -- subtables are present. Each subtable is in one of seven possible -- formats and begins with a format code indicating the format -- used. --- +-- -- The `platformID` and platform-specific `encodingID` in the header -- entry (and, in the case of the Macintosh platform, the `macLanguage` -- field in the subtable itself) are used to specify a particular @@ -36,7 +36,7 @@ import Data.Int -- `CmapTable`. -- -- When `platformID` is `UnicodePlatform`, `encodingID` is interpreted as follows: --- +-- -- * 0: Default semantics -- * 1: Version 1.1 semantics -- * 2: ISO 10646 1993 semantics (deprecated) @@ -46,7 +46,7 @@ import Data.Int -- * 6: Full Unicode coverage (used with type 13.0 cmaps by OpenType) -- -- When `platformID` `MacintoshPlatform`, the `encodingID` is a QuickDraw script code. --- +-- -- Note that the use of the Macintosh platformID is currently -- discouraged. Subtables with a Macintosh platformID are only -- required for backwards compatibility with QuickDraw and will be @@ -91,7 +91,7 @@ instance Eq CMap where (CMap pfID encID lang _ _ _) == (CMap pfID2 encID2 lang2 _ _ _) = (pfID, encID, lang) == (pfID2, encID2, lang2) -data MapFormat = +data MapFormat = -- | 8 bit encoding, contiguous block of bytes. /LEGACY ONLY./ MapFormat0 | -- | mixed 8\/16 bit encoding with gaps. /LEGACY ONLY./ @@ -191,7 +191,7 @@ putCodes start end _ putCodes start end [] = do putWord16be 0 putCodes (start+1) end [] - + putCodes start end l@((i, code):rest) | start < i = do putWord16be 0 putCodes (start+1) end l @@ -251,7 +251,7 @@ putMap2 cmap = do IS.toList $ fst $ IS.split 255 (multiByte cmap) subTableCodes = - filter ((/= 0) . entryCount) $ + filter ((/= 0) . entryCount) $ flip map highBytes $ \hb -> let subMap = subIntMap (fromIntegral hb `shift` 8) (fromIntegral hb `shift` 8 .|. 0xff) $ @@ -271,7 +271,7 @@ putMap2 cmap = do size :: Word16 size = 518 + 8 * (fromIntegral $ length subTables) + 2 * sum (map entryCount subTables) calcOffset prev st = st { rangeOffset = rangeOffset prev - 8 + 2*entryCount prev } - + getMap2 :: Strict.ByteString -> Either String CMap getMap2 bs = do lang <- index16 bs 0 @@ -288,8 +288,8 @@ getMap2 bs = do Right (fromIntegral $ fstCode + entry, if p == 0 then 0 else p + delta) let im = M.fromAscList $ filter ((/= 0).snd) $ concat l is = IS.fromAscList $ map fromIntegral highBytes - Right $ CMap UnicodePlatform 0 lang MapFormat2 is im - + Right $ CMap UnicodePlatform 0 lang MapFormat2 is im + data Segment4 = RangeSegment Word16 Word16 Word16 | CodeSegment Word16 Word16 [Word16] deriving Show @@ -314,7 +314,7 @@ getSegments :: [(Word32, Word16)] -> [Segment4] getSegments [] = [RangeSegment 0xffff 1 0] getSegments l@((start, c):_) | fromIntegral end - start >= 4 || - lc <= end-start+1 = + lc <= end-start+1 = RangeSegment (fromIntegral start) (fromIntegral end-fromIntegral start+1) c : getSegments r | otherwise = @@ -332,7 +332,7 @@ data Segment4layout = Segment4layout { s4idRangeOffset :: Word16, s4glyphIndex :: [GlyphID] } deriving Show - + putMap4 :: CMap -> PutM () putMap4 cmap = do putWord16be 4 @@ -399,7 +399,7 @@ putMap6 cmap = do lastCode = fromIntegral $ min (fromIntegral (maxBound :: Word16)::Word32) $ fst $ M.findMax (glyphMap cmap) - + getMap6 :: Strict.ByteString -> Either String CMap getMap6 bs = do lang <- index16 bs 0 @@ -429,13 +429,13 @@ readPacked bs = i <- [0..7], a .&. (1 `shift` i) /= 0 ] - + findRanges :: [(Word32, GlyphID)] -> [(Word32, Word32, GlyphID)] findRanges [] = [] findRanges l@((i,c):_) = (i, i2, c) : findRanges next where (i2, next) = findRange i (fromIntegral c-fromIntegral i) l - + putMap8 :: CMap -> PutM () putMap8 cmap = do putWord16be 8 @@ -522,4 +522,3 @@ getMap12 bs = do glyph <- index32 bs (i*3 + 4) return [(fromIntegral c, fromIntegral $ glyph+c-start) | c <- [start .. end]] Right $ CMap UnicodePlatform 0 lang MapFormat8 IS.empty gmap - diff --git a/Opentype/Fileformat/Name.hs b/Opentype/Fileformat/Name.hs index aad0782..8443dc4 100644 --- a/Opentype/Fileformat/Name.hs +++ b/Opentype/Fileformat/Name.hs @@ -1,7 +1,7 @@ module Opentype.Fileformat.Name where import Opentype.Fileformat.Types -import Data.List (sort, foldl') +import Data.List (sort) import Data.Maybe (fromMaybe) import Data.Word import Control.Monad @@ -54,7 +54,7 @@ instance Ord NameRecord where instance Eq NameRecord where (NameRecord pID eID lang nID _) == (NameRecord pID2 eID2 lang2 nID2 _) = - (pID, eID, lang, nID) == (pID2, eID2, lang2, nID2) + (pID, eID, lang, nID) == (pID2, eID2, lang2, nID2) putNameTable :: NameTable -> Put putNameTable (NameTable records_) = do @@ -76,23 +76,23 @@ putNameTable (NameTable records_) = do (\(offset, (noDups2, mp)) r -> if HM.member (nameString r) mp then (offset, (noDups2, mp)) - else (Strict.length (nameString r) + offset, + else (Strict.length (nameString r) + offset, (nameString r:noDups2, HM.insert (nameString r) offset mp))) (0, ([], HM.empty)) records - + readNameTable :: Strict.ByteString -> Either String NameTable readNameTable bs = do version <- index16 bs 0 when (version > 0) $ Left "Unsupported name table format." - len <- index16 bs 1 + len <- index16 bs 1 storage <- index16 bs 2 records <- for [0..len-1] $ \i -> do pf <- toPf =<< index16 bs (3 + i*6) enc <- index16 bs $ 3 + i*6 + 1 lang <- index16 bs $ 3 + i*6 + 2 nID <- index16 bs $ 3 + i*6 + 3 - len2 <- index16 bs $ 3 + i*6 + 4 + len2 <- index16 bs $ 3 + i*6 + 4 offset <- index16 bs $ 3 + i*6 + 5 Right (offset, len2, NameRecord pf enc lang nID) records2 <- for records $ From 41196674f1d76b6b7af4f0aef732ee9ffbcbf5a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Oct 2024 12:29:17 -0400 Subject: [PATCH 10/12] Ba-bump. --- opentype.cabal | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/opentype.cabal b/opentype.cabal index 3e6cac5..59e763b 100644 --- a/opentype.cabal +++ b/opentype.cabal @@ -13,18 +13,18 @@ description: This library supports loading and writing of opentype files. category: Typography author: Kristof Bastiaensen data-dir: "" - + source-repository head type: git location: https://github.com/kuribas/haskell-opentype - + library build-depends: base >=3 && <5, binary >=0.8.1.0, bytestring >0.10.0, containers >=0.5.3, - ghc >=7.10.0, + ghc >=9.10.0, microlens > 0.4.0.0, microlens-th > 0.4.0.0, mtl >= 2.2.1, @@ -49,9 +49,9 @@ library Opentype.Fileformat.Post Opentype.Fileformat.Kern Opentype.Fileformat.OS2 - Opentype.Fileformat.Unicode.PostNames + Opentype.Fileformat.Unicode.PostNames ghc-options: -Wall - + test-suite test type: exitcode-stdio-1.0 main-is: test.hs From 6dc2dd0a00b0529722ac886cc7fca53ea285bd4d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Oct 2024 12:32:47 -0400 Subject: [PATCH 11/12] Maybe not? --- opentype.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opentype.cabal b/opentype.cabal index 59e763b..64608e0 100644 --- a/opentype.cabal +++ b/opentype.cabal @@ -24,7 +24,7 @@ library binary >=0.8.1.0, bytestring >0.10.0, containers >=0.5.3, - ghc >=9.10.0, + ghc >=9.6.0, microlens > 0.4.0.0, microlens-th > 0.4.0.0, mtl >= 2.2.1, From 4b0ef6f928c1c6a8795cfbcaaaba7a00722fb444 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 4 Oct 2024 12:37:18 -0400 Subject: [PATCH 12/12] Revert "Maybe not?" This reverts commit 6dc2dd0a00b0529722ac886cc7fca53ea285bd4d. --- opentype.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/opentype.cabal b/opentype.cabal index 64608e0..59e763b 100644 --- a/opentype.cabal +++ b/opentype.cabal @@ -24,7 +24,7 @@ library binary >=0.8.1.0, bytestring >0.10.0, containers >=0.5.3, - ghc >=9.6.0, + ghc >=9.10.0, microlens > 0.4.0.0, microlens-th > 0.4.0.0, mtl >= 2.2.1,