shakespeare-css 0.10.5 → 0.10.6
raw patch · 4 files changed
+137/−37 lines, 4 files
Files
- Text/Css.hs +29/−21
- Text/Lucius.hs +59/−14
- shakespeare-css.cabal +1/−1
- test/ShakespeareCssTest.hs +48/−1
Text/Css.hs view
@@ -29,7 +29,7 @@ { _cssSelectors :: Builder , _cssAttributes :: [(Builder, Builder)] }-data CssTop = Media String [Css'] | Css Css' | Charset String+data CssTop = AtBlock String String [Css'] | Css Css' | AtDecl String String type Css = [CssTop] @@ -62,16 +62,17 @@ where go :: [TopLevel] -> ([(String, String)], [Content]) go [] = ([], [])- go (TopCharset cs:rest) =+ go (TopAtDecl dec cs:rest) = (scope, rest'') where (scope, rest') = go rest- rest'' =- ContentRaw "@charset "- : ContentRaw cs- : ContentRaw ";"- : rest'- go (MediaBlock _ blocks:rest) =+ rest'' = ContentRaw (concat+ [ "@"+ , dec+ , cs+ , ";"+ ]) : rest'+ go (TopAtBlock _ _ blocks:rest) = (scope1 ++ scope2, rest1 ++ rest2) where (scope1, rest1) = go (map TopBlock blocks)@@ -146,12 +147,12 @@ where goTop :: [(String, String)] -> [TopLevel] -> Css goTop _ [] = []- goTop scope (TopCharset cs:rest) = Charset cs : goTop scope rest+ goTop scope (TopAtDecl dec cs:rest) = AtDecl dec cs : goTop scope rest goTop scope (TopBlock b:rest) = map Css (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ goTop scope rest- goTop scope (MediaBlock s b:rest) =- Media s (foldr (either error id . blockRuntime (addScope scope) render') [] b) :+ goTop scope (TopAtBlock name s b:rest) =+ AtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : goTop scope rest goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest @@ -192,7 +193,14 @@ data Block = Block Selector Pairs [Block] -data TopLevel = TopBlock Block | MediaBlock String [Block] | TopCharset String | TopVar String String+data TopLevel = TopBlock Block+ | TopAtBlock+ { _atBlockName :: String+ , _atBlockSelector :: String+ , _atBlockInner :: [Block]+ }+ | TopAtDecl String String+ | TopVar String String type Pairs = [Pair] @@ -202,8 +210,8 @@ compressTopLevel :: TopLevel -> TopLevel compressTopLevel (TopBlock b) = TopBlock $ compressBlock b-compressTopLevel (MediaBlock s b) = MediaBlock s $ map compressBlock b-compressTopLevel x@TopCharset{} = x+compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b+compressTopLevel x@TopAtDecl{} = x compressTopLevel x@TopVar{} = x compressBlock :: Block -> Block@@ -262,12 +270,12 @@ e <- [|(++) $ map Css ($(blockToCss r scope b) [])|] es <- go r scope rest return $ e : es- go r scope (MediaBlock s b:rest) = do- e <- [|(:) $ Media $(lift s) $(blocksToCassius r scope b)|]+ go r scope (TopAtBlock name s b:rest) = do+ e <- [|(:) $ AtBlock $(lift name) $(lift s) $(blocksToCassius r scope b)|] es <- go r scope rest return $ e : es- go r scope (TopCharset cs:rest) = do- e <- [|(:) $ Charset $(lift cs)|]+ go r scope (TopAtDecl dec cs:rest) = do+ e <- [|(:) $ AtDecl $(lift dec) $(lift cs)|] es <- go r scope rest return $ e : es go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest@@ -281,12 +289,12 @@ toLazyText . mconcat . map go -- FIXME use a foldr where go (Css x) = renderCss' x- go (Media s x) =- fromText (pack "@media ") `mappend`+ go (AtBlock name s x) =+ fromText (pack $ concat ["@", name, " "]) `mappend` fromText (pack s) `mappend` singleton '{' `mappend` foldr mappend (singleton '}') (map renderCss' x)- go (Charset cs) = fromText (pack "@charset ") `mappend`+ go (AtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` fromText (pack cs) `mappend` singleton ';'
Text/Lucius.hs view
@@ -25,8 +25,10 @@ import qualified Data.Text.Lazy as TL import Text.ParserCombinators.Parsec hiding (Line) import Text.Css-import Data.Char (isSpace)+import Data.Char (isSpace, toLower, toUpper)+import Numeric (readHex) import Control.Applicative ((<$>))+import Control.Monad (when) import Data.Either (partitionEithers) import Data.Text.Lazy.Builder (fromText) @@ -43,9 +45,11 @@ $ either (error . show) id $ parse parseTopLevels s s whiteSpace :: Parser ()-whiteSpace = many+whiteSpace = many whiteSpace1 >> return ()++whiteSpace1 :: Parser ()+whiteSpace1 = ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))- >> return () -- FIXME comments, don't use many parseBlock :: Parser Block parseBlock = do@@ -114,7 +118,7 @@ parseContent :: String -> Parser Content parseContent restricted =- parseHash' <|> parseAt' <|> parseComment <|> parseChar+ parseHash' <|> parseAt' <|> parseComment <|> parseBack <|> parseChar where parseHash' = either ContentRaw ContentVar `fmap` parseHash parseAt' =@@ -122,8 +126,28 @@ where go (d, False) = ContentUrl d go (d, True) = ContentUrlParam d+ parseBack = try $ do+ _ <- char '\\'+ hex <- atMost 6 $ satisfy isHex+ (int, _):_ <- return $ readHex $ dropWhile (== '0') hex+ when (length hex < 6) $+ ((string "\r\n" >> return ()) <|> (satisfy isSpace >> return ()))+ return $ ContentRaw [toEnum int] parseChar = (ContentRaw . return) `fmap` noneOf restricted +isHex :: Char -> Bool+isHex c =+ ('0' <= c && c <= '9') ||+ ('A' <= c && c <= 'F') ||+ ('a' <= c && c <= 'f')++atMost :: Int -> Parser a -> Parser [a]+atMost 0 _ = return []+atMost i p = (do+ c <- p+ s <- atMost (i - 1) p+ return $ c : s) <|> return []+ parseComment :: Parser Content parseComment = do _ <- try $ string "/*"@@ -144,22 +168,36 @@ go id where go front = do- whiteSpace- ((charset <|> media <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))+ let string' s = string s >> return ()+ ignore = many (whiteSpace1 <|> string' "<!--" <|> string' "-->")+ >> return ()+ ignore+ tl <- ((charset <|> media <|> impor <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x)) <|> (return $ map compressTopLevel $ front [])+ ignore+ return tl charset = do- _ <- try $ string "@charset "+ try $ stringCI "@charset " cs <- many1 $ noneOf ";" _ <- char ';'- return $ TopCharset cs+ return $ TopAtDecl "charset" cs media = do- _ <- try $ string "@media "+ try $ stringCI "@media " name <- many1 $ noneOf "{" _ <- char '{' b <- parseBlocks id- return $ MediaBlock name b+ return $ TopAtBlock "media" (strip name) b+ impor = do+ try $ stringCI "@import ";+ val <- many1 $ noneOf ";";+ _ <- char ';'+ return $ TopAtDecl "import" val var = try $ do _ <- char '@'+ isPage <- (try $ string "page " >> return True) <|>+ (try $ string "font-face " >> return True) <|>+ return False+ when isPage $ fail "page is not a variable" k <- many1 $ noneOf ":" _ <- char ':' v <- many1 $ noneOf ";"@@ -171,6 +209,13 @@ (char '}' >> return (map compressBlock $ front [])) <|> (parseBlock >>= \x -> parseBlocks (front . (:) x)) +strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++stringCI :: String -> Parser ()+stringCI [] = return ()+stringCI (c:cs) = (char (toLower c) <|> char (toUpper c)) >> stringCI cs+ luciusRT' :: TL.Text -> Either String ([(Text, Text)] -> Either String Css) luciusRT' tl = case parse parseTopLevels (TL.unpack tl) (TL.unpack tl) of@@ -179,17 +224,17 @@ where go :: [(Text, Text)] -> [TopLevel] -> Either String Css go _ [] = Right []- go scope (TopCharset cs:rest) = do+ go scope (TopAtDecl dec cs:rest) = do rest' <- go scope rest- Right $ Charset cs : rest'+ Right $ AtDecl dec cs : rest' go scope (TopBlock b:rest) = do b' <- goBlock scope b rest' <- go scope rest Right $ map Css b' ++ rest'- go scope (MediaBlock m bs:rest) = do+ go scope (TopAtBlock name m bs:rest) = do bs' <- mapM (goBlock scope) bs rest' <- go scope rest- Right $ Media m (concat bs') : rest'+ Right $ AtBlock name m (concat bs') : rest' go scope (TopVar k v:rest) = go ((pack k, pack v):scope) rest goBlock :: [(Text, Text)] -> Block -> Either String [Css']
shakespeare-css.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-css-version: 0.10.5+version: 0.10.6 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/ShakespeareCssTest.hs view
@@ -284,9 +284,56 @@ bar: #{myvar}; } |] - + , it "lucius CDO/CDC tokens" $ + celper "*{a:b}" [lucius| +<!-- --> <!-- +* { + a: b; +} +--> +|] + , it "lucius @import statements" $ + celper "@import url(\"bla.css\");" [lucius| +@import url("bla.css"); +|] + , it "lucius simple escapes" $ + celper "*{a:test}" [lucius| +* { + a: t\65 st; +} +|] + , it "lucius bounded escapes" $ + celper "*{a:teft}" [lucius| +* { + a: t\000065ft; +} +|] + , it "lucius case-insensitive keywords" $ + celper "@media foo{}" [lucius| +@MeDIa foo { +} +|] + , it "lucius @page statements" $ + celper "@page :right{a:b;c:d}" [lucius| +@page :right { +a:b; +c:d; +} +|] + , it "lucius @font-face statements" $ + celper "@font-face{a:b;c:d}" [lucius| +@font-face { +a:b; +c:d; +} +|] , it "lucius runtime" $ Right (T.pack "foo{bar:baz}") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] , it "lucius runtime variables" $ Right (T.pack "foo{bar:baz}") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] + , it "variables inside value" $ + celper "foo{foo:XbarY}" [lucius| +@bar: bar; +foo { foo:X#{bar}Y; } +|] ] data Url = Home | Sub SubUrl