merge 2 prs together

src/Text/CSS/Parse.hs

@@ -15,9 +15,10 @@ module Text.CSS.Parse
 
 import Prelude hiding (takeWhile, take)
 import Data.Attoparsec.Text
-import Data.Text (Text, strip)
-import Control.Applicative ((<|>), many, (<$>))
+import Data.Text (Text, strip, append)
+import Control.Applicative ((<|>), many, (<$>), (<*), (*>))
 import Data.Char (isSpace)
+import Control.Monad (mzero)
 
 type CssBlock = (Text, [(Text, Text)])
 data NestedBlock = NestedBlock Text [NestedBlock] -- ^ for example a media query
@@ -60,68 +61,44 @@ attrParser = do
     key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')
     _ <- char ':' <|> fail "Missing colon in attribute"
     value <- valueParser
+    _ <- option ';' (char ';')
+    skipWS
     return (strip key, strip value)
 
 valueParser :: Parser Text
-valueParser = takeWhile (\c -> c /= ';' && c /= '}')
+valueParser = takeWhile (\c -> c /= ';' && c /= '}' && c /= '{')
 
 attrsParser :: Parser [(Text, Text)]
-attrsParser = (do
-    a <- attrParser
-    (char ';' >> skipWS >> ((a :) <$> attrsParser))
-      <|> return [a]
-  ) <|> return []
+attrsParser = many attrParser
 
 blockParser :: Parser (Text, [(Text, Text)])
 blockParser = do
-    skipWS
     sel <- takeWhile (/= '{')
     _ <- char '{'
     attrs <- attrsParser
     skipWS
     _ <- char '}'
     return (strip sel, attrs)
 
-nestedBlockParser :: Parser NestedBlock
-nestedBlockParser = do
-    skipWS
-    sel <- strip <$> takeTill (== '{')
+mediaQueryParser :: Parser NestedBlock
+mediaQueryParser = do
+    _ <- char '@'
+    sel <- strip <$> takeWhile (\c -> c /= '{' && c /= '}')
     _ <- char '{'
-    skipWS
-
-    unknown <- strip <$> takeTill (\c -> c == '{' || c == '}' || c == ':')
-    mc <- peekChar
-    res <- case mc of
-      Nothing -> fail "unexpected end of input"
-      Just c -> nestedParse sel unknown c
-
+    blocks <- nestedBlocksParser
     skipWS
     _ <- char '}'
-    return res
-  where
-    -- no colon means no content
-    nestedParse sel _ '}' = return $ LeafBlock (sel, [])
-
-    nestedParse sel unknown ':' = do
-        _ <- char ':'
-        value <- valueParser
-        (char ';' >> return ()) <|> return ()
-        skipWS
-        moreAttrs <- attrsParser
-        return $ LeafBlock (sel, (unknown, strip value) : moreAttrs)
-
-    -- TODO: handle infinite nesting
-    nestedParse sel unknown '{' = do
-        _ <- char '{'
-        attrs <- attrsParser
-        skipWS
-        _ <- char '}'
-        blocks <- blocksParser
-        return $ NestedBlock sel $ map LeafBlock $ (unknown, attrs) : blocks
-    nestedParse _ _ c = fail $ "expected { or : but got " ++ [c]
+    return $ NestedBlock ("@" `append` sel) $ blocks
 
 blocksParser :: Parser [(Text, [(Text, Text)])]
-blocksParser = many blockParser
+blocksParser =  skipWS *> blockParser `sepBy` skipWS <* skipWS
+
+nestedBlockParser :: Parser NestedBlock
+nestedBlockParser = do
+    mc <- peekChar
+    case mc of
+         Just '}' -> mzero
+         _        -> try mediaQueryParser <|> (LeafBlock <$> blockParser)
 
 nestedBlocksParser :: Parser [NestedBlock]
-nestedBlocksParser = many nestedBlockParser
+nestedBlocksParser = skipWS *> nestedBlockParser `sepBy` skipWS <* skipWS

stack.yaml

@@ -1 +1 @@
-resolver: lts-10.4
+resolver: lts-14.13

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 525876
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/13.yaml
+    sha256: 4a0e79eb194c937cc2a1852ff84d983c63ac348dc6bad5f38d20cab697036eef
+  original: lts-14.13

test/runtests.hs

@@ -50,6 +50,11 @@ main = hspec $ do
             , LeafBlock ("a, a:visited", [("text-decoration", "underline")])
             ]
           ]
+      parseNestedBlocks "@media whatever { foo { color: rgb(255, 255, 240); } }  bar { }"
+        `shouldBe` Right
+          [ NestedBlock "@media whatever" [ LeafBlock ("foo", [("color", "rgb(255, 255, 240)")]) ]
+          , LeafBlock ("bar", [])
+          ]
 
   describe "render" $ -- do
     it "works" $
@@ -73,9 +78,11 @@ newtype Blocks = Blocks { unBlocks :: [(Text, [(Text, Text)])] }
     deriving (Show, Eq)
 
 instance Arbitrary NestedBlock where
-    arbitrary = frequency
+    arbitrary = resize 4 $ frequency
       [ (80, (LeafBlock . unBlock) `liftM` arbitrary)
-      , (10, do mediatype <- elements ["print", "screen", "(min-width:768px)"]
+      , (10, do mediatype <- elements ["@print", "@screen",
+                                       "@media (min-width:768px)",
+                                       "@media screen and (max-width: 300px)"]
                 contents <- arbitrary
                 return (NestedBlock mediatype contents))
       ]
@@ -88,8 +95,12 @@ newtype Block = Block { unBlock :: (Text, [(Text, Text)]) }
 
 instance Arbitrary Block where
     arbitrary = do
-        (sel, attrs) <- arbitrary
-        return $ Block (unT sel, unAttrs attrs)
+        sel <- frequency [
+                     (90, unT `fmap` arbitrary)
+                   , (10, return "@font-face")
+                   ]
+        attrs <- arbitrary
+        return $ Block (sel, unAttrs attrs)
 
 newtype Attrs = Attrs { unAttrs :: [(Text, Text)] }