{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
module Diagrams.Backend.Rasterific.Text
( texterific'
, texterific
, fromFontStyle
, textBoundingBox
) where
import Graphics.Text.TrueType hiding (BoundingBox)
import Diagrams.Prelude
import Diagrams.TwoD.Text hiding (Font)
import Data.FileEmbed (embedDir)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict)
textBoundingBox :: RealFloat n => Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox :: Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox Font
f PointSize
p String
s = Point V2 n -> Point V2 n -> BoundingBox V2 n
forall (v :: * -> *) n.
(Additive v, Foldable v, Ord n) =>
Point v n -> Point v n -> BoundingBox v n
fromCorners
(n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 (n
2n -> n -> n
forall a. Num a => a -> a -> a
*(BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMin BoundingBox
bb) ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_yMin BoundingBox
bb))
(n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMax BoundingBox
bb n -> n -> n
forall a. Num a => a -> a -> a
+ (BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMin BoundingBox
bb) ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_yMax BoundingBox
bb))
where
r2f :: (BoundingBox -> Float) -> BoundingBox -> n
r2f = (Float -> n) -> (BoundingBox -> Float) -> BoundingBox -> n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac
bb :: BoundingBox
bb = Font -> Dpi -> PointSize -> String -> BoundingBox
stringBoundingBox Font
f Dpi
96 PointSize
p String
s
texterific' :: (TypeableFloat n, Renderable (Text n) b)
=> FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' :: FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' FontSlant
fs FontWeight
fw String
s = Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor Colour Double
forall a. Num a => Colour a
black (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a n. (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a
fontSizeL n
1
(QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => FontSlant -> a -> a
fontSlant FontSlant
fs (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => FontWeight -> a -> a
fontWeight FontWeight
fw
(QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ Prim b V2 n
-> Envelope V2 n
-> Trace V2 n
-> SubMap b V2 n Any
-> Query V2 n Any
-> QDiagram b V2 n Any
forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (Text n -> Prim b (V (Text n)) (N (Text n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim (Text n -> Prim b (V (Text n)) (N (Text n)))
-> Text n -> Prim b (V (Text n)) (N (Text n))
forall a b. (a -> b) -> a -> b
$ T2 n -> TextAlignment n -> String -> Text n
forall n. T2 n -> TextAlignment n -> String -> Text n
Text T2 n
forall a. Monoid a => a
mempty TextAlignment n
forall n. TextAlignment n
BaselineText String
s)
(BoundingBox V2 n
-> Envelope (V (BoundingBox V2 n)) (N (BoundingBox V2 n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope BoundingBox V2 n
bb)
(BoundingBox V2 n
-> Trace (V (BoundingBox V2 n)) (N (BoundingBox V2 n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace BoundingBox V2 n
bb)
SubMap b V2 n Any
forall a. Monoid a => a
mempty
(BoundingBox V2 n
-> Query (V (BoundingBox V2 n)) (N (BoundingBox V2 n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery BoundingBox V2 n
bb)
where
bb :: BoundingBox V2 n
bb = Font -> PointSize -> String -> BoundingBox V2 n
forall n.
RealFloat n =>
Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox Font
fnt (Float -> PointSize
PointSize Float
1) String
s
fnt :: Font
fnt = FontSlant -> FontWeight -> Font
fromFontStyle FontSlant
fs FontWeight
fw
texterific :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
texterific :: String -> QDiagram b V2 n Any
texterific String
s = FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
forall n b.
(TypeableFloat n, Renderable (Text n) b) =>
FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' FontSlant
FontSlantNormal FontWeight
FontWeightNormal String
s
fromFontStyle :: FontSlant -> FontWeight -> Font
fromFontStyle :: FontSlant -> FontWeight -> Font
fromFontStyle FontSlant
FontSlantItalic FontWeight
FontWeightBold = Font
openSansBoldItalic
fromFontStyle FontSlant
FontSlantOblique FontWeight
FontWeightBold = Font
openSansBoldItalic
fromFontStyle FontSlant
FontSlantNormal FontWeight
FontWeightBold = Font
openSansBold
fromFontStyle FontSlant
FontSlantItalic FontWeight
FontWeightNormal = Font
openSansItalic
fromFontStyle FontSlant
FontSlantOblique FontWeight
FontWeightNormal = Font
openSansItalic
fromFontStyle FontSlant
_ FontWeight
_ = Font
openSansRegular
fonts :: [(FilePath,ByteString)]
fonts :: [(String, ByteString)]
fonts = $(embedDir "fonts")
staticFont :: String -> Font
staticFont :: String -> Font
staticFont String
nm = case String -> [(String, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nm [(String, ByteString)]
fonts of
Maybe ByteString
Nothing -> String -> Font
forall a. HasCallStack => String -> a
error (String
"Font not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm)
Just ByteString
f -> case ByteString -> Either String Font
decodeFont (ByteString -> ByteString
fromStrict ByteString
f) of
Right Font
r -> Font
r
Left String
e -> String -> Font
forall a. HasCallStack => String -> a
error String
e
openSansRegular :: Font
openSansRegular :: Font
openSansRegular = String -> Font
staticFont String
"OpenSans-Regular.ttf"
openSansBold :: Font
openSansBold :: Font
openSansBold = String -> Font
staticFont String
"OpenSans-Bold.ttf"
openSansItalic :: Font
openSansItalic :: Font
openSansItalic = String -> Font
staticFont String
"OpenSans-Italic.ttf"
openSansBoldItalic :: Font
openSansBoldItalic :: Font
openSansBoldItalic = String -> Font
staticFont String
"OpenSans-BoldItalic.ttf"