source/factorcss/FactorCSS.hs

--
-- This file is part of FactorCSS
-- Licensed under the MIT License,
--                http://www.opensource.org/licenses/mit-license
-- Copyright 2004 James Bursa <james@semichrome.net>
--

-- Factor a CSS stylesheet.
--
-- This tool takes a CSS stylesheet on input and produces an almost equivalent
-- stylesheet on output, but with rulesets split, combined, and reordered to
-- "factor out" common declarations. This helps reveal shared components. The
-- resulting stylesheet may also be smaller.
--
-- The only known case where the output is not equivalent to the input is when
-- the stylesheet depends on the order of rules (see CSS 2.1 6.4.1).

import List
import System
import Tokeniser
import Parser
import CSS

-- Program entry function.
main :: IO ()
main = do
        args <- getArgs
        interact (run args)

-- Produce output from arguments and input.
run :: [String] -> String -> String
run args input
        | argument "help" args          = usage
        | null args                     = go factor
        | argument "factor" args        = go factor
        | argument "explode" args       = go (concatMap explode)
        | argument "identity" args      = go id
        | argument "lex" args           = show (alexScanTokens input) ++ "\n"
        | argument "tree" args          = show stylesheet ++ "\n"
        | argument "statistics" args    = stats stylesheet ++ "\n"
        | otherwise                     = usage
        where   go f = (unlines . show_stylesheet . process f) stylesheet
                stylesheet = (parser . alexScanTokens) input

-- Check an argument list for an argument in short or long form.
argument :: String -> [String] -> Bool
argument long args = elem short shorts || elem ("--" ++ long) args
                where   short = head long
                        shorts = (concat . filter is_short) args
                        is_short ('-':'-':_) = False
                        is_short ('-':_) = True
                        is_short _ = False

-- Usage help string.
usage :: String
usage = unlines ["Usage: factorcss [OPTION]... <FILE",
                "\"Factor out\" common declarations in a CSS stylesheet by splitting, reordering,",
                "and combining rulesets.",
                "The stylesheet is read from standard input, and the result is produced on",
                "standard output.",
                "",
                "Output mode:",
                "  -f, --factor      factor out common declarations (default)",
                "  -e, --explode     produce rulesets with one selector and declaration each",
                "  -i, --identity    just parse and output unmodified",
                "  -l, --lex         tokenise and display token stream",
                "  -t, --tree        parse and display parse tree",
                "  -s, --statistics  count rulesets, selectors, and declarations",
                "",
                "  -h, --help        display this help and exit"]

-- Process a Stylesheet.
process :: ([Statement] -> [Statement]) -> Stylesheet -> Stylesheet
process f (Stylesheet charset imports stmts) =
                Stylesheet charset imports (process_stmts f stmts)

-- Process a list of Statements.
process_stmts :: ([Statement] -> [Statement]) -> [Statement] -> [Statement]
process_stmts f stmts = (f . filter is_ruleset) stmts ++
                (map (process_media f) . filter is_media) stmts ++
                filter is_page stmts

-- Process a Media Statement.
process_media :: ([Statement] -> [Statement]) -> Statement -> Statement
process_media f (Media media stmts) = Media media (f stmts)

-- Factor a list of Ruleset Statements.
factor :: [Statement] -> [Statement]
factor = map implode_sel . groupBy eq_sel .
                sortBy cmp_sel .
                map implode_decl . groupBy eq_decl .
                sortBy cmp_decl . sortBy cmp_sel .
                concat . map explode

-- Explode a Ruleset Statement into an equivalent list of Ruleset Statements
-- with one Selector and one Declaration per Ruleset.
--
-- For example (in CSS syntax),
--   explode "h1, em { color: red; background-color: blue }" =
--       "h1 { color: red }
--        h1 { background-color: blue }
--        em { color: red }
--        em { background-color: blue }"
--
-- [length (explode (Ruleset sels decls)) == length sels * length decls]
explode :: Statement -> [Statement]
explode (Ruleset sels decls) =
                concat (map (\s -> map (\d -> Ruleset [s] [d]) decls) sels)

