FontyFruity 0.5.3.3 → 0.5.3.4
raw patch · 11 files changed
+1662/−1659 lines, 11 filesdep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers
API changes (from Hackage documentation)
Files
- FontyFruity.cabal +4/−4
- changelog +3/−0
- src/Graphics/Text/TrueType/Bytecode.hs +448/−448
- src/Graphics/Text/TrueType/CharacterMap.hs +385/−385
- src/Graphics/Text/TrueType/FontFolders.hs +241/−241
- src/Graphics/Text/TrueType/Header.hs +143/−143
- src/Graphics/Text/TrueType/HorizontalInfo.hs +120/−120
- src/Graphics/Text/TrueType/MaxpTable.hs +59/−59
- src/Graphics/Text/TrueType/Name.hs +122/−122
- src/Graphics/Text/TrueType/OffsetTable.hs +89/−89
- src/Graphics/Text/TrueType/Types.hs +48/−48
FontyFruity.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: FontyFruity -version: 0.5.3.3 +version: 0.5.3.4 synopsis: A true type file format loader description: A haskell Truetype file parser. @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: https://github.com/Twinside/FontyFruity.git - Tag: v0.5.3.3 + Tag: v0.5.3.4 library exposed-modules: Graphics.Text.TrueType @@ -50,10 +50,10 @@ ghc-prof-options: -Wall hs-source-dirs: src default-language: Haskell2010 - build-depends: base >= 4.5 && < 5 + build-depends: base >= 4.5 && < 6 , binary >= 0.5 , bytestring >= 0.10 - , containers >= 0.5 && < 0.6 + , containers >= 0.5 , vector >= 0.9 , directory , text
changelog view
@@ -1,5 +1,8 @@ -*-change-log-*- +v0.5.3.4 September 2018 + * Fix: GHC 8.6.1 compat + v0.5.3.3 June 2017 * Fix: Composite glyph positionning (patch from hsyl20) * Fix: glyph lookup (patch from hsyl20)
src/Graphics/Text/TrueType/Bytecode.hs view
@@ -1,448 +1,448 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.Bytecode where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -import Data.Monoid( mempty ) -#endif - -import Prelude hiding ( EQ, GT, LT ) -{-import Control.Monad.State.Strict( modify )-} -import Data.Bits( (.&.), testBit ) -import Data.Binary.Get( Get, getWord8, getWord16be ) -import Data.Int( Int32 ) -import qualified Data.Map as M -import Data.Word( Word8, Word16 ) -import qualified Data.Vector.Unboxed as VU - -import Graphics.Text.TrueType.Types - -type InstructionFlag = Bool - -data Instruction - -- | Pop one argument from the stack - = AA - | ABS - | ADD - | ALIGNPTS - | ALIGNRP - | AND - | CALL - | CEILING - | CINDEX - | CLEAR - | DEBUG - | DELTAC1 - | DELTAC2 - | DELTAC3 - | DELTAP1 - | DELTAP2 - | DELTAP3 - | DEPTH - | DIV - | DUP - | EIF - | ELSE - | ENDF - | EQ - | EVEN - | FDEF - | FLIPOFF - | FLIPON - | FLIPPT - | FLIPRGOFF - | FLIPRGON - | FLOOR - | GC PositionSource - | GETINFO - -- | Get Freedom vector - | GFV - | GPV - | GT - | GTEQ - | IDEF - | IF - | INSTCTRL - | IP - | ISECT - | IUP Direction - | JMPR - | JROF - | JROT - | LOOPCALL - | LT - | LTEQ - | MAX - | MD PositionSource - | MDAP Rounding - | MDRP PointReset DistanceKeeping Rounding Word8 - | MIAP Rounding - | MIN - | MINDEX - | MIRP PointReset DistanceKeeping Rounding Word8 - | MPPEM - | MPS - | MSIRP PointReset - | MUL - | NEG - | NEQ - | NOT - | NPUSHB (VU.Vector Word8) - | NPUSHW (VU.Vector Word16) - | NROUND Word8 - | ODD - | OR - | POP - | PUSHB (VU.Vector Word8) - | PUSHW (VU.Vector Word16) - | RCVT - | RDTG - | ROFF - | ROLL - | ROUND Word8 - | RS - | RTDG - | RTG - | RTHG - | RUTG - | S45ROUND - | SANGW - | SCANCTRL - | SCANTYPE - | SCFS - | SCVTCI - | SDB - | SDPVTL Parallelism - | SDS - | SFVFS - | SFVTCA Direction - | SFVTL Parallelism - | SFVTPV - | SHC CountourRef - | SHP CountourRef - | SHPIX - | SHZ CountourRef - | SLOOP - | SMD - | SPVFS - | SPVTCA Direction - | SPVTL Parallelism - | SROUND - | SRP0 - | SRP1 - | SRP2 - | SSW - | SSWCI - | SUB - | SVTCA Direction - | SWAP - | SZP0 - | SZP1 - | SZP2 - | SZPS - | UTP - | WCVTF - | WCVTP - | WS - deriving (Eq, Show) - -data CountourRef - = UseRP2InZP1 - | UseRP1InZP0 - deriving (Eq, Show) - -data Parallelism - = VectorParallel - | VectorPerpendicular - deriving (Eq, Show) - -data PositionSource - = PositionCurrent - | PositionOriginal - deriving (Eq, Show) - -data Direction - = DirectionX - | DirectionY - deriving (Eq, Show) - -data Rounding - = RoundingNone - | Rounding - deriving (Eq, Show) - -data PointReset - = ResetNot - | ResetRP0 - deriving (Eq, Show) - -data DistanceKeeping - = DistanceFree - | DistanceGreaterThanMin - deriving (Eq, Show) - -data ByteCodeProgram - = If [ByteCodeProgram] - | IfElse [ByteCodeProgram] [ByteCodeProgram] - | Function [ByteCodeProgram] - | Sequence [Instruction] - deriving (Eq, Show) - -instructionToProgram :: [Instruction]-> [ByteCodeProgram] -instructionToProgram = firstOfThird . go [] - where - firstOfThird (f, _, _) = f - - go acc [] = (reverse acc, [], []) - go acc (IF : rest) = - case go [] rest of - (ifBranch, [], final) -> go (If ifBranch : acc) final - (ifBranch, elseBranch, final) -> - go (IfElse ifBranch elseBranch : acc) final - go acc (EIF : rest) = (reverse acc, [], rest) - go acc (ELSE : rest) = (acc, elseBranch, final) - where (elseBranch, _, final) = go [] rest - go acc (FDEF : rest) = go (Function def: acc) final - where (def, _, final) = go [] rest - go acc (ENDF : rest) = (reverse acc, [], rest) - go acc (x : xs) = go (Sequence [x] : acc) xs - - -inRange :: Ord a => a -> (a, a) -> Bool -inRange v (lo, hi) = lo <= v && v <= hi - -getInstr :: Get Instruction -getInstr = getWord8 >>= go - where - mirpParse x constructor = constructor reset distance rounding distanceType - where - reset | x `testBit` 4 = ResetRP0 - | otherwise = ResetNot - - distance | x `testBit` 3 = DistanceGreaterThanMin - | otherwise = DistanceFree - - rounding | x `testBit` 2 = Rounding - | otherwise = RoundingNone - - distanceType = x .&. 0x3 - - go w = case w of - 0x7F -> return AA - 0x64 -> return ABS - 0x60 -> return ADD - 0x27 -> return ALIGNPTS - 0x3C -> return ALIGNRP - 0x5A -> return AND - 0x2B -> return CALL - 0x67 -> return CEILING - 0x25 -> return CINDEX - 0x22 -> return CLEAR - 0x4F -> return DEBUG - 0x73 -> return DELTAC1 - 0x74 -> return DELTAC2 - 0x75 -> return DELTAC3 - 0x5D -> return DELTAP1 - 0x71 -> return DELTAP2 - 0x72 -> return DELTAP3 - 0x24 -> return DEPTH - 0x62 -> return DIV - 0x20 -> return DUP - 0x59 -> return EIF - 0x1B -> return ELSE - 0x2D -> return ENDF - 0x54 -> return EQ - 0x57 -> return EVEN - 0x2C -> return FDEF - 0x4E -> return FLIPOFF - 0x4D -> return FLIPON - 0x80 -> return FLIPPT - 0x82 -> return FLIPRGOFF - 0x81 -> return FLIPRGON - 0x66 -> return FLOOR - 0x46 -> return $ GC PositionCurrent - 0x47 -> return $ GC PositionOriginal - 0x88 -> return GETINFO - 0x0D -> return GFV - 0x0C -> return GPV - 0x52 -> return GT - 0x53 -> return GTEQ - 0x89 -> return IDEF - 0x58 -> return IF - 0x8E -> return INSTCTRL - 0x39 -> return IP - 0x0F -> return ISECT - 0x30 -> return $ IUP DirectionY - 0x31 -> return $ IUP DirectionX - 0x1C -> return JMPR - 0x79 -> return JROF - 0x78 -> return JROT - 0x2A -> return LOOPCALL - 0x50 -> return LT - 0x51 -> return LTEQ - 0x8B -> return MAX - 0x49 -> return $ MD PositionCurrent - 0x4A -> return $ MD PositionOriginal - 0x2E -> return $ MDAP RoundingNone - 0x2F -> return $ MDAP Rounding - x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP - 0x3E -> return $ MIAP RoundingNone - 0x3F -> return $ MIAP Rounding - 0x8C -> return MIN - 0x26 -> return MINDEX - x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP - 0x4B -> return MPPEM - 0x4C -> return MPS - 0x3A -> return $ MSIRP ResetNot - 0x3B -> return $ MSIRP ResetRP0 - 0x63 -> return MUL - 0x65 -> return NEG - 0x55 -> return NEQ - 0x5C -> return NOT - 0x40 -> do - count <- fromIntegral <$> getWord8 - NPUSHB <$> VU.replicateM count getWord8 - - 0x41 -> do - count <- fromIntegral <$> getWord8 - NPUSHW <$> VU.replicateM count getWord16be - x | x `inRange` (0x6C, 0x6F) -> - return . NROUND $ x .&. 3 - 0x56 -> return ODD - 0x5B -> return OR - 0x21 -> return POP - x | x `inRange` (0xB0, 0xB7) -> do - let count = fromIntegral $ (x .&. 0x7) + 1 - PUSHB <$> VU.replicateM count getWord8 - x | x `inRange` (0xB8, 0xBF) -> do - let count = fromIntegral $ (x .&. 0x7) + 1 - PUSHW <$> VU.replicateM count getWord16be - 0x45 -> return RCVT - 0x7D -> return RDTG - 0x7A -> return ROFF - 0x8A -> return ROLL - x | x `inRange` (0x68, 0x6B) -> - return $ ROUND (x .&. 0x3) - 0x43 -> return RS - 0x3D -> return RTDG - 0x18 -> return RTG - 0x19 -> return RTHG - 0x7C -> return RUTG - 0x77 -> return S45ROUND - 0x7E -> return SANGW - 0x85 -> return SCANCTRL - 0x8D -> return SCANTYPE - 0x48 -> return SCFS - 0x1D -> return SCVTCI - 0x5E -> return SDB - 0x86 -> return $ SDPVTL VectorParallel - 0x87 -> return $ SDPVTL VectorPerpendicular - 0x5F -> return SDS - 0x0B -> return SFVFS - 0x04 -> return $ SFVTCA DirectionY - 0x05 -> return $ SFVTCA DirectionX - 0x08 -> return $ SFVTL VectorParallel - 0x09 -> return $ SFVTL VectorPerpendicular - 0x0E -> return SFVTPV - 0x34 -> return $ SHC UseRP2InZP1 - 0x35 -> return $ SHC UseRP1InZP0 - 0x32 -> return $ SHP UseRP2InZP1 - 0x33 -> return $ SHP UseRP1InZP0 - 0x38 -> return SHPIX - 0x36 -> return $ SHZ UseRP2InZP1 - 0x37 -> return $ SHZ UseRP1InZP0 - 0x17 -> return SLOOP - 0x1A -> return SMD - 0x0A -> return SPVFS - 0x02 -> return $ SPVTCA DirectionY - 0x03 -> return $ SPVTCA DirectionX - 0x06 -> return $ SPVTL VectorParallel - 0x07 -> return $ SPVTL VectorPerpendicular - 0x76 -> return SROUND - 0x10 -> return SRP0 - 0x11 -> return SRP1 - 0x12 -> return SRP2 - 0x1F -> return SSW - 0x1E -> return SSWCI - 0x61 -> return SUB - 0x00 -> return $ SVTCA DirectionY - 0x01 -> return $ SVTCA DirectionX - 0x23 -> return SWAP - 0x13 -> return SZP0 - 0x14 -> return SZP1 - 0x15 -> return SZP2 - 0x16 -> return SZPS - 0x29 -> return UTP - 0x70 -> return WCVTF - 0x44 -> return WCVTP - 0x42 -> return WS - _ -> fail "instruction reader coverage pleaser" - -type Point = (F26Dot6, F26Dot6) - -data GraphicalState = GraphicalState - { _stAutoFlip :: !Bool - , _stCutIn :: {-# UNPACK #-} !F26Dot6 - , _stDeltaBase :: {-# UNPACK #-} !Int32 - , _stDeltaShift :: {-# UNPACK #-} !Int32 - , _stDualProjection :: !(Maybe Point) - , _stFreedomVector :: !Point - , _stInstructionControl :: !Bool - , _stLoop :: {-# UNPACK #-} !Int32 - , _stMinDistance :: {-# UNPACK #-} !F26Dot6 - , _stProjectionVector :: !Point - , _stRoundState :: {-# UNPACK #-} !Int32 - , _stRp0 :: {-# UNPACK #-} !Int32 - , _stRp1 :: {-# UNPACK #-} !Int32 - , _stRp2 :: {-# UNPACK #-} !Int32 - , _stScanControl :: !Bool - , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6 - , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6 - , _stZp0 :: {-# UNPACK #-} !Int32 - , _stZp1 :: {-# UNPACK #-} !Int32 - , _stZp2 :: {-# UNPACK #-} !Int32 - , _stFunctions :: !(M.Map Int32 [ByteCodeProgram]) - } - deriving (Eq, Show) - -initialState :: GraphicalState -initialState = GraphicalState - { _stAutoFlip = True - , _stCutIn = 17 / 16 - , _stDeltaBase = 9 - , _stDeltaShift = 3 - , _stDualProjection = Nothing - , _stFreedomVector = (1, 0) - , _stInstructionControl = False - , _stLoop = 1 - , _stMinDistance = 1 - , _stProjectionVector = (1, 0) - , _stRoundState = 1 - , _stRp0 = 0 - , _stRp1 = 0 - , _stRp2 = 0 - , _stScanControl = False - , _stSingleWidthCutIn = 0 - , _stSingleWidthValue = 0 - , _stZp0 = 1 - , _stZp1 = 1 - , _stZp2 = 1 - , _stFunctions = mempty - } - -#if 0 - -evaluate :: [ByteCodeProgram] -> () -evaluate instrs = - where - byteExec [] stack = stack - byteExec (If _ : instr) (0:stack) = byteExec instr stack - byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack - byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack - byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack - byteExec (Function functionBody : instr) (id:stack) = - modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack - byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest - -#endif - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.Bytecode where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>) )+import Data.Monoid( mempty )+#endif++import Prelude hiding ( EQ, GT, LT )+{-import Control.Monad.State.Strict( modify )-}+import Data.Bits( (.&.), testBit )+import Data.Binary.Get( Get, getWord8, getWord16be )+import Data.Int( Int32 )+import qualified Data.Map as M+import Data.Word( Word8, Word16 )+import qualified Data.Vector.Unboxed as VU++import Graphics.Text.TrueType.Types++type InstructionFlag = Bool++data Instruction+ -- | Pop one argument from the stack+ = AA + | ABS+ | ADD+ | ALIGNPTS+ | ALIGNRP+ | AND+ | CALL+ | CEILING+ | CINDEX+ | CLEAR+ | DEBUG+ | DELTAC1+ | DELTAC2+ | DELTAC3+ | DELTAP1+ | DELTAP2+ | DELTAP3+ | DEPTH+ | DIV+ | DUP+ | EIF+ | ELSE+ | ENDF+ | EQ+ | EVEN+ | FDEF+ | FLIPOFF+ | FLIPON+ | FLIPPT+ | FLIPRGOFF+ | FLIPRGON+ | FLOOR+ | GC PositionSource+ | GETINFO+ -- | Get Freedom vector+ | GFV+ | GPV+ | GT+ | GTEQ+ | IDEF+ | IF+ | INSTCTRL+ | IP+ | ISECT+ | IUP Direction+ | JMPR+ | JROF+ | JROT+ | LOOPCALL+ | LT+ | LTEQ+ | MAX+ | MD PositionSource+ | MDAP Rounding+ | MDRP PointReset DistanceKeeping Rounding Word8+ | MIAP Rounding+ | MIN+ | MINDEX+ | MIRP PointReset DistanceKeeping Rounding Word8+ | MPPEM+ | MPS+ | MSIRP PointReset+ | MUL+ | NEG+ | NEQ+ | NOT+ | NPUSHB (VU.Vector Word8)+ | NPUSHW (VU.Vector Word16)+ | NROUND Word8+ | ODD+ | OR+ | POP+ | PUSHB (VU.Vector Word8)+ | PUSHW (VU.Vector Word16)+ | RCVT+ | RDTG+ | ROFF+ | ROLL+ | ROUND Word8+ | RS+ | RTDG+ | RTG+ | RTHG+ | RUTG+ | S45ROUND+ | SANGW+ | SCANCTRL+ | SCANTYPE+ | SCFS+ | SCVTCI+ | SDB+ | SDPVTL Parallelism+ | SDS+ | SFVFS+ | SFVTCA Direction+ | SFVTL Parallelism+ | SFVTPV+ | SHC CountourRef+ | SHP CountourRef+ | SHPIX+ | SHZ CountourRef+ | SLOOP+ | SMD+ | SPVFS+ | SPVTCA Direction+ | SPVTL Parallelism+ | SROUND+ | SRP0+ | SRP1+ | SRP2+ | SSW+ | SSWCI+ | SUB+ | SVTCA Direction+ | SWAP+ | SZP0+ | SZP1+ | SZP2+ | SZPS+ | UTP+ | WCVTF+ | WCVTP+ | WS+ deriving (Eq, Show)++data CountourRef+ = UseRP2InZP1+ | UseRP1InZP0+ deriving (Eq, Show)++data Parallelism+ = VectorParallel+ | VectorPerpendicular+ deriving (Eq, Show)++data PositionSource+ = PositionCurrent+ | PositionOriginal+ deriving (Eq, Show)++data Direction+ = DirectionX+ | DirectionY+ deriving (Eq, Show)++data Rounding+ = RoundingNone+ | Rounding+ deriving (Eq, Show)++data PointReset+ = ResetNot+ | ResetRP0+ deriving (Eq, Show)++data DistanceKeeping+ = DistanceFree+ | DistanceGreaterThanMin+ deriving (Eq, Show)++data ByteCodeProgram+ = If [ByteCodeProgram]+ | IfElse [ByteCodeProgram] [ByteCodeProgram]+ | Function [ByteCodeProgram]+ | Sequence [Instruction]+ deriving (Eq, Show)++instructionToProgram :: [Instruction]-> [ByteCodeProgram]+instructionToProgram = firstOfThird . go []+ where+ firstOfThird (f, _, _) = f++ go acc [] = (reverse acc, [], [])+ go acc (IF : rest) =+ case go [] rest of+ (ifBranch, [], final) -> go (If ifBranch : acc) final+ (ifBranch, elseBranch, final) ->+ go (IfElse ifBranch elseBranch : acc) final+ go acc (EIF : rest) = (reverse acc, [], rest)+ go acc (ELSE : rest) = (acc, elseBranch, final)+ where (elseBranch, _, final) = go [] rest+ go acc (FDEF : rest) = go (Function def: acc) final+ where (def, _, final) = go [] rest+ go acc (ENDF : rest) = (reverse acc, [], rest)+ go acc (x : xs) = go (Sequence [x] : acc) xs+++inRange :: Ord a => a -> (a, a) -> Bool+inRange v (lo, hi) = lo <= v && v <= hi++getInstr :: Get Instruction +getInstr = getWord8 >>= go+ where+ mirpParse x constructor = constructor reset distance rounding distanceType+ where+ reset | x `testBit` 4 = ResetRP0+ | otherwise = ResetNot++ distance | x `testBit` 3 = DistanceGreaterThanMin+ | otherwise = DistanceFree++ rounding | x `testBit` 2 = Rounding+ | otherwise = RoundingNone++ distanceType = x .&. 0x3++ go w = case w of+ 0x7F -> return AA+ 0x64 -> return ABS+ 0x60 -> return ADD+ 0x27 -> return ALIGNPTS+ 0x3C -> return ALIGNRP+ 0x5A -> return AND+ 0x2B -> return CALL+ 0x67 -> return CEILING+ 0x25 -> return CINDEX+ 0x22 -> return CLEAR+ 0x4F -> return DEBUG+ 0x73 -> return DELTAC1+ 0x74 -> return DELTAC2+ 0x75 -> return DELTAC3+ 0x5D -> return DELTAP1+ 0x71 -> return DELTAP2+ 0x72 -> return DELTAP3+ 0x24 -> return DEPTH+ 0x62 -> return DIV+ 0x20 -> return DUP+ 0x59 -> return EIF+ 0x1B -> return ELSE+ 0x2D -> return ENDF+ 0x54 -> return EQ+ 0x57 -> return EVEN+ 0x2C -> return FDEF+ 0x4E -> return FLIPOFF+ 0x4D -> return FLIPON+ 0x80 -> return FLIPPT+ 0x82 -> return FLIPRGOFF+ 0x81 -> return FLIPRGON+ 0x66 -> return FLOOR+ 0x46 -> return $ GC PositionCurrent+ 0x47 -> return $ GC PositionOriginal+ 0x88 -> return GETINFO+ 0x0D -> return GFV+ 0x0C -> return GPV+ 0x52 -> return GT+ 0x53 -> return GTEQ+ 0x89 -> return IDEF+ 0x58 -> return IF+ 0x8E -> return INSTCTRL+ 0x39 -> return IP+ 0x0F -> return ISECT+ 0x30 -> return $ IUP DirectionY+ 0x31 -> return $ IUP DirectionX+ 0x1C -> return JMPR+ 0x79 -> return JROF+ 0x78 -> return JROT+ 0x2A -> return LOOPCALL+ 0x50 -> return LT+ 0x51 -> return LTEQ+ 0x8B -> return MAX+ 0x49 -> return $ MD PositionCurrent+ 0x4A -> return $ MD PositionOriginal+ 0x2E -> return $ MDAP RoundingNone+ 0x2F -> return $ MDAP Rounding+ x | x `inRange` (0xC0, 0xDF) -> return $ mirpParse x MDRP+ 0x3E -> return $ MIAP RoundingNone+ 0x3F -> return $ MIAP Rounding+ 0x8C -> return MIN+ 0x26 -> return MINDEX+ x | x `inRange` (0xE0, 0xFF) -> return $ mirpParse x MIRP+ 0x4B -> return MPPEM+ 0x4C -> return MPS+ 0x3A -> return $ MSIRP ResetNot+ 0x3B -> return $ MSIRP ResetRP0+ 0x63 -> return MUL+ 0x65 -> return NEG+ 0x55 -> return NEQ+ 0x5C -> return NOT+ 0x40 -> do+ count <- fromIntegral <$> getWord8+ NPUSHB <$> VU.replicateM count getWord8++ 0x41 -> do+ count <- fromIntegral <$> getWord8+ NPUSHW <$> VU.replicateM count getWord16be+ x | x `inRange` (0x6C, 0x6F) ->+ return . NROUND $ x .&. 3+ 0x56 -> return ODD+ 0x5B -> return OR+ 0x21 -> return POP+ x | x `inRange` (0xB0, 0xB7) -> do+ let count = fromIntegral $ (x .&. 0x7) + 1+ PUSHB <$> VU.replicateM count getWord8+ x | x `inRange` (0xB8, 0xBF) -> do+ let count = fromIntegral $ (x .&. 0x7) + 1+ PUSHW <$> VU.replicateM count getWord16be+ 0x45 -> return RCVT+ 0x7D -> return RDTG+ 0x7A -> return ROFF+ 0x8A -> return ROLL+ x | x `inRange` (0x68, 0x6B) ->+ return $ ROUND (x .&. 0x3)+ 0x43 -> return RS+ 0x3D -> return RTDG+ 0x18 -> return RTG+ 0x19 -> return RTHG+ 0x7C -> return RUTG+ 0x77 -> return S45ROUND+ 0x7E -> return SANGW+ 0x85 -> return SCANCTRL+ 0x8D -> return SCANTYPE+ 0x48 -> return SCFS+ 0x1D -> return SCVTCI+ 0x5E -> return SDB+ 0x86 -> return $ SDPVTL VectorParallel+ 0x87 -> return $ SDPVTL VectorPerpendicular+ 0x5F -> return SDS+ 0x0B -> return SFVFS+ 0x04 -> return $ SFVTCA DirectionY+ 0x05 -> return $ SFVTCA DirectionX+ 0x08 -> return $ SFVTL VectorParallel+ 0x09 -> return $ SFVTL VectorPerpendicular+ 0x0E -> return SFVTPV+ 0x34 -> return $ SHC UseRP2InZP1+ 0x35 -> return $ SHC UseRP1InZP0+ 0x32 -> return $ SHP UseRP2InZP1+ 0x33 -> return $ SHP UseRP1InZP0+ 0x38 -> return SHPIX+ 0x36 -> return $ SHZ UseRP2InZP1+ 0x37 -> return $ SHZ UseRP1InZP0+ 0x17 -> return SLOOP+ 0x1A -> return SMD+ 0x0A -> return SPVFS+ 0x02 -> return $ SPVTCA DirectionY+ 0x03 -> return $ SPVTCA DirectionX+ 0x06 -> return $ SPVTL VectorParallel+ 0x07 -> return $ SPVTL VectorPerpendicular+ 0x76 -> return SROUND+ 0x10 -> return SRP0+ 0x11 -> return SRP1+ 0x12 -> return SRP2+ 0x1F -> return SSW+ 0x1E -> return SSWCI+ 0x61 -> return SUB+ 0x00 -> return $ SVTCA DirectionY+ 0x01 -> return $ SVTCA DirectionX+ 0x23 -> return SWAP+ 0x13 -> return SZP0+ 0x14 -> return SZP1+ 0x15 -> return SZP2+ 0x16 -> return SZPS+ 0x29 -> return UTP+ 0x70 -> return WCVTF+ 0x44 -> return WCVTP+ 0x42 -> return WS+ _ -> fail "instruction reader coverage pleaser"++type Point = (F26Dot6, F26Dot6)++data GraphicalState = GraphicalState+ { _stAutoFlip :: !Bool+ , _stCutIn :: {-# UNPACK #-} !F26Dot6+ , _stDeltaBase :: {-# UNPACK #-} !Int32+ , _stDeltaShift :: {-# UNPACK #-} !Int32+ , _stDualProjection :: !(Maybe Point)+ , _stFreedomVector :: !Point+ , _stInstructionControl :: !Bool+ , _stLoop :: {-# UNPACK #-} !Int32+ , _stMinDistance :: {-# UNPACK #-} !F26Dot6+ , _stProjectionVector :: !Point+ , _stRoundState :: {-# UNPACK #-} !Int32+ , _stRp0 :: {-# UNPACK #-} !Int32+ , _stRp1 :: {-# UNPACK #-} !Int32+ , _stRp2 :: {-# UNPACK #-} !Int32+ , _stScanControl :: !Bool+ , _stSingleWidthCutIn :: {-# UNPACK #-} !F26Dot6+ , _stSingleWidthValue :: {-# UNPACK #-} !F26Dot6+ , _stZp0 :: {-# UNPACK #-} !Int32+ , _stZp1 :: {-# UNPACK #-} !Int32+ , _stZp2 :: {-# UNPACK #-} !Int32+ , _stFunctions :: !(M.Map Int32 [ByteCodeProgram])+ }+ deriving (Eq, Show)++initialState :: GraphicalState+initialState = GraphicalState+ { _stAutoFlip = True+ , _stCutIn = 17 / 16+ , _stDeltaBase = 9+ , _stDeltaShift = 3+ , _stDualProjection = Nothing+ , _stFreedomVector = (1, 0)+ , _stInstructionControl = False+ , _stLoop = 1+ , _stMinDistance = 1+ , _stProjectionVector = (1, 0)+ , _stRoundState = 1+ , _stRp0 = 0+ , _stRp1 = 0+ , _stRp2 = 0+ , _stScanControl = False+ , _stSingleWidthCutIn = 0+ , _stSingleWidthValue = 0+ , _stZp0 = 1+ , _stZp1 = 1+ , _stZp2 = 1+ , _stFunctions = mempty+ }++#if 0++evaluate :: [ByteCodeProgram] -> ()+evaluate instrs =+ where+ byteExec [] stack = stack+ byteExec (If _ : instr) (0:stack) = byteExec instr stack+ byteExec (If thenBody : instr) (_:stack) = byteExec (thenBody ++ instr) stack+ byteExec (IfElse _ elseBody) (0:stack) = byteExec (elseBody ++ instr) stack+ byteExec (IfElse thenBody _) (_:stack) = byteExec (thenBody ++ instr) stack+ byteExec (Function functionBody : instr) (id:stack) =+ modify (\s -> s { _stFunctions = M.add id functionBody }) >> byteExec instr stack+ byteExec (Sequence intructions : rest) stack = go instructions stack >>= byteExec rest++#endif+
src/Graphics/Text/TrueType/CharacterMap.hs view
@@ -1,385 +1,385 @@-{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.CharacterMap - ( TtfEncoding( .. ) - , CharacterMaps - , LangId - , findCharGlyph - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Control.DeepSeq( NFData( .. ) ) -import Control.Monad( replicateM, when, foldM ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , skip - , bytesRead - , getWord8 - , getWord16be - , getWord32be ) - -import Data.Binary.Put( putWord16be - , putWord32be ) -import Data.Int( Int16 ) -import Data.List( find, sort, sortBy ) -import qualified Data.Map.Strict as M -import Data.Maybe( fromMaybe ) -import Data.Word( Word8, Word16, Word32 ) -import Data.Ord( comparing ) - -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU - -import Graphics.Text.TrueType.LanguageIds - --------------------------------------------------- ----- TtfEncoding --------------------------------------------------- -data TtfEncoding - = EncodingSymbol - | EncodingUnicode - | EncodingShiftJIS - | EncodingBig5 - | EncodingPRC - | EncodingWansung - | EncodingJohab - deriving (Eq, Show) - -instance Binary TtfEncoding where - put EncodingSymbol = putWord16be 0 - put EncodingUnicode = putWord16be 1 - put EncodingShiftJIS = putWord16be 2 - put EncodingBig5 = putWord16be 3 - put EncodingPRC = putWord16be 4 - put EncodingWansung = putWord16be 5 - put EncodingJohab = putWord16be 6 - - get = do - v <- getWord16be - case v of - 0 -> return EncodingSymbol - 1 -> return EncodingUnicode - 2 -> return EncodingShiftJIS - 3 -> return EncodingBig5 - 4 -> return EncodingPRC - 5 -> return EncodingWansung - 6 -> return EncodingJohab - _ -> fail "Unknown encoding" - -class CharMappeable a where - -- | Given a group a character, return a valid glyph - -- id and the rest of the string. - glyphIdFromTable :: a -> Char -> Int - - -- | Given a table, retrieve the language code - langIdOfCharMap :: a -> LangId - -type LangId = Word16 - --------------------------------------------------- ----- CharacterMaps --------------------------------------------------- -data CharacterMap = CharacterMap - { _charMapPlatformId :: !PlatformId - , _charMapPlatformSpecific :: !Word16 - , _charMap :: !CharacterTable - } - deriving (Eq, Show) - -instance NFData CharacterMap where - rnf (CharacterMap {}) = () - -instance Ord CharacterMap where - compare = comparing _charMap - -newtype CharacterMaps = CharacterMaps [CharacterMap] - deriving (Eq, Show) - -instance NFData CharacterMaps where - rnf (CharacterMaps maps) = rnf maps `seq` () - -instance Binary CharacterMaps where - put _ = fail "Unimplemented" - get = do - startIndex <- bytesRead - versionNumber <- getWord16be - when (versionNumber /= 0) - (fail "Characte map - invalid version number") - tableCount <- fromIntegral <$> getWord16be - let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be - third (_, _, t) = t - tableDesc <- - sortBy (comparing third) <$> replicateM tableCount descFetcher - - - let fetcher (allMaps, lst) (platformId, platformSpecific, offset) - | M.member offset allMaps = case M.lookup offset allMaps of - Nothing -> fail "Impossible" - Just table -> - return (allMaps, CharacterMap platformId platformSpecific table : lst) - fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do - currentOffset <- fromIntegral <$> bytesRead - let toSkip = fromIntegral offset - currentOffset + startIndex - when (toSkip > 0) - (skip $ fromIntegral toSkip) - mapData <- get - let charMap = CharacterMap platformId platformSpecific mapData - return (M.insert offset mapData allMaps, charMap : lst) - - (_, tables) <- foldM fetcher (M.empty, []) tableDesc - return . CharacterMaps $ sortBy (comparing _charMap) tables - -data CharMapOffset = CharMapOffset - { _cmoPlatformId :: !Word16 - , _cmoEncodingId :: !TtfEncoding - , _cmoOffset :: !Word32 - } - deriving (Eq, Show) - -instance Binary CharMapOffset where - get = CharMapOffset <$> getWord16be <*> get <*> getWord32be - put (CharMapOffset platform encoding offset) = - putWord16be platform >> put encoding >> putWord32be offset - --------------------------------------------------- ----- CharacterTable --------------------------------------------------- -data CharacterTable - = TableFormat0 !Format0 - | TableFormat2 !Format2 - | TableFormat4 !Format4 - | TableFormat6 !Format6 - | TableFormatUnknown !Word16 - deriving (Eq, Show) - -charTableMap :: (forall table . (CharMappeable table) => table -> a) - -> CharacterTable -> a -charTableMap f = go - where - go (TableFormat0 t) = f t - go (TableFormat2 t) = f t - go (TableFormat4 t) = f t - go (TableFormat6 t) = f t - go (TableFormatUnknown v) = f v - -findCharGlyph :: CharacterMaps -> LangId -> Char -> Int -findCharGlyph (CharacterMaps charMaps) langId character = - fromMaybe 0 . find (/= 0) . map snd . sort $ - [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m) - | allMap <- charMaps - , let m = _charMap allMap - , isLangCompatible m] - where - isLangCompatible v = tableLang == 0 || tableLang == langId - where tableLang = charTableMap langIdOfCharMap v - -instance Ord CharacterTable where - compare (TableFormat0 v1) (TableFormat0 v2) = - comparing langIdOfCharMap v1 v2 - compare (TableFormat2 v1) (TableFormat2 v2) = - comparing langIdOfCharMap v1 v2 - compare (TableFormat4 v1) (TableFormat4 v2) = - comparing langIdOfCharMap v1 v2 - compare (TableFormat6 v1) (TableFormat6 v2) = - comparing langIdOfCharMap v1 v2 - compare (TableFormat0 _) _ = LT - compare (TableFormat2 _) _ = LT - compare (TableFormat4 _) _ = LT - compare (TableFormat6 _) _ = LT - compare _ _ = GT - -instance Binary CharacterTable where - put _ = fail "Binary.put CharacterTable - Unimplemented" - get = do - format <- getWord16be - case format of - 0 -> TableFormat0 <$> get - 2 -> TableFormat2 <$> get - 4 -> TableFormat4 <$> get - 6 -> TableFormat6 <$> get - n -> return $ TableFormatUnknown n - -instance CharMappeable Word16 where - glyphIdFromTable _ _ = 0 - langIdOfCharMap _ = 0 - - --------------------------------------------------- ----- Format4 --------------------------------------------------- -data Format4 = Format4 - { _f4Language :: {-# UNPACK #-} !LangId - , _f4Map :: M.Map Word16 Word16 - } - deriving (Eq, Show) - -instance CharMappeable Format4 where - glyphIdFromTable tab v = - fromIntegral . M.findWithDefault 0 wc $ _f4Map tab - where wc = fromIntegral $ fromEnum v - langIdOfCharMap = _f4Language - -instance Binary Format4 where - put _ = error "put Format4 - unimplemented" - get = do - startIndex <- bytesRead - tableLength <- fromIntegral <$> getWord16be - language <- getWord16be - -- 2 * segCount - segCount <- (`div` 2) . fromIntegral <$> getWord16be - -- 2 * (2**FLOOR(log2(segCount))) - _searchRange <- getWord16be - -- log2(searchRange/2) - _entrySelector <- getWord16be - -- (2 * segCount) - searchRange - _rangeShift <- getWord16be - - let fetcher :: Get (VU.Vector Int) - fetcher = - VU.replicateM segCount (fromIntegral <$> getWord16be) - - endCodes <- fetcher - _reservedPad <- getWord16be - startCodes <- fetcher - idDelta <- - VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16) - idRangeOffset <- fetcher - - tableBeginIndex <- bytesRead - let idDeltaInt = VU.map fromIntegral idDelta - rangeInfo = init . VU.toList $ - VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $ - VU.enumFromN 0 segCount - - indexLeft = fromIntegral $ - (tableLength - (tableBeginIndex - startIndex + 2)) - `div` 2 - - indexTable <- VU.replicateM indexLeft getWord16be - - endIndex <- bytesRead - let toSkip = endIndex - startIndex - tableLength + 2 - if toSkip < 0 then - fail $ "Read to much Format4 table " ++ show toSkip - else - skip $ fromIntegral toSkip - - - return . Format4 language . M.fromList - $ concatMap (prepare segCount indexTable) rangeInfo - where - prepare _ _ (start, end, delta, 0, _) = - [(fromIntegral char, fromIntegral $ char + delta) - | char <- [start .. end]] - prepare segCount indexTable - (start, end, delta, rangeOffset, ix) = - -- this is... so convoluted oO - [( fromIntegral char - , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta)) - | char <- [start .. end] - , let index = - (rangeOffset `div` 2) + (char - start) + ix - - segCount - , index < VU.length indexTable - , let glyphId = indexTable VU.! index - ] - --------------------------------------------------- ----- Format0 --------------------------------------------------- -data Format0 = Format0 - { _format0Language :: {-# UNPACK #-} !LangId - , _format0Table :: !(VU.Vector Word8) - } - deriving (Eq, Show) - -instance CharMappeable Format0 where - glyphIdFromTable Format0 { _format0Table = table } v - | ic > VU.length table = 0 - | otherwise = fromIntegral $ table VU.! ic - where ic = fromEnum v - - langIdOfCharMap = _format0Language - -instance Binary Format0 where - put _ = fail "Binary.Format0.put - unimplemented" - get = do - tableSize <- getWord16be - when (tableSize /= 262) $ - fail ("table cmap format 0, invalid size: " - ++ show tableSize) - Format0 <$> getWord16be <*> VU.replicateM 256 getWord8 - --------------------------------------------------- ----- Format2 --------------------------------------------------- -data Format2 = Format2 - { _format2Language :: {-# UNPACK #-} !LangId - , _format2SubKeys :: !(VU.Vector Word16) - , _format2SubHeaders :: !(V.Vector Format2SubHeader) - } - deriving (Eq, Show) - -data Format2SubHeader = Format2SubHeader - { _f2SubCode :: {-# UNPACK #-} !Word16 - , _f2EntryCount :: {-# UNPACK #-} !Word16 - , _f2IdDelta :: {-# UNPACK #-} !Int16 - , _f2IdRangeOffset :: {-# UNPACK #-} !Word16 - } - deriving (Eq, Show) - -instance CharMappeable Format2 where - glyphIdFromTable _ _ = 0 - langIdOfCharMap = _format2Language - -instance Binary Format2SubHeader where - put (Format2SubHeader a b c d) = - p16 a >> p16 b >> pi16 c >> p16 d - where - p16 = putWord16be - pi16 = p16 . fromIntegral - - get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16 - where g16 = getWord16be - - -instance Binary Format2 where - put _ = fail "Format2.put - unimplemented" - get = do - _tableSize <- getWord16be - lang <- getWord16be - subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be - let maxSubIndex = VU.maximum subKeys - subHeaders <- V.replicateM (fromIntegral maxSubIndex) get - -- TODO finish the parsing of format 2 - return $ Format2 lang subKeys subHeaders - --------------------------------------------------- ----- Format6 --------------------------------------------------- -data Format6 = Format6 - { _format6Language :: {-# UNPACK #-} !LangId - , _format6FirstCode :: {-# UNPACK #-} !Word16 - , _format6ArrayIndex :: !(VU.Vector Word16) - } - deriving (Eq, Show) - -instance CharMappeable Format6 where - glyphIdFromTable Format6 { _format6ArrayIndex = table } v - | ic < VU.length table = fromIntegral $ table VU.! ic - | otherwise = 0 - where ic = fromEnum v - - langIdOfCharMap = _format6Language - -instance Binary Format6 where - put _ = fail "Format6.put - unimplemented" - get = do - _length <- getWord16be - language <- getWord16be - firstCode <- getWord16be - entryCount <- fromIntegral <$> getWord16be - Format6 language firstCode <$> VU.replicateM entryCount getWord16be +{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.CharacterMap+ ( TtfEncoding( .. )+ , CharacterMaps+ , LangId+ , findCharGlyph+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++import Control.DeepSeq( NFData( .. ) )+import Control.Monad( replicateM, when, foldM )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( Get+ , skip+ , bytesRead+ , getWord8+ , getWord16be+ , getWord32be )++import Data.Binary.Put( putWord16be+ , putWord32be )+import Data.Int( Int16 )+import Data.List( find, sort, sortBy )+import qualified Data.Map.Strict as M+import Data.Maybe( fromMaybe )+import Data.Word( Word8, Word16, Word32 )+import Data.Ord( comparing )++import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU++import Graphics.Text.TrueType.LanguageIds++--------------------------------------------------+---- TtfEncoding+--------------------------------------------------+data TtfEncoding+ = EncodingSymbol+ | EncodingUnicode+ | EncodingShiftJIS+ | EncodingBig5+ | EncodingPRC+ | EncodingWansung+ | EncodingJohab+ deriving (Eq, Show)++instance Binary TtfEncoding where+ put EncodingSymbol = putWord16be 0+ put EncodingUnicode = putWord16be 1+ put EncodingShiftJIS = putWord16be 2+ put EncodingBig5 = putWord16be 3+ put EncodingPRC = putWord16be 4+ put EncodingWansung = putWord16be 5+ put EncodingJohab = putWord16be 6++ get = do+ v <- getWord16be+ case v of+ 0 -> return EncodingSymbol+ 1 -> return EncodingUnicode+ 2 -> return EncodingShiftJIS+ 3 -> return EncodingBig5+ 4 -> return EncodingPRC+ 5 -> return EncodingWansung+ 6 -> return EncodingJohab+ _ -> fail "Unknown encoding"++class CharMappeable a where+ -- | Given a group a character, return a valid glyph+ -- id and the rest of the string.+ glyphIdFromTable :: a -> Char -> Int++ -- | Given a table, retrieve the language code+ langIdOfCharMap :: a -> LangId++type LangId = Word16++--------------------------------------------------+---- CharacterMaps+--------------------------------------------------+data CharacterMap = CharacterMap+ { _charMapPlatformId :: !PlatformId+ , _charMapPlatformSpecific :: !Word16+ , _charMap :: !CharacterTable+ }+ deriving (Eq, Show)++instance NFData CharacterMap where+ rnf (CharacterMap {}) = ()++instance Ord CharacterMap where+ compare = comparing _charMap++newtype CharacterMaps = CharacterMaps [CharacterMap]+ deriving (Eq, Show)++instance NFData CharacterMaps where+ rnf (CharacterMaps maps) = rnf maps `seq` ()++instance Binary CharacterMaps where+ put _ = fail "Unimplemented"+ get = do+ startIndex <- bytesRead+ versionNumber <- getWord16be+ when (versionNumber /= 0)+ (fail "Characte map - invalid version number")+ tableCount <- fromIntegral <$> getWord16be+ let descFetcher = (,,) <$> get <*> getWord16be <*> getWord32be+ third (_, _, t) = t+ tableDesc <-+ sortBy (comparing third) <$> replicateM tableCount descFetcher+ ++ let fetcher (allMaps, lst) (platformId, platformSpecific, offset)+ | M.member offset allMaps = case M.lookup offset allMaps of+ Nothing -> fail "Impossible"+ Just table ->+ return (allMaps, CharacterMap platformId platformSpecific table : lst)+ fetcher (allMaps, lst) (platformId, platformSpecific, offset) = do+ currentOffset <- fromIntegral <$> bytesRead+ let toSkip = fromIntegral offset - currentOffset + startIndex+ when (toSkip > 0)+ (skip $ fromIntegral toSkip)+ mapData <- get+ let charMap = CharacterMap platformId platformSpecific mapData+ return (M.insert offset mapData allMaps, charMap : lst)+ + (_, tables) <- foldM fetcher (M.empty, []) tableDesc+ return . CharacterMaps $ sortBy (comparing _charMap) tables++data CharMapOffset = CharMapOffset+ { _cmoPlatformId :: !Word16+ , _cmoEncodingId :: !TtfEncoding+ , _cmoOffset :: !Word32+ }+ deriving (Eq, Show)++instance Binary CharMapOffset where+ get = CharMapOffset <$> getWord16be <*> get <*> getWord32be+ put (CharMapOffset platform encoding offset) =+ putWord16be platform >> put encoding >> putWord32be offset++--------------------------------------------------+---- CharacterTable+--------------------------------------------------+data CharacterTable+ = TableFormat0 !Format0+ | TableFormat2 !Format2+ | TableFormat4 !Format4+ | TableFormat6 !Format6+ | TableFormatUnknown !Word16+ deriving (Eq, Show)++charTableMap :: (forall table . (CharMappeable table) => table -> a)+ -> CharacterTable -> a+charTableMap f = go+ where+ go (TableFormat0 t) = f t+ go (TableFormat2 t) = f t+ go (TableFormat4 t) = f t+ go (TableFormat6 t) = f t+ go (TableFormatUnknown v) = f v++findCharGlyph :: CharacterMaps -> LangId -> Char -> Int+findCharGlyph (CharacterMaps charMaps) langId character =+ fromMaybe 0 . find (/= 0) . map snd . sort $+ [(_charMapPlatformId allMap, charTableMap (`glyphIdFromTable` character) m)+ | allMap <- charMaps+ , let m = _charMap allMap+ , isLangCompatible m]+ where+ isLangCompatible v = tableLang == 0 || tableLang == langId + where tableLang = charTableMap langIdOfCharMap v++instance Ord CharacterTable where+ compare (TableFormat0 v1) (TableFormat0 v2) =+ comparing langIdOfCharMap v1 v2+ compare (TableFormat2 v1) (TableFormat2 v2) =+ comparing langIdOfCharMap v1 v2+ compare (TableFormat4 v1) (TableFormat4 v2) =+ comparing langIdOfCharMap v1 v2+ compare (TableFormat6 v1) (TableFormat6 v2) =+ comparing langIdOfCharMap v1 v2+ compare (TableFormat0 _) _ = LT+ compare (TableFormat2 _) _ = LT+ compare (TableFormat4 _) _ = LT+ compare (TableFormat6 _) _ = LT+ compare _ _ = GT++instance Binary CharacterTable where+ put _ = fail "Binary.put CharacterTable - Unimplemented"+ get = do+ format <- getWord16be+ case format of+ 0 -> TableFormat0 <$> get+ 2 -> TableFormat2 <$> get+ 4 -> TableFormat4 <$> get+ 6 -> TableFormat6 <$> get+ n -> return $ TableFormatUnknown n++instance CharMappeable Word16 where+ glyphIdFromTable _ _ = 0+ langIdOfCharMap _ = 0+++--------------------------------------------------+---- Format4+--------------------------------------------------+data Format4 = Format4+ { _f4Language :: {-# UNPACK #-} !LangId+ , _f4Map :: M.Map Word16 Word16+ }+ deriving (Eq, Show)++instance CharMappeable Format4 where+ glyphIdFromTable tab v =+ fromIntegral . M.findWithDefault 0 wc $ _f4Map tab+ where wc = fromIntegral $ fromEnum v+ langIdOfCharMap = _f4Language++instance Binary Format4 where+ put _ = error "put Format4 - unimplemented"+ get = do+ startIndex <- bytesRead+ tableLength <- fromIntegral <$> getWord16be+ language <- getWord16be+ -- 2 * segCount+ segCount <- (`div` 2) . fromIntegral <$> getWord16be+ -- 2 * (2**FLOOR(log2(segCount)))+ _searchRange <- getWord16be+ -- log2(searchRange/2)+ _entrySelector <- getWord16be+ -- (2 * segCount) - searchRange+ _rangeShift <- getWord16be++ let fetcher :: Get (VU.Vector Int)+ fetcher =+ VU.replicateM segCount (fromIntegral <$> getWord16be)++ endCodes <- fetcher+ _reservedPad <- getWord16be+ startCodes <- fetcher+ idDelta <-+ VU.replicateM segCount (fromIntegral <$> getWord16be) :: Get (VU.Vector Int16)+ idRangeOffset <- fetcher++ tableBeginIndex <- bytesRead+ let idDeltaInt = VU.map fromIntegral idDelta+ rangeInfo = init . VU.toList $+ VU.zip5 startCodes endCodes idDeltaInt idRangeOffset $+ VU.enumFromN 0 segCount++ indexLeft = fromIntegral $+ (tableLength - (tableBeginIndex - startIndex + 2))+ `div` 2++ indexTable <- VU.replicateM indexLeft getWord16be++ endIndex <- bytesRead+ let toSkip = endIndex - startIndex - tableLength + 2+ if toSkip < 0 then+ fail $ "Read to much Format4 table " ++ show toSkip+ else+ skip $ fromIntegral toSkip+++ return . Format4 language . M.fromList+ $ concatMap (prepare segCount indexTable) rangeInfo+ where+ prepare _ _ (start, end, delta, 0, _) =+ [(fromIntegral char, fromIntegral $ char + delta)+ | char <- [start .. end]]+ prepare segCount indexTable+ (start, end, delta, rangeOffset, ix) =+ -- this is... so convoluted oO+ [( fromIntegral char+ , fromIntegral (if glyphId == 0 then 0 else glyphId + fromIntegral delta))+ | char <- [start .. end]+ , let index =+ (rangeOffset `div` 2) + (char - start) + ix+ - segCount+ , index < VU.length indexTable+ , let glyphId = indexTable VU.! index+ ]++--------------------------------------------------+---- Format0+--------------------------------------------------+data Format0 = Format0+ { _format0Language :: {-# UNPACK #-} !LangId+ , _format0Table :: !(VU.Vector Word8)+ }+ deriving (Eq, Show)++instance CharMappeable Format0 where+ glyphIdFromTable Format0 { _format0Table = table } v+ | ic > VU.length table = 0+ | otherwise = fromIntegral $ table VU.! ic+ where ic = fromEnum v+ + langIdOfCharMap = _format0Language++instance Binary Format0 where+ put _ = fail "Binary.Format0.put - unimplemented"+ get = do+ tableSize <- getWord16be+ when (tableSize /= 262) $+ fail ("table cmap format 0, invalid size: "+ ++ show tableSize)+ Format0 <$> getWord16be <*> VU.replicateM 256 getWord8++--------------------------------------------------+---- Format2+--------------------------------------------------+data Format2 = Format2+ { _format2Language :: {-# UNPACK #-} !LangId+ , _format2SubKeys :: !(VU.Vector Word16)+ , _format2SubHeaders :: !(V.Vector Format2SubHeader)+ }+ deriving (Eq, Show)++data Format2SubHeader = Format2SubHeader+ { _f2SubCode :: {-# UNPACK #-} !Word16+ , _f2EntryCount :: {-# UNPACK #-} !Word16+ , _f2IdDelta :: {-# UNPACK #-} !Int16+ , _f2IdRangeOffset :: {-# UNPACK #-} !Word16+ }+ deriving (Eq, Show)++instance CharMappeable Format2 where+ glyphIdFromTable _ _ = 0+ langIdOfCharMap = _format2Language++instance Binary Format2SubHeader where+ put (Format2SubHeader a b c d) =+ p16 a >> p16 b >> pi16 c >> p16 d+ where+ p16 = putWord16be+ pi16 = p16 . fromIntegral++ get = Format2SubHeader <$> g16 <*> g16 <*> (fromIntegral <$> g16) <*> g16+ where g16 = getWord16be+++instance Binary Format2 where+ put _ = fail "Format2.put - unimplemented"+ get = do+ _tableSize <- getWord16be+ lang <- getWord16be+ subKeys <- VU.map (`div` 8) <$> VU.replicateM 256 getWord16be+ let maxSubIndex = VU.maximum subKeys+ subHeaders <- V.replicateM (fromIntegral maxSubIndex) get+ -- TODO finish the parsing of format 2+ return $ Format2 lang subKeys subHeaders++--------------------------------------------------+---- Format6+--------------------------------------------------+data Format6 = Format6+ { _format6Language :: {-# UNPACK #-} !LangId+ , _format6FirstCode :: {-# UNPACK #-} !Word16+ , _format6ArrayIndex :: !(VU.Vector Word16)+ }+ deriving (Eq, Show)++instance CharMappeable Format6 where+ glyphIdFromTable Format6 { _format6ArrayIndex = table } v+ | ic < VU.length table = fromIntegral $ table VU.! ic+ | otherwise = 0+ where ic = fromEnum v++ langIdOfCharMap = _format6Language++instance Binary Format6 where+ put _ = fail "Format6.put - unimplemented"+ get = do+ _length <- getWord16be+ language <- getWord16be+ firstCode <- getWord16be+ entryCount <- fromIntegral <$> getWord16be+ Format6 language firstCode <$> VU.replicateM entryCount getWord16be
src/Graphics/Text/TrueType/FontFolders.hs view
@@ -1,241 +1,241 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.FontFolders - ( loadUnixFontFolderList - , loadWindowsFontFolderList - , fontFolders - , findFont - , descriptorOf - , FontCache( .. ) - , FontDescriptor( .. ) - , emptyFontCache - , buildFontCache - , enumerateFonts - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -#if !MIN_VERSION_base(4,6,0) -import Control.Monad( guard ) -import Control.Exception( tryJust ) -import System.IO.Error( isDoesNotExistError ) -import System.Environment( getEnv ) -#else -import System.Environment( lookupEnv ) -#endif - -import Control.Monad( when, replicateM ) -import System.Directory( getDirectoryContents - , getHomeDirectory - , doesDirectoryExist - , doesFileExist - ) -import qualified Data.ByteString as B -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , getWord32be - , getByteString - ) -import Data.Binary.Put( Put - , putWord32be - , putByteString ) -import qualified Data.Map.Strict as M -import System.FilePath( (</>) ) - -import Text.XML.Light( elChildren - , elName - , onlyElems - , parseXML - , qName - , strContent ) - -import qualified Control.Exception as E -import qualified Data.Text as T -import qualified Data.Text.IO as T (readFile) - -import Graphics.Text.TrueType.FontType -import Graphics.Text.TrueType.Header -import Graphics.Text.TrueType.Name - -import Control.DeepSeq (($!!)) - -catchAny :: IO a -> (E.SomeException -> IO a) -> IO a -catchAny = E.catch - -loadParseFontsConf :: IO [FilePath] -loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf" - where - getPaths s = map strContent - $ filter ((== "dir") . qName . elName) - $ concatMap elChildren - $ onlyElems - $ parseXML s - -#if !MIN_VERSION_base(4,6,0) -lookupEnv :: String -> IO (Maybe String) -lookupEnv varName = do - v <- tryJust (guard . isDoesNotExistError) $ getEnv varName - case v of - Left _ -> return Nothing - Right val -> return $ Just val -#endif - -loadUnixFontFolderList :: IO [FilePath] -loadUnixFontFolderList = catchAny - (do conf <- loadParseFontsConf - return $!! conf ++ map (</> "truetype") conf) - (const $ return defaults) - where - defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"] - -loadWindowsFontFolderList :: IO [FilePath] -loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir" - where toFontFolder (Just a) = [a </> "Fonts"] - toFontFolder Nothing = [] - -loadOsXFontFolderList :: IO [FilePath] -loadOsXFontFolderList = do - home <- getHomeDirectory - return [home </> "Library" </> "Fonts" - ,"/" </> "Library" </> "Fonts" - ,"/" </> "System" </> "Library" </> "Fonts" - ,"/" </> "System Folder" </> "Fonts" - ] - - -fontFolders :: IO [FilePath] -fontFolders = do - unix <- loadUnixFontFolderList - win <- loadWindowsFontFolderList - osx <- loadOsXFontFolderList - return $ unix ++ win ++ osx - --- | A font descriptor is a key used to find a font --- in a font cache. -data FontDescriptor = FontDescriptor - { -- | The family name of the font - _descriptorFamilyName :: !T.Text - -- | The desired style - , _descriptorStyle :: !FontStyle - } - deriving (Eq, Ord, Show) - -instance Binary FontDescriptor where - put (FontDescriptor t s) = put (T.unpack t) >> put s - get = FontDescriptor <$> (T.pack <$> get) <*> get - --- | A font cache is a cache listing all the found --- fonts on the system, allowing faster font lookup --- once created --- --- FontCache is an instance of binary, to get okish --- performance you should save it in a file somewhere --- instead of rebuilding it everytime! --- --- The font cache is dependent on the version --- of rasterific, you must rebuild it for every --- version. -newtype FontCache = - FontCache (M.Map FontDescriptor FilePath) - deriving Show - --- | Font cache with no pre-existing fonts in it. -emptyFontCache :: FontCache -emptyFontCache = FontCache M.empty - -signature :: B.ByteString -signature = "FontyFruity__FONTCACHE:0.5" - -putFontCache :: FontCache -> Put -putFontCache (FontCache cache) = do - putByteString signature - putWord32be . fromIntegral $ M.size cache - mapM_ put $ M.toList cache - -getFontCache :: Get FontCache -getFontCache = do - str <- getByteString $ B.length signature - when (str /= signature) $ - fail "Invalid font cache" - count <- fromIntegral <$> getWord32be - FontCache . M.fromList <$> replicateM count get - -instance Binary FontCache where - put = putFontCache - get = getFontCache - --- | Returns a list of descriptors of fonts stored in the given cache. -enumerateFonts :: FontCache -> [FontDescriptor] -enumerateFonts (FontCache fs) = M.keys fs - - --- | If possible, returns a descriptor of the Font. -descriptorOf :: Font -> Maybe FontDescriptor -descriptorOf font = do - hdr <- _fontHeader font - names <- _fontNames font - return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr) - - --- | Look in the system's folder for usable fonts. -buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache -buildFontCache loader = do - folders <- fontFolders - found <- build [("", v) | v <- folders] - return . FontCache - $ M.fromList [(d, path) | (Just d, path) <- found - , _descriptorFamilyName d /= ""] - where - build [] = return [] - build ((".", _):rest) = build rest - build (("..", _):rest) = build rest - build ((_, n):rest) = do - isDirectory <- doesDirectoryExist n - - if isDirectory then do - sub <- getDirectoryContents n - (++) <$> build [(s, n </> s) | s <- sub] - <*> build rest - else do - isFile <- doesFileExist n - if isFile then do - f <- loader n - case f of - Nothing -> build rest - Just fo -> ((descriptorOf fo, n) :) <$> build rest - else build rest - -findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle - -> IO (Maybe FilePath) -findFont loader fontName fontStyle = do - folders <- fontFolders - searchIn [("", v) | v <- folders] - where - fontNameText = T.pack fontName - isMatching n (Font { _fontHeader = Just hdr - , _fontNames = Just names}) - | _fHdrMacStyle hdr == fontStyle && - fontFamilyName names == fontNameText = Just n - isMatching _ _ = Nothing - - searchIn [] = return Nothing - searchIn ((".", _):rest) = searchIn rest - searchIn (("..", _):rest) = searchIn rest - searchIn ((_, n):rest) = do - isDirectory <- doesDirectoryExist n - - let findOrRest Nothing = searchIn rest - findOrRest l = return l - - if isDirectory then do - sub <- getDirectoryContents n - subRez <- searchIn [(s, n </> s) | s <- sub] - findOrRest subRez - else do - isFile <- doesFileExist n - if isFile then do - font <- loader n - findOrRest $ font >>= isMatching n - else searchIn rest +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.FontFolders+ ( loadUnixFontFolderList+ , loadWindowsFontFolderList+ , fontFolders+ , findFont+ , descriptorOf+ , FontCache( .. )+ , FontDescriptor( .. )+ , emptyFontCache+ , buildFontCache+ , enumerateFonts+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++#if !MIN_VERSION_base(4,6,0)+import Control.Monad( guard )+import Control.Exception( tryJust )+import System.IO.Error( isDoesNotExistError )+import System.Environment( getEnv )+#else+import System.Environment( lookupEnv )+#endif++import Control.Monad( when, replicateM )+import System.Directory( getDirectoryContents+ , getHomeDirectory+ , doesDirectoryExist+ , doesFileExist+ )+import qualified Data.ByteString as B+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( Get+ , getWord32be+ , getByteString+ )+import Data.Binary.Put( Put+ , putWord32be+ , putByteString )+import qualified Data.Map.Strict as M+import System.FilePath( (</>) )++import Text.XML.Light( elChildren+ , elName+ , onlyElems+ , parseXML+ , qName+ , strContent )++import qualified Control.Exception as E+import qualified Data.Text as T+import qualified Data.Text.IO as T (readFile)++import Graphics.Text.TrueType.FontType+import Graphics.Text.TrueType.Header+import Graphics.Text.TrueType.Name++import Control.DeepSeq (($!!))++catchAny :: IO a -> (E.SomeException -> IO a) -> IO a+catchAny = E.catch++loadParseFontsConf :: IO [FilePath]+loadParseFontsConf = getPaths <$> T.readFile "/etc/fonts/fonts.conf"+ where+ getPaths s = map strContent+ $ filter ((== "dir") . qName . elName)+ $ concatMap elChildren+ $ onlyElems+ $ parseXML s++#if !MIN_VERSION_base(4,6,0)+lookupEnv :: String -> IO (Maybe String)+lookupEnv varName = do+ v <- tryJust (guard . isDoesNotExistError) $ getEnv varName+ case v of+ Left _ -> return Nothing+ Right val -> return $ Just val+#endif++loadUnixFontFolderList :: IO [FilePath]+loadUnixFontFolderList = catchAny+ (do conf <- loadParseFontsConf+ return $!! conf ++ map (</> "truetype") conf)+ (const $ return defaults)+ where+ defaults = ["/usr/share/fonts", "/usr/local/share/fonts", "~/.fonts"]++loadWindowsFontFolderList :: IO [FilePath]+loadWindowsFontFolderList = toFontFolder <$> lookupEnv "Windir"+ where toFontFolder (Just a) = [a </> "Fonts"]+ toFontFolder Nothing = []++loadOsXFontFolderList :: IO [FilePath]+loadOsXFontFolderList = do+ home <- getHomeDirectory+ return [home </> "Library" </> "Fonts"+ ,"/" </> "Library" </> "Fonts"+ ,"/" </> "System" </> "Library" </> "Fonts"+ ,"/" </> "System Folder" </> "Fonts"+ ]+++fontFolders :: IO [FilePath]+fontFolders = do+ unix <- loadUnixFontFolderList+ win <- loadWindowsFontFolderList+ osx <- loadOsXFontFolderList+ return $ unix ++ win ++ osx++-- | A font descriptor is a key used to find a font+-- in a font cache.+data FontDescriptor = FontDescriptor+ { -- | The family name of the font+ _descriptorFamilyName :: !T.Text+ -- | The desired style+ , _descriptorStyle :: !FontStyle+ }+ deriving (Eq, Ord, Show)++instance Binary FontDescriptor where+ put (FontDescriptor t s) = put (T.unpack t) >> put s+ get = FontDescriptor <$> (T.pack <$> get) <*> get++-- | A font cache is a cache listing all the found+-- fonts on the system, allowing faster font lookup+-- once created+--+-- FontCache is an instance of binary, to get okish+-- performance you should save it in a file somewhere+-- instead of rebuilding it everytime!+--+-- The font cache is dependent on the version+-- of rasterific, you must rebuild it for every+-- version.+newtype FontCache =+ FontCache (M.Map FontDescriptor FilePath)+ deriving Show++-- | Font cache with no pre-existing fonts in it.+emptyFontCache :: FontCache+emptyFontCache = FontCache M.empty++signature :: B.ByteString+signature = "FontyFruity__FONTCACHE:0.5"++putFontCache :: FontCache -> Put+putFontCache (FontCache cache) = do+ putByteString signature+ putWord32be . fromIntegral $ M.size cache+ mapM_ put $ M.toList cache++getFontCache :: Get FontCache+getFontCache = do+ str <- getByteString $ B.length signature+ when (str /= signature) $+ fail "Invalid font cache"+ count <- fromIntegral <$> getWord32be+ FontCache . M.fromList <$> replicateM count get++instance Binary FontCache where+ put = putFontCache+ get = getFontCache++-- | Returns a list of descriptors of fonts stored in the given cache.+enumerateFonts :: FontCache -> [FontDescriptor]+enumerateFonts (FontCache fs) = M.keys fs+++-- | If possible, returns a descriptor of the Font.+descriptorOf :: Font -> Maybe FontDescriptor+descriptorOf font = do+ hdr <- _fontHeader font+ names <- _fontNames font+ return $ FontDescriptor (fontFamilyName names) (_fHdrMacStyle hdr)+++-- | Look in the system's folder for usable fonts.+buildFontCache :: (FilePath -> IO (Maybe Font)) -> IO FontCache+buildFontCache loader = do+ folders <- fontFolders+ found <- build [("", v) | v <- folders]+ return . FontCache+ $ M.fromList [(d, path) | (Just d, path) <- found+ , _descriptorFamilyName d /= ""]+ where+ build [] = return []+ build ((".", _):rest) = build rest+ build (("..", _):rest) = build rest+ build ((_, n):rest) = do+ isDirectory <- doesDirectoryExist n++ if isDirectory then do+ sub <- getDirectoryContents n+ (++) <$> build [(s, n </> s) | s <- sub]+ <*> build rest+ else do+ isFile <- doesFileExist n+ if isFile then do+ f <- loader n+ case f of+ Nothing -> build rest+ Just fo -> ((descriptorOf fo, n) :) <$> build rest+ else build rest++findFont :: (FilePath -> IO (Maybe Font)) -> String -> FontStyle+ -> IO (Maybe FilePath)+findFont loader fontName fontStyle = do+ folders <- fontFolders+ searchIn [("", v) | v <- folders]+ where+ fontNameText = T.pack fontName+ isMatching n (Font { _fontHeader = Just hdr+ , _fontNames = Just names})+ | _fHdrMacStyle hdr == fontStyle &&+ fontFamilyName names == fontNameText = Just n+ isMatching _ _ = Nothing++ searchIn [] = return Nothing+ searchIn ((".", _):rest) = searchIn rest+ searchIn (("..", _):rest) = searchIn rest+ searchIn ((_, n):rest) = do+ isDirectory <- doesDirectoryExist n++ let findOrRest Nothing = searchIn rest+ findOrRest l = return l++ if isDirectory then do+ sub <- getDirectoryContents n+ subRez <- searchIn [(s, n </> s) | s <- sub]+ findOrRest subRez+ else do+ isFile <- doesFileExist n+ if isFile then do+ font <- loader n+ findOrRest $ font >>= isMatching n+ else searchIn rest
src/Graphics/Text/TrueType/Header.hs view
@@ -1,143 +1,143 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.Header - ( FontHeader( .. ) - , FontStyle( .. ) - , HeaderFlags( .. ) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Control.DeepSeq( NFData( .. ) ) -import Data.Bits( (.|.), setBit, testBit ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be - , getWord32be - , getWord64be - ) - -import Data.Binary.Put( putWord16be) - -import Data.Int( Int16 ) -import Data.List( foldl' ) -import Data.Word( Word16, Word32, Word64 ) - -import Graphics.Text.TrueType.Types - --- | Describe the basic stylistic properties --- of a font. -data FontStyle = FontStyle - { _fontStyleBold :: !Bool -- ^ If the font is bold. - , _fontStyleItalic :: !Bool -- ^ If the font is italic. - } - deriving (Eq, Ord, Show) - -instance Binary FontStyle where - put style = putWord16be $ italicByte .|. boldByte - where - boldByte - | _fontStyleBold style = 1 - | otherwise = 0 - - italicByte - | _fontStyleItalic style = 2 - | otherwise = 0 - - get = do - styleWord <- getWord16be - let bitAt = testBit styleWord - return $ FontStyle (bitAt 0) (bitAt 1) - --- | Font header -data FontHeader = FontHeader - { -- | Table version number 0x00010000 for version 1.0. - _fHdrVersionNumber :: !Fixed - -- | fontRevision Set by font manufacturer. - , _fHdrFontRevision :: !Fixed - -- | To compute: set it to 0, sum the entire font as - -- ULONG, then store 0xB1B0AFBA - sum. - , _fHdrChecksumAdjust :: !Word32 - - -- | Should be equal to 0x5F0F3CF5. - , _fHdrMagicNumber :: !Word32 - , _fHdrFlags :: !HeaderFlags - - -- | Valid range is from 16 to 16384 - , _fUnitsPerEm :: !Word16 - -- | International date (8-byte field). - , _fHdrCreateTime :: !Word64 - -- | International date (8-byte field). - , _fHdrModificationTime :: !Word64 - - -- | For all glyph bounding boxes. - , _fHdrxMin :: !FWord - -- | For all glyph bounding boxes. - , _fHdrYMin :: !FWord - -- | For all glyph bounding boxes. - , _fHdrXMax :: !FWord - -- | For all glyph bounding boxes. - , _fHdrYMax :: !FWord - -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1) - , _fHdrMacStyle :: !FontStyle - -- | Smallest readable size in pixels. - , _fHdrLowestRecPPEM :: !Word16 - - -- | 0 Fully mixed directional glyphs; - -- 1 Only strongly left to right; - -- 2 Like 1 but also contains neutrals ; - -- -1 Only strongly right to left; - -- -2 Like -1 but also contains neutrals. - , _fHdrFontDirectionHint :: !Int16 - -- | 0 for short offsets, 1 for long. - , _fHdrIndexToLocFormat :: !Int16 - -- | 0 for current format. - , _fHdrGlyphDataFormat :: !Int16 - } - deriving (Eq, Show) - -instance NFData FontHeader where - rnf (FontHeader {}) = () - -instance Binary FontHeader where - put _ = fail "Unimplemented" - get = - FontHeader <$> get <*> get <*> g32 <*> g32 <*> get - <*> g16 <*> g64 <*> g64 <*> get <*> get - <*> get <*> get <*> get <*> g16 <*> gi16 - <*> gi16 <*> gi16 - where g16 = getWord16be - g32 = getWord32be - gi16 = fromIntegral <$> getWord16be - g64 = getWord64be - - --- | Header flags. -data HeaderFlags = HeaderFlags - { -- | Bit 0 - baseline for font at y=0; - _hfBaselineY0 :: !Bool - -- | Bit 1 - left sidebearing at x=0; - , _hfLeftSideBearing :: !Bool - -- | Bit 2 - instructions may depend on point size; - , _hfInstrDependPointSize :: !Bool - -- | Bit 3 - force ppem to integer values for all internal - -- scaler math; may use fractional ppem sizes if this bit - -- is clear; - , _hfForcePPEM :: !Bool - -- | Bit 4 - instructions may alter advance width (the - -- advance widths might not scale linearly); - , _hfAlterAdvance :: !Bool - } - deriving (Eq, Show) - -instance Binary HeaderFlags where - get = do - flags <- getWord16be - let at ix = flags `testBit` ix - return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4) - - put (HeaderFlags a0 a1 a2 a3 a4) = - putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4] - where setter acc (_, False) = acc - setter acc (ix, True) = setBit acc ix - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.Header+ ( FontHeader( .. )+ , FontStyle( .. )+ , HeaderFlags( .. )+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++import Control.DeepSeq( NFData( .. ) )+import Data.Bits( (.|.), setBit, testBit )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( getWord16be+ , getWord32be+ , getWord64be+ )++import Data.Binary.Put( putWord16be)++import Data.Int( Int16 )+import Data.List( foldl' )+import Data.Word( Word16, Word32, Word64 )++import Graphics.Text.TrueType.Types++-- | Describe the basic stylistic properties+-- of a font.+data FontStyle = FontStyle+ { _fontStyleBold :: !Bool -- ^ If the font is bold.+ , _fontStyleItalic :: !Bool -- ^ If the font is italic.+ }+ deriving (Eq, Ord, Show)++instance Binary FontStyle where+ put style = putWord16be $ italicByte .|. boldByte+ where+ boldByte+ | _fontStyleBold style = 1+ | otherwise = 0++ italicByte+ | _fontStyleItalic style = 2+ | otherwise = 0++ get = do+ styleWord <- getWord16be + let bitAt = testBit styleWord+ return $ FontStyle (bitAt 0) (bitAt 1)++-- | Font header+data FontHeader = FontHeader+ { -- | Table version number 0x00010000 for version 1.0.+ _fHdrVersionNumber :: !Fixed+ -- | fontRevision Set by font manufacturer.+ , _fHdrFontRevision :: !Fixed+ -- | To compute: set it to 0, sum the entire font as+ -- ULONG, then store 0xB1B0AFBA - sum.+ , _fHdrChecksumAdjust :: !Word32+ + -- | Should be equal to 0x5F0F3CF5.+ , _fHdrMagicNumber :: !Word32+ , _fHdrFlags :: !HeaderFlags++ -- | Valid range is from 16 to 16384+ , _fUnitsPerEm :: !Word16+ -- | International date (8-byte field).+ , _fHdrCreateTime :: !Word64+ -- | International date (8-byte field).+ , _fHdrModificationTime :: !Word64++ -- | For all glyph bounding boxes.+ , _fHdrxMin :: !FWord+ -- | For all glyph bounding boxes.+ , _fHdrYMin :: !FWord+ -- | For all glyph bounding boxes.+ , _fHdrXMax :: !FWord+ -- | For all glyph bounding boxes.+ , _fHdrYMax :: !FWord+ -- | Bit 0 bold (if set to 1); Bit 1 italic (if set to 1)+ , _fHdrMacStyle :: !FontStyle+ -- | Smallest readable size in pixels.+ , _fHdrLowestRecPPEM :: !Word16++ -- | 0 Fully mixed directional glyphs;+ -- 1 Only strongly left to right;+ -- 2 Like 1 but also contains neutrals ;+ -- -1 Only strongly right to left;+ -- -2 Like -1 but also contains neutrals.+ , _fHdrFontDirectionHint :: !Int16+ -- | 0 for short offsets, 1 for long.+ , _fHdrIndexToLocFormat :: !Int16+ -- | 0 for current format.+ , _fHdrGlyphDataFormat :: !Int16+ }+ deriving (Eq, Show)++instance NFData FontHeader where+ rnf (FontHeader {}) = ()++instance Binary FontHeader where+ put _ = fail "Unimplemented"+ get =+ FontHeader <$> get <*> get <*> g32 <*> g32 <*> get+ <*> g16 <*> g64 <*> g64 <*> get <*> get+ <*> get <*> get <*> get <*> g16 <*> gi16+ <*> gi16 <*> gi16+ where g16 = getWord16be+ g32 = getWord32be+ gi16 = fromIntegral <$> getWord16be+ g64 = getWord64be+++-- | Header flags.+data HeaderFlags = HeaderFlags+ { -- | Bit 0 - baseline for font at y=0;+ _hfBaselineY0 :: !Bool+ -- | Bit 1 - left sidebearing at x=0;+ , _hfLeftSideBearing :: !Bool+ -- | Bit 2 - instructions may depend on point size;+ , _hfInstrDependPointSize :: !Bool+ -- | Bit 3 - force ppem to integer values for all internal+ -- scaler math; may use fractional ppem sizes if this bit+ -- is clear;+ , _hfForcePPEM :: !Bool+ -- | Bit 4 - instructions may alter advance width (the+ -- advance widths might not scale linearly);+ , _hfAlterAdvance :: !Bool+ }+ deriving (Eq, Show)++instance Binary HeaderFlags where+ get = do+ flags <- getWord16be+ let at ix = flags `testBit` ix+ return $ HeaderFlags (at 0) (at 1) (at 2) (at 3) (at 4)++ put (HeaderFlags a0 a1 a2 a3 a4) =+ putWord16be . foldl' setter 0 $ zip [0..] [a0, a1, a2, a3, a4]+ where setter acc (_, False) = acc+ setter acc (ix, True) = setBit acc ix+
src/Graphics/Text/TrueType/HorizontalInfo.hs view
@@ -1,120 +1,120 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.HorizontalInfo - ( HorizontalHeader( .. ) - , HorizontalMetricsTable( .. ) - , HorizontalMetric( .. ) - , getHorizontalMetrics - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Control.DeepSeq( NFData( .. ) ) -import Control.Monad( when, replicateM_ ) -import Data.Word( Word16 ) -import Data.Int( Int16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get, getWord16be, getWord32be ) -import Data.Binary.Put( putWord16be, putWord32be ) -import qualified Data.Vector as V - -import Graphics.Text.TrueType.Types - --- | Describe the "hhea" TrueType table. -data HorizontalHeader = HorizontalHeader - { -- | Distance from baseline of highest ascender - _hheaAscent :: {-# UNPACK #-} !FWord - -- | Distance from baseline of lowest descender - , _hheaDescent :: {-# UNPACK #-} !FWord - -- | typographic line gap - , _hheaLineGap :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord - -- | must be consistent with horizontal metrics - , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord - -- | max(lsb + (xMax-xMin)) - , _hheaXmaxExtent :: {-# UNPACK #-} !FWord - -- | used to calculate the slope of the caret - -- (rise/run) set to 1 for vertical caret - , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16 - -- | 0 for vertical - , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16 - -- | set value to 0 for non-slanted fonts - , _hheaCaretOffset :: {-# UNPACK #-} !FWord - -- | 0 for current format - , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16 - -- | number of advance widths in metrics table - , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16 - } - deriving (Eq, Show) - -instance NFData HorizontalHeader where - rnf (HorizontalHeader {}) = () - -instance Binary HorizontalHeader where - put hdr = do - putWord32be 0x00010000 - put $ _hheaAscent hdr - put $ _hheaDescent hdr - put $ _hheaLineGap hdr - put $ _hheaAdvanceWidthMax hdr - put $ _hheaMinLeftSideBearing hdr - put $ _hheaMinRightSideBearing hdr - put $ _hheaXmaxExtent hdr - putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr - putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr - put $ _hheaCaretOffset hdr - replicateM_ 4 $ putWord16be 0 - putWord16be . fromIntegral $ _hheaMetricDataFormat hdr - putWord16be $ _hheaLongHorMetricCount hdr - - get = do - ver <- getWord32be - when (ver /= 0x00010000) - (fail "Invalid HorizontalHeader (hhea) version") - startHdr <- HorizontalHeader - <$> get <*> get <*> get <*> get - <*> get <*> get <*> get - <*> (fromIntegral <$> getWord16be) - <*> (fromIntegral <$> getWord16be) - <*> get - replicateM_ 4 getWord16be -- reserved, don't care - startHdr <$> (fromIntegral <$> getWord16be) - <*> getWord16be - --- | Information of horizontal advance. -data HorizontalMetric = HorizontalMetric - { _hmtxAdvanceWidth :: {-# UNPACK #-} !Word16 - , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16 - } - deriving (Eq, Show) - -instance Binary HorizontalMetric where - put (HorizontalMetric adv bear) = - putWord16be adv >> putWord16be (fromIntegral bear) - - get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16) - where g16 = getWord16be - --- | For every glyph (indexed by the glyph index), --- provide horizontal information. -data HorizontalMetricsTable = HorizontalMetricsTable - { _glyphMetrics :: !(V.Vector HorizontalMetric) - } - deriving (Eq, Show) - -getHorizontalMetrics :: Int -- ^ Metrics count - -> Int -- ^ Glyph count - -> Get HorizontalMetricsTable -getHorizontalMetrics numberOfMetrics glyphCount = do - hMetrics <- V.replicateM numberOfMetrics get - let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics - run <- V.replicateM sideBearingCount $ - HorizontalMetric lastAdvance . fromIntegral <$> getWord16be - return $ HorizontalMetricsTable $ V.concat [hMetrics, run] - where - sideBearingCount = glyphCount - numberOfMetrics - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.HorizontalInfo+ ( HorizontalHeader( .. )+ , HorizontalMetricsTable( .. )+ , HorizontalMetric( .. )+ , getHorizontalMetrics+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++import Control.DeepSeq( NFData( .. ) )+import Control.Monad( when, replicateM_ )+import Data.Word( Word16 )+import Data.Int( Int16 )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( Get, getWord16be, getWord32be )+import Data.Binary.Put( putWord16be, putWord32be )+import qualified Data.Vector as V++import Graphics.Text.TrueType.Types++-- | Describe the "hhea" TrueType table.+data HorizontalHeader = HorizontalHeader+ { -- | Distance from baseline of highest ascender+ _hheaAscent :: {-# UNPACK #-} !FWord+ -- | Distance from baseline of lowest descender+ , _hheaDescent :: {-# UNPACK #-} !FWord+ -- | typographic line gap+ , _hheaLineGap :: {-# UNPACK #-} !FWord+ -- | must be consistent with horizontal metrics+ , _hheaAdvanceWidthMax :: {-# UNPACK #-} !FWord+ -- | must be consistent with horizontal metrics+ , _hheaMinLeftSideBearing :: {-# UNPACK #-} !FWord+ -- | must be consistent with horizontal metrics+ , _hheaMinRightSideBearing :: {-# UNPACK #-} !FWord+ -- | max(lsb + (xMax-xMin))+ , _hheaXmaxExtent :: {-# UNPACK #-} !FWord+ -- | used to calculate the slope of the caret + -- (rise/run) set to 1 for vertical caret+ , _hheaCaretSlopeRise :: {-# UNPACK #-} !Int16+ -- | 0 for vertical+ , _hheaCaretSlopeRun :: {-# UNPACK #-} !Int16+ -- | set value to 0 for non-slanted fonts+ , _hheaCaretOffset :: {-# UNPACK #-} !FWord+ -- | 0 for current format+ , _hheaMetricDataFormat :: {-# UNPACK #-} !Int16+ -- | number of advance widths in metrics table+ , _hheaLongHorMetricCount :: {-# UNPACK #-} !Word16+ }+ deriving (Eq, Show)++instance NFData HorizontalHeader where+ rnf (HorizontalHeader {}) = ()++instance Binary HorizontalHeader where+ put hdr = do+ putWord32be 0x00010000+ put $ _hheaAscent hdr+ put $ _hheaDescent hdr+ put $ _hheaLineGap hdr+ put $ _hheaAdvanceWidthMax hdr+ put $ _hheaMinLeftSideBearing hdr+ put $ _hheaMinRightSideBearing hdr+ put $ _hheaXmaxExtent hdr+ putWord16be . fromIntegral $ _hheaCaretSlopeRise hdr+ putWord16be . fromIntegral $ _hheaCaretSlopeRun hdr+ put $ _hheaCaretOffset hdr+ replicateM_ 4 $ putWord16be 0+ putWord16be . fromIntegral $ _hheaMetricDataFormat hdr+ putWord16be $ _hheaLongHorMetricCount hdr++ get = do+ ver <- getWord32be+ when (ver /= 0x00010000)+ (fail "Invalid HorizontalHeader (hhea) version")+ startHdr <- HorizontalHeader+ <$> get <*> get <*> get <*> get+ <*> get <*> get <*> get+ <*> (fromIntegral <$> getWord16be)+ <*> (fromIntegral <$> getWord16be)+ <*> get+ replicateM_ 4 getWord16be -- reserved, don't care+ startHdr <$> (fromIntegral <$> getWord16be)+ <*> getWord16be++-- | Information of horizontal advance.+data HorizontalMetric = HorizontalMetric+ { _hmtxAdvanceWidth :: {-# UNPACK #-} !Word16+ , _hmtxLeftSideBearing :: {-# UNPACK #-} !Int16+ }+ deriving (Eq, Show)++instance Binary HorizontalMetric where+ put (HorizontalMetric adv bear) =+ putWord16be adv >> putWord16be (fromIntegral bear)++ get = HorizontalMetric <$> g16 <*> (fromIntegral <$> g16)+ where g16 = getWord16be++-- | For every glyph (indexed by the glyph index),+-- provide horizontal information.+data HorizontalMetricsTable = HorizontalMetricsTable+ { _glyphMetrics :: !(V.Vector HorizontalMetric)+ }+ deriving (Eq, Show)++getHorizontalMetrics :: Int -- ^ Metrics count+ -> Int -- ^ Glyph count+ -> Get HorizontalMetricsTable+getHorizontalMetrics numberOfMetrics glyphCount = do+ hMetrics <- V.replicateM numberOfMetrics get+ let lastAdvance = _hmtxAdvanceWidth $ V.last hMetrics+ run <- V.replicateM sideBearingCount $+ HorizontalMetric lastAdvance . fromIntegral <$> getWord16be+ return $ HorizontalMetricsTable $ V.concat [hMetrics, run]+ where+ sideBearingCount = glyphCount - numberOfMetrics +
src/Graphics/Text/TrueType/MaxpTable.hs view
@@ -1,59 +1,59 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Control.DeepSeq( NFData( .. ) ) -import Data.Word( Word16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be ) - -import Graphics.Text.TrueType.Types - -data MaxpTable = MaxpTable - { -- | version number 0x00010000 for version 1.0. - _maxpTableVersion :: !Fixed - -- | The number of glyphs in the font. - , _maxpnumGlyphs :: !Word16 - -- | Maximum points in a non-composite glyph. - , _maxpmaxPoints :: !Word16 - -- | Maximum contours in a non-composite glyph. - , _maxpmaxContours :: !Word16 - -- | Maximum points in a composite glyph. - , _maxpmaxCompositePoints :: !Word16 - -- | Maximum contours in a composite glyph. - , _maxpmaxCompositeContours :: !Word16 - -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases. - , _maxpmaxZones :: !Word16 - -- | Maximum points used in Z0. - , _maxpmaxTwilightPoints :: !Word16 - -- | Number of Storage Area locations. - , _maxpmaxStorage :: !Word16 - -- | Number of FDEFs. - , _maxpmaxFunctionDefs :: !Word16 - -- | Number of IDEFs. - , _maxpmaxInstructionDefs :: !Word16 - -- | Maximum stack depth . - , _maxpmaxStackElements :: !Word16 - -- | Maximum byte count for glyph instructions. - , _maxpmaxSizeOfInstructions :: !Word16 - -- | Maximum number of components referenced at "top level" for any composite glyph. - , _maxpmaxComponentElements :: !Word16 - -- | Maximum levels of recursion; 1 for simple components. - , _maxpmaxComponentDepth :: !Word16 - } - deriving (Eq, Show) - -instance NFData MaxpTable where - rnf (MaxpTable {}) = () - -instance Binary MaxpTable where - put _ = fail "Unimplemented" - get = MaxpTable - <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 - where g16 = getWord16be - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.MaxpTable( MaxpTable( .. ) ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++import Control.DeepSeq( NFData( .. ) )+import Data.Word( Word16 )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( getWord16be )++import Graphics.Text.TrueType.Types++data MaxpTable = MaxpTable + { -- | version number 0x00010000 for version 1.0.+ _maxpTableVersion :: !Fixed+ -- | The number of glyphs in the font.+ , _maxpnumGlyphs :: !Word16+ -- | Maximum points in a non-composite glyph.+ , _maxpmaxPoints :: !Word16+ -- | Maximum contours in a non-composite glyph.+ , _maxpmaxContours :: !Word16+ -- | Maximum points in a composite glyph.+ , _maxpmaxCompositePoints :: !Word16+ -- | Maximum contours in a composite glyph.+ , _maxpmaxCompositeContours :: !Word16+ -- | 1 if instructions do not use the twilight zone (Z0), or 2 if instructions do use Z0; should be set to 2 in most cases.+ , _maxpmaxZones :: !Word16+ -- | Maximum points used in Z0.+ , _maxpmaxTwilightPoints :: !Word16+ -- | Number of Storage Area locations. + , _maxpmaxStorage :: !Word16+ -- | Number of FDEFs.+ , _maxpmaxFunctionDefs :: !Word16+ -- | Number of IDEFs.+ , _maxpmaxInstructionDefs :: !Word16+ -- | Maximum stack depth .+ , _maxpmaxStackElements :: !Word16+ -- | Maximum byte count for glyph instructions.+ , _maxpmaxSizeOfInstructions :: !Word16+ -- | Maximum number of components referenced at "top level" for any composite glyph.+ , _maxpmaxComponentElements :: !Word16+ -- | Maximum levels of recursion; 1 for simple components.+ , _maxpmaxComponentDepth :: !Word16+ }+ deriving (Eq, Show)++instance NFData MaxpTable where+ rnf (MaxpTable {}) = ()++instance Binary MaxpTable where+ put _ = fail "Unimplemented"+ get = MaxpTable + <$> get <*> g16 <*> g16 <*> g16 <*> g16 <*> g16+ <*> g16 <*> g16 <*> g16 <*> g16 <*> g16 <*> g16+ <*> g16 <*> g16 <*> g16+ where g16 = getWord16be+
src/Graphics/Text/TrueType/Name.hs view
@@ -1,122 +1,122 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.Name - ( NameTable - , NameRecords - , fontFamilyName - ) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( (<$>), (<*>), pure ) -#endif - -import Control.DeepSeq( NFData( .. ) ) -import Control.Monad( when, replicateM ) -import Data.Foldable( asum ) -import Data.Function( on ) -import Data.List( maximumBy ) -import Data.Maybe( fromMaybe ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be, getByteString ) -import Data.Binary.Put( putWord16be ) -import Data.Word( Word16 ) -import qualified Data.Vector as V -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE - -import Graphics.Text.TrueType.LanguageIds - -data NameTable = NameTable - { _ntRecords :: !(V.Vector NameRecords) } - deriving Show - -instance NFData NameTable where - rnf (NameTable {}) = () - -instance Binary NameTable where - put _ = fail "Binary.put NameTable - unimplemented" - get = do - nameFormatId <- getWord16be - when (nameFormatId /= 0) $ - fail "Invalid name table format" - count <- getWord16be - stringOffset <- getWord16be - records <- replicateM (fromIntegral count) get - let maxRec = maximumBy (compare `on` _nrOffset) records - toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec) - - fromIntegral stringOffset - - strTable <- getByteString toFetch - let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable } - where iLength = fromIntegral $ _nrLength r - iOffset = fromIntegral $ _nrOffset r - - return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records - -data NameRecords = NameRecords - { _nrPlatoformId :: {-# UNPACK #-} !Word16 - , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16 - , _nrLanguageId :: {-# UNPACK #-} !Word16 - , _nrNameId :: {-# UNPACK #-} !Word16 - , _nrLength :: {-# UNPACK #-} !Word16 - , _nrOffset :: {-# UNPACK #-} !Word16 - , _nrString :: !B.ByteString - } - deriving Show - -fontFamilyName :: NameTable -> T.Text -fontFamilyName (NameTable { _ntRecords = records }) = - fromMaybe T.empty . asum $ transform <$> - [ (selectorUnicode, utf16Decoder) - , (selectorMac, utf8Decoder) - , (selectorWin0, utf16Decoder) - , (selectorWin1, utf16Decoder) - ] - where - utf16Decoder = TE.decodeUtf16BE . _nrString - utf8Decoder = TE.decodeUtf8 . _nrString - transform (selector, decoder) = - decoder <$> V.find selector records - - fontFamilyId = 1 - - windowsPlatform = - platformToWord PlatformWindows - selectorWin0 r = - _nrNameId r == fontFamilyId && - _nrPlatoformId r == windowsPlatform && - _nrPlatformSpecificId r == 0 - - selectorWin1 r = - _nrNameId r == fontFamilyId && - _nrPlatoformId r == windowsPlatform && - _nrPlatformSpecificId r == 1 - - macPlatform = - platformToWord PlatformMacintosh - selectorMac r = - _nrNameId r == fontFamilyId && - _nrPlatoformId r == macPlatform && - _nrPlatformSpecificId r == 0 - - unicodePlatform = - platformToWord PlatformUnicode - semanticUnicode2 = - unicodePlatformSpecificToId UnicodeBMPOnly2_0 - selectorUnicode r = - _nrNameId r == fontFamilyId && - _nrPlatoformId r == unicodePlatform && - _nrPlatformSpecificId r == semanticUnicode2 - -instance Binary NameRecords where - get = NameRecords <$> g16 <*> g16 <*> g16 - <*> g16 <*> g16 <*> g16 - <*> pure mempty - where g16 = getWord16be - - put (NameRecords p ps l n len ofs _) = - p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs - where p16 = putWord16be - - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.Name+ ( NameTable+ , NameRecords+ , fontFamilyName+ ) where++#if !MIN_VERSION_base(4,8,0)+import Data.Monoid( mempty )+import Control.Applicative( (<$>), (<*>), pure )+#endif++import Control.DeepSeq( NFData( .. ) )+import Control.Monad( when, replicateM )+import Data.Foldable( asum )+import Data.Function( on )+import Data.List( maximumBy )+import Data.Maybe( fromMaybe )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( getWord16be, getByteString )+import Data.Binary.Put( putWord16be )+import Data.Word( Word16 )+import qualified Data.Vector as V+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Graphics.Text.TrueType.LanguageIds++data NameTable = NameTable+ { _ntRecords :: !(V.Vector NameRecords) }+ deriving Show++instance NFData NameTable where+ rnf (NameTable {}) = ()++instance Binary NameTable where+ put _ = fail "Binary.put NameTable - unimplemented"+ get = do+ nameFormatId <- getWord16be+ when (nameFormatId /= 0) $+ fail "Invalid name table format"+ count <- getWord16be+ stringOffset <- getWord16be+ records <- replicateM (fromIntegral count) get+ let maxRec = maximumBy (compare `on` _nrOffset) records+ toFetch = fromIntegral (_nrOffset maxRec) + fromIntegral (_nrLength maxRec)+ - fromIntegral stringOffset++ strTable <- getByteString toFetch+ let fetcher r = r { _nrString = B.take iLength $ B.drop iOffset strTable }+ where iLength = fromIntegral $ _nrLength r+ iOffset = fromIntegral $ _nrOffset r++ return . NameTable . V.fromListN (fromIntegral count) $ map fetcher records++data NameRecords = NameRecords+ { _nrPlatoformId :: {-# UNPACK #-} !Word16+ , _nrPlatformSpecificId :: {-# UNPACK #-} !Word16+ , _nrLanguageId :: {-# UNPACK #-} !Word16+ , _nrNameId :: {-# UNPACK #-} !Word16+ , _nrLength :: {-# UNPACK #-} !Word16+ , _nrOffset :: {-# UNPACK #-} !Word16+ , _nrString :: !B.ByteString+ }+ deriving Show++fontFamilyName :: NameTable -> T.Text+fontFamilyName (NameTable { _ntRecords = records }) =+ fromMaybe T.empty . asum $ transform <$>+ [ (selectorUnicode, utf16Decoder)+ , (selectorMac, utf8Decoder)+ , (selectorWin0, utf16Decoder)+ , (selectorWin1, utf16Decoder)+ ]+ where+ utf16Decoder = TE.decodeUtf16BE . _nrString+ utf8Decoder = TE.decodeUtf8 . _nrString+ transform (selector, decoder) =+ decoder <$> V.find selector records++ fontFamilyId = 1++ windowsPlatform =+ platformToWord PlatformWindows+ selectorWin0 r =+ _nrNameId r == fontFamilyId &&+ _nrPlatoformId r == windowsPlatform &&+ _nrPlatformSpecificId r == 0++ selectorWin1 r =+ _nrNameId r == fontFamilyId &&+ _nrPlatoformId r == windowsPlatform &&+ _nrPlatformSpecificId r == 1++ macPlatform =+ platformToWord PlatformMacintosh+ selectorMac r =+ _nrNameId r == fontFamilyId &&+ _nrPlatoformId r == macPlatform &&+ _nrPlatformSpecificId r == 0++ unicodePlatform =+ platformToWord PlatformUnicode+ semanticUnicode2 =+ unicodePlatformSpecificToId UnicodeBMPOnly2_0+ selectorUnicode r =+ _nrNameId r == fontFamilyId &&+ _nrPlatoformId r == unicodePlatform &&+ _nrPlatformSpecificId r == semanticUnicode2++instance Binary NameRecords where+ get = NameRecords <$> g16 <*> g16 <*> g16 + <*> g16 <*> g16 <*> g16 + <*> pure mempty+ where g16 = getWord16be++ put (NameRecords p ps l n len ofs _) =+ p16 p >> p16 ps >> p16 l >> p16 n >> p16 len >> p16 ofs+ where p16 = putWord16be++
src/Graphics/Text/TrueType/OffsetTable.hs view
@@ -1,89 +1,89 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.OffsetTable - ( OffsetTableHeader( .. ) - , OffsetTable( .. ) - , TableDirectoryEntry( .. ) - , filterTable - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Data.Word( Word16, Word32 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be - , getWord32be - , getByteString - ) - -import Data.Binary.Put( putWord16be - , putWord32be - , putByteString - ) - -import qualified Data.Vector as V -import qualified Data.ByteString.Char8 as BC - -import Graphics.Text.TrueType.Types - -data OffsetTableHeader = OffsetTableHeader - { -- | sfnt version 0x00010000 for version 1.0. - _othSfntVersion :: !Fixed - -- | numTables Number of tables. - , _othTableCount :: !Word16 - -- | searchRange (Maximum power of 2 ? numTables) x 16. - , _othSearchRange :: !Word16 - -- | entrySelector Log2(maximum power of 2 ? numTables). - , _othEntrySelector :: !Word16 - -- | rangeShift NumTables x 16-searchRange. - , _othRangeShift :: !Word16 - } - deriving (Eq, Show) - -instance Binary OffsetTableHeader where - get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16 - where g16 = getWord16be - put (OffsetTableHeader ver c sr es rs) = - put ver >> p16 c >> p16 sr >> p16 es >> p16 rs - where p16 = putWord16be - -data TableDirectoryEntry = TableDirectoryEntry - { -- | tag 4 -byte identifier. - _tdeTag :: !BC.ByteString - -- | CheckSum for this table. - , _tdeChecksum :: !Word32 - -- | Offset from beginning of TrueType font file. - , _tdeOffset :: !Word32 - -- | Length of this table. - , _tdeLength :: !Word32 - } - deriving (Eq, Show) - -filterTable :: (BC.ByteString -> Bool) -> OffsetTable - -> OffsetTable -filterTable f table = - table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table } - -instance Binary TableDirectoryEntry where - get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32 - where g32 = getWord32be - put (TableDirectoryEntry tag chk offset ln) = - putByteString tag >> p32 chk >> p32 offset >> p32 ln - where p32 = putWord32be - -data OffsetTable = OffsetTable - { _otHeader :: !OffsetTableHeader - , _otEntries :: !(V.Vector TableDirectoryEntry) - } - deriving (Eq, Show) - -instance Binary OffsetTable where - put (OffsetTable hdr entries) = - put hdr >> V.forM_ entries put - - get = do - hdr <- get - let count = fromIntegral $ _othTableCount hdr - OffsetTable hdr <$> V.replicateM count get - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.OffsetTable+ ( OffsetTableHeader( .. )+ , OffsetTable( .. )+ , TableDirectoryEntry( .. )+ , filterTable+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<*>), (<$>) )+#endif++import Data.Word( Word16, Word32 )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( getWord16be+ , getWord32be+ , getByteString+ )++import Data.Binary.Put( putWord16be+ , putWord32be+ , putByteString+ )++import qualified Data.Vector as V+import qualified Data.ByteString.Char8 as BC++import Graphics.Text.TrueType.Types++data OffsetTableHeader = OffsetTableHeader+ { -- | sfnt version 0x00010000 for version 1.0.+ _othSfntVersion :: !Fixed+ -- | numTables Number of tables.+ , _othTableCount :: !Word16+ -- | searchRange (Maximum power of 2 ? numTables) x 16.+ , _othSearchRange :: !Word16+ -- | entrySelector Log2(maximum power of 2 ? numTables).+ , _othEntrySelector :: !Word16+ -- | rangeShift NumTables x 16-searchRange.+ , _othRangeShift :: !Word16+ }+ deriving (Eq, Show)++instance Binary OffsetTableHeader where+ get = OffsetTableHeader <$> get <*> g16 <*> g16 <*> g16 <*> g16+ where g16 = getWord16be+ put (OffsetTableHeader ver c sr es rs) =+ put ver >> p16 c >> p16 sr >> p16 es >> p16 rs+ where p16 = putWord16be++data TableDirectoryEntry = TableDirectoryEntry+ { -- | tag 4 -byte identifier.+ _tdeTag :: !BC.ByteString+ -- | CheckSum for this table.+ , _tdeChecksum :: !Word32+ -- | Offset from beginning of TrueType font file.+ , _tdeOffset :: !Word32+ -- | Length of this table.+ , _tdeLength :: !Word32+ }+ deriving (Eq, Show)++filterTable :: (BC.ByteString -> Bool) -> OffsetTable+ -> OffsetTable+filterTable f table =+ table { _otEntries = V.filter (f . _tdeTag) $ _otEntries table }++instance Binary TableDirectoryEntry where+ get = TableDirectoryEntry <$> getByteString 4 <*> g32 <*> g32 <*> g32+ where g32 = getWord32be+ put (TableDirectoryEntry tag chk offset ln) =+ putByteString tag >> p32 chk >> p32 offset >> p32 ln+ where p32 = putWord32be++data OffsetTable = OffsetTable+ { _otHeader :: !OffsetTableHeader+ , _otEntries :: !(V.Vector TableDirectoryEntry)+ }+ deriving (Eq, Show)++instance Binary OffsetTable where+ put (OffsetTable hdr entries) =+ put hdr >> V.forM_ entries put++ get = do+ hdr <- get+ let count = fromIntegral $ _othTableCount hdr+ OffsetTable hdr <$> V.replicateM count get+
src/Graphics/Text/TrueType/Types.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE CPP #-} -module Graphics.Text.TrueType.Types - ( Fixed( .. ) - , FWord( .. ) - , F26Dot6( .. ) - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>) ) -#endif - -import Data.Int( Int32 ) -import Data.Word( Word16 ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( getWord16be) -import Data.Binary.Put( putWord16be ) - -data Fixed = Fixed Word16 Word16 - deriving (Eq, Show) - -instance Binary Fixed where - get = Fixed <$> getWord16be <*> getWord16be - put (Fixed a b) = putWord16be a >> putWord16be b - -newtype FWord = FWord Word16 - deriving (Eq, Show) - -instance Binary FWord where - put (FWord w) = putWord16be w - get = FWord <$> getWord16be - -newtype F26Dot6 = F26Dot6 Int32 - deriving (Eq, Show, Ord) - -instance Num F26Dot6 where - (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b - (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b - (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64 - negate (F26Dot6 a) = F26Dot6 $ negate a - abs (F26Dot6 a) = F26Dot6 $ abs a - signum (F26Dot6 a) = F26Dot6 $ signum a * 64 - fromInteger a = F26Dot6 $ fromInteger a * 64 - -instance Fractional F26Dot6 where - fromRational a = F26Dot6 $ floor ad - where ad = fromRational a * 64 :: Double - (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b - +{-# LANGUAGE CPP #-}+module Graphics.Text.TrueType.Types+ ( Fixed( .. )+ , FWord( .. )+ , F26Dot6( .. )+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative( (<$>), (<*>) )+#endif++import Data.Int( Int32 )+import Data.Word( Word16 )+import Data.Binary( Binary( .. ) )+import Data.Binary.Get( getWord16be)+import Data.Binary.Put( putWord16be )++data Fixed = Fixed Word16 Word16+ deriving (Eq, Show)++instance Binary Fixed where+ get = Fixed <$> getWord16be <*> getWord16be+ put (Fixed a b) = putWord16be a >> putWord16be b++newtype FWord = FWord Word16+ deriving (Eq, Show)++instance Binary FWord where+ put (FWord w) = putWord16be w+ get = FWord <$> getWord16be++newtype F26Dot6 = F26Dot6 Int32+ deriving (Eq, Show, Ord)++instance Num F26Dot6 where+ (F26Dot6 a) + (F26Dot6 b) = F26Dot6 $ a + b+ (F26Dot6 a) - (F26Dot6 b) = F26Dot6 $ a - b+ (F26Dot6 a) * (F26Dot6 b) = F26Dot6 $ (a * b) `div` 64+ negate (F26Dot6 a) = F26Dot6 $ negate a+ abs (F26Dot6 a) = F26Dot6 $ abs a+ signum (F26Dot6 a) = F26Dot6 $ signum a * 64+ fromInteger a = F26Dot6 $ fromInteger a * 64++instance Fractional F26Dot6 where+ fromRational a = F26Dot6 $ floor ad+ where ad = fromRational a * 64 :: Double+ (F26Dot6 a) / (F26Dot6 b) = F26Dot6 $ (a * 64) `div` b+