{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Typograffiti.Store where
import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar,
readTMVar, takeTMVar)
import Control.Monad.Except (MonadError (..), liftEither)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Linear
import Typograffiti.Atlas
import Typograffiti.Cache
import Typograffiti.Glyph
data RenderedText t m = RenderedText
{ drawRenderedText :: t -> m ()
, sizeOfRenderedText :: V2 Int
}
data Font t = Font
{ fontAtlas :: Atlas
, fontWordCache :: WordCache t
}
data TextRenderingData t = TextRenderingData
{ textRenderingDataAllocWord :: Atlas -> String -> IO (Either TypograffitiError (AllocatedRendering t))
, textRenderingDataFontMap :: Map (FilePath, GlyphSize) (Font t)
, textRenderingDataCharSet :: Set Char
}
newtype FontStore t = FontStore
{ unFontStore :: TMVar (TextRenderingData t)}
getTextRendering
:: ( MonadIO m
, MonadError TypograffitiError m
, Layout t
)
=> FontStore t
-> FilePath
-> GlyphSize
-> String
-> m (RenderedText t m)
getTextRendering store file sz str = do
let mvar = unFontStore store
s <- liftIO $ atomically $ readTMVar mvar
font <- case M.lookup (file, sz) $ textRenderingDataFontMap s of
Nothing -> allocFont store file sz
Just font -> return font
(draw, tsz, cache) <-
loadText
(\x y -> liftIO (textRenderingDataAllocWord s x y) >>= liftEither)
(fontAtlas font)
(fontWordCache font)
str
liftIO
$ atomically $ do
s1 <- takeTMVar mvar
let alterf Nothing = Just $ Font (fontAtlas font) cache
alterf (Just (Font atlas _)) = Just $ Font atlas cache
fontmap = M.alter alterf (file,sz)
$ textRenderingDataFontMap s1
putTMVar mvar s1{ textRenderingDataFontMap = fontmap }
return RenderedText
{ drawRenderedText = liftIO . draw
, sizeOfRenderedText = tsz
}
newDefaultFontStore
:: ( MonadIO m
, MonadError TypograffitiError m
, Integral i
)
=> IO (V2 i)
-> m (FontStore [TextTransform])
newDefaultFontStore getDims = do
aw <- makeDefaultAllocateWord getDims
let dat = TextRenderingData
{ textRenderingDataAllocWord = aw
, textRenderingDataFontMap = mempty
, textRenderingDataCharSet = S.fromList asciiChars
}
FontStore
<$> liftIO (atomically $ newTMVar dat)
allocFont
:: ( MonadIO m
, MonadError TypograffitiError m
, Layout t
)
=> FontStore t
-> FilePath
-> GlyphSize
-> m (Font t)
allocFont store file sz = do
let mvar = unFontStore store
s <- liftIO $ atomically $ takeTMVar mvar
atlas <-
allocAtlas
file
sz
$ S.toList
$ textRenderingDataCharSet s
let fontmap = textRenderingDataFontMap s
font = Font
{ fontAtlas = atlas
, fontWordCache = mempty
}
liftIO
$ atomically
$ putTMVar mvar
$ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap }
return font