-- Compare two Ruleset Statements by the Selectors in each.
cmp_sel :: Statement -> Statement -> Ordering
cmp_sel (Ruleset sels0 decls0) (Ruleset sels1 decls1)
        | a < b         = LT
        | a == b        = EQ
        | a > b         = GT
        where   a = show_selectors sels0
                b = show_selectors sels1

-- Compare two Ruleset Statements by the first Declaration in each.
cmp_decl :: Statement -> Statement -> Ordering
cmp_decl (Ruleset sels0 (decl0:decls0)) (Ruleset sels1 (decl1:decls1))
        | a < b         = LT
        | a == b        = EQ
        | a > b         = GT
        where   a = show_declaration decl0
                b = show_declaration decl1

-- Compare two Ruleset Statements for equality by the Selectors in each.
eq_sel :: Statement -> Statement -> Bool
eq_sel z = (== EQ) . cmp_sel z

-- Compare two Ruleset Statements for equality by the first declaration in
-- each.
eq_decl :: Statement -> Statement -> Bool
eq_decl z = (== EQ) . cmp_decl z

-- Implode a list of Ruleset Statements with equal lists of Selectors to a
-- single equivalent Ruleset Statement.
--
-- For example,
--   implode_sel "h1, em { color: red }
--        h1, em { background-color: blue }" =
--       "h1, em { color: red; background-color: blue }"
implode_sel :: [Statement] -> Statement
implode_sel ((Ruleset sels decls):stmts) =
                Ruleset sels (concat (decls:(map declarations stmts)))

-- Implode a list of Ruleset Statements with equal lists of Declarations to a
-- single equivalent Ruleset Statement.
--
-- For example,
--   implode_decl "h1 { color: red }
--        em { color: red }" =
--       "h1, em { color: red }"
implode_decl :: [Statement] -> Statement
implode_decl ((Ruleset sels decls):stmts) =
                Ruleset (concat (sels:(map selectors stmts))) decls

-- Count rulesets, selectors, and declarations in a Stylesheet.
stats :: Stylesheet -> String
stats (Stylesheet charset imports stmts)
        | n == 0        = "0 rulesets"
        | otherwise     = "rulesets " ++ show n ++
                          ", selectors min " ++ show s0 ++
                          " max " ++ show s1 ++
                          " mean " ++ take 5 (
                                show (fromIntegral sn / fromIntegral n)) ++
                          ", declarations min " ++ show d0 ++
                          " max " ++ show d1 ++
                          " mean " ++ take 5 (
                                show (fromIntegral dn / fromIntegral n))
        where [n, s0, s1, sn, d0, d1, dn] = stats_stmts stmts

-- Count rulesets, selectors, and declarations in a list of Statements.
stats_stmts :: [Statement] -> [Int]
stats_stmts stmts = stats_rulesets (filter is_ruleset stmts ++
                (concatMap get_stmts (filter is_media stmts)))
                where   get_stmts (Media media stmts) = stmts

-- Count rulesets, selectors, and declarations in a list of Ruleset Statements.
stats_rulesets :: [Statement] -> [Int]
stats_rulesets stmts = [length stmts,
                minimum sel_lengths, maximum sel_lengths, sum sel_lengths,
                minimum decl_lengths, maximum decl_lengths, sum decl_lengths]
                where   sel_lengths = map (length . selectors) stmts
                        decl_lengths = map (length . declarations) stmts

-- Extract the list of Selectors from a Ruleset Statement.
selectors :: Statement -> [Selector]
selectors (Ruleset s d) = s

