1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Main where
import qualified Data.ByteString.Lazy as B
import Data.Text (Text, unpack)
import qualified Data.Text as Txt
import System.Directory (getCurrentDirectory)
import qualified System.Directory as Dir
import Data.FileEmbed
import Network.URI.Fetch.XML (fetchDocument, Page(..), loadVisited, applyCSScharset)
import Network.URI.Fetch (newSession, Session, fetchURL)
import Network.URI (URI(..), relativeTo, parseURIReference, nullURI)
import Network.URI.Charset (charsets)
import Text.XML (Document(..), Prologue(..), Element(..))
import qualified Data.CSS.Syntax.StyleSheet as CSS
import qualified Data.CSS.Style as Style
import Data.CSS.StyleTree
import qualified Data.CSS.Syntax.Tokens as CSSTok
import qualified Data.CSS.Preprocessor.Conditions as CSSCond
import Data.CSS.Preprocessor.Conditions (conditionalStyles)
import Data.CSS.Preprocessor.Assets
import qualified Data.CSS.Preprocessor.PsuedoClasses as CSSPseudo
import qualified Data.CSS.Preprocessor.Text as CSSTxt
import Stylist (cssPriorityAgent, cssPriorityUser, attrTest, elementPath)
import Stylist.Tree (treeFind)
import Data.HTML2CSS (el2stylist)
import Graphics.Layout.CSS (CSSBox(..), finalizeCSS')
import Graphics.Layout.CSS.Internal (placeholderFont, Font'(..),
pattern2font, hbScale, CSSFont(..))
import Graphics.Layout.Box as B (zeroBox, PaddedBox(..), Size(..))
import Graphics.Layout (boxLayout, glyphsPerFont)
import Graphics.Text.Font.Choose (nameParse)
import FreeType.FontConfig (instantiatePattern, bmpAndMetricsForIndex,
FTFC_Subpixel(..))
import FreeType.Core.Base (ft_With_FreeType)
import Typograffiti (makeDrawGlyphs, allocAtlas)
import SDL hiding (rotate)
import Graphics.GL.Core32
import Data.Function (fix)
import Control.Monad (unless, forM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Except (runExceptT)
import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import System.Environment (getArgs)
type Style = Style.VarParser (CSSTxt.TextStyle (CSSBox VizStyle))
data VizStyle = VizStyle
instance Style.PropertyParser VizStyle where
temp = VizStyle
inherit _ = VizStyle
longhand _ _ _ _ = Nothing
inlinePseudos' :: Style.PropertyParser s => StyleTree [(Text, Style.VarParser s)] -> StyleTree s
inlinePseudos' (StyleTree self childs) = StyleTree {
style = fromMaybe Style.temp $ Style.innerParser <$> lookup "" self,
children = pseudo "before" ++ map inlinePseudos' childs ++ pseudo "after"
} where
pseudo n
| Just style <- Style.innerParser <$> lookup n self,
Just style' <- Style.longhand style style "::" [CSSTok.Ident n] = [StyleTree style' []]
| Just style <- Style.innerParser <$> lookup n self = [StyleTree style []]
| otherwise = []
loadUserStyles styles = do
dir <- Dir.getXdgDirectory Dir.XdgConfig "haphaestus"
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
retreiveStyles :: Session -> CSSCond.ConditionalStyles (Style) ->
IO (CSSCond.ConditionalStyles Style)
retreiveStyles manager authorStyle = do
let agentStyle = cssPriorityAgent authorStyle `CSS.parse` $(embedStringFile "useragent.css")
userStyle <- loadUserStyles agentStyle
CSSCond.loadImports loadURL lowerVars lowerToks userStyle []
where
loadURL url = do
response <- fetchURL manager ["text/css"] url
let charsets' = map unpack charsets
return $ case response of
("text/css", Left text) -> text
("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes
(_, _) -> ""
resolve' = CSSCond.resolve lowerVars lowerToks
lowerVars "speech" = CSSCond.B True
lowerVars "-rhapsode" = CSSCond.B True
lowerVars _ = CSSCond.B False
lowerToks _ = CSSCond.B False
main :: IO ()
main = do
sess <- newSession
cwd <- getCurrentDirectory
hist <- loadVisited "haphaestus"
let referer = 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 = hist,
initCSS = conditionalStyles,
appName = "haphaestus"
}
[arg, scale'] <- getArgs
let uri = nullURI `fromMaybe` parseURIReference arg `relativeTo` pageURL referer
page <- fetchDocument sess referer uri
let pseudofilter :: CSSPseudo.LowerPsuedoClasses (Style.QueryableStyleSheet Style)
pseudofilter = CSSPseudo.htmlPsuedoFilter Style.queryableStyleSheet
css <- retreiveStyles sess $ css page
let css' = CSSPseudo.inner $ resolve' pseudofilter css
let style = CSSTxt.resolve $ inlinePseudos' $ stylize css' $ el2stylist $
documentRoot $ html page
let sysfont = (pattern2font (nameParse "serif") Style.temp { cssFontSize = (12,"pt") }
placeholderFont placeholderFont) { scale = read scale' }
let inf = 1/0
let infbox = zeroBox { B.min = Size inf inf, B.size = Size inf inf,
B.max = Size inf inf }
let layout0 = boxLayout infbox (finalizeCSS' sysfont style) False
SDL.initializeAll
let openGL = defaultOpenGL { glProfile = Core Debug 3 3 }
wcfg = defaultWindow {
windowInitialSize = V2 640 480,
windowGraphicsContext = OpenGLContext openGL,
windowResizable = True
}
w <- createWindow "Typograffiti" wcfg
_ <- glCreateContext w
ft_With_FreeType $ \ft -> runExceptT $ do
drawGlyphs <- makeDrawGlyphs
atlases <- forM (M.toList $ glyphsPerFont layout0) $ \((pat, size), glyphs) -> do
font <- liftIO $ instantiatePattern ft pat (-1, size)
atlas <- allocAtlas (liftIO . bmpAndMetricsForIndex font SubpixelDefault)
(map toEnum $ IS.toList glyphs)
(realToFrac $ hbScale sysfont, realToFrac $ hbScale sysfont)
return ((pat, size), atlas)
let atlases' = M.fromList atlases
fix $ \loop -> do
events <- fmap eventPayload <$> pollEvents
liftIO $ glClearColor 0 0 0 1
liftIO $ glClear GL_COLOR_BUFFER_BIT
sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w
liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh)
let size = B.Size (fromIntegral dw) (fromIntegral dh)
let outerbox = zeroBox { B.min = size, B.size = size, B.max = size }
let layout = boxLayout outerbox (finalizeCSS' sysfont style) False
liftIO $ glSwapWindow w
unless (QuitEvent `elem` events) loop
return ()