shakespeare-css 1.0.0 → 1.0.1
raw patch · 5 files changed
+79/−37 lines, 5 files
Files
- Text/Css.hs +60/−18
- Text/Lucius.hs +3/−3
- shakespeare-css.cabal +2/−2
- test/ShakespeareCssTest.hs +13/−13
- test/cassiuses/external2.lucius +1/−1
Text/Css.hs view
@@ -41,7 +41,8 @@ } data CssTop = AtBlock String Builder [Css'] | Css Css' | AtDecl String Builder -type Css = [CssTop]+data Css = CssWhitespace [CssTop]+ | CssNoWhitespace [CssTop] data Content = ContentRaw String | ContentVar Deref@@ -161,9 +162,9 @@ cssRuntime parseBlocks fp cd render' = unsafePerformIO $ do s <- fmap TL.unpack $ qRunIO $ readUtf8File fp let a = either (error . show) id $ parse parseBlocks s s- return $ goTop [] a+ return $ CssWhitespace $ goTop [] a where- goTop :: [(String, String)] -> [TopLevel] -> Css+ goTop :: [(String, String)] -> [TopLevel] -> [CssTop] goTop _ [] = [] goTop scope (TopAtDecl dec cs':rest) = AtDecl dec cs : goTop scope rest@@ -287,7 +288,7 @@ topLevelsToCassius :: [TopLevel] -> Q Exp topLevelsToCassius a = do r <- newName "_render"- lamE [varP r] $ appE [|foldr ($) []|] $ fmap ListE $ go r [] a+ lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a where go _ _ [] = return [] go r scope (TopBlock b:rest) = do@@ -310,25 +311,66 @@ appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a renderCss :: Css -> TL.Text-renderCss =- toLazyText . mconcat . map go -- FIXME use a foldr+renderCss css =+ toLazyText $ mconcat $ map go tops-- FIXME use a foldr where- go (Css x) = renderCss' x+ (haveWhiteSpace, tops) =+ case css of+ CssWhitespace x -> (True, x)+ CssNoWhitespace x -> (False, x)+ go (Css x) = renderCss' haveWhiteSpace mempty x go (AtBlock name s x) = fromText (pack $ concat ["@", name, " "]) `mappend` s `mappend`- singleton '{' `mappend`- foldr mappend (singleton '}') (map renderCss' x)+ startBlock `mappend`+ foldr mappend endBlock (map (renderCss' haveWhiteSpace (fromString " ")) x) go (AtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` cs `mappend`- singleton ';'+ endDecl -renderCss' :: Css' -> Builder-renderCss' (Css' _x []) = mempty-renderCss' (Css' x y) =- x- `mappend` singleton '{'- `mappend` mconcat (intersperse (singleton ';') $ map go' y)- `mappend` singleton '}'+ startBlock+ | haveWhiteSpace = fromString " {\n"+ | otherwise = singleton '{'++ endBlock+ | haveWhiteSpace = fromString "}\n"+ | otherwise = singleton '}'++ endDecl+ | haveWhiteSpace = fromString ";\n"+ | otherwise = singleton ';'++renderCss' :: Bool -> Builder -> Css' -> Builder+renderCss' _ _ (Css' _x []) = mempty+renderCss' haveWhiteSpace indent (Css' x y) =+ startSelect+ `mappend` x+ `mappend` startBlock+ `mappend` mconcat (intersperse endDecl $ map go' y)+ `mappend` endBlock where- go' (k, v) = k `mappend` singleton ':' `mappend` v+ go' (k, v) = startDecl `mappend` k `mappend` colon `mappend` v++ colon+ | haveWhiteSpace = fromString ": "+ | otherwise = singleton ':'++ startSelect+ | haveWhiteSpace = indent+ | otherwise = mempty++ startBlock+ | haveWhiteSpace = fromString " {\n"+ | otherwise = singleton '{'++ endBlock+ | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n"+ | otherwise = singleton '}'++ startDecl+ | haveWhiteSpace = indent `mappend` fromString " "+ | otherwise = mempty++ endDecl+ | haveWhiteSpace = fromString ";\n"+ | otherwise = singleton ';'
Text/Lucius.hs view
@@ -213,13 +213,13 @@ 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.Text -> Either String ([(Text, Text)] -> Either String [CssTop]) luciusRT' tl = case parse parseTopLevels (TL.unpack tl) (TL.unpack tl) of Left s -> Left $ show s Right tops -> Right $ \scope -> go scope tops where- go :: [(Text, Text)] -> [TopLevel] -> Either String Css+ go :: [(Text, Text)] -> [TopLevel] -> Either String [CssTop] go _ [] = Right [] go scope (TopAtDecl dec cs':rest) = do let scope' = map goScope scope@@ -249,4 +249,4 @@ goScope (k, v) = (DerefIdent (Ident $ unpack k), CDPlain $ fromText v) luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text-luciusRT tl scope = either Left (Right . renderCss) $ either Left ($ scope) (luciusRT' tl)+luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl)
shakespeare-css.cabal view
@@ -1,6 +1,6 @@ name: shakespeare-css-version: 1.0.0-license: BSD3+version: 1.0.1+license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>
test/ShakespeareCssTest.hs view
@@ -27,11 +27,11 @@ let selector = "foo" let urlp = (Home, [(pack "p", pack "q")]) flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat - [ "foo{background:#000;bar:baz;color:#F00}" - , "bin{" - , "background-image:url(url);" - , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" - , "urlp:url(url?p=q)}" + [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" + , "bin {\n" + , " background-image: url(url);\n" + , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" + , " urlp: url(url?p=q);\n}\n" ] {- TODO @@ -199,16 +199,14 @@ , "urlp:url(url?p=q)}" ] -{- , it "lucius file debug" caseLuciusFileDebug - -} , it "lucius nested" $ do celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") - celper "foo bar{baz:bin}" $(luciusFileDebug "test/cassiuses/external-nested.lucius") + celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") celper "foo bar{baz:bin}" [lucius| foo { bar { @@ -253,7 +251,7 @@ , it "lucius media" $ do celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") - celper "@media only screen{foo bar{baz:bin}}" $(luciusFileDebug "test/cassiuses/external-media.lucius") + celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") celper "@media only screen{foo bar{baz:bin}}" [lucius| @media only screen{ foo { @@ -327,8 +325,10 @@ 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 "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] + , it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] + , it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") + @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] , it "variables inside value" $ celper "foo{foo:XbarY}" [lucius| @bar: bar; @@ -439,7 +439,7 @@ caseLuciusFileDebug = do let var = "var" writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" - celper "foo{var:1}" $(luciusFileDebug "test/cassiuses/external2.lucius") + celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" - celper "foo{var:2}" $(luciusFileDebug "test/cassiuses/external2.lucius") + celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
test/cassiuses/external2.lucius view
@@ -1,1 +1,1 @@-foo{#{var}: 2}+foo{#{var}: 1}