shakespeare-css 0.10.7.1 → 0.10.8
raw patch · 13 files changed
+1087/−1087 lines, 13 filesdep ~shakespearesetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: shakespeare
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- Setup.lhs +8/−8
- Text/Cassius.hs +304/−304
- Text/Css.hs +321/−321
- Text/Lucius.hs +250/−250
- Text/MkSizeType.hs +73/−73
- shakespeare-css.cabal +63/−63
- test.hs +5/−5
- 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,321 +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 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 +{-# 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,250 +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) -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) +{-# 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.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 +name: shakespeare-css+version: 0.10.8+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.12+ , 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.12+ , base >= 4 && < 5+ , HUnit+ , hspec >= 0.8 && < 0.10+ , text >= 0.7 && < 0.12+++source-repository head+ type: git+ location: git://github.com/yesodweb/shakespeare.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/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