~alcinnz/haskell-stylist

haskell-stylist/src/Data/CSS/Syntax/AtLayer.hs -rw-r--r-- 3.7 KiB
8880b129 — Adrian Cochrane Minor fix to repair the testsuite! 11 months ago 
                                                                                
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
module Data.CSS.Syntax.AtLayer(parseAtLayer, Tree(..),
    registerLayer, layerPath, uniqueName, emptyTree) where

import Data.HashMap.Lazy as M (HashMap, (!?), insert, size, empty)
import Data.Text as T hiding (reverse, replicate, length)
import Data.CSS.Syntax.Tokens

import Stylist.Parse

parseAtLayer :: StyleSheet s => [Text] -> [Token] -> Tree ->
    ([Text] -> [Int] -> s) -> (Tree, Maybe s, [Token])
parseAtLayer namespace (Whitespace:toks) tree cb = parseAtLayer namespace toks tree cb
parseAtLayer namespace (Ident layer:toks) tree cb = inner toks [layer] tree
    where
        inner (Delim '.':Ident sublayer:toks') layers tree' =  inner toks' (sublayer:layers) tree'
        inner (Whitespace:toks') layers tree' = inner toks' layers tree'
        inner (Comma:toks') layers tree' =
            let (ret, tail') = parseLayerStmt namespace toks' $registerLayer (namespaced layers) tree'
            in (ret, Nothing, tail')
        inner (LeftCurlyBracket:toks') layers  tree' =
            let (ret, styles, tail') = parseLayerBlock (namespaced layers) toks' tree' cb
            in (ret, Just styles, tail')
        inner (Semicolon:toks') layers tree' = (registerLayer (namespaced layers) tree', Nothing, toks')
        inner [] layers tree' = (registerLayer (namespaced layers) tree', Nothing, [])
        inner toks' _ _ = (tree, Nothing, skipAtRule toks')
        namespaced layers = namespace ++ reverse layers
parseAtLayer ns (LeftCurlyBracket:toks) tree cb = 
    let (ret, styles, tail') = parseLayerBlock (uniqueName ns tree) toks tree cb
    in (ret, Just styles, tail')
parseAtLayer _ toks tree _ = (tree, Nothing, skipAtRule toks)

parseLayerStmt :: [Text] -> [Token] -> Tree -> (Tree, [Token])
parseLayerStmt namespace (Whitespace:toks) tree = parseLayerStmt namespace toks tree
parseLayerStmt namespace (Ident layer:toks) tree = inner toks [layer] tree
    where
        inner (Delim '.':Ident sublayer:toks') layers tree' = inner toks' (sublayer:layers) tree'
        inner (Comma:toks') layers tree' =
            parseLayerStmt namespace toks' $ registerLayer (namespaced layers) tree'
        inner (Whitespace:toks') layers tree' = inner toks' layers tree'
        inner (Semicolon:toks') layers tree' = (registerLayer (namespaced layers) tree', toks')
        inner [] layers tree' = (registerLayer (namespaced layers) tree', [])
        inner toks' _ _ = (tree, skipAtRule toks')
        namespaced layers = namespace ++ reverse layers
parseLayerStmt _ toks tree = (tree, skipAtRule toks)

parseLayerBlock :: StyleSheet s => [Text] -> [Token] -> Tree ->
    ([Text] -> [Int] -> s) -> (Tree, s, [Token])
parseLayerBlock layers toks tree cb = (tree', parse' styles block, toks')
    where
        (block, toks') = scanBlock toks
        tree' = registerLayer layers tree
        styles = cb layers $ layerPath layers tree'

newtype Tree = Tree (HashMap Text (Int, Tree))
registerLayer :: [Text] -> Tree -> Tree
registerLayer (layer:sublayers) (Tree self)
    | Just (ix, subtree) <- self !? layer = Tree $ insert layer (ix, registerLayer sublayers subtree) self
    | otherwise = Tree $ insert layer (succ $ size self, registerLayer sublayers $ Tree M.empty) self
registerLayer [] self = self

layerPath :: [Text] -> Tree -> [Int]
layerPath (layer:sublayers) (Tree self)
    | Just (ix, subtree) <- self !? layer = ix:layerPath sublayers subtree
    | otherwise = [] -- Should have registered first...
layerPath [] _ = []

uniqueName :: [Text] -> Tree -> [Text]
uniqueName (namespace:namespaces) (Tree self) 
    | Just (_, subtree) <- self !? namespace = namespace:uniqueName namespaces subtree
    | otherwise = replicate (length namespaces + 2) T.empty -- Should have registered first
uniqueName [] (Tree self) = [T.pack $ show $ size self]

emptyTree :: Tree
emptyTree = Tree M.empty