-- Extract the list of Declarations from a Ruleset Statement.
declarations :: Statement -> [Declaration]
declarations (Ruleset s d) = d
1	--
2	-- This file is part of FactorCSS
3	-- Licensed under the MIT License,
4	-- http://www.opensource.org/licenses/mit-license
5	-- Copyright 2004 James Bursa <james@semichrome.net>
6	--
7
8	-- Factor a CSS stylesheet.
9	--
10	-- This tool takes a CSS stylesheet on input and produces an almost equivalent
11	-- stylesheet on output, but with rulesets split, combined, and reordered to
12	-- "factor out" common declarations. This helps reveal shared components. The
13	-- resulting stylesheet may also be smaller.
14	--
15	-- The only known case where the output is not equivalent to the input is when
16	-- the stylesheet depends on the order of rules (see CSS 2.1 6.4.1).
17
18	import List
19	import System
20	import Tokeniser
21	import Parser
22	import CSS
23
24	-- Program entry function.
25	main :: IO ()
26	main = do
27	args <- getArgs
28	interact (run args)
29
30	-- Produce output from arguments and input.
31	run :: [String] -> String -> String
32	run args input
33	\| argument "help" args = usage
34	\| null args = go factor
35	\| argument "factor" args = go factor
36	\| argument "explode" args = go (concatMap explode)
37	\| argument "identity" args = go id
38	\| argument "lex" args = show (alexScanTokens input) ++ "\n"
39	\| argument "tree" args = show stylesheet ++ "\n"
40	\| argument "statistics" args = stats stylesheet ++ "\n"
41	\| otherwise = usage
42	where go f = (unlines . show_stylesheet . process f) stylesheet
43	stylesheet = (parser . alexScanTokens) input
44
45	-- Check an argument list for an argument in short or long form.
46	argument :: String -> [String] -> Bool
47	argument long args = elem short shorts \|\| elem ("--" ++ long) args
48	where short = head long
49	shorts = (concat . filter is_short) args
50	is_short ('-':'-':_) = False
51	is_short ('-':_) = True
52	is_short _ = False
53
54	-- Usage help string.
55	usage :: String
56	usage = unlines ["Usage: factorcss [OPTION]... <FILE",
57	"\"Factor out\" common declarations in a CSS stylesheet by splitting, reordering,",
58	"and combining rulesets.",
59	"The stylesheet is read from standard input, and the result is produced on",
60	"standard output.",
61	"",
62	"Output mode:",
63	" -f, --factor factor out common declarations (default)",
64	" -e, --explode produce rulesets with one selector and declaration each",
65	" -i, --identity just parse and output unmodified",
66	" -l, --lex tokenise and display token stream",
67	" -t, --tree parse and display parse tree",
68	" -s, --statistics count rulesets, selectors, and declarations",
69	"",
70	" -h, --help display this help and exit"]
71
72	-- Process a Stylesheet.
73	process :: ([Statement] -> [Statement]) -> Stylesheet -> Stylesheet
74	process f (Stylesheet charset imports stmts) =
75	Stylesheet charset imports (process_stmts f stmts)
76
77	-- Process a list of Statements.
78	process_stmts :: ([Statement] -> [Statement]) -> [Statement] -> [Statement]
79	process_stmts f stmts = (f . filter is_ruleset) stmts ++
80	(map (process_media f) . filter is_media) stmts ++
81	filter is_page stmts
82
83	-- Process a Media Statement.
84	process_media :: ([Statement] -> [Statement]) -> Statement -> Statement
85	process_media f (Media media stmts) = Media media (f stmts)
86
87	-- Factor a list of Ruleset Statements.
88	factor :: [Statement] -> [Statement]
89	factor = map implode_sel . groupBy eq_sel .
90	sortBy cmp_sel .
91	map implode_decl . groupBy eq_decl .
92	sortBy cmp_decl . sortBy cmp_sel .
93	concat . map explode
94
95	-- Explode a Ruleset Statement into an equivalent list of Ruleset Statements
96	-- with one Selector and one Declaration per Ruleset.
97	--
98	-- For example (in CSS syntax),
99	-- explode "h1, em { color: red; background-color: blue }" =
100	-- "h1 { color: red }
101	-- h1 { background-color: blue }
102	-- em { color: red }
103	-- em { background-color: blue }"
104	--
105	-- [length (explode (Ruleset sels decls)) == length sels * length decls]
106	explode :: Statement -> [Statement]
107	explode (Ruleset sels decls) =
108	concat (map (\s -> map (\d -> Ruleset [s] [d]) decls) sels)
109
110	-- Compare two Ruleset Statements by the Selectors in each.
111	cmp_sel :: Statement -> Statement -> Ordering
112	cmp_sel (Ruleset sels0 decls0) (Ruleset sels1 decls1)
113	\| a < b = LT
114	\| a == b = EQ
115	\| a > b = GT
116	where a = show_selectors sels0
117	b = show_selectors sels1
118
119	-- Compare two Ruleset Statements by the first Declaration in each.
120	cmp_decl :: Statement -> Statement -> Ordering
121	cmp_decl (Ruleset sels0 (decl0:decls0)) (Ruleset sels1 (decl1:decls1))
122	\| a < b = LT
123	\| a == b = EQ
124	\| a > b = GT
125	where a = show_declaration decl0
126	b = show_declaration decl1
127
128	-- Compare two Ruleset Statements for equality by the Selectors in each.
129	eq_sel :: Statement -> Statement -> Bool
130	eq_sel z = (== EQ) . cmp_sel z
131
132	-- Compare two Ruleset Statements for equality by the first declaration in
133	-- each.
134	eq_decl :: Statement -> Statement -> Bool
135	eq_decl z = (== EQ) . cmp_decl z
136
137	-- Implode a list of Ruleset Statements with equal lists of Selectors to a
138	-- single equivalent Ruleset Statement.
139	--
140	-- For example,
141	-- implode_sel "h1, em { color: red }
142	-- h1, em { background-color: blue }" =
143	-- "h1, em { color: red; background-color: blue }"
144	implode_sel :: [Statement] -> Statement
145	implode_sel ((Ruleset sels decls):stmts) =
146	Ruleset sels (concat (decls:(map declarations stmts)))
147
148	-- Implode a list of Ruleset Statements with equal lists of Declarations to a
149	-- single equivalent Ruleset Statement.
150	--
151	-- For example,
152	-- implode_decl "h1 { color: red }
153	-- em { color: red }" =
154	-- "h1, em { color: red }"
155	implode_decl :: [Statement] -> Statement
156	implode_decl ((Ruleset sels decls):stmts) =
157	Ruleset (concat (sels:(map selectors stmts))) decls
158
159	-- Count rulesets, selectors, and declarations in a Stylesheet.
160	stats :: Stylesheet -> String
161	stats (Stylesheet charset imports stmts)
162	\| n == 0 = "0 rulesets"
163	\| otherwise = "rulesets " ++ show n ++
164	", selectors min " ++ show s0 ++
165	" max " ++ show s1 ++
166	" mean " ++ take 5 (
167	show (fromIntegral sn / fromIntegral n)) ++
168	", declarations min " ++ show d0 ++
169	" max " ++ show d1 ++
170	" mean " ++ take 5 (
171	show (fromIntegral dn / fromIntegral n))
172	where [n, s0, s1, sn, d0, d1, dn] = stats_stmts stmts
173
174	-- Count rulesets, selectors, and declarations in a list of Statements.
175	stats_stmts :: [Statement] -> [Int]
176	stats_stmts stmts = stats_rulesets (filter is_ruleset stmts ++
177	(concatMap get_stmts (filter is_media stmts)))
178	where get_stmts (Media media stmts) = stmts
179
180	-- Count rulesets, selectors, and declarations in a list of Ruleset Statements.
181	stats_rulesets :: [Statement] -> [Int]
182	stats_rulesets stmts = [length stmts,
183	minimum sel_lengths, maximum sel_lengths, sum sel_lengths,
184	minimum decl_lengths, maximum decl_lengths, sum decl_lengths]
185	where sel_lengths = map (length . selectors) stmts
186	decl_lengths = map (length . declarations) stmts
187
188	-- Extract the list of Selectors from a Ruleset Statement.
189	selectors :: Statement -> [Selector]
190	selectors (Ruleset s d) = s
191
192	-- Extract the list of Declarations from a Ruleset Statement.
193	declarations :: Statement -> [Declaration]
194	declarations (Ruleset s d) = d