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
data FontStyle = FontStyle
{ _fontStyleBold :: !Bool
, _fontStyleItalic :: !Bool
}
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)
data FontHeader = FontHeader
{
_fHdrVersionNumber :: !Fixed
, _fHdrFontRevision :: !Fixed
, _fHdrChecksumAdjust :: !Word32
, _fHdrMagicNumber :: !Word32
, _fHdrFlags :: !HeaderFlags
, _fUnitsPerEm :: !Word16
, _fHdrCreateTime :: !Word64
, _fHdrModificationTime :: !Word64
, _fHdrxMin :: !FWord
, _fHdrYMin :: !FWord
, _fHdrXMax :: !FWord
, _fHdrYMax :: !FWord
, _fHdrMacStyle :: !FontStyle
, _fHdrLowestRecPPEM :: !Word16
, _fHdrFontDirectionHint :: !Int16
, _fHdrIndexToLocFormat :: !Int16
, _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
data HeaderFlags = HeaderFlags
{
_hfBaselineY0 :: !Bool
, _hfLeftSideBearing :: !Bool
, _hfInstrDependPointSize :: !Bool
, _hfForcePPEM :: !Bool
, _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