packages feed

shakespeare-css 0.10.3 → 0.10.4

raw patch · 4 files changed

+146/−56 lines, 4 files

Files

Text/Css.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} module Text.Css where @@ -12,8 +13,9 @@ import Language.Haskell.TH.Syntax import System.IO.Unsafe (unsafePerformIO) import Text.ParserCombinators.Parsec (Parser, parse)-import Text.Shakespeare.Base+import Text.Shakespeare.Base hiding (Scope) import Language.Haskell.TH+import Control.Applicative ((<$>), (<*>))  class ToCss a where     toCss :: a -> Builder@@ -61,6 +63,7 @@         intercalate [ContentRaw ","] x ++         concatMap go' y ++         concatMap (go . TopBlock) z+    go TopVar{} = error "FIXME cssFileDebug does not support TopVar"     go' (k, v) = k ++ v  combineSelectors :: Selector -> Selector -> Selector@@ -69,6 +72,46 @@     b' <- b     return $ a' ++ ContentRaw " " : b' +blockRuntime :: [(Deref, CDData url)]+             -> (url -> [(Text, Text)] -> Text)+             -> Block+             -> Either String ([Css'] -> [Css'])+-- FIXME share code with blockToCss+blockRuntime cd render' (Block x y z) = do+    x' <- mapM go' $ intercalate [ContentRaw ","] x+    y' <- mapM go'' y+    z' <- mapM (subGo x) z -- FIXME use difflists again+    Right $ \rest -> Css' (mconcat x') y' : foldr ($) rest z'+    {-+    (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))+    . foldr (.) id (map (subGo x) z)+    -}+  where+    go' :: Content -> Either String Builder+    go' (ContentRaw s) = Right $ fromText $ pack s+    go' (ContentVar d) =+        case lookup d cd of+            Just (CDPlain s) -> Right s+            _ -> Left $ show d ++ ": expected CDPlain"+    go' (ContentUrl d) =+        case lookup d cd of+            Just (CDUrl u) -> Right $ fromText $ render' u []+            _ -> Left $ show d ++ ": expected CDUrl"+    go' (ContentUrlParam d) =+        case lookup d cd of+            Just (CDUrlParam (u, p)) ->+                Right $ fromText $ render' u p+            _ -> Left $ show d ++ ": expected CDUrlParam"++    go'' :: ([Content], [Content]) -> Either String (Builder, Builder)+    go'' (k, v) = (,) <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v)++    subGo :: Selector -> Block -> Either String ([Css'] -> [Css'])+    subGo x' (Block a b c) =+        blockRuntime cd render' (Block a' b c)+      where+        a' = combineSelectors x' a+ cssRuntime :: Parser [TopLevel]            -> FilePath            -> [(Deref, CDData url)]@@ -81,34 +124,9 @@   where     goTop :: TopLevel -> Css -> Css     goTop (TopCharset cs) x = Charset cs : x-    goTop (TopBlock b) x = map Css (go b []) ++ x-    goTop (MediaBlock s b) x = Media s (foldr go [] b) : x-    go :: Block -> [Css'] -> [Css']-    -- FIXME share code with blockToCss-    go (Block x y z) =-        (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))-        . foldr (.) id (map (subGo x) z)-    subGo :: Selector -> Block -> [Css'] -> [Css']-    subGo x (Block a b c) =-        go (Block a' b c)-      where-        a' = combineSelectors x a-    go' :: Content -> Builder-    go' (ContentRaw s) = fromText $ pack s-    go' (ContentVar d) =-        case lookup d cd of-            Just (CDPlain s) -> s-            _ -> error $ show d ++ ": expected CDPlain"-    go' (ContentUrl d) =-        case lookup d cd of-            Just (CDUrl u) -> fromText $ render' u []-            _ -> error $ show d ++ ": expected CDUrl"-    go' (ContentUrlParam d) =-        case lookup d cd of-            Just (CDUrlParam (u, p)) ->-                fromText $ render' u p-            _ -> error $ show d ++ ": expected CDUrlParam"-    go'' (k, v) = (mconcat $ map go' k, mconcat $ map go' v)+    goTop (TopBlock b) x = map Css (either error ($[]) $ blockRuntime cd render' b) ++ x+    goTop TopVar{} _ = error "FIXME cssRuntime does not support TopVar"+    goTop (MediaBlock s b) x = Media s (foldr (either error id . blockRuntime cd render') [] b) : x  vtToExp :: (Deref, VarType) -> Q Exp vtToExp (d, vt) = do@@ -129,7 +147,7 @@  data Block = Block Selector Pairs [Block] -data TopLevel = TopBlock Block | MediaBlock String [Block] | TopCharset String+data TopLevel = TopBlock Block | MediaBlock String [Block] | TopCharset String | TopVar String String  type Pairs = [Pair] @@ -141,6 +159,7 @@ compressTopLevel (TopBlock b) = TopBlock $ compressBlock b compressTopLevel (MediaBlock s b) = MediaBlock s $ map compressBlock b compressTopLevel x@TopCharset{} = x+compressTopLevel x@TopVar{} = x  compressBlock :: Block -> Block compressBlock (Block x y blocks) =@@ -151,50 +170,66 @@     cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c     cc (a:b) = a : cc b -blockToCss :: Name -> Block -> Q Exp-blockToCss r (Block sel props subblocks) =-    [|(:) (Css' $(selectorToBuilder r sel) $(listE $ map go props))+blockToCss :: Name -> Scope -> Block -> Q Exp+blockToCss r scope (Block sel props subblocks) =+    [|(:) (Css' $(selectorToBuilder r scope sel) $(listE $ map go props))       . foldr (.) id $(listE $ map subGo subblocks)     |]   where-    go (x, y) = tupE [contentsToBuilder r x, contentsToBuilder r y]+    go (x, y) = tupE [contentsToBuilder r scope x, contentsToBuilder r scope y]     subGo (Block sel' b c) =-        blockToCss r $ Block sel'' b c+        blockToCss r scope $ Block sel'' b c       where         sel'' = combineSelectors sel sel' -selectorToBuilder :: Name -> Selector -> Q Exp-selectorToBuilder r sels =-    contentsToBuilder r $ intercalate [ContentRaw ","] sels+selectorToBuilder :: Name -> Scope -> Selector -> Q Exp+selectorToBuilder r scope sels =+    contentsToBuilder r scope $ intercalate [ContentRaw ","] sels -contentsToBuilder :: Name -> [Content] -> Q Exp-contentsToBuilder r contents =-    appE [|mconcat|] $ listE $ map (contentToBuilder r) contents+contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp+contentsToBuilder r scope contents =+    appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents -contentToBuilder :: Name -> Content -> Q Exp-contentToBuilder _ (ContentRaw x) =+contentToBuilder :: Name -> Scope -> Content -> Q Exp+contentToBuilder _ _ (ContentRaw x) =     [|fromText . pack|] `appE` litE (StringL x)-contentToBuilder _ (ContentVar d) =-    [|toCss|] `appE` return (derefToExp [] d)-contentToBuilder r (ContentUrl u) =+contentToBuilder _ scope (ContentVar d) =+    case d of+        DerefIdent (Ident s)+            | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val)+        _ -> [|toCss|] `appE` return (derefToExp [] d)+contentToBuilder r _ (ContentUrl u) =     [|fromText|] `appE`         (varE r `appE` return (derefToExp [] u) `appE` listE [])-contentToBuilder r (ContentUrlParam u) =+contentToBuilder r _ (ContentUrlParam u) =     [|fromText|] `appE`         ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u)) +type Scope = [(String, String)]+ topLevelsToCassius :: [TopLevel] -> Q Exp topLevelsToCassius a = do     r <- newName "_render"-    lamE [varP r] $ appE [|foldr ($) []|] $ listE $ map (go r) a+    lamE [varP r] $ appE [|foldr ($) []|] $ fmap ListE $ go r [] a   where-    go r (TopBlock b) = [|(++) $ map Css ($(blockToCss r b) [])|]-    go r (MediaBlock s b) = [|(:) $ Media $(lift s) $(blocksToCassius r b)|]-    go r (TopCharset cs) = [|(:) $ Charset $(lift cs)|]+    go _ _ [] = return []+    go r scope (TopBlock b:rest) = do+        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)|]+        es <- go r scope rest+        return $ e : es+    go r scope (TopCharset cs:rest) = do+        e <- [|(:) $ Charset $(lift cs)|]+        es <- go r scope rest+        return $ e : es+    go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest -blocksToCassius :: Name -> [Block] -> Q Exp-blocksToCassius r a = do-    appE [|foldr ($) []|] $ listE $ map (blockToCss r) a+blocksToCassius :: Name -> Scope -> [Block] -> Q Exp+blocksToCassius r scope a = do+    appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a  renderCss :: Css -> TL.Text renderCss =
Text/Lucius.hs view
@@ -9,6 +9,9 @@       lucius     , luciusFile     , luciusFileDebug+      -- ** Runtime+    , luciusRT+    , luciusRT'       -- * Re-export cassius     , module Text.Cassius     ) where@@ -17,12 +20,14 @@ import Text.Shakespeare.Base import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax+import Data.Text (Text, pack, unpack) import qualified Data.Text.Lazy as TL import Text.ParserCombinators.Parsec hiding (Line) import Text.Css import Data.Char (isSpace) import Control.Applicative ((<$>)) import Data.Either (partitionEithers)+import Data.Text.Lazy.Builder (fromText)  -- | --@@ -138,7 +143,7 @@   where     go front = do         whiteSpace-        ((charset <|> media <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))+        ((charset <|> media <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))             <|> (return $ map compressTopLevel $ front [])     charset = do         _ <- try $ string "@charset "@@ -151,7 +156,46 @@         _ <- char '{'         b <- parseBlocks id         return $ MediaBlock name b+    var = try $ do+        _ <- char '@'+        k <- many1 $ noneOf ":"+        _ <- char ':'+        v <- many1 $ noneOf ";"+        _ <- char ';'+        let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace+        return $ TopVar (trimS k) (trimS v)     parseBlocks front = do         whiteSpace         (char '}' >> return (map compressBlock $ front []))             <|> (parseBlock >>= \x -> parseBlocks (front . (:) x))++luciusRT' :: TL.Text -> Either String ([(Text, Text)] -> Either String Css)+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 _ [] = Right []+    go scope (TopCharset cs:rest) = do+        rest' <- go scope rest+        Right $ Charset 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+        bs' <- mapM (goBlock scope) bs+        rest' <- go scope rest+        Right $ Media m (concat bs') : rest'+    go scope (TopVar k v:rest) = go ((pack k, pack v):scope) rest++    goBlock :: [(Text, Text)] -> Block -> Either String [Css']+    goBlock scope =+        either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs")+      where+        scope' = map goScope scope+        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)
shakespeare-css.cabal view
@@ -1,5 +1,5 @@ name:            shakespeare-css-version:         0.10.3+version:         0.10.4 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>
test/ShakespeareCssTest.hs view
@@ -11,6 +11,7 @@ import Text.Lucius
 import Data.List (intercalate)
 import qualified Data.Text.Lazy as T
+import qualified Data.Text as TS
 import qualified Data.List
 import qualified Data.List as L
 import Data.Text (Text, pack, unpack)
@@ -276,6 +277,16 @@ 
   , it "lucius trailing comments" $
       celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|]
+
+  , it "lucius variables" $ celper "foo{bar:baz}" [lucius|
+@myvar: baz;
+foo {
+    bar: #{myvar};
+}
+|]
+
+  , 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}}") []
   ]
 
 data Url = Home | Sub SubUrl