{-# LANGUAGE OverloadedStrings, TemplateHaskell, FlexibleContexts #-}
module Main where
import FreeType.FontConfig (instantiatePattern, bmpAndMetricsForIndex,
FTFC_Subpixel(..))
import FreeType.Core.Base (ft_With_FreeType, FT_Library)
import Typograffiti (makeDrawGlyphs, allocAtlas, AllocatedRendering(..),
TextTransform(..), Atlas, TypograffitiError)
import SDL hiding (rotate)
import Graphics.GL.Core32
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (runExceptT, MonadError, MonadIO)
import System.Environment (getArgs)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text as Txt
import qualified Data.ByteString as BS
import System.Directory (getCurrentDirectory)
import qualified System.Directory as Dir
import Graphics.Layout.CSS (CSSBox(..), finalizeCSS')
import Graphics.Layout.CSS.Font (placeholderFont, pattern2font, hbUnit,
Font'(scale, pattern, fontSize),
CSSFont(cssFontSize))
import Graphics.Layout (LayoutItem(..), boxLayout,
glyphsPerFont, glyphs, fragmentFont,
layoutGetBox, layoutGetChilds, layoutGetInner)
import Graphics.Layout.Box (zeroBox)
import qualified Graphics.Layout.Box as B
import Network.URI.Fetch.XML (Page(..), fetchDocument, applyCSScharset)
import Network.URI.Fetch (newSession, fetchURL)
import Network.URI.Charset (charsets)
import Network.URI (URI(..), nullURI, parseURIReference)
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.HTML2CSS (el2stylist)
import Text.XML as X (Document(..), Element(..), Node(..), Prologue(..))
import Stylist.Tree (StyleTree(..), preorder, treeMap)
import Stylist (PropertyParser(..), cssPriorityAgent, cssPriorityUser)
import qualified Data.CSS.Style as Style
import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Preprocessor.Text as CSSTxt
import Data.CSS.Preprocessor.Conditions as CSSCond
(ConditionalStyles, conditionalStyles, loadImports, Datum(..), resolve)
import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo
import Control.Concurrent.MVar (putMVar, newEmptyMVar, tryReadMVar)
import Control.Concurrent (forkIO)
import Control.DeepSeq (NFData(..), ($!!))
import SDL hiding (rotate)
import Foreign.C.Types (CInt)
import Data.Function (fix)
import Control.Monad (unless, forM)
import qualified Graphics.Text.Font.Choose as FC
import Data.CSS.Syntax.Tokens (Token(..))
import qualified Data.IntSet as IS
import Data.Text.Glyphize (GlyphInfo, GlyphPos)
type Style = Style.VarParser (CSSTxt.TextStyle (CSSBox VizStyle))
data VizStyle = VizStyle (V4 Float)
instance Eq VizStyle where
VizStyle x == VizStyle y = case compare x y of
EQ -> True
_ -> False
instance Style.PropertyParser VizStyle where
temp = VizStyle (V4 0 0 0 1)
inherit = id
longhand _ self "color" [Ident "black"] = Just $ VizStyle (V4 0 0 0 1)
longhand _ self "color" [Ident "white"] = Just $ VizStyle (V4 1 1 1 1)
longhand _ self "color" [Ident "red"] = Just $ VizStyle (V4 1 0 0 1)
longhand _ self "color" [Ident "green"] = Just $ VizStyle (V4 0 1 0 1)
longhand _ self "color" [Ident "blue"] = Just $ VizStyle (V4 0 0 1 1)
longhand _ _ _ _ = Nothing
renderLayout :: (MonadError TypograffitiError m, MonadIO m) =>
M.Map (FC.Pattern, Double) Atlas ->
(Atlas -> [(GlyphInfo, GlyphPos)] ->
m (AllocatedRendering [TextTransform])) ->
LayoutItem Double Double ((Double, Double), VizStyle) ->
m ()
renderLayout atlases drawText (LayoutSpan self)
| Just atlas <- M.lookup (pattern font, fontSize font) atlases = do
drawText' <- drawText atlas $ glyphs self
liftIO $ arDraw drawText' [TextTransformMultiply color] $
V2 (fromEnum x) (fromEnum y)
where
(font, _) = fragmentFont self
((x, y), VizStyle color) = layoutGetInner $ LayoutSpan self
{-renderLayout atlases drawText (LayoutSpan ((x, y), VizStyle color) font self)
| Just atlas <- M.lookup (pattern font, fontSize font) atlases = do
drawText' <- drawText atlas $ fragmentGlyphs self
-- FIXME Switch from temp to inherit for inline caller-properties.
liftIO $ arDraw drawText' [TextTransformMultiply color]
(V2 (fromEnum x) (fromEnum y))-} -- FIXME: New API!
renderLayout atlases drawText node = do
layoutGetChilds node `forM` renderLayout atlases drawText
return ()
initReferer :: IO (Page (CSSCond.ConditionalStyles (CSSBox VizStyle)))
initReferer = do
cwd <- getCurrentDirectory
return $ Page {
-- Default to URIs being relative to CWD.
pageURL = URI {uriScheme = "file:", uriPath = cwd,
uriAuthority = Nothing, uriQuery = "", uriFragment = ""},
-- Blank values:
css = conditionalStyles nullURI "temp",
domain = "temp",
html = Document {
documentPrologue = Prologue [] Nothing [],
documentRoot = Element "temp" M.empty [],
documentEpilogue = []
},
pageTitle = "", pageMIME = "", apps = [],
backStack = [], forwardStack = [], visitedURLs = S.empty,
initCSS = conditionalStyles,
appName = "cattrap"
}
stylize' style = preorder inner
where
inner parent _ el = Style.cascade style el [] $
Style.inherit $ fromMaybe Style.temp parent
resolveCSS manager page = do
let agentStyle = cssPriorityAgent (css page) `CSS.parse`
$(makeRelativeToProject "useragent.css" >>= embedStringFile)
userStyle <- loadUserStyles agentStyle
CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
where
loadURL url = do
response <- fetchURL manager ["text/css"] url
let charsets' = map Txt.unpack charsets
return $ case response of
("text/css", Left text) -> text
("text/css", Right bytes) -> applyCSScharset charsets' $ BS.toStrict bytes
(_, _) -> ""
loadUserStyles styles = do
dir <- Dir.getXdgDirectory Dir.XdgConfig "rhapsode"
exists <- Dir.doesDirectoryExist dir
loadDirectory dir exists
where
loadDirectory _ False = return styles
loadDirectory dir True = do
files <- Dir.listDirectory dir
loadFiles (cssPriorityUser styles) files
loadFiles style (file:files) = do
source <- readFile file
CSS.parse style (Txt.pack source) `loadFiles` files
loadFiles style [] = return style
-- FIXME: Support more media queries!
resolve' = CSSCond.resolve lowerVars lowerToks
lowerVars _ = CSSCond.B False
lowerToks _ = CSSCond.B False
main :: IO ()
main = do
FC.init
SDL.initializeAll
let wcfg = defaultWindow {
windowInitialSize = V2 1280 480,
windowGraphicsContext = OpenGLContext defaultOpenGL {
glProfile = Core Debug 3 3
},
-- Simplify moving layout/download out-of-thread
windowResizable = False
}
w <- createWindow "Haphaestus" wcfg
_ <- glCreateContext w
args <- getArgs
let url = case args of
(url:_) -> url
[] -> "https://git.argonaut-constellation.org/~alcinnz/CatTrap"
sess <- newSession
ref <- initReferer
xml <- fetchDocument sess ref $ fromMaybe nullURI $ parseURIReference url
let pseudoFilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet
css' <- resolveCSS sess xml
let css = CSSPseudo.inner $ resolve' pseudoFilter css'
let styles = CSSTxt.resolve $ treeMap Style.innerParser $
stylize' css $ el2stylist $ X.documentRoot $ html xml
let layout = finalizeCSS' placeholderFont styles
ft_With_FreeType $ \ft -> do
V2 x y <- get $ windowSize w
pages' <- forkCompute $ addAtlas ft $ boxLayout zeroBox {
B.size = B.Size (fromIntegral x) (fromIntegral y)
} layout True
drawGlyphs' <- runExceptT makeDrawGlyphs
let drawGlyphs = case drawGlyphs' of
Left err -> error $ show err
Right ret -> ret
fix $ \loop -> do
events <- fmap eventPayload <$> pollEvents
liftIO $ glClearColor 1 1 1 1
liftIO $ glClear GL_COLOR_BUFFER_BIT
sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
layout' <- tryReadMVar pages'
res <- case layout' of
Just (layout:_, atlases') -> runExceptT $
renderLayout atlases' drawGlyphs layout
_ -> return $ Right ()
case res of
Left err -> print err
Right () -> return ()
liftIO $ glSwapWindow w
unless (QuitEvent `elem` events) loop
SDL.quit
-- FC.fini -- FIXME: Need to free all Haskell data before freeing FontConfig's
c :: (Enum a, Enum b) => a -> b
c = toEnum . fromEnum
forkCompute dat = do
ret <- liftIO $ newEmptyMVar
liftIO $ forkIO (putMVar ret =<< dat)
return ret
type Layouts = [LayoutItem Double Double ((Double, Double), VizStyle)]
addAtlas :: FT_Library -> Layouts -> IO (Layouts, M.Map (FC.Pattern, Double) Atlas)
addAtlas ft layout = do
let sysfont = (pattern2font (FC.nameParse "serif") Style.temp { cssFontSize = (12,"pt") }
placeholderFont placeholderFont) { scale = 1 }
let required = glyphsPerFont $ LayoutFlow ((0, 0), temp) zeroBox layout
atlases <- forM (M.toList required) $ \(key@(pat, size), glyphs) -> do
font <- instantiatePattern ft pat (-1, size)
atlas <- runExceptT $ allocAtlas
(liftIO . bmpAndMetricsForIndex font SubpixelDefault)
(map toEnum $ IS.toList glyphs)
(realToFrac $ hbUnit, realToFrac $ hbUnit)
case atlas of
Left err -> do
print err
return (key, Nothing)
Right atlas' -> return (key, Just atlas')
return (layout, M.fromList [(k, v) | (k, Just v) <- atlases])