git.fiddlerwoaroof.com
Browse code

Init

fiddlerwoaroof authored on 07/02/2017 09:25:44
Showing 12 changed files
.gitignore
History View file @ eccab7b
1 1 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+.stack-work/
COPYING
History View file @ eccab7b
0 2 
new file mode 100644
... ... 
@@ -0,0 +1,29 @@
1 
+Copyright (c) 2015 Edward Langley
2 
+All rights reserved.
3 
+
4 
+Redistribution and use in source and binary forms, with or without
5 
+modification, are permitted provided that the following conditions
6 
+are met:
7 
+
8 
+Redistributions of source code must retain the above copyright notice,
9 
+this list of conditions and the following disclaimer.
10 
+
11 
+Redistributions in binary form must reproduce the above copyright
12 
+notice, this list of conditions and the following disclaimer in the
13 
+documentation and/or other materials provided with the distribution.
14 
+
15 
+Neither the name of the project's author nor the names of its
16 
+contributors may be used to endorse or promote products derived from
17 
+this software without specific prior written permission.
18 
+
19 
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
20 
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
21 
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
22 
+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
23 
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
24 
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
25 
+TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
26 
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
27 
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28 
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29 
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
LICENSE
History View file @ eccab7b
0 30 
new file mode 100644
... ... 
@@ -0,0 +1,30 @@
1 
+Copyright Author name here (c) 2017
2 
+
3 
+All rights reserved.
4 
+
5 
+Redistribution and use in source and binary forms, with or without
6 
+modification, are permitted provided that the following conditions are met:
7 
+
8 
+    * Redistributions of source code must retain the above copyright
9 
+      notice, this list of conditions and the following disclaimer.
10 
+
11 
+    * Redistributions in binary form must reproduce the above
12 
+      copyright notice, this list of conditions and the following
13 
+      disclaimer in the documentation and/or other materials provided
14 
+      with the distribution.
15 
+
16 
+    * Neither the name of Author name here nor the names of other
17 
+      contributors may be used to endorse or promote products derived
18 
+      from this software without specific prior written permission.
19 
+
20 
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
0 31 
\ No newline at end of file
README.md
History View file @ eccab7b
1 32 
new file mode 100644
Setup.hs
History View file @ eccab7b
2 33 
new file mode 100644
... ... 
@@ -0,0 +1,2 @@
1 
+import Distribution.Simple
2 
+main = defaultMain
app/Main.hs
History View file @ eccab7b
0 3 
new file mode 100644
... ... 
@@ -0,0 +1,42 @@
1 
+{-
2 
+ -Copyright (c) 2015 Edward Langley
3 
+ -All rights reserved.
4 
+ -
5 
+ -Redistribution and use in source and binary forms, with or without
6 
+ -modification, are permitted provided that the following conditions
7 
+ -are met:
8 
+ -
9 
+ -Redistributions of source code must retain the above copyright notice,
10 
+ -this list of conditions and the following disclaimer.
11 
+ -
12 
+ -Redistributions in binary form must reproduce the above copyright
13 
+ -notice, this list of conditions and the following disclaimer in the
14 
+ -documentation and/or other materials provided with the distribution.
15 
+ -
16 
+ -Neither the name of the project's author nor the names of its
17 
+ -contributors may be used to endorse or promote products derived from
18 
+ -this software without specific prior written permission.
19 
+ -
20 
+ -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 
+ -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 
+ -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23 
+ -FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 
+ -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 
+ -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
26 
+ -TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27 
+ -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28 
+ -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 
+ -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 
+ -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 
+ -}
32 
+module Main where
33 
+
34 
+import Text.Parsec
35 
+import System.IO
36 
+import CssParser
37 
+import System.Environment
38 
+
39 
+main = do
40 
+  args <- getArgs
41 
+  dat <- readFile (args !! 0)
42 
+  putStrLn $ show $ parseCSS dat
cssparser.cabal
History View file @ eccab7b
0 43 
new file mode 100644
... ... 
@@ -0,0 +1,47 @@
1 
+name:                cssparser
2 
+version:             0.1.0.0
3 
+-- synopsis:
4 
+-- description:
5 
+homepage:            https://github.com/githubuser/cssparser#readme
6 
+license:             BSD3
7 
+license-file:        LICENSE
8 
+author:              Author name here
9 
+maintainer:          example@example.com
10 
+copyright:           2017 Author name here
11 
+category:            Web
12 
+build-type:          Simple
13 
+extra-source-files:  README.md
14 
+cabal-version:       >=1.10
15 
+
16 
+library
17 
+  hs-source-dirs:      src
18 
+  exposed-modules:     CssParser
19 
+  build-depends:       base >= 4.7 && < 5
20 
+                     , containers >= 0.5.7
21 
+                     , parsec == 3.1.11
22 
+  default-language:    Haskell2010
23 
+
24 
+executable cssparser-exe
25 
+  hs-source-dirs:      app
26 
+  main-is:             Main.hs
27 
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
28 
+  build-depends:       base
29 
+                     , parsec == 3.1.11
30 
+                     , cssparser
31 
+  default-language:    Haskell2010
32 
+
33 
+test-suite cssparser-test
34 
+  type:                exitcode-stdio-1.0
35 
+  hs-source-dirs:      test
36 
+  main-is:             CssParserTest.hs
37 
+  build-depends:       base
38 
+                     , parsec == 3.1.11
39 
+                     , containers >= 0.5.7
40 
+                     , HUnit >= 1.3
41 
+                     , cssparser
42 
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
43 
+  default-language:    Haskell2010
44 
+
45 
+source-repository head
46 
+  type:     git
47 
+  location: https://github.com/fiddlerwoaroof/cssparser
src/CssParser.hs
History View file @ eccab7b
0 48 
new file mode 100644
... ... 
@@ -0,0 +1,475 @@
1 
+{-
2 
+ -Copyright (c) 2015 Edward Langley
3 
+ -All rights reserved.
4 
+ -
5 
+ -Redistribution and use in source and binary forms, with or without
6 
+ -modification, are permitted provided that the following conditions
7 
+ -are met:
8 
+ -
9 
+ -Redistributions of source code must retain the above copyright notice,
10 
+ -this list of conditions and the following disclaimer.
11 
+ -
12 
+ -Redistributions in binary form must reproduce the above copyright
13 
+ -notice, this list of conditions and the following disclaimer in the
14 
+ -documentation and/or other materials provided with the distribution.
15 
+ -
16 
+ -Neither the name of the project's author nor the names of its
17 
+ -contributors may be used to endorse or promote products derived from
18 
+ -this software without specific prior written permission.
19 
+ -
20 
+ -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 
+ -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 
+ -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23 
+ -FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 
+ -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 
+ -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
26 
+ -TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27 
+ -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28 
+ -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 
+ -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 
+ -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 
+ -}
32 
+
33 
+{-# LANGUAGE RankNTypes,KindSignatures #-}
34 
+
35 
+module CssParser
36 
+  where
37 
+
38 
+import Prelude
39 
+import Control.Monad
40 
+import qualified Text.Parsec as NP
41 
+import Text.ParserCombinators.Parsec
42 
+import Data.Functor.Identity()
43 
+import Text.Parsec.Prim()
44 
+import Data.Map hiding (foldr,null,map)
45 
+import Data.Maybe
46 
+
47 
+data URL = URLFunc String |
48 
+           URLString String |
49 
+           URLMedia [String] URL
50 
+  deriving (Show, Eq)
51 
+
52 
+
53 
+type Query = [String]
54 
+data CSSDeclaration = CSSDeclaration CSSSelector CSSBody |
55 
+                      PageDeclaration (Maybe String) CSSBody |
56 
+                      Charset String |
57 
+                      Import URL |
58 
+                      MediaQuery Query CSSDeclaration |
59 
+                      DeclarationList [CSSDeclaration]
60 
+  deriving (Show,Eq)
61 
+
62 
+
63 
+type CSSBody = Map String String
64 
+
65 
+data CSSSelector =
66 
+  Ident String |
67 
+  TagName String |
68 
+  Pseudo String |
69 
+  Attribute String String |
70 
+  Id String |
71 
+  Class String |
72 
+  Sibling CSSSelector CSSSelector | -- These are all XRelation Head Tail
73 
+  DirectChild CSSSelector CSSSelector |
74 
+  Child CSSSelector CSSSelector |
75 
+  SelectorList [CSSSelector]
76 
+  deriving (Show,Eq)
77 
+
78 
+matchUpToX :: (Eq a,Num a) => GenParser Char st Char -> a -> GenParser Char st String
79 
+matchUpToX p n = scan id n
80 
+  where
81 
+    scan f x = if x == 0
82 
+      then return (f [])
83 
+      else do {
84 
+        nxt <- p;
85 
+        scan (\tail_ -> f (nxt:tail_)) (x-1)
86 
+      } <|> return (f [])
87 
+
88 
+match1ToX :: (Eq a,Num a) => GenParser Char st Char -> a -> GenParser Char st String
89 
+match1ToX p n = do
90 
+  result <- p
91 
+  tail_ <- matchUpToX p (n-1)
92 
+  return (result:tail_)
93 
+
94 
+-- Char classes
95 
+h :: GenParser Char st Char
96 
+h = hexDigit
97 
+
98 
+nonascii  :: GenParser Char st Char
99 
+nonascii  = satisfy isNonAscii
100 
+  where
101 
+    isNonAscii a = '\240' <= a && a <= '\1114111'
102 
+
103 
+unicode :: GenParser Char st String
104 
+unicode = do
105 
+  char '\\'
106 
+  result <- match1ToX h (6 :: Integer)
107 
+  spaces
108 
+  return result
109 
+
110 
+escape :: GenParser Char st String
111 
+escape = (liftM ('\\':) $ try unicode) <|> do
112 
+  char '\\' <:> (many1 $ noneOf "\r\n\f0123456789abcdef")
113 
+
114 
+nmstart :: GenParser Char st Char
115 
+nmstart = oneOf "-" <|> letter
116 
+
117 
+nmchar :: GenParser Char st Char
118 
+nmchar = oneOf "_-" <|> alphaNum
119 
+
120 
+
121 
+space_ :: GenParser Char st Char
122 
+space_ = oneOf " \t\r\n\f"
123 
+
124 
+s :: GenParser Char st String
125 
+s = many1 space_
126 
+
127 
+w :: GenParser Char st String
128 
+w = many space_
129 
+
130 
+nl :: GenParser Char st String
131 
+nl = (string "\n" <|> (try $ string "\r\n") <|> string "\r" <|> string "\f") >> return "\n"
132 
+
133 
+genBadString :: Char -> GenParser Char st String
134 
+genBadString c = do
135 
+  char c
136 
+  result <- liftM (foldr (++) []) $
137 
+    many $ (many1 $ noneOf (c:"\n\r\f")) <|> (char '\\' >> nl) <|> escape
138 
+  char '\\'
139 
+  anyChar
140 
+  return result
141 
+
142 
+badstring :: GenParser Char st String
143 
+badstring = genBadString '"' <|> genBadString '\''
144 
+
145 
+string_ :: GenParser Char st String
146 
+string_ = do
147 
+  a <- char '"' <|> char '\''
148 
+  result <- liftM (foldr (++) []) $ many $ do
149 
+    res <- (try $ char '\\' <:> nl) <|> (try escape) <|> (liftM (:[]) $ noneOf (a:"\n\r\f"))
150 
+    return res
151 
+  char a
152 
+  return result
153 
+
154 
+-- badcomment, baduri, comment undefined
155 
+
156 
+-- tested
157 
+ident :: GenParser Char st String
158 
+ident = do
159 
+  head_ <- optionMaybe $ string "-"
160 
+  result <- nmstart
161 
+  tail_ <- many nmchar
162 
+  return $ (fromMaybe "" head_) ++ (result:tail_)
163 
+
164 
+--tested
165 
+name :: GenParser Char st String
166 
+name = many1 nmchar
167 
+
168 
+-- tested
169 
+num :: GenParser Char st String
170 
+num = floating <|> many1 digit
171 
+  where
172 
+    floating = try $ do
173 
+      radix <- many digit
174 
+      mantissa <- char '.' <:> many1 digit
175 
+      return $ radix ++ mantissa
176 
+
177 
+cdo :: GenParser Char st String
178 
+cdo = string "<!--"
179 
+
180 
+cdc :: GenParser Char st String
181 
+cdc = string "-->"
182 
+
183 
+-- TODO: figger out if / should be here
184 
+url :: GenParser Char st String
185 
+url = liftM (foldr (++) []) $ many $ many1 (oneOf "!#$%&*-~" <|> nonascii) <|> escape
186 
+
187 
+atEnd :: forall b s u (m :: * -> *) t. (Show t, NP.Stream s m t) => NP.ParsecT s u m b -> NP.ParsecT s u m b
188 
+atEnd p = p >>= ((eof >>) . return)
189 
+
190 
+-- partially tested
191 
+urlParse :: GenParser Char st URL
192 
+urlParse = do
193 
+  result <- between (string "url(" >> spaces) (char ')')
194 
+                      (withSpace $ string_ <|> (many1 $ oneOf "=?.,:/" <|> alphaNum) <|> url)
195 
+
196 
+  return $ URLFunc result
197 
+
198 
+stylesheet :: GenParser Char st CSSDeclaration
199 
+stylesheet = do -- TODO: allow the letters to be escaped in these strings
200 
+  chrset <- charset
201 
+  let cset  = case chrset of
202 
+              Nothing -> [];
203 
+              Just x -> [x]
204 
+  many $ s <|> cdo <|> cdc
205 
+
206 
+  imports <- liftM (foldr (++) []) $ many $ do
207 
+    imports <- many1 $ import_
208 
+    many ((cdo >> spaces) <|> (cdc >> spaces))
209 
+    return $ imports
210 
+
211 
+  result <- many $ ruleset  <|> media <|> page
212 
+  many $ (cdo >> many s) <|> (cdc >> many s)
213 
+
214 
+  return $ DeclarationList $ cset ++ imports ++ result
215 
+
216 
+page :: GenParser Char st CSSDeclaration
217 
+page = do
218 
+  string "@page"
219 
+  spaces
220 
+  pseudo_ <- optionMaybe pseudo_page
221 
+
222 
+  body <- rulebody
223 
+  return $ PageDeclaration pseudo_ $ fromList body
224 
+
225 
+pseudo_page :: GenParser Char st String
226 
+pseudo_page = char ':' >> ident >>= (spaces >>) . return
227 
+
228 
+
229 
+charset :: GenParser Char st (Maybe CSSDeclaration)
230 
+charset = optionMaybe $ do
231 
+  try $ string "@charset "
232 
+  result <- string_
233 
+  char ';'
234 
+  return $ Charset result
235 
+
236 
+medium :: GenParser Char st String
237 
+medium = ident >>= (\q -> spaces >> return q)
238 
+
239 
+mediaList :: GenParser Char st [String]
240 
+mediaList = sepBy medium (char ',' >> spaces)
241 
+
242 
+media :: GenParser Char st CSSDeclaration
243 
+media =  do
244 
+  try $ string "@media"
245 
+  spaces
246 
+  query <- mediaList
247 
+  body <- between (char '{') (char '}') $ do
248 
+    spaces
249 
+    rules <- many ruleset
250 
+    spaces
251 
+    return rules
252 
+  return $ MediaQuery query $ DeclarationList body
253 
+
254 
+import_ :: GenParser Char st CSSDeclaration
255 
+import_ = do
256 
+  try $ string "@import "
257 
+  spaces
258 
+  result <- (liftM URLString string_) <|> urlParse
259 
+  spaces
260 
+  tail_ <- optionMaybe $ mediaList
261 
+  char ';'
262 
+  spaces
263 
+  return $ Import $ case tail_ of
264 
+    Nothing -> result
265 
+    Just x -> URLMedia x result
266 
+
267 
+
268 
+
269 
+cssRule :: GenParser Char st CSSSelector
270 
+cssRule = (sepBy1 selector $ char ',' >> spaces)  >>= (return . SelectorList)
271 
+
272 
+selector :: GenParser Char st CSSSelector
273 
+selector = do
274 
+  result <- simpleSelector
275 
+  tail_ <- optionMaybe $ parseCombinator result <|> try (parseOCombinator result)
276 
+  spaces
277 
+  return $ fromMaybe result tail_
278 
+
279 
+-- This returns the value of a combinator, ignoring trailing spaces
280 
+withSpace :: GenParser Char u b -> GenParser Char u b
281 
+withSpace = (>>= ((spaces >>) . return))
282 
+
283 
+oneOfWithSpace :: String -> GenParser Char st Char
284 
+oneOfWithSpace ss = foldr1 (<|>) parsers
285 
+  where
286 
+    parsers = map (withSpace . char) ss
287 
+
288 
+operator :: GenParser Char st Char
289 
+operator = oneOfWithSpace "/,"
290 
+
291 
+combinator :: GenParser Char st Char
292 
+combinator = oneOfWithSpace "+>"
293 
+
294 
+unary_operator :: GenParser Char st Char
295 
+unary_operator = oneOf "-+"
296 
+
297 
+-- parse an optional combinator
298 
+parseOCombinator :: CSSSelector -> GenParser Char st CSSSelector
299 
+parseOCombinator head_ = do
300 
+  spaces
301 
+  combine <- optionMaybe $ combinator
302 
+  sel <- selector
303 
+  return $ case combine of
304 
+    Nothing -> Child head_ sel
305 
+    (Just x) -> case x of
306 
+      '+' -> Sibling head_ sel
307 
+      '>' -> DirectChild head_ sel
308 
+
309 
+-- parse a combinator
310 
+parseCombinator :: CSSSelector -> GenParser Char st CSSSelector
311 
+parseCombinator head_ = do
312 
+  combine <- combinator
313 
+  sel <- selector
314 
+  return $ case combine of
315 
+    '+' -> Sibling head_ sel
316 
+    '>' -> DirectChild head_ sel
317 
+
318 
+
319 
+
320 
+simpleSelector :: GenParser Char st CSSSelector
321 
+simpleSelector = do
322 
+  result <- (try elementName <:> many modifier) <|> many1 modifier
323 
+  return $ if null $ tail result
324 
+    then head result
325 
+    else SelectorList result
326 
+
327 
+modifier :: GenParser Char st CSSSelector
328 
+modifier = hash <|> class_ <|> attrib <|> pseudo
329 
+
330 
+elementName :: GenParser Char st CSSSelector
331 
+elementName = liftM TagName $ ident <|> string "*"
332 
+
333 
+hash :: GenParser Char st CSSSelector
334 
+hash = char '#' >> liftM Id ident
335 
+
336 
+class_ :: GenParser Char st CSSSelector
337 
+class_ = char '.' >> liftM Class ident
338 
+
339 
+attrib :: GenParser Char st CSSSelector
340 
+attrib = between (char '[') (char ']') $ do
341 
+  spaces
342 
+  key <- ident
343 
+  spaces
344 
+  char '='
345 
+  value <- ident
346 
+  spaces
347 
+  return $ Attribute key value
348 
+
349 
+pseudo :: GenParser Char st CSSSelector
350 
+pseudo = char ':' >> liftM Pseudo selectorIdent
351 
+  where
352 
+    selectorIdent = do
353 
+      init <- optionMaybe $ string ":"
354 
+      idnt <- ident
355 
+      return $ (fromMaybe "" init) ++ idnt
356 
+
357 
+
358 
+{-# ANN (<++>) "HLint: ignore" #-}
359 
+(<++>) :: Monad m => m [a] -> m [a] -> m [a]
360 
+a <++> b = liftM2 (++) a b
361 
+
362 
+(<:>) :: Monad m => m a -> m [a] -> m [a]
363 
+a <:> b = liftM2 (:) a b
364 
+
365 
+
366 
+ruleset :: GenParser Char st CSSDeclaration
367 
+ruleset = do
368 
+  selector_ <- cssRule
369 
+  spaces
370 
+  result <- rulebody
371 
+  return $ CSSDeclaration selector_ $ fromList result
372 
+
373 
+rulebody :: GenParser Char st [(String, String)]
374 
+rulebody = between (withSpace $ char '{') (withSpace $ char '}') $ do
375 
+    head_ <- declaration
376 
+    tail_ <- many $ do
377 
+      char ';'
378 
+      spaces
379 
+      optionMaybe declaration
380 
+    spaces
381 
+    return $ (head_:catMaybes tail_)
382 
+
383 
+declaration :: GenParser Char st (String,String)
384 
+declaration = do
385 
+  prop <- property
386 
+  withSpace $ char ':'
387 
+  value <- expr
388 
+  optional prio
389 
+  return (prop,value)
390 
+
391 
+prio :: GenParser Char st String
392 
+prio = char '!' >> spaces >> string "important"
393 
+
394 
+-- TODO: Still need to implement comments . . .
395 
+
396 
+expr :: GenParser Char st String
397 
+expr = do
398 
+  fst <- term
399 
+  rst <- many $ do
400 
+    op <- optionMaybe $ liftM (:[]) operator
401 
+    trm <- term
402 
+    return $ case op of
403 
+      Nothing -> trm
404 
+      Just x -> x ++ (' ':trm)
405 
+  return $ fst ++ foldr (\x y -> (' ':x++(' ':y))) [] rst
406 
+
407 
+term :: GenParser Char st String
408 
+term = do
409 
+  withSpace numerical <|> withSpace uri <|> withSpace string_ <|> withSpace ident <|> hexcolor <|> function
410 
+
411 
+numerical :: GenParser Char st String
412 
+numerical = do
413 
+  unop <- optionMaybe unary_operator
414 
+  value <- withSpace (try percentage) <|> withSpace (try length) <|> withSpace (try ems) <|> withSpace (try exs)
415 
+           <|> withSpace (try angle) <|> withSpace (try time) <|> withSpace (try freq) <|> withSpace number
416 
+  return $ case unop of
417 
+    Just '-' -> '-':value
418 
+    _ -> value
419 
+  where
420 
+    number  :: GenParser Char st String
421 
+    number = num
422 
+
423 
+    percentage :: GenParser Char st String
424 
+    percentage = num <++> string "%"
425 
+
426 
+    length :: GenParser Char st String
427 
+    length = num <++> (foldr1 (<|>) $ map string ["px", "cm", "mm", "in", "pt", "pc", "rem", "vw", "vh"])
428 
+
429 
+    ems  :: GenParser Char st String
430 
+    ems = num <++> string "em"
431 
+
432 
+    exs  :: GenParser Char st String
433 
+    exs = num <++> string "ex"
434 
+
435 
+    angle  :: GenParser Char st String
436 
+    angle = num <++> (string "deg" <|> string "rad" <|> string "grad")
437 
+
438 
+    time  :: GenParser Char st String
439 
+    time = num <++> (string "ms" <|> string "s")
440 
+
441 
+    freq  :: GenParser Char st String
442 
+    freq = num <++> (string "hz" <|> string "khz")
443 
+
444 
+
445 
+function :: GenParser Char st String
446 
+function = do
447 
+  _ <- ident
448 
+  _ <- string "("
449 
+  spaces
450 
+  d <- expr
451 
+  _ <- string ")"
452 
+  spaces
453 
+  return $ d
454 
+
455 
+hexcolor :: GenParser Char st String
456 
+hexcolor = char '#' <:> many1 hexDigit
457 
+
458 
+uri :: GenParser Char st String
459 
+uri = do
460 
+  a <- string "url("
461 
+  w
462 
+  result <- try string_ <|> url
463 
+  w
464 
+  d <- string ")"
465 
+  return $ a ++ result ++ d
466 
+
467 
+
468 
+property :: GenParser Char st String
469 
+property = do
470 
+  result <- ident
471 
+  spaces
472 
+  return result
473 
+
474 
+parseCSS :: String -> Either ParseError CSSDeclaration
475 
+parseCSS = parse stylesheet  "(unknown)"
stack.yaml
History View file @ eccab7b
0 476 
new file mode 100644
... ... 
@@ -0,0 +1,66 @@
1 
+# This file was automatically generated by 'stack init'
2 
+#
3 
+# Some commonly used options have been documented as comments in this file.
4 
+# For advanced use and comprehensive documentation of the format, please see:
5 
+# http://docs.haskellstack.org/en/stable/yaml_configuration/
6 
+
7 
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8 
+# A snapshot resolver dictates the compiler version and the set of packages
9 
+# to be used for project dependencies. For example:
10 
+#
11 
+# resolver: lts-3.5
12 
+# resolver: nightly-2015-09-21
13 
+# resolver: ghc-7.10.2
14 
+# resolver: ghcjs-0.1.0_ghc-7.10.2
15 
+# resolver:
16 
+#  name: custom-snapshot
17 
+#  location: "./custom-snapshot.yaml"
18 
+resolver: lts-7.19
19 
+
20 
+# User packages to be built.
21 
+# Various formats can be used as shown in the example below.
22 
+#
23 
+# packages:
24 
+# - some-directory
25 
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 
+# - location:
27 
+#    git: https://github.com/commercialhaskell/stack.git
28 
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 
+#   extra-dep: true
31 
+#  subdirs:
32 
+#  - auto-update
33 
+#  - wai
34 
+#
35 
+# A package marked 'extra-dep: true' will only be built if demanded by a
36 
+# non-dependency (i.e. a user package), and its test suites and benchmarks
37 
+# will not be run. This is useful for tweaking upstream packages.
38 
+packages:
39 
+- '.'
40 
+# Dependency packages to be pulled from upstream that are not in the resolver
41 
+# (e.g., acme-missiles-0.3)
42 
+extra-deps: []
43 
+
44 
+# Override default flag values for local packages and extra-deps
45 
+flags: {}
46 
+
47 
+# Extra package databases containing global packages
48 
+extra-package-dbs: []
49 
+
50 
+# Control whether we use the GHC we find on the path
51 
+# system-ghc: true
52 
+#
53 
+# Require a specific version of stack, using version ranges
54 
+# require-stack-version: -any # Default
55 
+# require-stack-version: ">=1.3"
56 
+#
57 
+# Override the architecture used by stack, especially useful on Windows
58 
+# arch: i386
59 
+# arch: x86_64
60 
+#
61 
+# Extra directories used by stack for building
62 
+# extra-include-dirs: [/path/to/dir]
63 
+# extra-lib-dirs: [/path/to/dir]
64 
+#
65 
+# Allow a newer minor version of GHC than the snapshot specifies
66 
+# compiler-check: newer-minor
0 67 
\ No newline at end of file
style.css
History View file @ eccab7b
1 68 
new file mode 100644
... ... 
@@ -0,0 +1,48 @@
1 
+*{
2 
+    box-sizing: border-box;
3 
+}
4 
+
5 
+article::after{
6 
+    clear: both;
7 
+    float: none;
8 
+    display: block;
9 
+    content: " ";
10 
+}
11 
+
12 
+h1,
13 
+ h2{
14 
+    margin-left: -3em;
15 
+}
16 
+
17 
+h3{
18 
+    text-align: center;
19 
+    border-bottom: thin solid black;
20 
+}
21 
+
22 
+body{
23 
+    margin-left: 12.5em;
24 
+}
25 
+
26 
+header{
27 
+    max-width: 30em;
28 
+    width: 75vw;
29 
+}
30 
+
31 
+section#ingredients{
32 
+    float: left;
33 
+    max-width: 10em;
34 
+    width: 24vw;
35 
+}
36 
+
37 
+section#instructions{
38 
+    float: left;
39 
+    max-width: 20em;
40 
+    margin-left: 2vw;
41 
+    width: 49vw;
42 
+}
43 
+
44 
+article + article h2{
45 
+    margin-top: 1em;
46 
+    padding-top: 1em;
47 
+    border-top: thin solid black;
48 
+}
0 49 
\ No newline at end of file
test/CssParserTest.hs
History View file @ eccab7b
1 50 
new file mode 100644
... ... 
@@ -0,0 +1,176 @@
1 
+{-
2 
+ -Copyright (c) 2015 Edward Langley
3 
+ -All rights reserved.
4 
+ -
5 
+ -Redistribution and use in source and binary forms, with or without
6 
+ -modification, are permitted provided that the following conditions
7 
+ -are met:
8 
+ -
9 
+ -Redistributions of source code must retain the above copyright notice,
10 
+ -this list of conditions and the following disclaimer.
11 
+ -
12 
+ -Redistributions in binary form must reproduce the above copyright
13 
+ -notice, this list of conditions and the following disclaimer in the
14 
+ -documentation and/or other materials provided with the distribution.
15 
+ -
16 
+ -Neither the name of the project's author nor the names of its
17 
+ -contributors may be used to endorse or promote products derived from
18 
+ -this software without specific prior written permission.
19 
+ -
20 
+ -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 
+ -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 
+ -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23 
+ -FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 
+ -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 
+ -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
26 
+ -TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27 
+ -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28 
+ -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29 
+ -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30 
+ -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 
+ -}
32 
+
33 
+{-# LANGUAGE RankNTypes,KindSignatures #-}
34 
+
35 
+module Main
36 
+  where
37 
+
38 
+import Test.HUnit (Assertion, (@=?), runTestTT, Test(..), Counts(..))
39 
+import Data.Functor.Identity(Identity)
40 
+import Text.Parsec hiding (runParser)
41 
+import qualified CssParser as C
42 
+import System.Exit (ExitCode(..), exitWith)
43 
+import Data.Map hiding (foldr,null,map)
44 
+{-import Data.Char (toUpper)-}
45 
+
46 
+exitProperly :: IO Counts -> IO ()
47 
+exitProperly m = do
48 
+  counts <- m
49 
+  exitWith $ if failures counts /= 0 || errors counts /= 0 then ExitFailure 1 else ExitSuccess
50 
+
51 
+testCase :: String -> Assertion -> Test
52 
+testCase label_ assertion = TestLabel label_ (TestCase assertion)
53 
+
54 
+main :: IO ()
55 
+main = exitProperly $ runTestTT $ TestList [ TestList parserTests ]
56 
+
57 
+runParser :: ParsecT String () Identity a -> String -> Either ParseError a
58 
+runParser parser = flip parse "" $ atEnd parser
59 
+
60 
+testSuccParser :: forall b. (Eq b, Show b) => ParsecT String () Identity b -> String -> b -> Assertion
61 
+testSuccParser parser in_ out = (Right out) @=? (runParser parser in_)
62 
+
63 
+testFailParser :: forall a. (Eq a) => ParsecT String () Identity a -> String -> Assertion
64 
+testFailParser parser in_ =
65 
+  case (runParser parser in_) of
66 
+    Left _ -> 1 @=? 1
67 
+    Right _ -> 1 @=? 2
68 
+
69 
+parserSuccEqualsTestCase :: forall a. (Eq a, Show a) => String -> ParsecT String () Identity a -> String -> a -> Test
70 
+parserSuccEqualsTestCase name = ((testCase name .) .) . testSuccParser
71 
+
72 
+parserFailsTestCase :: forall a. Eq a => String -> ParsecT String () Identity a -> String -> Test
73 
+parserFailsTestCase name parser in_ = testCase name $ testFailParser parser in_
74 
+
75 
+atEnd :: forall b s u (m :: * -> *) t. (Show t, Stream s m t) => ParsecT s u m b -> ParsecT s u m b
76 
+atEnd p = p >>= ((eof >>) . return)
77 
+
78 
+parserTests :: [Test]
79 
+parserTests =
80 
+  [ parserSuccEqualsTestCase "matchUpToX" (C.matchUpToX digit 2) "" "",
81 
+    parserSuccEqualsTestCase "matchUpToX" (C.matchUpToX digit 2) "1" "1",
82 
+    parserSuccEqualsTestCase "matchUpToX" (C.matchUpToX digit 2) "11" "11",
83 
+    parserFailsTestCase "matchUpToX" (C.matchUpToX digit 2) "111", -- Here, it should complain
84 
+
85 
+    parserFailsTestCase "match1ToX" (C.match1ToX digit 2) "",
86 
+    parserSuccEqualsTestCase "match1ToX" (C.match1ToX digit 2) "1" "1",
87 
+    parserSuccEqualsTestCase "match1ToX" (C.match1ToX digit 2) "11" "11",
88 
+    parserFailsTestCase "match1ToX" (C.match1ToX digit 2) "111", -- Here, it should complain
89 
+
90 
+    parserSuccEqualsTestCase "nonascii" C.nonascii "\240" '\240',
91 
+    parserSuccEqualsTestCase "nonascii" C.nonascii "\241" '\241',
92 
+    parserSuccEqualsTestCase "nonascii" C.nonascii "\1114110" '\1114110',
93 
+    parserSuccEqualsTestCase "nonascii" C.nonascii "\1114111" '\1114111',
94 
+    parserFailsTestCase "nonascii" C.nonascii "\230",
95 
+
96 
+    parserSuccEqualsTestCase "unicode" C.unicode "\\222230 " "222230",
97 
+    parserFailsTestCase "unicode" C.unicode "\\2222301",
98 
+    parserFailsTestCase "unicode" C.unicode "\\",
99 
+
100 
+    parserSuccEqualsTestCase "lone \\n" C.nl "\n" "\n",
101 
+    parserSuccEqualsTestCase "lone \\r" C.nl "\r" "\n",
102 
+    parserSuccEqualsTestCase "lone \\f" C.nl "\f" "\n",
103 
+    parserSuccEqualsTestCase "\\r\\n" C.nl "\r\n" "\n",
104 
+    parserFailsTestCase "nl" C.nl "a",
105 
+
106 
+    parserSuccEqualsTestCase "test double quote" C.string_ "\"aaa\"" "aaa",
107 
+    parserSuccEqualsTestCase "test double quote" C.string_ "\"aa\\\"a\"" "aa\\\"a",
108 
+    parserSuccEqualsTestCase "test single quote" C.string_ "'aaa'" "aaa",
109 
+    parserSuccEqualsTestCase "test escaped quote" C.string_ "'aa\\'a'" "aa\\'a",
110 
+    parserSuccEqualsTestCase "test escaped quote" C.string_ "'aa\\\na'" "aa\\\na",
111 
+    parserFailsTestCase "unended string" C.string_ "'aaa",
112 
+    parserFailsTestCase "unended string" C.string_ "\"aaa",
113 
+    parserFailsTestCase "no string" C.string_ "aaa",
114 
+
115 
+    parserSuccEqualsTestCase "escape" C.escape "\\j" "\\j",
116 
+    parserSuccEqualsTestCase "escape" C.escape "\\00" "\\00",
117 
+    parserSuccEqualsTestCase "escape" C.escape "\\'" "\\'",
118 
+    parserFailsTestCase "no escaped letter should fail" C.escape "\\",
119 
+    parserFailsTestCase "escaped newline fails" C.escape "\\\n",
120 
+
121 
+    parserSuccEqualsTestCase "test simple ident" C.ident "ident" "ident",
122 
+    parserSuccEqualsTestCase "test alnum ident"  C.ident "ident0" "ident0",
123 
+    parserSuccEqualsTestCase "test alnum ident"  C.ident "-ident0" "-ident0",
124 
+    parserFailsTestCase "ident can't begin with num" C.ident "1dent",
125 
+    parserFailsTestCase "ident can't contain space" C.ident "dent ",
126 
+
127 
+    parserSuccEqualsTestCase "test simple name" C.name "name" "name",
128 
+    parserSuccEqualsTestCase "test alnum name"  C.name "name0" "name0",
129 
+    parserSuccEqualsTestCase "test alnum name"  C.name "-name0" "-name0",
130 
+    parserSuccEqualsTestCase "name begins with num" C.name "1dent" "1dent",
131 
+    parserFailsTestCase "name can't contain space" C.name "dent ",
132 
+
133 
+    parserSuccEqualsTestCase "test num" C.num "123" "123",
134 
+    parserSuccEqualsTestCase "test floating num" C.num "1.23" "1.23",
135 
+    parserSuccEqualsTestCase "test floating num" C.num ".23" ".23",
136 
+
137 
+    parserSuccEqualsTestCase "url with string" C.urlParse "url('something')" $ C.URLFunc "something",
138 
+    parserSuccEqualsTestCase "url with string" C.urlParse "url(\"something\")" $ C.URLFunc "something",
139 
+    parserSuccEqualsTestCase "url with string and spaces" C.urlParse "url( \"something\" )" $ C.URLFunc "something",
140 
+    parserSuccEqualsTestCase "url without string" C.urlParse "url(/a/b/c)" $ C.URLFunc "/a/b/c",
141 
+    parserSuccEqualsTestCase "url without string" C.urlParse "url(a/b/c)" $ C.URLFunc "a/b/c",
142 
+
143 
+    parserSuccEqualsTestCase "page rule" C.page "@page{a:b}" $ C.PageDeclaration Nothing (fromList [("a","b")]),
144 
+    parserSuccEqualsTestCase "page whitespace" C.page "@page { a  : b ; }" $ C.PageDeclaration Nothing (fromList [("a","b")]),
145 
+    parserSuccEqualsTestCase "pseudo-page" C.page "@page:first{a:b;}" $ C.PageDeclaration (Just "first") (fromList [("a","b")]),
146 
+
147 
+    parserSuccEqualsTestCase "charset" C.charset "@charset \"UTF-8\";" $ (Just . C.Charset)  "UTF-8",
148 
+
149 
+    parserSuccEqualsTestCase "Medium identifier" C.medium "print" $ "print",
150 
+    parserSuccEqualsTestCase "Medium identifier" C.medium "print " $ "print",
151 
+
152 
+    parserSuccEqualsTestCase "Media Declarations" C.mediaList "print, screen" $ ["print", "screen"],
153 
+
154 
+    parserSuccEqualsTestCase "Media Declarations" C.media "@media screen {}" $ C.MediaQuery ["screen"] $ C.DeclarationList [],
155 
+    parserSuccEqualsTestCase "Media Declarations" C.media "@media screen { a {b:c;} }" $ C.MediaQuery ["screen"] $ C.DeclarationList [C.CSSDeclaration (C.SelectorList [C.TagName "a"]) (fromList [("b", "c")])]
156 
+    ]
157 
+  {-
158 
+   -[ testCase "empty accumulation" $
159 
+   -  [] @=? accumulate square []
160 
+   -, testCase "accumulate squares" $
161 
+   -  [1, 4, 9] @=? accumulate square [1, 2, 3]
162 
+   -, testCase "accumulate upcases" $
163 
+   -  ["HELLO", "WORLD"] @=? accumulate (map toUpper) ["hello", "world"]
164 
+   -, testCase "accumulate reversed strings" $
165 
+   -  ["eht", "kciuq", "nworb", "xof", "cte"] @=?
166 
+   -  accumulate reverse ["the", "quick", "brown", "fox", "etc"]
167 
+   -, testCase "accumulate recursively" $
168 
+   -  [["a1", "a2", "a3"], ["b1", "b2", "b3"], ["c1", "c2", "c3"]] @=?
169 
+   -  accumulate (\c -> accumulate ((c:) . show) ([1, 2, 3] :: [Int])) "abc"
170 
+   -, testCase "accumulate non-strict" $
171 
+   -  ["nice work!"] @=?
172 
+   -  take 1 (accumulate id
173 
+   -    ("nice work!" :
174 
+   -     error "accumulate should be even lazier, don't use reverse!"))
175 
+   -]
176 
+   -}
tmp.css
History View file @ eccab7b
0 177 
new file mode 100644
... ... 
@@ -0,0 +1,4 @@
1 
+a {
2 
+  display: block;
3 
+  tmp: asd;
4 
+}