css-text 0.1.1 → 0.1.2
raw patch · 4 files changed
+141/−57 lines, 4 filesdep −HUnitdep ~hspecnew-uploader
Dependencies removed: HUnit
Dependency ranges changed: hspec
Files
- Text/CSS/Parse.hs +70/−18
- Text/CSS/Render.hs +12/−0
- css-text.cabal +2/−3
- runtests.hs +57/−36
Text/CSS/Parse.hs view
@@ -8,26 +8,38 @@ , 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) <|> (skip isSpace >> skipWhile isSpace >> skipWS)@@ -43,21 +55,20 @@ 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 @@ _ <- 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
Text/CSS/Render.hs view
@@ -4,11 +4,13 @@ , 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 @@ 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
css-text.cabal view
@@ -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 @@ 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
runtests.hs view
@@ -1,54 +1,75 @@ {-# 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*/"- ])+main :: IO ()+main = hspec $ do+ describe "single attribute parser" $ do+ it "trimming whitespace" $+ parseAttr " foo : bar " `shouldBe` Right ("foo", "bar") - describe "render" $ do- it "works" $- "foo{bar:baz;bin:bang}foo2{x:y}" @=? renderBlocks- [ ("foo", [("bar", "baz"), ("bin", "bang")])- , ("foo2", [("x", "y")])- ]+ describe "multiple attribute parser" $ do+ it "no final semicolon" $+ parseAttrs " foo: bar ; baz : bin "+ `shouldBe` Right [("foo", "bar"), ("baz", "bin")] - describe "parse/render" $ do- prop "is idempotent" $ \bs ->- parseBlocks (toStrict $ toLazyText $ renderBlocks $ unBlocks bs) == Right (unBlocks bs)+ 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