summaryrefslogtreecommitdiff
path: root/src/Data/CSS/Preprocessor/Text.hs
blob: cb0ec265807aeea3d6c14e45f4032213a5d6c307 (plain)
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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
{-# LANGUAGE OverloadedStrings #-}
-- | Lowers certain CSS properties to plain text.
module Data.CSS.Preprocessor.Text(TextStyle, resolve) where

import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.CSS.Style (PropertyParser(..))
import Data.CSS.StyleTree
import qualified Data.Text as Txt
import Data.Text (Text)

import Data.Maybe (fromMaybe)
import qualified Data.HashMap.Lazy as M
import Data.Function ((&))

import Data.Char (isSpace)

type Counters = [(Text, Integer)]
-- | `PropertyParser` decorator that parses & lowers certain CSS properties to plain text.
data TextStyle p = TextStyle {
    inner :: p,
    counterProps :: [(Text, [Token])],

    counterReset :: Counters,
    counterIncrement :: Counters,
    counterSet :: Counters,

    whiteSpaceCollapse :: Bool,
    newlineCollapse :: Bool
}

instance PropertyParser p => PropertyParser (TextStyle p) where
    temp = TextStyle {
            inner = temp,
            counterProps = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = True,
            newlineCollapse = True
        }
    inherit parent = TextStyle {
            inner = inherit $ inner parent,
            counterProps = [],
            counterReset = [],
            counterIncrement = [],
            counterSet = [],
            whiteSpaceCollapse = whiteSpaceCollapse parent,
            newlineCollapse = newlineCollapse parent
        }

    shorthand _ key value
        | key `elem` ["counter-reset", "counter-increment", "counter-set"],
            Just _ <- parseCounters 0 value = [(key, value)]
    shorthand self "white-space" [Ident val]
        | val `elem` ["normal", "pre", "pre-wrap", "pre-line"] = [("white-space", [Ident val])]
        | otherwise = shorthand (inner self) "white-space" [Ident val]
    shorthand TextStyle { inner = s } k v
        | Just _ <- longhand s s k $ removeCounters v = [(k, v)]
        | otherwise = shorthand s k v

    longhand _ self "counter-reset" value = (\v -> self {counterReset = v}) <$> parseCounters 0 value
    longhand _ self "counter-increment" value = (\v -> self {counterIncrement = v}) <$> parseCounters 1 value
    longhand _ self "counter-set" value = (\v -> self {counterSet = v}) <$> parseCounters 0 value

    longhand p self "white-space" [Ident "initial"] = setWhiteSpace p self True True "normal"
    longhand p self "white-space" [Ident "normal"] = setWhiteSpace p self True True "normal"
    longhand p self "white-space" [Ident "pre"] = setWhiteSpace p self False False "nowrap"
    longhand p self "white-space" [Ident "nowrap"] = setWhiteSpace p self True True "nowrap"
    longhand p self "white-space" [Ident "pre-wrap"] = setWhiteSpace p self False False "normal"
    longhand p self "white-space" [Ident "pre-line"] = setWhiteSpace p self True False "normal"

    -- Capture `content` properties & anything else using counter(s) functions.
    -- This is important in Rhapsode for the sake of navigational markers.
    longhand parent self key value
        | key == "content" || Function "counter" `elem` value || Function "counters" `elem` value =
            Just $ self { counterProps = insertList key value $ counterProps self }
        | otherwise = (\v -> self {inner = v}) <$> longhand (inner parent ) (inner self) key value

insertList :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
insertList key value list | Nothing <- lookup key list = (key, value) : list
    | otherwise = [(k, if k == key then value else v) | (k, v) <- list]

removeCounters :: [Token] -> [Token]
removeCounters (Function "counter":Ident _:RightParen:toks) = String "" : removeCounters toks
removeCounters (Function "counters":Ident _:Comma:String _:toks) = String "" : removeCounters toks
removeCounters (tok:toks) = tok : removeCounters toks
removeCounters [] = []

setWhiteSpace :: PropertyParser p => TextStyle p -> TextStyle p -> Bool -> Bool -> Text -> Maybe (TextStyle p)
setWhiteSpace parent self collapse noNewlines lowered = Just $ self {
        inner = inner self `fromMaybe` longhand (inner parent) (inner self) "white-space" [Ident lowered],
        whiteSpaceCollapse = collapse,
        newlineCollapse = noNewlines
    }
parseCounters :: Integer -> [Token] -> Maybe [(Text, Integer)]
parseCounters _ [Ident "none"] = Just []
parseCounters _ [Ident "initial"] = Just []
parseCounters _ [] = Just []
parseCounters x (Ident counter : Number _ (NVInteger count') : toks) =
    (:) (counter, count') <$> parseCounters x toks
parseCounters x (Ident counter : toks) = (:) (counter, x) <$> parseCounters x toks
parseCounters _ _ = Nothing

-- | Returns inner `PropertyParser` with text properties applied.
resolve :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p
resolve = resolve' . collapseWS . applyCounters
resolve' :: PropertyParser p => StyleTree (TextStyle p) -> StyleTree p
resolve' = treeMap $ \TextStyle {inner = inner', counterProps = props} -> foldl resolveProp inner' props
resolveProp :: PropertyParser p => p -> (Text, [Token]) -> p
resolveProp sty (key, value) = sty `fromMaybe` longhand temp sty key value

--------
---- Counters
--------
type Context = M.HashMap Text [([Integer], Integer)]

inheritCounters :: Context -> Context -> Context
inheritCounters counterSource valueSource = M.intersectionWith cb valueSource counterSource -- indexed by name & el-path
    where cb val source = [counter | counter@(path, _) <- val, path `elem` [p | (p, _) <- source]]

instantiateCounter :: Context -> Path -> Text -> Integer -> Context
instantiateCounter counters path name val = M.insertWith appendCounter name [(path, val)] counters
    where
        appendCounter new (old@((_:oldPath), _):olds)
            | oldPath == tail path = new ++ olds
            | otherwise =  new ++ (old:olds)
        appendCounter new [] = new
        appendCounter new (_:olds) = new ++ olds
instantiateCounters :: Path -> Counters -> Context -> Context
instantiateCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = instantiateCounter counters' path name value

incrementCounter :: Context -> Path -> Text -> Integer -> Context
incrementCounter counters path name val = M.insertWith addCounter name [(path, val)] counters
    where
        addCounter ((_, new):_) ((path', old):rest) = (path', new + old):rest
        addCounter [] old = old
        addCounter new [] = new
incrementCounters :: Path -> Counters -> Context -> Context
incrementCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = incrementCounter counters' path name value

setCounter :: Context -> Path -> Text -> Integer -> Context
setCounter counters path name val = M.insertWith setCounter' name [(path, val)] counters
    where
        setCounter' ((_, val'):_) ((path', _):rest) = (path', val'):rest
        setCounter' [] old = old
        setCounter' new [] = new
setCounters :: Path -> Counters -> Context -> Context
setCounters path instruct counters = foldl cb counters instruct
    where cb counters' (name, value) = setCounter counters' path name value


renderCounters :: Context -> [Token] -> [Token]
renderCounters counters (Function "counter":Ident name:RightParen:toks)
    | Just ((_, count):_) <- name `M.lookup` counters =
        String (Txt.pack $ show count) : renderCounters counters toks
    | otherwise = renderCounters counters toks
renderCounters counters (Function "counters":Ident name:Comma:String sep:RightParen:toks)
    | Just counter <- name `M.lookup` counters = String (Txt.intercalate sep [
        Txt.pack $ show count | (_, count) <- reverse counter
    ]) : renderCounters counters toks
    | otherwise = renderCounters counters toks
renderCounters counters (tok:toks) = tok : renderCounters counters toks
renderCounters _ [] = []

applyCounters :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)
applyCounters = treeOrder applyCounters0 M.empty
applyCounters0 :: Context -> Context -> Path -> TextStyle p -> (Context, TextStyle p)
applyCounters0 counterSource valueSource path node =
    let counters = inheritCounters counterSource valueSource &
            instantiateCounters path (counterReset node) &
            incrementCounters path (counterIncrement node) &
            setCounters path (counterSet node)
    in (counters, node {
        counterProps = [(k, renderCounters counters v) | (k, v) <- counterProps node]
    })

--------
---- white-space
--------
content :: TextStyle p -> [Token]
content = fromMaybe [] . lookup "content" . counterProps
setContent :: [Token] -> TextStyle p -> TextStyle p
setContent value self = self {
        counterProps = [(k, if k == "content" then value else v) | (k, v) <- counterProps self]
    }

collapseWS :: StyleTree (TextStyle p) -> StyleTree (TextStyle p)
collapseWS = treeOrder collapseWS0 True
collapseWS0 :: Bool -> Bool -> Path -> TextStyle p -> (Bool, TextStyle p)
collapseWS0 _ _ _ node@(TextStyle {whiteSpaceCollapse = False, newlineCollapse = False}) = (False, node)
collapseWS0 _ inSpace _ node@(TextStyle {
        whiteSpaceCollapse = wsCollapse,
        newlineCollapse = nlCollapse
    }) = (trailingSpace, setContent content' node)
  where (trailingSpace, content') = collapseWSToks inSpace wsCollapse nlCollapse $ content node

collapseWSToks :: Bool -> Bool -> Bool -> [Token] -> (Bool, [Token])
collapseWSToks stripStart wsCollapse nlCollapse (String txt:toks) =
    let (trailingSpace, str') = collapseWSStr stripStart wsCollapse nlCollapse $ Txt.unpack txt
        (trailingSpace', toks') = collapseWSToks trailingSpace wsCollapse nlCollapse toks
    in (trailingSpace', String (Txt.pack str'):toks')
collapseWSToks _ wsCollapse nlCollapse (tok:toks) =
    let (trailingSpace, toks') = collapseWSToks False wsCollapse nlCollapse toks
    in (trailingSpace, tok:toks')
collapseWSToks trailingWS _ _ [] = (trailingWS, [])

collapseWSStr, collapseWSStr' :: Bool -> Bool -> Bool -> String -> (Bool, String)
collapseWSStr _ wsCollapse False str@('\n':_) = collapseWSStr' True wsCollapse True str
collapseWSStr True True nlCollapse (ch:str) | isSpace ch = collapseWSStr True True nlCollapse str
collapseWSStr False True nlCollapse str@(ch:_) | isSpace ch = collapseWSStr' True True nlCollapse str
collapseWSStr _ wsCollapse nlCollapse str = collapseWSStr' False wsCollapse nlCollapse str
collapseWSStr' a b c (d:ds) = let (trailing, ds') = collapseWSStr a b c ds in (trailing, d:ds')
collapseWSStr' a _ _ [] = (a, [])