diff --git a/Opentype/Fileformat/Cmap.hs b/Opentype/Fileformat/Cmap.hs index 548c2df..858f084 100644 --- a/Opentype/Fileformat/Cmap.hs +++ b/Opentype/Fileformat/Cmap.hs @@ -2,8 +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.Either (either) +import Data.List (sort, mapAccumL) import Control.Monad import Data.Traversable (for) import Data.Foldable (for_, traverse_) @@ -28,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 @@ -37,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) @@ -47,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 @@ -92,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./ @@ -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 = @@ -193,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 @@ -253,13 +251,13 @@ 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) $ 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 @@ -273,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 @@ -290,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 @@ -316,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 = @@ -334,7 +332,7 @@ data Segment4layout = Segment4layout { s4idRangeOffset :: Word16, s4glyphIndex :: [GlyphID] } deriving Show - + putMap4 :: CMap -> PutM () putMap4 cmap = do putWord16be 4 @@ -401,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 @@ -431,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 @@ -524,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 b7e5fa1..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,29 +76,29 @@ 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) $ fail "Unsupported name table format." - len <- index16 bs 1 + when (version > 0) $ Left "Unsupported name table format." + 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 $ \(offset, len2, r) -> - if storage+offset+len2 > fromIntegral (Strict.length bs) - then Left "string storage bounds exceeded" + 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) return $ NameTable records2 diff --git a/opentype.cabal b/opentype.cabal index db2eb42..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,11 +49,12 @@ 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 buildable: True hs-source-dirs: tests + build-depends: base