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