summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGregWeber <>2014-02-18 15:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-02-18 15:21:00 (GMT)
commit37c9d7849f312c789b30a7252b9a5d1c133c10db (patch)
tree9936a7a92fe477af1bc6c6eb82c5958758cc9ffc
parentde0b78ddbf4f378753e0d804fd784ee9eb2f9ba4 (diff)
version 0.1.20.1.2
-rw-r--r--Text/CSS/Parse.hs88
-rw-r--r--Text/CSS/Render.hs12
-rw-r--r--css-text.cabal5
-rw-r--r--runtests.hs97
4 files changed, 143 insertions, 59 deletions
diff --git a/Text/CSS/Parse.hs b/Text/CSS/Parse.hs
index 90c7ed0..76b20a0 100644
--- a/Text/CSS/Parse.hs
+++ b/Text/CSS/Parse.hs
@@ -8,25 +8,37 @@ module Text.CSS.Parse
, parseAttrs
, parseBlock
, parseBlocks
+ , parseNestedBlocks
+ , NestedBlock(..)
) where
-import Prelude hiding (takeWhile)
+import Prelude hiding (takeWhile, take)
import Data.Attoparsec.Text
import Data.Text (Text, strip)
-import Control.Applicative ((<|>), many)
+import Control.Applicative ((<|>), many, (<$>))
import Data.Char (isSpace)
+type CssBlock = (Text, [(Text, Text)])
+data NestedBlock = NestedBlock Text [NestedBlock]
+ | LeafBlock CssBlock
+ deriving (Eq, Show)
+
+-- | The preferred parser, will capture media queries
+parseNestedBlocks :: Text -> Either String [NestedBlock]
+parseNestedBlocks = parseOnly nestedBlocksParser
+
+parseBlocks :: Text -> Either String [CssBlock]
+parseBlocks = parseOnly blocksParser
+
+parseBlock :: Text -> Either String CssBlock
+parseBlock = parseOnly blockParser
+
parseAttrs :: Text -> Either String [(Text, Text)]
parseAttrs = parseOnly attrsParser
parseAttr :: Text -> Either String (Text, Text)
parseAttr = parseOnly attrParser
-parseBlocks :: Text -> Either String [(Text, [(Text, Text)])]
-parseBlocks = parseOnly blocksParser
-
-parseBlock :: Text -> Either String (Text, [(Text, Text)])
-parseBlock = parseOnly blockParser
skipWS :: Parser ()
skipWS = (string "/*" >> endComment >> skipWS)
@@ -43,21 +55,20 @@ skipWS = (string "/*" >> endComment >> skipWS)
attrParser :: Parser (Text, Text)
attrParser = do
skipWS
- key <- takeWhile1 (not . flip elem ":{}")
+ key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')
_ <- char ':' <|> fail "Missing colon in attribute"
- value <- (takeWhile (not . flip elem ";}"))
+ value <- valueParser
return (strip key, strip value)
+valueParser :: Parser Text
+valueParser = takeWhile (\c -> c /= ';' && c /= '}')
+
attrsParser :: Parser [(Text, Text)]
-attrsParser =
- go id
- where
- go front = (do
- a <- attrParser
- (char ';' >> return ()) <|> return ()
- skipWS
- go $ front . (:) a
- ) <|> return (front [])
+attrsParser = (do
+ a <- attrParser
+ (char ';' >> skipWS >> ((a :) <$> attrsParser))
+ <|> return [a]
+ ) <|> return []
blockParser :: Parser (Text, [(Text, Text)])
blockParser = do
@@ -69,5 +80,46 @@ blockParser = do
_ <- char '}'
return (strip sel, attrs)
+nestedBlockParser :: Parser NestedBlock
+nestedBlockParser = do
+ skipWS
+ sel <- strip <$> takeTill (== '{')
+ _ <- 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
+
+ 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]
+
blocksParser :: Parser [(Text, [(Text, Text)])]
blocksParser = many blockParser
+
+nestedBlocksParser :: Parser [NestedBlock]
+nestedBlocksParser = many nestedBlockParser
diff --git a/Text/CSS/Render.hs b/Text/CSS/Render.hs
index 633df9f..30f4f3c 100644
--- a/Text/CSS/Render.hs
+++ b/Text/CSS/Render.hs
@@ -4,11 +4,13 @@ module Text.CSS.Render
, renderAttrs
, renderBlock
, renderBlocks
+ , renderNestedBlocks
) where
import Data.Text (Text)
import Data.Text.Lazy.Builder (Builder, fromText, singleton)
import Data.Monoid (mappend, mempty, mconcat)
+import Text.CSS.Parse
(<>) :: Builder -> Builder -> Builder
(<>) = mappend
@@ -27,3 +29,13 @@ renderBlock (sel, attrs) =
renderBlocks :: [(Text, [(Text, Text)])] -> Builder
renderBlocks = mconcat . map renderBlock
+
+renderNestedBlock :: NestedBlock -> Builder
+renderNestedBlock (LeafBlock b) = renderBlock b
+renderNestedBlock (NestedBlock t bs) = fromText t
+ <> singleton '{'
+ <> renderNestedBlocks bs
+ <> singleton '}'
+
+renderNestedBlocks :: [NestedBlock] -> Builder
+renderNestedBlocks = mconcat . map renderNestedBlock
diff --git a/css-text.cabal b/css-text.cabal
index da0faf5..78b010f 100644
--- a/css-text.cabal
+++ b/css-text.cabal
@@ -1,5 +1,5 @@
name: css-text
-version: 0.1.1
+version: 0.1.2
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -26,8 +26,7 @@ test-suite runtests
build-depends: base >= 4 && < 5
, text >= 0.11
, attoparsec >= 0.10
- , HUnit >= 1.2
- , hspec >= 0.6.1
+ , hspec >= 1.3
, QuickCheck
source-repository head
diff --git a/runtests.hs b/runtests.hs
index 8a74e0d..d0b494a 100644
--- a/runtests.hs
+++ b/runtests.hs
@@ -1,55 +1,76 @@
{-# LANGUAGE OverloadedStrings #-}
import Text.CSS.Parse
import Text.CSS.Render
-import Test.Hspec.Monadic
-import Test.Hspec.HUnit ()
-import Test.Hspec.QuickCheck
-import Test.HUnit ((@=?))
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
import qualified Data.Text as T
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy (toStrict)
import Data.Text (Text)
import Test.QuickCheck
import Control.Arrow ((***))
+import Control.Monad (liftM)
-main = hspecX $ do
- describe "single attribute parser" $ do
- it "trimming whitespace" $
- Right ("foo", "bar") @=? parseAttr " foo : bar "
- describe "multiple attribute parser" $ do
- it "no final semicolon" $
- Right [("foo", "bar"), ("baz", "bin")] @=?
- parseAttrs " foo: bar ; baz : bin "
- it "final semicolon" $
- Right [("foo", "bar"), ("baz", "bin")] @=?
- parseAttrs " foo: bar ; baz : bin ;"
- it "ignores comments" $
- Right [("foo", "bar"), ("baz", "bin")] @=?
- parseAttrs " foo: bar ; /* ignored */ baz : bin ;"
- describe "block parser" $ do
- it "multiple blocks" $
- Right [ ("foo", [("fooK1", "fooV1"), ("fooK2", "fooV2")])
- , ("bar", [("barK1", "barV1"), ("barK2", "barV2")])
- ] @=? parseBlocks (T.concat
- [ "foo{fooK1:fooV1;/*ignored*/fooK2:fooV2 }\n\n"
- , "/*ignored*/"
- , "bar{barK1:barV1;/*ignored*/barK2:barV2 ;}\n\n/*ignored*/"
- ])
-
- describe "render" $ do
- it "works" $
- "foo{bar:baz;bin:bang}foo2{x:y}" @=? renderBlocks
- [ ("foo", [("bar", "baz"), ("bin", "bang")])
- , ("foo2", [("x", "y")])
- ]
-
- describe "parse/render" $ do
- prop "is idempotent" $ \bs ->
- parseBlocks (toStrict $ toLazyText $ renderBlocks $ unBlocks bs) == Right (unBlocks bs)
+main :: IO ()
+main = hspec $ do
+ describe "single attribute parser" $ do
+ it "trimming whitespace" $
+ parseAttr " foo : bar " `shouldBe` Right ("foo", "bar")
+
+ describe "multiple attribute parser" $ do
+ it "no final semicolon" $
+ parseAttrs " foo: bar ; baz : bin "
+ `shouldBe` Right [("foo", "bar"), ("baz", "bin")]
+
+ it "final semicolon" $
+ parseAttrs " foo: bar ; baz : bin ;"
+ `shouldBe` Right [("foo", "bar"), ("baz", "bin")]
+
+ it "ignores comments" $
+ parseAttrs " foo: bar ; /* ignored */ baz : bin ;"
+ `shouldBe` Right [("foo", "bar"), ("baz", "bin")]
+
+ describe "block parser" $ do
+ it "multiple blocks" $
+ parseBlocks (T.concat
+ [ "foo{fooK1:fooV1;/*ignored*/fooK2:fooV2 }\n\n"
+ , "/*ignored*/"
+ , "bar{barK1:barV1;/*ignored*/barK2:barV2 ;}\n\n/*ignored*/"
+ ]) `shouldBe` Right [
+ ("foo", [("fooK1", "fooV1"), ("fooK2", "fooV2")])
+ , ("bar", [("barK1", "barV1"), ("barK2", "barV2")])
+ ]
+
+ it "media queries" $ do
+ parseBlocks "@media print {* {text-shadow: none !important;} }"
+ `shouldBe` Right []
+ parseNestedBlocks "@media print {* {text-shadow: none !important; color: #000 !important; } a, a:visited { text-decoration: underline; }}"
+ `shouldBe` Right [NestedBlock "@media print"
+ [ LeafBlock ("*", [("text-shadow", "none !important"), ("color", "#000 !important")])
+ , LeafBlock ("a, a:visited", [("text-decoration", "underline")])
+ ]
+ ]
+
+ describe "render" $ -- do
+ it "works" $
+ renderBlocks [
+ ("foo", [("bar", "baz"), ("bin", "bang")])
+ , ("foo2", [("x", "y")])
+ ]
+ `shouldBe` "foo{bar:baz;bin:bang}foo2{x:y}"
+
+ describe "parse/render" $ do
+ prop "idempotent blocks" $ \bs ->
+ parseBlocks (toStrict $ toLazyText $ renderBlocks $ unBlocks bs) == Right (unBlocks bs)
+ prop "idempotent nested blocks" $ \bs ->
+ parseNestedBlocks (toStrict $ toLazyText $ renderNestedBlocks bs) == Right bs
newtype Blocks = Blocks { unBlocks :: [(Text, [(Text, Text)])] }
deriving (Show, Eq)
+instance Arbitrary NestedBlock where
+ arbitrary = (LeafBlock . unBlock) `liftM` arbitrary
+
instance Arbitrary Blocks where
arbitrary = fmap (Blocks . map unBlock) arbitrary