diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,20 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: +Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# css-text + +[![Build Status](https://travis-ci.org/yesodweb/css-text.svg?branch=master)](https://travis-ci.org/yesodweb/css-text) +[![Build status](https://ci.appveyor.com/api/projects/status/xss40qb97i2qspma/branch/master?svg=true)](https://ci.appveyor.com/project/snoyberg/css-text/branch/master) + +a haskell css parser diff --git a/Text/CSS/Parse.hs b/Text/CSS/Parse.hs deleted file mode 100644 --- a/Text/CSS/Parse.hs +++ /dev/null @@ -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 diff --git a/Text/CSS/Render.hs b/Text/CSS/Render.hs deleted file mode 100644 --- a/Text/CSS/Render.hs +++ /dev/null @@ -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 diff --git a/css-text.cabal b/css-text.cabal --- a/css-text.cabal +++ b/css-text.cabal @@ -1,34 +1,62 @@ -name: css-text -version: 0.1.2.1 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman , Greg Weber -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 +-- 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 +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 +maintainer: Michael Snoyman , Greg Weber +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 - location: git://github.com/yesodweb/css-text.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 diff --git a/runtests.hs b/runtests.hs deleted file mode 100644 --- a/runtests.hs +++ /dev/null @@ -1,98 +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 = (LeafBlock . unBlock) `liftM` arbitrary - -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'] - , "-_" - ] diff --git a/src/Text/CSS/Parse.hs b/src/Text/CSS/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS/Parse.hs @@ -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 diff --git a/src/Text/CSS/Render.hs b/src/Text/CSS/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS/Render.hs @@ -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 diff --git a/test/runtests.hs b/test/runtests.hs new file mode 100644 --- /dev/null +++ b/test/runtests.hs @@ -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'] + , "-_" + ]