shakespeare-css 0.10.7 → 0.10.7.1
raw patch · 14 files changed
+1093/−1077 lines, 14 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- Setup.lhs +8/−8
- Text/Cassius.hs +304/−304
- Text/Css.hs +321/−312
- Text/Lucius.hs +250/−248
- Text/MkSizeType.hs +73/−73
- shakespeare-css.cabal +63/−63
- test.hs +5/−5
- test/ShakespeareCssTest.hs +6/−1
- test/cassiuses/external-media.lucius +7/−7
- test/cassiuses/external-nested.lucius +6/−6
- test/cassiuses/external1.cassius +11/−11
- test/cassiuses/external1.lucius +13/−13
- test/cassiuses/external2.cassius +1/−1
LICENSE view
@@ -1,25 +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.+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
@@ -1,8 +1,8 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple-> import System.Cmd (system)--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain
Text/Cassius.hs view
@@ -1,304 +1,304 @@-{-# 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- , cassiusFileReload- -- * 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-#ifdef GHC_7_4- qAddDependentFile fp-#endif- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- cassiusFromString contents--cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp-cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels-cassiusFileReload = cassiusFileDebug--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"+{-# 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 + , cassiusFileReload + -- * 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 +#ifdef GHC_7_4 + qAddDependentFile fp +#endif + contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp + cassiusFromString contents + +cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp +cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels +cassiusFileReload = cassiusFileDebug + +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
@@ -1,312 +1,321 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}-module Text.Css where--import Data.List (intersperse, intercalate)-import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText, fromLazyText, fromString)-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 hiding (Scope)-import Language.Haskell.TH-import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((***))--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 = AtBlock String String [Css'] | Css Css' | AtDecl String String--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- deriving Show--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-#ifdef GHC_7_4- qAddDependentFile fp-#endif- let a = either (error . show) id $ parse parseBlocks s s- let (scope, contents) = go a- vs <- mapM (getVars scope) contents- c <- mapM vtToExp $ concat vs- cr <- [|cssRuntime|]- parseBlocks'' <- parseBlocks'- return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c- where- go :: [TopLevel] -> ([(String, String)], [Content])- go [] = ([], [])- go (TopAtDecl dec cs:rest) =- (scope, rest'')- where- (scope, rest') = go rest- rest'' = ContentRaw (concat- [ "@"- , dec- , cs- , ";"- ]) : rest'- go (TopAtBlock _ _ blocks:rest) =- (scope1 ++ scope2, rest1 ++ rest2)- where- (scope1, rest1) = go (map TopBlock blocks)- (scope2, rest2) = go rest- go (TopBlock (Block x y z):rest) =- (scope1 ++ scope2, rest0 ++ rest1 ++ rest2)- where- rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y- (scope1, rest1) = go (map TopBlock z)- (scope2, rest2) = go rest- go (TopVar k v:rest) =- ((k, v):scope, rest')- where- (scope, rest') = go rest- go' (k, v) = k ++ v--combineSelectors :: Selector -> Selector -> Selector-combineSelectors a b = do- a' <- a- 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)]- -> (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 $ goTop [] a- where- goTop :: [(String, String)] -> [TopLevel] -> Css- goTop _ [] = []- 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 (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-- addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd--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 :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]-getVars _ ContentRaw{} = return []-getVars scope (ContentVar d) =- case lookupD d scope of- Just _ -> return []- Nothing -> return [(d, VTPlain)]-getVars scope (ContentUrl d) =- case lookupD d scope of- Nothing -> return [(d, VTUrl)]- Just s -> fail $ "Expected URL for " ++ s-getVars scope (ContentUrlParam d) =- case lookupD d scope of- Nothing -> return [(d, VTUrlParam)]- Just s -> fail $ "Expected URLParam for " ++ s--lookupD :: Deref -> [(String, b)] -> Maybe String-lookupD (DerefIdent (Ident s)) scope =- case lookup s scope of- Nothing -> Nothing- Just _ -> Just s-lookupD _ _ = Nothing--data Block = Block Selector Pairs [Block]--data TopLevel = TopBlock Block- | TopAtBlock- { _atBlockName :: String- , _atBlockSelector :: String- , _atBlockInner :: [Block]- }- | TopAtDecl String String- | TopVar String String--type Pairs = [Pair]--type Pair = (Contents, Contents)--type Selector = [Contents]--compressTopLevel :: TopLevel -> TopLevel-compressTopLevel (TopBlock b) = TopBlock $ compressBlock b-compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b-compressTopLevel x@TopAtDecl{} = x-compressTopLevel x@TopVar{} = x--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 -> 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 scope x, contentsToBuilder r scope y]- subGo (Block sel' b c) =- blockToCss r scope $ Block sel'' b c- where- sel'' = combineSelectors sel sel'--selectorToBuilder :: Name -> Scope -> Selector -> Q Exp-selectorToBuilder r scope sels =- contentsToBuilder r scope $ intercalate [ContentRaw ","] sels--contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp-contentsToBuilder r scope contents =- appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents--contentToBuilder :: Name -> Scope -> Content -> Q Exp-contentToBuilder _ _ (ContentRaw x) =- [|fromText . pack|] `appE` litE (StringL x)-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) =- [|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 ($) []|] $ fmap ListE $ go r [] a- where- 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 (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 (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--blocksToCassius :: Name -> Scope -> [Block] -> Q Exp-blocksToCassius r scope a = do- appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a--renderCss :: Css -> TL.Text-renderCss =- toLazyText . mconcat . map go -- FIXME use a foldr- where- go (Css x) = renderCss' x- go (AtBlock name s x) =- fromText (pack $ concat ["@", name, " "]) `mappend`- fromText (pack s) `mappend`- singleton '{' `mappend`- foldr mappend (singleton '}') (map renderCss' x)- go (AtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend`- fromText (pack cs) `mappend`- singleton ';'--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+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} +module Text.Css where + +import Data.List (intersperse, intercalate) +import Data.Text.Lazy.Builder (Builder, fromText, singleton, toLazyText, fromLazyText, fromString) +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 hiding (Scope) +import Language.Haskell.TH +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow ((***)) + +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 = AtBlock String Builder [Css'] | Css Css' | AtDecl String String + +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 + deriving Show + +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 +#ifdef GHC_7_4 + qAddDependentFile fp +#endif + let a = either (error . show) id $ parse parseBlocks s s + let (scope, contents) = go a + vs <- mapM (getVars scope) contents + c <- mapM vtToExp $ concat vs + cr <- [|cssRuntime|] + parseBlocks'' <- parseBlocks' + return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c + where + go :: [TopLevel] -> ([(String, String)], [Content]) + go [] = ([], []) + go (TopAtDecl dec cs:rest) = + (scope, rest'') + where + (scope, rest') = go rest + rest'' = ContentRaw (concat + [ "@" + , dec + , cs + , ";" + ]) : rest' + go (TopAtBlock _ _ blocks:rest) = + (scope1 ++ scope2, rest1 ++ rest2) + where + (scope1, rest1) = go (map TopBlock blocks) + (scope2, rest2) = go rest + go (TopBlock (Block x y z):rest) = + (scope1 ++ scope2, rest0 ++ rest1 ++ rest2) + where + rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y + (scope1, rest1) = go (map TopBlock z) + (scope2, rest2) = go rest + go (TopVar k v:rest) = + ((k, v):scope, rest') + where + (scope, rest') = go rest + go' (k, v) = k ++ v + +combineSelectors :: Selector -> Selector -> Selector +combineSelectors a b = do + a' <- a + 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' = contentToBuilderRT cd render' + + 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 + +contentToBuilderRT :: [(Deref, CDData url)] + -> (url -> [(Text, Text)] -> Text) + -> Content + -> Either String Builder +contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s +contentToBuilderRT cd _ (ContentVar d) = + case lookup d cd of + Just (CDPlain s) -> Right s + _ -> Left $ show d ++ ": expected CDPlain" +contentToBuilderRT cd render' (ContentUrl d) = + case lookup d cd of + Just (CDUrl u) -> Right $ fromText $ render' u [] + _ -> Left $ show d ++ ": expected CDUrl" +contentToBuilderRT cd render' (ContentUrlParam d) = + case lookup d cd of + Just (CDUrlParam (u, p)) -> + Right $ fromText $ render' u p + _ -> Left $ show d ++ ": expected CDUrlParam" + +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 $ goTop [] a + where + goTop :: [(String, String)] -> [TopLevel] -> Css + goTop _ [] = [] + 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 (TopAtBlock name s' b:rest) = + AtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) : + goTop scope rest + where + s = either error mconcat $ mapM (contentToBuilderRT cd render') s' + goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest + + addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd + +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 :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)] +getVars _ ContentRaw{} = return [] +getVars scope (ContentVar d) = + case lookupD d scope of + Just _ -> return [] + Nothing -> return [(d, VTPlain)] +getVars scope (ContentUrl d) = + case lookupD d scope of + Nothing -> return [(d, VTUrl)] + Just s -> fail $ "Expected URL for " ++ s +getVars scope (ContentUrlParam d) = + case lookupD d scope of + Nothing -> return [(d, VTUrlParam)] + Just s -> fail $ "Expected URLParam for " ++ s + +lookupD :: Deref -> [(String, b)] -> Maybe String +lookupD (DerefIdent (Ident s)) scope = + case lookup s scope of + Nothing -> Nothing + Just _ -> Just s +lookupD _ _ = Nothing + +data Block = Block Selector Pairs [Block] + deriving Show + +data TopLevel = TopBlock Block + | TopAtBlock + { _atBlockName :: String + , _atBlockSelector :: Contents + , _atBlockInner :: [Block] + } + | TopAtDecl String String + | TopVar String String + +type Pairs = [Pair] + +type Pair = (Contents, Contents) + +type Selector = [Contents] + +compressTopLevel :: TopLevel -> TopLevel +compressTopLevel (TopBlock b) = TopBlock $ compressBlock b +compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b +compressTopLevel x@TopAtDecl{} = x +compressTopLevel x@TopVar{} = x + +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 -> 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 scope x, contentsToBuilder r scope y] + subGo (Block sel' b c) = + blockToCss r scope $ Block sel'' b c + where + sel'' = combineSelectors sel sel' + +selectorToBuilder :: Name -> Scope -> Selector -> Q Exp +selectorToBuilder r scope sels = + contentsToBuilder r scope $ intercalate [ContentRaw ","] sels + +contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp +contentsToBuilder r scope contents = + appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents + +contentToBuilder :: Name -> Scope -> Content -> Q Exp +contentToBuilder _ _ (ContentRaw x) = + [|fromText . pack|] `appE` litE (StringL x) +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) = + [|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 ($) []|] $ fmap ListE $ go r [] a + where + 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 (TopAtBlock name s b:rest) = do + let s' = contentsToBuilder r scope s + e <- [|(:) $ AtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] + es <- go r scope rest + return $ e : es + 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 + +blocksToCassius :: Name -> Scope -> [Block] -> Q Exp +blocksToCassius r scope a = do + appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a + +renderCss :: Css -> TL.Text +renderCss = + toLazyText . mconcat . map go -- FIXME use a foldr + where + go (Css x) = renderCss' x + go (AtBlock name s x) = + fromText (pack $ concat ["@", name, " "]) `mappend` + s `mappend` + singleton '{' `mappend` + foldr mappend (singleton '}') (map renderCss' x) + go (AtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` + fromText (pack cs) `mappend` + singleton ';' + +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
@@ -1,248 +1,250 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Text.Lucius- ( -- * Parsing- lucius- , luciusFile- , luciusFileDebug- , luciusFileReload- -- ** Runtime- , luciusRT- , luciusRT'- -- * Re-export cassius- , module Text.Cassius- ) where--import Text.Cassius hiding (cassius, cassiusFile, cassiusFileDebug, cassiusFileReload)-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, toLower, toUpper)-import Numeric (readHex)-import Control.Applicative ((<$>))-import Control.Monad (when)-import Data.Either (partitionEithers)-import Data.Text.Lazy.Builder (fromText)---- |------ >>> 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 whiteSpace1 >> return ()--whiteSpace1 :: Parser ()-whiteSpace1 =- ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))--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 <|> parseBack <|> 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- 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 "/*"- _ <- manyTill anyChar $ try $ string "*/"- return $ ContentRaw ""--luciusFile :: FilePath -> Q Exp-luciusFile fp = do- contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- luciusFromString contents--luciusFileDebug, luciusFileReload :: FilePath -> Q Exp-luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels-luciusFileReload = luciusFileDebug--parseTopLevels :: Parser [TopLevel]-parseTopLevels =- go id- where- go front = do- 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 $ stringCI "@charset "- cs <- many1 $ noneOf ";"- _ <- char ';'- return $ TopAtDecl "charset" cs- media = do- try $ stringCI "@media "- name <- many1 $ noneOf "{"- _ <- char '{'- b <- parseBlocks id- 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 ";"- _ <- 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))--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- Left s -> Left $ show s- Right tops -> Right $ \scope -> go scope tops- where- go :: [(Text, Text)] -> [TopLevel] -> Either String Css- go _ [] = Right []- go scope (TopAtDecl dec cs:rest) = do- rest' <- go scope 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 (TopAtBlock name m bs:rest) = do- bs' <- mapM (goBlock scope) bs- rest' <- go scope 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']- 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)+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} +module Text.Lucius + ( -- * Parsing + lucius + , luciusFile + , luciusFileDebug + , luciusFileReload + -- ** Runtime + , luciusRT + , luciusRT' + -- * Re-export cassius + , module Text.Cassius + ) where + +import Text.Cassius hiding (cassius, cassiusFile, cassiusFileDebug, cassiusFileReload) +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, toLower, toUpper) +import Numeric (readHex) +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.Either (partitionEithers) +import Data.Text.Lazy.Builder (fromText) +import Data.Monoid (mconcat) + +-- | +-- +-- >>> 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 whiteSpace1 >> return () + +whiteSpace1 :: Parser () +whiteSpace1 = + ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ())) + +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 <|> parseBack <|> 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 + 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 "/*" + _ <- manyTill anyChar $ try $ string "*/" + return $ ContentRaw "" + +luciusFile :: FilePath -> Q Exp +luciusFile fp = do + contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp + luciusFromString contents + +luciusFileDebug, luciusFileReload :: FilePath -> Q Exp +luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels +luciusFileReload = luciusFileDebug + +parseTopLevels :: Parser [TopLevel] +parseTopLevels = + go id + where + go front = do + 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 $ stringCI "@charset " + cs <- many1 $ noneOf ";" + _ <- char ';' + return $ TopAtDecl "charset" cs + media = do + try $ stringCI "@media " + selector <- parseContents "{" + _ <- char '{' + b <- parseBlocks id + return $ TopAtBlock "media" selector 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 ";" + _ <- 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)) + +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 + Left s -> Left $ show s + Right tops -> Right $ \scope -> go scope tops + where + go :: [(Text, Text)] -> [TopLevel] -> Either String Css + go _ [] = Right [] + go scope (TopAtDecl dec cs:rest) = do + rest' <- go scope 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 (TopAtBlock name m' bs:rest) = do + let scope' = map goScope scope + render = error "luciusRT has no URLs" + m <- mapM (contentToBuilderRT scope' render) m' + bs' <- mapM (goBlock scope) bs + rest' <- go scope rest + Right $ AtBlock name (mconcat 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)
Text/MkSizeType.hs view
@@ -1,73 +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"+-- | 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
@@ -1,63 +1,63 @@-name: shakespeare-css-version: 0.10.7-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-extra-source-files:- test/cassiuses/external1.cassius- test/cassiuses/external1.lucius- test/cassiuses/external2.cassius- test/cassiuses/external2.lucius- test/cassiuses/external-media.lucius- test/cassiuses/external-nested.lucius- test/ShakespeareCssTest.hs- test.hs--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- if impl(ghc >= 7.4)- cpp-options: -DGHC_7_4--test-suite test- hs-source-dirs: test- main-is: ../test.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.8 && < 0.10- , text >= 0.7 && < 0.12---source-repository head- type: git- location: git://github.com/yesodweb/hamlet.git+name: shakespeare-css +version: 0.10.7.1 +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 +extra-source-files: + test/cassiuses/external1.cassius + test/cassiuses/external1.lucius + test/cassiuses/external2.cassius + test/cassiuses/external2.lucius + test/cassiuses/external-media.lucius + test/cassiuses/external-nested.lucius + test/ShakespeareCssTest.hs + test.hs + +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 + if impl(ghc >= 7.4) + cpp-options: -DGHC_7_4 + +test-suite test + hs-source-dirs: test + main-is: ../test.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.8 && < 0.10 + , text >= 0.7 && < 0.12 + + +source-repository head + type: git + location: git://github.com/yesodweb/hamlet.git
test.hs view
@@ -1,5 +1,5 @@-import Test.Hspec-import ShakespeareCssTest (specs)--main :: IO ()-main = hspecX $ descriptions [specs]+import Test.Hspec +import ShakespeareCssTest (specs) + +main :: IO () +main = hspecX $ descriptions [specs]
test/ShakespeareCssTest.hs view
@@ -309,7 +309,7 @@ } |] , it "lucius case-insensitive keywords" $ - celper "@media foo{}" [lucius| + celper "@media foo {}" [lucius| @MeDIa foo { } |] @@ -333,6 +333,11 @@ celper "foo{foo:XbarY}" [lucius| @bar: bar; foo { foo:X#{bar}Y; } +|] + , it "variables in media selector" $ + celper "@media (max-width: 400px){foo{color:red}}" [lucius| +@mobileWidth: 400px; +@media (max-width: #{mobileWidth}){ foo { color: red; } } |] ]
test/cassiuses/external-media.lucius view
@@ -1,7 +1,7 @@-@media only screen{- foo {- bar {- baz: bin;- }- }-}+@media only screen{ + foo { + bar { + baz: bin; + } + } +}
test/cassiuses/external-nested.lucius view
@@ -1,6 +1,6 @@-@topvarbin: bin;-foo {- bar {- baz: #{topvarbin};- }-}+@topvarbin: bin; +foo { + bar { + baz: #{topvarbin}; + } +}
test/cassiuses/external1.cassius view
@@ -1,11 +1,11 @@-#{selector}- background: #{colorBlack}- bar: baz- color: #{colorRed}-bin- background-image: url(@{Home})- bar: bar- color: #{(((Color 127) 100) 5)}- f#{var}x: someval- unicode-test: שלום- urlp: url(@?{urlp})+#{selector} + background: #{colorBlack} + bar: baz + color: #{colorRed} +bin + background-image: url(@{Home}) + bar: bar + color: #{(((Color 127) 100) 5)} + f#{var}x: someval + unicode-test: שלום + urlp: url(@?{urlp})
test/cassiuses/external1.lucius view
@@ -1,13 +1,13 @@-foo {- background: #{colorBlack};- bar: baz;- color: #{colorRed};-}-bin {- background-image: url(@{Home});- bar: bar;- color: #{(((Color 127) 100) 5)};- f#{var}x: someval;- unicode-test: שלום;- urlp: url(@?{urlp});-}+foo { + background: #{colorBlack}; + bar: baz; + color: #{colorRed}; +} +bin { + background-image: url(@{Home}); + bar: bar; + color: #{(((Color 127) 100) 5)}; + f#{var}x: someval; + unicode-test: שלום; + urlp: url(@?{urlp}); +}
test/cassiuses/external2.cassius view
@@ -1,2 +1,2 @@-foo+foo #{var}: 2