packages feed

shakespeare-css (empty) → 0.10.0

raw patch · 7 files changed

+825/−0 lines, 7 filesdep +HUnitdep +basedep +hspecsetup-changed

Dependencies added: HUnit, base, hspec, parsec, process, shakespeare, shakespeare-css, template-haskell, text

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, 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:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* 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.++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.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMain
+ Text/Cassius.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Cassius+    ( -- * Datatypes+      Css+    , CssUrl+      -- * Type class+    , ToCss (..)+      -- * Rendering+    , renderCss+    , renderCssUrl+      -- * Parsing+    , cassius+    , cassiusFile+    , cassiusFileDebug+      -- * ToCss instances+      -- ** Color+    , Color (..)+    , colorRed+    , colorBlack+      -- ** Size+    , mkSize+    , AbsoluteUnit (..)+    , AbsoluteSize (..)+    , absoluteSize+    , EmSize (..)+    , ExSize (..)+    , PercentageSize (..)+    , percentageSize+    , PixelSize (..)+    ) where++import Text.Css+import Text.MkSizeType+import Text.Shakespeare.Base+import Text.ParserCombinators.Parsec hiding (Line)+import Text.Printf (printf)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Language.Haskell.TH+import Data.Text.Lazy.Builder (fromText, fromLazyText)+import Data.Maybe (catMaybes)+import Data.Word (Word8)+import Data.Bits+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Data.Char (isSpace)++data Color = Color Word8 Word8 Word8+    deriving Show+instance ToCss Color where+    toCss (Color r g b) =+        let (r1, r2) = toHex r+            (g1, g2) = toHex g+            (b1, b2) = toHex b+         in fromText $ TS.pack $ '#' :+            if r1 == r2 && g1 == g2 && b1 == b2+                then [r1, g1, b1]+                else [r1, r2, g1, g2, b1, b2]+      where+        toHex :: Word8 -> (Char, Char)+        toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15)+        toChar :: Word8 -> Char+        toChar c+            | c < 10 = mkChar c 0 '0'+            | otherwise = mkChar c 10 'A'+        mkChar :: Word8 -> Word8 -> Char -> Char+        mkChar a b' c =+            toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c)++colorRed :: Color+colorRed = Color 255 0 0++colorBlack :: Color+colorBlack = Color 0 0 0++renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text+renderCssUrl r s = renderCss $ s r++type CssUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Css++parseBlocks :: Parser [Block]+parseBlocks = (map compressBlock . catMaybes) `fmap` many parseBlock++parseEmptyLine :: Parser ()+parseEmptyLine = do+    try $ skipMany $ oneOf " \t"+    parseComment <|> eol++parseComment :: Parser ()+parseComment = do+    _ <- try (skipMany (oneOf " \t") >> string "/*")+    _ <- manyTill anyChar $ try $ string "*/"+    -- FIXME This requires that any line beginning with a comment is entirely a comment+    skipMany $ oneOf " \t"+    _ <- eol <|> eof+    return ()++parseIndent :: Parser Int+parseIndent =+    sum `fmap` many ((char ' ' >> return 1) <|> (char '\t' >> fail "Tabs are not allowed in Cassius indentation"))++parseBlock :: Parser (Maybe Block)+parseBlock = do+    indent <- parseIndent+    (emptyBlock >> return Nothing)+        <|> (eof >> if indent > 0 then return Nothing else fail "")+        <|> realBlock indent+  where+    emptyBlock = parseEmptyLine+    realBlock indent = do+        name <- many1 $ parseContent True+        eol+        pairs <- fmap catMaybes $ many $ parsePair' indent+        case pairs of+            [] -> return Nothing+            _ -> return $ Just $ Block [name] pairs []+    parsePair' indent = try (parseEmptyLine >> return Nothing)+                    <|> try (Just `fmap` parsePair indent)++parsePair :: Int -> Parser (Contents, Contents)+parsePair minIndent = do+    indent <- parseIndent+    if indent <= minIndent then fail "not indented" else return ()+    key <- manyTill (parseContent False) $ char ':'+    spaces+    value <- manyTill (parseContent True) $ eol <|> eof+    return (trim key, value) -- FIXME consider trimming value as well++trim :: Contents -> Contents+trim =+    reverse . go . reverse . go+  where+    go [] = []+    go (ContentRaw x:xs) =+        case dropWhile isSpace x of+            [] -> go xs+            y -> ContentRaw y:xs+    go x = x+++eol :: Parser ()+eol = (char '\n' >> return ()) <|> (string "\r\n" >> return ())++parseContent :: Bool -> Parser Content+parseContent allowColon =+    parseHash' <|> parseAt' <|> parseComment' <|> parseChar+  where+    parseHash' = either ContentRaw ContentVar `fmap` parseHash+    parseAt' =+        either ContentRaw go `fmap` parseAt+      where+        go (d, False) = ContentUrl d+        go (d, True) = ContentUrlParam d+    parseChar = (ContentRaw . return) `fmap` noneOf restricted+    restricted = (if allowColon then id else (:) ':') "\r\n"+    parseComment' = do+        _ <- try $ string "/*"+        _ <- manyTill anyChar $ try $ string "*/"+        return $ ContentRaw ""++cassius :: QuasiQuoter+cassius = QuasiQuoter { quoteExp = cassiusFromString }++cassiusFromString :: String -> Q Exp+cassiusFromString s =+    topLevelsToCassius $ map TopBlock+  $ either (error . show) id $ parse parseBlocks s s++cassiusFile :: FilePath -> Q Exp+cassiusFile fp = do+    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    cassiusFromString contents++cassiusFileDebug :: FilePath -> Q Exp+cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels++parseTopLevels :: Parser [TopLevel]+parseTopLevels = do+    x <- parseBlocks+    return $ map TopBlock x++-- CSS size wrappers++-- | Create a CSS size, e.g. $(mkSize "100px").+mkSize :: String -> ExpQ+mkSize s = appE nameE valueE+  where [(value, unit)] = reads s :: [(Double, String)]+        absoluteSizeE = varE $ mkName "absoluteSize"+        nameE = case unit of+          "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter")+          "em" -> conE $ mkName "EmSize"+          "ex" -> conE $ mkName "ExSize"+          "in" -> appE absoluteSizeE (conE $ mkName "Inch")+          "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter")+          "pc" -> appE absoluteSizeE (conE $ mkName "Pica")+          "pt" -> appE absoluteSizeE (conE $ mkName "Point")+          "px" -> conE $ mkName "PixelSize"+          "%" -> varE $ mkName "percentageSize"+          _ -> error $ "In mkSize, invalid unit: " ++ unit+        valueE = litE $ rationalL (toRational value)++-- | Absolute size units.+data AbsoluteUnit = Centimeter+                  | Inch+                  | Millimeter+                  | Pica+                  | Point+                  deriving (Eq, Show)++-- | Not intended for direct use, see 'mkSize'.+data AbsoluteSize = AbsoluteSize+    { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting.+    , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters.+    }++-- | Absolute size unit convertion rate to centimeters.+absoluteUnitRate :: AbsoluteUnit -> Rational+absoluteUnitRate Centimeter = 1+absoluteUnitRate Inch = 2.54+absoluteUnitRate Millimeter = 0.1+absoluteUnitRate Pica = 12 * absoluteUnitRate Point+absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch++-- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'.+absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize+absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit)++instance Show AbsoluteSize where+  show (AbsoluteSize unit value') = printf "%f" value ++ suffix+    where value = fromRational (value' / absoluteUnitRate unit) :: Double+          suffix = case unit of+            Centimeter -> "cm"+            Inch -> "in"+            Millimeter -> "mm"+            Pica -> "pc"+            Point -> "pt"++instance Eq AbsoluteSize where+  (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2++instance Ord AbsoluteSize where+  compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2++instance Num AbsoluteSize where+  (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2)+  (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2)+  (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2)+  abs (AbsoluteSize u v) = AbsoluteSize u (abs v)+  signum (AbsoluteSize u v) = AbsoluteSize u (abs v)+  fromInteger x = AbsoluteSize Centimeter (fromInteger x)++instance Fractional AbsoluteSize where+  (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2)+  fromRational x = AbsoluteSize Centimeter (fromRational x)++instance ToCss AbsoluteSize where+  toCss = fromText . TS.pack . show++-- | Not intended for direct use, see 'mkSize'.+data PercentageSize = PercentageSize+    { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%.+    }+                    deriving (Eq, Ord)++-- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'.+percentageSize :: Rational -> PercentageSize+percentageSize value = PercentageSize (value / 100)++instance Show PercentageSize where+  show (PercentageSize value') = printf "%f" value ++ "%"+    where value = fromRational (value' * 100) :: Double++instance Num PercentageSize where+  (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2)+  (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2)+  (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2)+  abs (PercentageSize v) = PercentageSize (abs v)+  signum (PercentageSize v) = PercentageSize (abs v)+  fromInteger x = PercentageSize (fromInteger x)++instance Fractional PercentageSize where+  (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2)+  fromRational x = PercentageSize (fromRational x)++instance ToCss PercentageSize where+  toCss = fromText . TS.pack . show++-- | Converts number and unit suffix to CSS format.+showSize :: Rational -> String -> String+showSize value' unit = printf "%f" value ++ unit+  where value = fromRational value' :: Double++mkSizeType "EmSize" "em"+mkSizeType "ExSize" "ex"+mkSizeType "PixelSize" "px"
+ Text/Css.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.Css where++import Data.List (intersperse, intercalate)+import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText, fromLazyText)+import qualified Data.Text.Lazy as TL+import Data.Monoid (mconcat, mappend, mempty)+import Data.Text (Text, pack)+import Language.Haskell.TH.Syntax+import System.IO.Unsafe (unsafePerformIO)+import Text.ParserCombinators.Parsec (Parser, parse)+import Text.Shakespeare.Base+import Language.Haskell.TH++class ToCss a where+    toCss :: a -> Builder++instance ToCss [Char] where toCss = fromLazyText . TL.pack+instance ToCss Text where toCss = fromText+instance ToCss TL.Text where toCss = fromLazyText++data Css' = Css'+    { _cssSelectors :: Builder+    , _cssAttributes :: [(Builder, Builder)]+    }+data CssTop = Media String [Css'] | Css Css'++type Css = [CssTop]++data Content = ContentRaw String+             | ContentVar Deref+             | ContentUrl Deref+             | ContentUrlParam Deref+    deriving (Show, Eq)++type Contents = [Content]+type ContentPair = (Contents, Contents)++data VarType = VTPlain | VTUrl | VTUrlParam++data CDData url = CDPlain Builder+                | CDUrl url+                | CDUrlParam (url, [(Text, Text)])++cssFileDebug :: Q Exp -> Parser [TopLevel] -> FilePath -> Q Exp+cssFileDebug parseBlocks' parseBlocks fp = do+    s <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    let a = either (error . show) id $ parse parseBlocks s s+    c <- mapM vtToExp $ concatMap getVars $ concatMap go a+    cr <- [|cssRuntime|]+    parseBlocks'' <- parseBlocks'+    return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c+  where+    go :: TopLevel -> [Content] -- FIXME use blockToCss+    go (MediaBlock _ blocks) = concatMap (go . TopBlock) blocks+    go (TopBlock (Block x y z)) =+        intercalate [ContentRaw ","] x +++        concatMap go' y +++        concatMap (go . TopBlock) z+    go' (k, v) = k ++ v++combineSelectors :: Selector -> Selector -> Selector+combineSelectors a b = do+    a' <- a+    b' <- b+    return $ a' ++ ContentRaw " " : b'++cssRuntime :: Parser [TopLevel]+           -> FilePath+           -> [(Deref, CDData url)]+           -> (url -> [(Text, Text)] -> Text)+           -> Css+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 $ foldr ($) [] $ map goTop a+  where+    goTop :: TopLevel -> Css -> Css+    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)++vtToExp :: (Deref, VarType) -> Q Exp+vtToExp (d, vt) = do+    d' <- lift d+    c' <- c vt+    return $ TupE [d', c' `AppE` derefToExp [] d]+  where+    c :: VarType -> Q Exp+    c VTPlain = [|CDPlain . toCss|]+    c VTUrl = [|CDUrl|]+    c VTUrlParam = [|CDUrlParam|]++getVars :: Content -> [(Deref, VarType)]+getVars ContentRaw{} = []+getVars (ContentVar d) = [(d, VTPlain)]+getVars (ContentUrl d) = [(d, VTUrl)]+getVars (ContentUrlParam d) = [(d, VTUrlParam)]++data Block = Block Selector Pairs [Block]++data TopLevel = TopBlock Block | MediaBlock String [Block]++type Pairs = [Pair]++type Pair = (Contents, Contents)++type Selector = [Contents]++compressTopLevel :: TopLevel -> TopLevel+compressTopLevel (TopBlock b) = TopBlock $ compressBlock b+compressTopLevel (MediaBlock s b) = MediaBlock s $ map compressBlock b++compressBlock :: Block -> Block+compressBlock (Block x y blocks) =+    Block (map cc x) (map go y) (map compressBlock blocks)+  where+    go (k, v) = (cc k, cc v)+    cc [] = []+    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))+      . foldr (.) id $(listE $ map subGo subblocks)+    |]+  where+    go (x, y) = tupE [contentsToBuilder r x, contentsToBuilder r y]+    subGo (Block sel' b c) =+        blockToCss r $ Block sel'' b c+      where+        sel'' = combineSelectors sel sel'++selectorToBuilder :: Name -> Selector -> Q Exp+selectorToBuilder r sels =+    contentsToBuilder r $ intercalate [ContentRaw ","] sels++contentsToBuilder :: Name -> [Content] -> Q Exp+contentsToBuilder r contents =+    appE [|mconcat|] $ listE $ map (contentToBuilder r) contents++contentToBuilder :: Name -> Content -> Q Exp+contentToBuilder _ (ContentRaw x) =+    [|fromText . pack|] `appE` litE (StringL x)+contentToBuilder _ (ContentVar d) =+    [|toCss|] `appE` return (derefToExp [] d)+contentToBuilder r (ContentUrl u) =+    [|fromText|] `appE`+        (varE r `appE` return (derefToExp [] u) `appE` listE [])+contentToBuilder r (ContentUrlParam u) =+    [|fromText|] `appE`+        ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))++topLevelsToCassius :: [TopLevel] -> Q Exp+topLevelsToCassius a = do+    r <- newName "_render"+    lamE [varP r] $ appE [|foldr ($) []|] $ listE $ map (go r) a+  where+    go r (TopBlock b) = [|(++) $ map Css ($(blockToCss r b) [])|]+    go r (MediaBlock s b) = [|(:) $ Media $(lift s) $(blocksToCassius r b)|]++blocksToCassius :: Name -> [Block] -> Q Exp+blocksToCassius r a = do+    appE [|foldr ($) []|] $ listE $ map (blockToCss r) a++renderCss :: Css -> TL.Text+renderCss =+    toLazyText . mconcat . map go -- FIXME use a foldr+  where+    go (Css x) = renderCss' x+    go (Media s x) =+        fromText (pack "@media ") `mappend`+        fromText (pack s) `mappend`+        singleton '{' `mappend`+        foldr mappend (singleton '}') (map renderCss' x)++renderCss' :: Css' -> Builder+renderCss' (Css' _x []) = mempty+renderCss' (Css' x y) =+    x+    `mappend` singleton '{'+    `mappend` mconcat (intersperse (singleton ';') $ map go' y)+    `mappend` singleton '}'+  where+    go' (k, v) = k `mappend` singleton ':' `mappend` v
+ Text/Lucius.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Lucius+    ( -- * Parsing+      lucius+    , luciusFile+    , luciusFileDebug+      -- * Re-export cassius+    , module Text.Cassius+    ) where++import Text.Cassius hiding (cassius, cassiusFile, cassiusFileDebug)+import Text.Shakespeare.Base+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import qualified Text.Cassius as C+import Text.ParserCombinators.Parsec hiding (Line)+import Text.Css+import Data.Char (isSpace)+import Control.Applicative ((<$>))+import Data.Either (partitionEithers)++-- |+--+-- >>> renderLucius undefined [lucius|foo{bar:baz}|]+-- "foo{bar:baz}"+lucius :: QuasiQuoter+lucius = QuasiQuoter { quoteExp = luciusFromString }++luciusFromString :: String -> Q Exp+luciusFromString s =+    topLevelsToCassius+  $ either (error . show) id $ parse parseTopLevels s s++whiteSpace :: Parser ()+whiteSpace = many+    ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))+    >> return () -- FIXME comments, don't use many++parseBlock :: Parser Block+parseBlock = do+    sel <- parseSelector+    _ <- char '{'+    whiteSpace+    pairsBlocks <- parsePairsBlocks id+    let (pairs, blocks) = partitionEithers pairsBlocks+    whiteSpace+    return $ Block sel pairs blocks++parseSelector :: Parser Selector+parseSelector =+    go id+  where+    go front = do+        c <- parseContents "{,"+        let front' = front . (:) (trim c)+        (char ',' >> go front') <|> return (front' [])++trim :: Contents -> Contents+trim =+    reverse . trim' False . reverse . trim' True+  where+    trim' _ [] = []+    trim' b (ContentRaw s:rest) =+        let s' = trimS b s+         in if null s' then trim' b rest else ContentRaw s' : rest+    trim' _ x = x+    trimS True = dropWhile isSpace+    trimS False = reverse . dropWhile isSpace . reverse++type PairBlock = Either Pair Block+parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]+parsePairsBlocks front = (char '}' >> return (front [])) <|> (do+    isBlock <- lookAhead checkIfBlock+    x <- if isBlock+            then (do+                b <- parseBlock+                whiteSpace+                return $ Right b)+            else Left <$> parsePair+    parsePairsBlocks $ front . (:) x)+  where+    checkIfBlock = do+        skipMany $ noneOf "#@{};"+        (parseHash >> checkIfBlock)+            <|> (parseAt >> checkIfBlock)+            <|> (char '{' >> return True)+            <|> (oneOf ";}" >> return False)+            <|> (anyChar >> checkIfBlock)+            <|> fail "checkIfBlock"++parsePair :: Parser Pair+parsePair = do+    key <- parseContents ":"+    _ <- char ':'+    whiteSpace+    val <- parseContents ";}"+    (char ';' >> return ()) <|> return ()+    whiteSpace+    return (key, val)++parseContents :: String -> Parser Contents+parseContents = many1 . parseContent++parseContent :: String -> Parser Content+parseContent restricted =+    parseHash' <|> parseAt' <|> parseComment <|> parseChar+  where+    parseHash' = either ContentRaw ContentVar `fmap` parseHash+    parseAt' =+        either ContentRaw go `fmap` parseAt+      where+        go (d, False) = ContentUrl d+        go (d, True) = ContentUrlParam d+    parseChar = (ContentRaw . return) `fmap` noneOf restricted++parseComment :: Parser Content+parseComment = do+    _ <- try $ string "/*"+    _ <- manyTill anyChar $ try $ string "*/"+    return $ ContentRaw ""++luciusFile :: FilePath -> Q Exp+luciusFile fp = do+    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    luciusFromString contents++luciusFileDebug :: FilePath -> Q Exp+luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels++parseTopLevels :: Parser [TopLevel]+parseTopLevels =+    go id+  where+    go front = do+        whiteSpace+        ((media <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))+            <|> (return $ map compressTopLevel $ front [])+    media = do+        try $ string "@media "+        name <- many1 $ noneOf "{"+        _ <- char '{'+        b <- parseBlocks id+        return $ MediaBlock name b+    parseBlocks front = do+        whiteSpace+        (char '}' >> return (map compressBlock $ front []))+            <|> (parseBlock >>= \x -> parseBlocks (front . (:) x))
+ Text/MkSizeType.hs view
@@ -0,0 +1,73 @@+-- | Internal functions to generate CSS size wrapper types.+module Text.MkSizeType (mkSizeType) where++import Language.Haskell.TH.Syntax++mkSizeType :: String -> String -> Q [Dec]+mkSizeType name' unit = return [ dataDec name+                               , showInstanceDec name unit+                               , numInstanceDec name+                               , fractionalInstanceDec name+                               , toCssInstanceDec name ]+  where name = mkName $ name'++dataDec :: Name -> Dec+dataDec name = DataD [] name [] [constructor] derives+  where constructor = NormalC name [(NotStrict, ConT $ mkName "Rational")]+        derives = map mkName ["Eq", "Ord"]++showInstanceDec :: Name -> String -> Dec+showInstanceDec name unit' = InstanceD [] (instanceType "Show" name) [showDec]+  where showSize = VarE $ mkName "showSize"+        x = mkName "x"+        unit = LitE $ StringL unit'+        showDec = FunD (mkName "show") [Clause [showPat] showBody []]+        showPat = ConP name [VarP x]+        showBody = NormalB $ AppE (AppE showSize $ VarE x) unit++numInstanceDec :: Name -> Dec+numInstanceDec name = InstanceD [] (instanceType "Num" name) decs+  where decs = map (binaryFunDec name) ["+", "*", "-"] +++               map (unariFunDec1 name) ["abs", "signum"] +++               [unariFunDec2 name "fromInteger"]++fractionalInstanceDec :: Name -> Dec+fractionalInstanceDec name = InstanceD [] (instanceType "Fractional" name) decs+  where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"]++toCssInstanceDec :: Name -> Dec+toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec]+  where toCssDec = FunD (mkName "toCss") [Clause [] showBody []]+        showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show')+        -- FIXME this whole section makes me a little nervous+        from = VarE (mkName "fromLazyText")+        pack = VarE (mkName "TL.pack")+        dot = VarE (mkName ".")+        show' = VarE (mkName "show")++instanceType :: String -> Name -> Type+instanceType className name = AppT (ConT $ mkName className) (ConT name)++binaryFunDec :: Name -> String -> Dec+binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []]+  where pat1 = ConP name [VarP v1]+        pat2 = ConP name [VarP v2]+        body = NormalB $ AppE (ConE name) result+        result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2)+        fun = mkName fun'+        v1 = mkName "v1"+        v2 = mkName "v2"++unariFunDec1 :: Name -> String -> Dec+unariFunDec1 name fun' = FunD fun [Clause [pat] body []]+  where pat = ConP name [VarP v]+        body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v))+        fun = mkName fun'+        v = mkName "v"++unariFunDec2 :: Name -> String -> Dec+unariFunDec2 name fun' = FunD fun [Clause [pat] body []]+  where pat = VarP x+        body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x))+        fun = mkName fun'+        x = mkName "x"
+ shakespeare-css.cabal view
@@ -0,0 +1,52 @@+name:            shakespeare-css+version:         0.10.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+synopsis:        Stick your haskell variables into css at compile time.+description:+    .+    Shakespeare is a template family for type-safe, efficient templates with simple variable interpolation . Shakespeare templates can be used inline with a quasi-quoter or in an external file. Shakespeare interpolates variables according to the type being inserted.+    In this case, the variable type needs a ToCss instance.+    .+    This package contains 2 css template languages. The Cassius language uses whitespace to avoid the need for closing brackets and semi-colons. Lucius does not care about whitespace and is a strict superset of css. There are also some significant conveniences added for css.+    .+    Please see http://docs.yesodweb.com/book/templates for a more thorough description and examples+category:        Web, Yesod+stability:       Stable+cabal-version:   >= 1.8+build-type:      Simple+homepage:        http://www.yesodweb.com/book/templates++library+    build-depends:   base             >= 4       && < 5+                   , shakespeare      >= 0.10    && < 0.11+                   , template-haskell+                   , text             >= 0.7     && < 0.12+                   , process          >= 1.0     && < 1.2+                   , parsec           >= 2       && < 4++    exposed-modules: Text.Cassius+                     Text.Lucius+    other-modules:   Text.MkSizeType+                     Text.Css+    ghc-options:     -Wall++test-suite test+    hs-source-dirs: test+    main-is: main.hs+    type: exitcode-stdio-1.0++    ghc-options:   -Wall+    build-depends: shakespeare-css  >= 0.10    && < 0.11+                 , shakespeare      >= 0.10    && < 0.11+                 , base             >= 4       && < 5+                 , HUnit+                 , hspec >= 0.6.1 && < 0.7+                 , text             >= 0.7     && < 0.12+++source-repository head+  type:     git+  location: git://github.com/yesodweb/hamlet.git