css-text 0.1.2.2 → 0.1.3.0
raw patch · 9 files changed
+340/−301 lines, 9 filesdep +css-textdep +semigroupsPVP ok
version bump matches the API change (PVP)
Dependencies added: css-text, semigroups
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- README.md +5/−0
- Text/CSS/Parse.hs +0/−127
- Text/CSS/Render.hs +0/−42
- css-text.cabal +57/−29
- runtests.hs +0/−103
- src/Text/CSS/Parse.hs +127/−0
- src/Text/CSS/Render.hs +40/−0
- test/runtests.hs +107/−0
ChangeLog.md view
@@ -1,3 +1,7 @@+## 0.1.3.0++* Support for GHC 8.4 [#13](https://github.com/yesodweb/css-text/pull/13)+ ## 0.1.2.2 * Clarified MIT license
README.md view
@@ -1,1 +1,6 @@+# css-text++[](https://travis-ci.org/yesodweb/css-text)+[](https://ci.appveyor.com/project/snoyberg/css-text/branch/master)+ a haskell css parser
− Text/CSS/Parse.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Parse CSS with parseNestedBlocks and render it with renderNestedBlock-module Text.CSS.Parse- ( NestedBlock(..)- , parseNestedBlocks- , parseBlocks- , parseBlock- , attrParser- , attrsParser- , blockParser- , blocksParser- , parseAttr- , parseAttrs- ) where--import Prelude hiding (takeWhile, take)-import Data.Attoparsec.Text-import Data.Text (Text, strip)-import Control.Applicative ((<|>), many, (<$>))-import Data.Char (isSpace)--type CssBlock = (Text, [(Text, Text)])-data NestedBlock = NestedBlock Text [NestedBlock] -- ^ for example a media query- | LeafBlock CssBlock- deriving (Eq, Show)---- | The preferred parser, will capture media queries-parseNestedBlocks :: Text -> Either String [NestedBlock]-parseNestedBlocks = parseOnly nestedBlocksParser---- | The original parser of basic CSS, but throws out media queries-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---skipWS :: Parser ()-skipWS = (string "/*" >> endComment >> skipWS)- <|> (skip isSpace >> skipWhile isSpace >> skipWS)- <|> return ()- where- endComment = do- skipWhile (/= '*')- (do- _ <- char '*'- (char '/' >> return ()) <|> endComment- ) <|> fail "Missing end comment"--attrParser :: Parser (Text, Text)-attrParser = do- skipWS- key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')- _ <- char ':' <|> fail "Missing colon in attribute"- value <- valueParser- return (strip key, strip value)--valueParser :: Parser Text-valueParser = takeWhile (\c -> c /= ';' && c /= '}')--attrsParser :: Parser [(Text, Text)]-attrsParser = (do- a <- attrParser- (char ';' >> skipWS >> ((a :) <$> attrsParser))- <|> return [a]- ) <|> return []--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 (== '{')- _ <- 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
@@ -1,42 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Prender CSS with renderNestedBlocks-module Text.CSS.Render- ( renderNestedBlocks- , renderBlocks- , renderBlock- , renderAttrs- , renderAttr- ) 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--renderAttr :: (Text, Text) -> Builder-renderAttr (k, v) = fromText k <> singleton ':' <> fromText v--renderAttrs :: [(Text, Text)] -> Builder-renderAttrs [] = mempty-renderAttrs [x] = renderAttr x-renderAttrs (x:xs) = renderAttr x <> singleton ';' <> renderAttrs xs--renderBlock :: (Text, [(Text, Text)]) -> Builder-renderBlock (sel, attrs) =- fromText sel <> singleton '{' <> renderAttrs attrs <> singleton '}'--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,34 +1,62 @@-name: css-text-version: 0.1.2.2-license: MIT-license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>-synopsis: CSS parser and renderer.-category: Web, Yesod-stability: Stable-cabal-version: >= 1.8-build-type: Simple-homepage: http://www.yesodweb.com/-extra-source-files: runtests.hs README.md ChangeLog.md+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: bc09a14475e42f4d9f29dd5063a9bde24ddcf078b0d4749b9a91275c3c82231b -library- build-depends: base >= 4 && < 5- , text >= 0.11- , attoparsec >= 0.10.2.0- exposed-modules: Text.CSS.Parse- Text.CSS.Render- ghc-options: -Wall+name: css-text+version: 0.1.3.0+synopsis: CSS parser and renderer.+description: Please see the README and generated docs at <https://www.stackage.org/package/css-text>+category: Web, Yesod+stability: Stable+homepage: https://github.com/yesodweb/css-text.git#readme+bug-reports: https://github.com/yesodweb/css-text.git/issues+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10 -test-suite runtests- type: exitcode-stdio-1.0- main-is: runtests.hs- build-depends: base >= 4 && < 5- , text >= 0.11- , attoparsec >= 0.10.2.0- , hspec >= 1.3- , QuickCheck+extra-source-files:+ ChangeLog.md+ README.md source-repository head- type: git+ type: git location: https://github.com/yesodweb/css-text.git++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ attoparsec >=0.10.2.0+ , base >=4 && <5+ , text >=0.11+ if !(impl(ghc >=8.0))+ build-depends:+ semigroups >=0.16.1+ exposed-modules:+ Text.CSS.Parse+ Text.CSS.Render+ other-modules:+ Paths_css_text+ default-language: Haskell2010++test-suite runtests+ type: exitcode-stdio-1.0+ main-is: runtests.hs+ hs-source-dirs:+ test+ build-depends:+ QuickCheck+ , attoparsec >=0.10.2.0+ , base >=4 && <5+ , css-text+ , hspec >=1.3+ , text >=0.11+ other-modules:+ Paths_css_text+ default-language: Haskell2010
− runtests.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Text.CSS.Parse-import Text.CSS.Render-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 :: 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 = frequency- [ (80, (LeafBlock . unBlock) `liftM` arbitrary)- , (10, do mediatype <- elements ["print", "screen", "(min-width:768px)"]- contents <- arbitrary- return (NestedBlock mediatype contents))- ]--instance Arbitrary Blocks where- arbitrary = fmap (Blocks . map unBlock) arbitrary--newtype Block = Block { unBlock :: (Text, [(Text, Text)]) }- deriving (Show, Eq)--instance Arbitrary Block where- arbitrary = do- (sel, attrs) <- arbitrary- return $ Block (unT sel, unAttrs attrs)--newtype Attrs = Attrs { unAttrs :: [(Text, Text)] }--instance Arbitrary Attrs where- arbitrary = fmap (Attrs . map (unT *** unT)) arbitrary--newtype T = T { unT :: Text }--instance Arbitrary T where- arbitrary = fmap (T . T.pack) $ listOf1 $ elements $ concat- [ ['A'..'Z']- , ['a'..'z']- , ['0'..'9']- , "-_"- ]
+ src/Text/CSS/Parse.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Parse CSS with parseNestedBlocks and render it with renderNestedBlock+module Text.CSS.Parse+ ( NestedBlock(..)+ , parseNestedBlocks+ , parseBlocks+ , parseBlock+ , attrParser+ , attrsParser+ , blockParser+ , blocksParser+ , parseAttr+ , parseAttrs+ ) where++import Prelude hiding (takeWhile, take)+import Data.Attoparsec.Text+import Data.Text (Text, strip)+import Control.Applicative ((<|>), many, (<$>))+import Data.Char (isSpace)++type CssBlock = (Text, [(Text, Text)])+data NestedBlock = NestedBlock Text [NestedBlock] -- ^ for example a media query+ | LeafBlock CssBlock+ deriving (Eq, Show)++-- | The preferred parser, will capture media queries+parseNestedBlocks :: Text -> Either String [NestedBlock]+parseNestedBlocks = parseOnly nestedBlocksParser++-- | The original parser of basic CSS, but throws out media queries+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+++skipWS :: Parser ()+skipWS = (string "/*" >> endComment >> skipWS)+ <|> (skip isSpace >> skipWhile isSpace >> skipWS)+ <|> return ()+ where+ endComment = do+ skipWhile (/= '*')+ (do+ _ <- char '*'+ (char '/' >> return ()) <|> endComment+ ) <|> fail "Missing end comment"++attrParser :: Parser (Text, Text)+attrParser = do+ skipWS+ key <- takeWhile1 (\c -> c /= ':' && c /= '{' && c /= '}')+ _ <- char ':' <|> fail "Missing colon in attribute"+ value <- valueParser+ return (strip key, strip value)++valueParser :: Parser Text+valueParser = takeWhile (\c -> c /= ';' && c /= '}')++attrsParser :: Parser [(Text, Text)]+attrsParser = (do+ a <- attrParser+ (char ';' >> skipWS >> ((a :) <$> attrsParser))+ <|> return [a]+ ) <|> return []++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 (== '{')+ _ <- 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
+ src/Text/CSS/Render.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Prender CSS with renderNestedBlocks+module Text.CSS.Render+ ( renderNestedBlocks+ , renderBlocks+ , renderBlock+ , renderAttrs+ , renderAttr+ ) where++import Data.Text (Text)+import Data.Text.Lazy.Builder (Builder, fromText, singleton)+import Data.Monoid (mempty, mconcat)+import Data.Semigroup ((<>))+import Text.CSS.Parse++renderAttr :: (Text, Text) -> Builder+renderAttr (k, v) = fromText k <> singleton ':' <> fromText v++renderAttrs :: [(Text, Text)] -> Builder+renderAttrs [] = mempty+renderAttrs [x] = renderAttr x+renderAttrs (x:xs) = renderAttr x <> singleton ';' <> renderAttrs xs++renderBlock :: (Text, [(Text, Text)]) -> Builder+renderBlock (sel, attrs) =+ fromText sel <> singleton '{' <> renderAttrs attrs <> singleton '}'++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
+ test/runtests.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+import Text.CSS.Parse+import Text.CSS.Render+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, when)++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+ when False $ it "three levels of nesting" $ do+ let bs = [NestedBlock "a" [NestedBlock "b" [LeafBlock ("c",[])]]]+ txt = "a{b{c{}}}"+ parseNestedBlocks txt `shouldBe` Right bs+ prop "idempotent blocks" $ \bs ->+ parseBlocks (toStrict $ toLazyText $ renderBlocks $ unBlocks bs) == Right (unBlocks bs)+ when False $ prop "idempotent nested blocks" $ \bs ->+ parseNestedBlocks (toStrict $ toLazyText $ renderNestedBlocks bs) `shouldBe` Right bs++newtype Blocks = Blocks { unBlocks :: [(Text, [(Text, Text)])] }+ deriving (Show, Eq)++instance Arbitrary NestedBlock where+ arbitrary = frequency+ [ (80, (LeafBlock . unBlock) `liftM` arbitrary)+ , (10, do mediatype <- elements ["print", "screen", "(min-width:768px)"]+ contents <- arbitrary+ return (NestedBlock mediatype contents))+ ]++instance Arbitrary Blocks where+ arbitrary = fmap (Blocks . map unBlock) arbitrary++newtype Block = Block { unBlock :: (Text, [(Text, Text)]) }+ deriving (Show, Eq)++instance Arbitrary Block where+ arbitrary = do+ (sel, attrs) <- arbitrary+ return $ Block (unT sel, unAttrs attrs)++newtype Attrs = Attrs { unAttrs :: [(Text, Text)] }++instance Arbitrary Attrs where+ arbitrary = fmap (Attrs . map (unT *** unT)) arbitrary++newtype T = T { unT :: Text }++instance Arbitrary T where+ arbitrary = fmap (T . T.pack) $ listOf1 $ elements $ concat+ [ ['A'..'Z']+ , ['a'..'z']+ , ['0'..'9']+ , "-_"+ ]