shakespeare-css 1.0.1.5 → 1.0.2
raw patch · 7 files changed
+356/−272 lines, 7 filesdep +transformersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: transformers
API changes (from Hackage documentation)
- Text.Cassius: instance Eq AbsoluteSize
- Text.Cassius: instance Eq AbsoluteUnit
- Text.Cassius: instance Eq EmSize
- Text.Cassius: instance Eq ExSize
- Text.Cassius: instance Eq PercentageSize
- Text.Cassius: instance Eq PixelSize
- Text.Cassius: instance Fractional AbsoluteSize
- Text.Cassius: instance Fractional EmSize
- Text.Cassius: instance Fractional ExSize
- Text.Cassius: instance Fractional PercentageSize
- Text.Cassius: instance Fractional PixelSize
- Text.Cassius: instance Num AbsoluteSize
- Text.Cassius: instance Num EmSize
- Text.Cassius: instance Num ExSize
- Text.Cassius: instance Num PercentageSize
- Text.Cassius: instance Num PixelSize
- Text.Cassius: instance Ord AbsoluteSize
- Text.Cassius: instance Ord EmSize
- Text.Cassius: instance Ord ExSize
- Text.Cassius: instance Ord PercentageSize
- Text.Cassius: instance Ord PixelSize
- Text.Cassius: instance Show AbsoluteSize
- Text.Cassius: instance Show AbsoluteUnit
- Text.Cassius: instance Show Color
- Text.Cassius: instance Show EmSize
- Text.Cassius: instance Show ExSize
- Text.Cassius: instance Show PercentageSize
- Text.Cassius: instance Show PixelSize
- Text.Cassius: instance ToCss AbsoluteSize
- Text.Cassius: instance ToCss Color
- Text.Cassius: instance ToCss EmSize
- Text.Cassius: instance ToCss ExSize
- Text.Cassius: instance ToCss PercentageSize
- Text.Cassius: instance ToCss PixelSize
+ Text.Cassius: cassiusUsedIdentifiers :: String -> [(Deref, VarType)]
+ Text.Lucius: AbsoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize
+ Text.Lucius: Centimeter :: AbsoluteUnit
+ Text.Lucius: Color :: Word8 -> Word8 -> Word8 -> Color
+ Text.Lucius: EmSize :: Rational -> EmSize
+ Text.Lucius: ExSize :: Rational -> ExSize
+ Text.Lucius: Inch :: AbsoluteUnit
+ Text.Lucius: Millimeter :: AbsoluteUnit
+ Text.Lucius: PercentageSize :: Rational -> PercentageSize
+ Text.Lucius: Pica :: AbsoluteUnit
+ Text.Lucius: PixelSize :: Rational -> PixelSize
+ Text.Lucius: Point :: AbsoluteUnit
+ Text.Lucius: absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize
+ Text.Lucius: absoluteSizeUnit :: AbsoluteSize -> AbsoluteUnit
+ Text.Lucius: absoluteSizeValue :: AbsoluteSize -> Rational
+ Text.Lucius: class ToCss a
+ Text.Lucius: colorBlack :: Color
+ Text.Lucius: colorRed :: Color
+ Text.Lucius: data AbsoluteSize
+ Text.Lucius: data AbsoluteUnit
+ Text.Lucius: data Color
+ Text.Lucius: data Css
+ Text.Lucius: data EmSize
+ Text.Lucius: data ExSize
+ Text.Lucius: data PercentageSize
+ Text.Lucius: data PixelSize
+ Text.Lucius: luciusUsedIdentifiers :: String -> [(Deref, VarType)]
+ Text.Lucius: mkSize :: String -> ExpQ
+ Text.Lucius: parseTopLevels :: Parser [TopLevel]
+ Text.Lucius: percentageSize :: Rational -> PercentageSize
+ Text.Lucius: percentageSizeValue :: PercentageSize -> Rational
+ Text.Lucius: renderCss :: Css -> Text
+ Text.Lucius: renderCssUrl :: (url -> [(Text, Text)] -> Text) -> CssUrl url -> Text
+ Text.Lucius: toCss :: ToCss a => a -> Builder
+ Text.Lucius: type CssUrl url = (url -> [(Text, Text)] -> Text) -> Css
Files
- Text/Cassius.hs +13/−250
- Text/Css.hs +34/−16
- Text/CssCommon.hs +161/−0
- Text/IndentToBrace.hs +83/−0
- Text/Lucius.hs +33/−4
- shakespeare-css.cabal +4/−1
- test/ShakespeareCssTest.hs +28/−1
Text/Cassius.hs view
@@ -32,144 +32,22 @@ , PercentageSize (..) , percentageSize , PixelSize (..)+ -- * Internal+ , cassiusUsedIdentifiers ) 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 (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 ""+import Text.CssCommon+import Text.Lucius (lucius)+import qualified Text.Lucius+import Text.IndentToBrace (i2b) cassius :: QuasiQuoter-cassius = QuasiQuoter { quoteExp = cassiusFromString }--cassiusFromString :: String -> Q Exp-cassiusFromString s =- topLevelsToCassius $ map TopBlock- $ either (error . show) id $ parse parseBlocks s s+cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } cassiusFile :: FilePath -> Q Exp cassiusFile fp = do@@ -177,128 +55,13 @@ qAddDependentFile fp #endif contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp- cassiusFromString contents+ quoteExp cassius contents cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp-cassiusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels+cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.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"+-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+cassiusUsedIdentifiers :: String -> [(Deref, VarType)]+cassiusUsedIdentifiers = cssUsedIdentifiers True Text.Lucius.parseTopLevels
Text/Css.hs view
@@ -19,7 +19,11 @@ import Language.Haskell.TH import Control.Applicative ((<$>), (<*>)) import Control.Arrow ((***))+import Text.IndentToBrace (i2b)+import Data.Functor.Identity (runIdentity) +type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css+ pack :: String -> Text pack = T.pack #if !MIN_VERSION_text(0, 11, 2)@@ -62,20 +66,19 @@ | 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+-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion+ -> Parser [TopLevel]+ -> String+ -> [(Deref, VarType)]+cssUsedIdentifiers toi2b parseBlocks s' =+ concat $ runIdentity $ mapM (getVars scope0) contents where+ s = if toi2b then i2b s' else s'+ a = either (error . show) id $ parse parseBlocks s s+ (scope0, contents) = go a+ go :: [TopLevel] -> ([(String, String)], [Content]) go [] = ([], []) go (TopAtDecl dec _FIXMEcs:rest) =@@ -105,6 +108,19 @@ (scope, rest') = go rest go' (k, v) = k ++ v +cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion+ -> Q Exp -> Parser [TopLevel] -> FilePath -> Q Exp+cssFileDebug toi2b parseBlocks' parseBlocks fp = do+ s <- fmap TL.unpack $ qRunIO $ readUtf8File fp+#ifdef GHC_7_4+ qAddDependentFile fp+#endif+ let vs = cssUsedIdentifiers toi2b parseBlocks s+ c <- mapM vtToExp vs+ cr <- [|cssRuntime toi2b|]+ parseBlocks'' <- parseBlocks'+ return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c+ combineSelectors :: Selector -> Selector -> Selector combineSelectors a b = do a' <- a@@ -156,13 +172,15 @@ Right $ fromText $ render' u p _ -> Left $ show d ++ ": expected CDUrlParam" -cssRuntime :: Parser [TopLevel]+cssRuntime :: Bool -- ^ i2b?+ -> 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+cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do+ s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp+ let s = if toi2b then i2b s' else s' let a = either (error . show) id $ parse parseBlocks s s return $ CssWhitespace $ goTop [] a where
+ Text/CssCommon.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.CssCommon where++import Text.Css+import Text.MkSizeType+import qualified Data.Text as TS+import Text.Printf (printf)+import Language.Haskell.TH+import Data.Word (Word8)+import Data.Bits+import Data.Text.Lazy.Builder (fromLazyText)+import qualified Data.Text.Lazy as TL++renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text+renderCssUrl r s = renderCss $ s r++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++-- 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/IndentToBrace.hs view
@@ -0,0 +1,83 @@+module Text.IndentToBrace+ ( i2b+ ) where++import Control.Monad.Trans.Writer (execWriter, tell, Writer)+import Data.List (isPrefixOf, isInfixOf)++i2b :: String -> String+i2b = ($ [])+ . execWriter+ . mapM_ unnest+ . map addClosingCount+ . nest+ . map toL+ . lines+ . filter (/= '\r')++data Line = Line+ { lineIndent :: Int+ , lineContent :: String+ }+ deriving (Show, Eq)++data Nest = Nest Line Int [Nest]+ | Blank String+ deriving (Show, Eq)++isBlank :: Nest -> Bool+isBlank Blank{} = True+isBlank _ = False++addClosingCount :: Nest -> Nest+addClosingCount (Blank x) = Blank x+addClosingCount (Nest l c children) =+ Nest l c $ increment $ map addClosingCount children+ where+ increment+ | any (not . isBlank) children = increment'+ | otherwise = id++ increment' [] = error "should never happen"+ increment' (Blank x:rest) = Blank x : increment' rest+ increment' (n@(Nest l' c' children'):rest)+ | any (not . isBlank) rest = n : increment' rest+ | any (not . isBlank) children' = Nest l' c' (increment' children') : rest+ | otherwise = Nest l' (c' + 1) children' : rest++toL :: String -> Either String Line+toL s+ | null y || "/*" `isPrefixOf` y = Left s+ | otherwise = Right $ Line (length x) y+ where+ (x, y) = span (== ' ') s++nest :: [Either String Line] -> [Nest]+nest [] = []+nest (Left x:rest) = Blank x : nest rest+nest (Right l:rest) =+ Nest l 0 (nest inside) : nest outside+ where+ (inside, outside) = span isNested rest+ isNested Left{} = True+ isNested (Right l2) = lineIndent l2 > lineIndent l++tell' :: String -> Writer (String -> String) ()+tell' s = tell (s ++)++unnest :: Nest -> Writer (String -> String) ()+unnest (Blank x) = do+ tell' x+ tell' "\n"+unnest (Nest l count inside) = do+ tell' $ replicate (lineIndent l) ' '+ tell' $ lineContent l+ tell' $+ case () of+ ()+ | not $ all isBlank inside -> "{"+ | ";" `isInfixOf` lineContent l -> ""+ | otherwise -> ";"+ tell' $ replicate count '}'+ tell' "\n"+ mapM_ unnest inside
Text/Lucius.hs view
@@ -13,11 +13,35 @@ -- ** Runtime , luciusRT , luciusRT'- -- * Re-export cassius- , module Text.Cassius+ , -- * Datatypes+ Css+ , CssUrl+ -- * Type class+ , ToCss (..)+ -- * Rendering+ , renderCss+ , renderCssUrl+ -- * ToCss instances+ -- ** Color+ , Color (..)+ , colorRed+ , colorBlack+ -- ** Size+ , mkSize+ , AbsoluteUnit (..)+ , AbsoluteSize (..)+ , absoluteSize+ , EmSize (..)+ , ExSize (..)+ , PercentageSize (..)+ , percentageSize+ , PixelSize (..)+ -- * Internal+ , parseTopLevels+ , luciusUsedIdentifiers ) where -import Text.Cassius hiding (cassius, cassiusFile, cassiusFileDebug, cassiusFileReload)+import Text.CssCommon import Text.Shakespeare.Base import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax@@ -161,7 +185,7 @@ luciusFromString contents luciusFileDebug, luciusFileReload :: FilePath -> Q Exp-luciusFileDebug = cssFileDebug [|parseTopLevels|] parseTopLevels+luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels luciusFileReload = luciusFileDebug parseTopLevels :: Parser [TopLevel]@@ -262,3 +286,8 @@ luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl)++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+luciusUsedIdentifiers :: String -> [(Deref, VarType)]+luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels
shakespeare-css.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-css-version: 1.0.1.5+version: 1.0.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -35,11 +35,14 @@ , text >= 0.11.1.1 && < 0.12 , process >= 1.0 && < 1.2 , parsec >= 2 && < 4+ , transformers exposed-modules: Text.Cassius Text.Lucius other-modules: Text.MkSizeType Text.Css+ Text.IndentToBrace+ Text.CssCommon ghc-options: -Wall if impl(ghc >= 7.4) cpp-options: -DGHC_7_4
test/ShakespeareCssTest.hs view
@@ -91,15 +91,38 @@ it "cassius trailing comments" $ - celper "h1:hover {color:green ;font-family:sans-serif}" [cassius| + celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| h1:hover /* Please ignore this */ color: green /* This is a comment. */ /* Obviously this is ignored too. */ font-family:sans-serif |] + it "cassius nesting" $ + celper "foo bar{baz:bin}" [cassius| + foo + bar + baz: bin + |] + it "cassius variable" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar} + |] + it "cassius trailing semicolon" $ + celper "foo bar{baz:bin}" [cassius| + @binvar: bin + foo + bar + baz: #{binvar}; + |] + + + it "cassius module names" $ do let foo = "foo" dub = 3.14::Double @@ -118,10 +141,12 @@ att: $@^ |] + {- celper "sel{att:#{@{^{}" [cassius| sel att: #\{@\{^{ |] +-} it "dollar operator" $ do @@ -262,11 +287,13 @@ |] + {- it "cassius removes whitespace" $ do celper "foo{bar:baz}" [cassius| foo bar : baz |] + -}