css-text-0.1.2.2/0000755000000000000000000000000012737473211011621 5ustar0000000000000000css-text-0.1.2.2/ChangeLog.md0000644000000000000000000000004512737473211013771 0ustar0000000000000000## 0.1.2.2 * Clarified MIT license css-text-0.1.2.2/css-text.cabal0000644000000000000000000000226312737473211014362 0ustar0000000000000000name: css-text version: 0.1.2.2 license: MIT 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 README.md ChangeLog.md 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 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 source-repository head type: git location: https://github.com/yesodweb/css-text.git css-text-0.1.2.2/LICENSE0000644000000000000000000000207512737473211012632 0ustar0000000000000000Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ 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: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. css-text-0.1.2.2/README.md0000644000000000000000000000002512737473211013075 0ustar0000000000000000a haskell css parser css-text-0.1.2.2/runtests.hs0000644000000000000000000000663312737473211014054 0ustar0000000000000000{-# 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'] , "-_" ] css-text-0.1.2.2/Setup.lhs0000644000000000000000000000016212737473211013430 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain css-text-0.1.2.2/Text/0000755000000000000000000000000012737473211012545 5ustar0000000000000000css-text-0.1.2.2/Text/CSS/0000755000000000000000000000000012737473211013175 5ustar0000000000000000css-text-0.1.2.2/Text/CSS/Parse.hs0000644000000000000000000000673012737473211014611 0ustar0000000000000000{-# 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 css-text-0.1.2.2/Text/CSS/Render.hs0000644000000000000000000000247212737473211014755 0ustar0000000000000000{-# 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