shakespeare-css-1.0.6.2/0000755000000000000000000000000012172720705013130 5ustar0000000000000000shakespeare-css-1.0.6.2/shakespeare-css.cabal0000644000000000000000000000506012172720705017176 0ustar0000000000000000name: shakespeare-css version: 1.0.6.2 license: MIT 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://www.yesodweb.com/book/shakespearean-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/shakespearean-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/cassiuses/mixin.lucius test/ShakespeareCssTest.hs test.hs library build-depends: base >= 4 && < 5 , shakespeare >= 1.0 && < 1.1 , template-haskell , text >= 0.11.1.1 , process >= 1.0 , 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-suite test hs-source-dirs: test main-is: ../test.hs type: exitcode-stdio-1.0 ghc-options: -Wall build-depends: shakespeare-css , shakespeare , base >= 4 && < 5 , HUnit , hspec >= 1.3 , text >= 0.7 && < 0.12 source-repository head type: git location: git://github.com/yesodweb/shakespeare.git shakespeare-css-1.0.6.2/LICENSE0000644000000000000000000000207512172720705014141 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. shakespeare-css-1.0.6.2/test.hs0000644000000000000000000000012412172720705014440 0ustar0000000000000000import Test.Hspec import ShakespeareCssTest (spec) main :: IO () main = hspec spec shakespeare-css-1.0.6.2/Setup.lhs0000644000000000000000000000021712172720705014740 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain shakespeare-css-1.0.6.2/Text/0000755000000000000000000000000012172720705014054 5ustar0000000000000000shakespeare-css-1.0.6.2/Text/Cassius.hs0000644000000000000000000000336412172720705016030 0ustar0000000000000000{-# 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 (..) -- * Internal , cassiusUsedIdentifiers ) where import Text.Css import Text.Shakespeare.Base import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import qualified Data.Text.Lazy as TL import Text.CssCommon import Text.Lucius (lucius) import qualified Text.Lucius import Text.IndentToBrace (i2b) cassius :: QuasiQuoter cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b } cassiusFile :: FilePath -> Q Exp cassiusFile fp = do #ifdef GHC_7_4 qAddDependentFile fp #endif contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp quoteExp cassius contents cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels cassiusFileReload = cassiusFileDebug -- | 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 shakespeare-css-1.0.6.2/Text/Css.hs0000644000000000000000000004306612172720705015151 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} module Text.Css where import Data.List (intersperse, intercalate) import Data.Text.Lazy.Builder (Builder, singleton, toLazyText, fromLazyText, fromString) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB import Data.Monoid (Monoid, mconcat, mappend, mempty) import Data.Text (Text) import qualified Data.Text as T 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 ((***), second) import Text.IndentToBrace (i2b) import Data.Functor.Identity (runIdentity) #if MIN_VERSION_base(4,5,0) import Data.Monoid ((<>)) #else (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css type DList a = [a] -> [a] -- FIXME great use case for data kinds data Resolved data Unresolved type family Selector a type instance Selector Resolved = Builder type instance Selector Unresolved = [Contents] type family ChildBlocks a type instance ChildBlocks Resolved = () type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)] type HasLeadingSpace = Bool type family Str a type instance Str Resolved = Builder type instance Str Unresolved = Contents type family Mixins a type instance Mixins Resolved = () type instance Mixins Unresolved = [Deref] data Block a = Block { blockSelector :: !(Selector a) , blockAttrs :: ![Attr a] , blockBlocks :: !(ChildBlocks a) , blockMixins :: !(Mixins a) } data Mixin = Mixin { mixinAttrs :: ![Attr Resolved] , mixinBlocks :: ![Block Resolved] } instance Monoid Mixin where mempty = Mixin mempty mempty mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y) data TopLevel a where TopBlock :: !(Block a) -> TopLevel a TopAtBlock :: !String -- name e.g., media -> !(Str a) -- selector -> ![Block a] -> TopLevel a TopAtDecl :: !String -> !(Str a) -> TopLevel a TopVar :: !String -> !String -> TopLevel Unresolved data Attr a = Attr { attrKey :: !(Str a) , attrVal :: !(Str a) } data Css = CssWhitespace ![TopLevel Resolved] | CssNoWhitespace ![TopLevel Resolved] data Content = ContentRaw String | ContentVar Deref | ContentUrl Deref | ContentUrlParam Deref | ContentMixin Deref deriving (Show, Eq) type Contents = [Content] data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin deriving Show data CDData url = CDPlain Builder | CDUrl url | CDUrlParam (url, [(Text, Text)]) | CDMixin Mixin pack :: String -> Text pack = T.pack #if !MIN_VERSION_text(0, 11, 2) {-# NOINLINE pack #-} #endif fromText :: Text -> Builder fromText = TLB.fromText {-# NOINLINE fromText #-} 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 -- | 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 Unresolved] -> 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 Unresolved] -> (Scope, [Content]) go [] = ([], []) go (TopAtDecl dec _FIXMEcs:rest) = (scope, rest'') where (scope, rest') = go rest rest'' = ContentRaw (concat [ "@" , dec -- FIXME, 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 mixins):rest) = (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm) where rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y (scope1, rest1) = go (map (TopBlock . snd) z) (scope2, rest2) = go rest restm = map ContentMixin mixins go (TopVar k v:rest) = ((k, v):scope, rest') where (scope, rest') = go rest go' (Attr k v) = k ++ v cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion -> Q Exp -> Parser [TopLevel Unresolved] -> 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 :: HasLeadingSpace -> [Contents] -> [Contents] -> [Contents] combineSelectors hsl a b = do a' <- a b' <- b return $ a' ++ addSpace b' where addSpace | hsl = (ContentRaw " " :) | otherwise = id blockRuntime :: [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text) -> Block Unresolved -> Either String (DList (Block Resolved)) -- FIXME share code with blockToCss blockRuntime cd render' (Block x attrs z mixinsDerefs) = do mixins <- mapM getMixin mixinsDerefs x' <- mapM go' $ intercalate [ContentRaw ","] x attrs' <- mapM resolveAttr attrs z' <- mapM (subGo x) z -- FIXME use difflists again Right $ \rest -> Block { blockSelector = mconcat x' , blockAttrs = concat $ attrs' : map mixinAttrs mixins , blockBlocks = () , blockMixins = () } : foldr ($) rest z' {- (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y)) . foldr (.) id (map (subGo x) z) -} where go' = contentToBuilderRT cd render' getMixin d = case lookup d cd of Nothing -> Left $ "Mixin not found: " ++ show d Just (CDMixin m) -> Right m Just _ -> Left $ "For " ++ show d ++ ", expected Mixin" resolveAttr :: Attr Unresolved -> Either String (Attr Resolved) resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v) subGo :: [Contents] -- ^ parent selectors -> (HasLeadingSpace, Block Unresolved) -> Either String (DList (Block Resolved)) subGo x' (hls, Block a b c d) = blockRuntime cd render' (Block a' b c d) where a' = combineSelectors hls 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" contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin" cssRuntime :: Bool -- ^ i2b? -> Parser [TopLevel Unresolved] -> FilePath -> [(Deref, CDData url)] -> (url -> [(Text, Text)] -> Text) -> Css 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 goTop :: [(String, String)] -- ^ scope -> [TopLevel Unresolved] -> [TopLevel Resolved] goTop _ [] = [] goTop scope (TopAtDecl dec cs':rest) = TopAtDecl dec cs : goTop scope rest where cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs' goTop scope (TopBlock b:rest) = map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) ++ goTop scope rest goTop scope (TopAtBlock name s' b:rest) = TopAtBlock 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|] c VTMixin = [|CDMixin|] 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 getVars scope (ContentMixin d) = case lookupD d scope of Nothing -> return [(d, VTMixin)] Just s -> fail $ "Expected Mixin 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 compressTopLevel :: TopLevel Unresolved -> TopLevel Unresolved 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 Unresolved -> Block Unresolved compressBlock (Block x y blocks mixins) = Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins where go (Attr k v) = Attr (cc k) (cc v) cc [] = [] cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c cc (a:b) = a : cc b blockToMixin :: Name -> Scope -> Block Unresolved -> Q Exp blockToMixin r scope (Block _sel props subblocks mixins) = [|Mixin { mixinAttrs = concat $ $(listE $ map go props) : map mixinAttrs $mixinsE -- FIXME too many complications to implement sublocks for now... , mixinBlocks = [] -- foldr (.) id $(listE $ map subGo subblocks) [] }|] {- . foldr (.) id $(listE $ map subGo subblocks) . (concatMap mixinBlocks $mixinsE ++) |] -} where mixinsE = return $ ListE $ map (derefToExp []) mixins go (Attr x y) = conE 'Attr `appE` (contentsToBuilder r scope x) `appE` (contentsToBuilder r scope y) subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d blockToCss :: Name -> Scope -> Block Unresolved -> Q Exp blockToCss r scope (Block sel props subblocks mixins) = [|((Block { blockSelector = $(selectorToBuilder r scope sel) , blockAttrs = concat $ $(listE $ map go props) : map mixinAttrs $mixinsE , blockBlocks = () , blockMixins = () } :: Block Resolved):) . foldr (.) id $(listE $ map subGo subblocks) . (concatMap mixinBlocks $mixinsE ++) |] where mixinsE = return $ ListE $ map (derefToExp []) mixins go (Attr x y) = conE 'Attr `appE` (contentsToBuilder r scope x) `appE` (contentsToBuilder r scope y) subGo (hls, Block sel' b c d) = blockToCss r scope $ Block sel'' b c d where sel'' = combineSelectors hls sel sel' selectorToBuilder :: Name -> Scope -> [Contents] -> 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)) contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin" type Scope = [(String, String)] topLevelsToCassius :: [TopLevel Unresolved] -> Q Exp topLevelsToCassius a = do r <- newName "_render" lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a where go _ _ [] = return [] go r scope (TopBlock b:rest) = do e <- [|(++) $ map TopBlock ($(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 <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|] es <- go r scope rest return $ e : es go r scope (TopAtDecl dec cs:rest) = do e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope 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 Unresolved] -> Q Exp blocksToCassius r scope a = do appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a renderCss :: Css -> TL.Text renderCss css = toLazyText $ mconcat $ map go tops where (haveWhiteSpace, tops) = case css of CssWhitespace x -> (True, x) CssNoWhitespace x -> (False, x) go (TopBlock x) = renderBlock haveWhiteSpace mempty x go (TopAtBlock name s x) = fromText (pack $ concat ["@", name, " "]) `mappend` s `mappend` startBlock `mappend` foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString " ")) x) go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend` cs `mappend` endDecl startBlock | haveWhiteSpace = fromString " {\n" | otherwise = singleton '{' endBlock | haveWhiteSpace = fromString "}\n" | otherwise = singleton '}' endDecl | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' renderBlock :: Bool -- ^ have whitespace? -> Builder -- ^ indentation -> Block Resolved -> Builder renderBlock haveWhiteSpace indent (Block sel attrs () ()) | null attrs = mempty | otherwise = startSelect <> sel <> startBlock <> mconcat (intersperse endDecl $ map renderAttr attrs) <> endBlock where renderAttr (Attr k v) = startDecl <> k <> colon <> v colon | haveWhiteSpace = fromString ": " | otherwise = singleton ':' startSelect | haveWhiteSpace = indent | otherwise = mempty startBlock | haveWhiteSpace = fromString " {\n" | otherwise = singleton '{' endBlock | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n" | otherwise = singleton '}' startDecl | haveWhiteSpace = indent `mappend` fromString " " | otherwise = mempty endDecl | haveWhiteSpace = fromString ";\n" | otherwise = singleton ';' instance Lift Mixin where lift (Mixin a b) = [|Mixin a b|] instance Lift (Attr Unresolved) where lift (Attr k v) = [|Attr k v :: Attr Unresolved |] instance Lift (Attr Resolved) where lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |] liftBuilder :: Builder -> Q Exp liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|] instance Lift Content where lift (ContentRaw s) = [|ContentRaw s|] lift (ContentVar d) = [|ContentVar d|] lift (ContentUrl d) = [|ContentUrl d|] lift (ContentUrlParam d) = [|ContentUrlParam d|] lift (ContentMixin m) = [|ContentMixin m|] instance Lift (Block Unresolved) where lift (Block a b c d) = [|Block a b c d|] instance Lift (Block Resolved) where lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|] shakespeare-css-1.0.6.2/Text/IndentToBrace.hs0000644000000000000000000000415612172720705017077 0ustar0000000000000000module 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 shakespeare-css-1.0.6.2/Text/Lucius.hs0000644000000000000000000002763012172720705015664 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} module Text.Lucius ( -- * Parsing lucius , luciusFile , luciusFileDebug , luciusFileReload -- ** Mixins , luciusMixin , Mixin -- ** Runtime , luciusRT , luciusRT' , luciusRTMinified -- *** Mixin , luciusRTMixin , RTValue (..) , -- * 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.CssCommon import Text.Shakespeare.Base import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Language.Haskell.TH.Syntax import Data.Text (Text, 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, unless) import Data.Monoid (mconcat) import Data.List (isSuffixOf) import Control.Arrow (second) -- | -- -- >>> renderCss ([lucius|foo{bar:baz}|] undefined) -- "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 Unresolved) parseBlock = do sel <- parseSelector _ <- char '{' whiteSpace pairsBlocks <- parsePairsBlocks id let (pairs, blocks, mixins) = partitionPBs pairsBlocks whiteSpace return $ Block sel pairs (map detectAmp blocks) mixins -- | Looks for an & at the beginning of a selector and, if present, indicates -- that we should not have a leading space. Otherwise, we should have the -- leading space. detectAmp :: Block Unresolved -> (Bool, Block Unresolved) detectAmp (Block (sel) b c d) = (hls, Block sel' b c d) where (hls, sel') = case sel of (ContentRaw "&":rest):others -> (False, rest : others) (ContentRaw ('&':s):rest):others -> (False, (ContentRaw s : rest) : others) _ -> (True, sel) partitionPBs :: [PairBlock] -> ([Attr Unresolved], [Block Unresolved], [Deref]) partitionPBs = go id id id where go a b c [] = (a [], b [], c []) go a b c (PBAttr x:xs) = go (a . (x:)) b c xs go a b c (PBBlock x:xs) = go a (b . (x:)) c xs go a b c (PBMixin x:xs) = go a b (c . (x:)) xs parseSelector :: Parser (Selector Unresolved) 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 data PairBlock = PBAttr (Attr Unresolved) | PBBlock (Block Unresolved) | PBMixin Deref parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock] parsePairsBlocks front = (char '}' >> return (front [])) <|> (do isBlock <- lookAhead checkIfBlock x <- grabMixin <|> (if isBlock then grabBlock else grabPair) parsePairsBlocks $ front . (:) x) where grabBlock = do b <- parseBlock whiteSpace return $ PBBlock b grabPair = PBAttr <$> parsePair grabMixin = try $ do whiteSpace Right x <- parseCaret whiteSpace return $ PBMixin x checkIfBlock = do skipMany $ noneOf "#@{};" (parseHash >> checkIfBlock) <|> (parseAt >> checkIfBlock) <|> (char '{' >> return True) <|> (oneOf ";}" >> return False) <|> (anyChar >> checkIfBlock) <|> fail "checkIfBlock" parsePair :: Parser (Attr Unresolved) parsePair = do key <- parseContents ":" _ <- char ':' whiteSpace val <- parseContents ";}" (char ';' >> return ()) <|> return () whiteSpace return $ Attr 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 False [|parseTopLevels|] parseTopLevels luciusFileReload = luciusFileDebug parseTopLevels :: Parser [TopLevel Unresolved] parseTopLevels = go id where go front = do let string' s = string s >> return () ignore = many (whiteSpace1 <|> string' "") >> return () ignore tl <- ((charset <|> media <|> impor <|> topAtBlock <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x)) <|> (return $ map compressTopLevel $ front []) ignore return tl charset = do try $ stringCI "@charset " cs <- parseContents ";" _ <- 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 <- parseContents ";" _ <- 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) topAtBlock = do (name, selector) <- try $ do _ <- char '@' name <- many1 $ noneOf " \t" _ <- many1 $ oneOf " \t" unless ("keyframes" `isSuffixOf` name) $ fail "only accepting keyframes" selector <- parseContents "{" _ <- char '{' return (name, selector) b <- parseBlocks id return $ TopAtBlock name selector b 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 [TopLevel Resolved]) luciusRT' = either Left (Right . go) . luciusRTInternal where go :: ([(Text, RTValue)] -> Either String [TopLevel Resolved]) -> ([(Text, Text)] -> Either String [TopLevel Resolved]) go f = f . map (second RTVRaw) luciusRTInternal :: TL.Text -> Either String ([(Text, RTValue)] -> Either String [TopLevel Resolved]) luciusRTInternal 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, RTValue)] -> [TopLevel Unresolved] -> Either String [TopLevel Resolved] go _ [] = Right [] go scope (TopAtDecl dec cs':rest) = do let scope' = map goScope scope render = error "luciusRT has no URLs" cs <- mapM (contentToBuilderRT scope' render) cs' rest' <- go scope rest Right $ TopAtDecl dec (mconcat cs) : rest' go scope (TopBlock b:rest) = do b' <- goBlock scope b rest' <- go scope rest Right $ map TopBlock 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 $ TopAtBlock name (mconcat m) (concat bs') : rest' go scope (TopVar k v:rest) = go ((pack k, RTVRaw $ pack v):scope) rest goBlock :: [(Text, RTValue)] -> Block Unresolved -> Either String [Block Resolved] goBlock scope = either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs") where scope' = map goScope scope goScope (k, rt) = (DerefIdent (Ident $ unpack k), cd) where cd = case rt of RTVRaw t -> CDPlain $ fromText t RTVMixin m -> CDMixin m luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl) -- | Runtime Lucius with mixin support. -- -- Since 1.0.6 luciusRTMixin :: TL.Text -- ^ template -> Bool -- ^ minify? -> [(Text, RTValue)] -- ^ scope -> Either String TL.Text luciusRTMixin tl minify scope = either Left (Right . renderCss . cw) $ either Left ($ scope) (luciusRTInternal tl) where cw | minify = CssNoWhitespace | otherwise = CssWhitespace data RTValue = RTVRaw Text | RTVMixin Mixin -- | Same as 'luciusRT', but output has no added whitespace. -- -- Since 1.0.3 luciusRTMinified :: TL.Text -> [(Text, Text)] -> Either String TL.Text luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $ 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 luciusMixin :: QuasiQuoter luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString } luciusMixinFromString :: String -> Q Exp luciusMixinFromString s' = do r <- newName "_render" case fmap compressBlock $ parse parseBlock s s of Left e -> error $ show e Right block -> blockToMixin r [] block where s = concat ["mixin{", s', "}"] shakespeare-css-1.0.6.2/Text/MkSizeType.hs0000644000000000000000000000561312172720705016461 0ustar0000000000000000-- | 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-1.0.6.2/Text/CssCommon.hs0000644000000000000000000001326212172720705016315 0ustar0000000000000000{-# 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" shakespeare-css-1.0.6.2/test/0000755000000000000000000000000012172720705014107 5ustar0000000000000000shakespeare-css-1.0.6.2/test/ShakespeareCssTest.hs0000755000000000000000000003470412172720705020222 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module ShakespeareCssTest (spec) where import Test.HUnit hiding (Test) import Test.Hspec import Prelude hiding (reverse) import Text.Cassius import Text.Lucius import Data.List (intercalate) import qualified Data.Text.Lazy as T import qualified Data.Text as TS import qualified Data.List import qualified Data.List as L import Data.Text (Text, pack, unpack) import Data.Monoid (mappend) spec :: Spec spec = do describe "shakespeare-css" $ do it "cassius" caseCassius it "cassiusFile" caseCassiusFile it "cassiusFileDebug" $ do let var = "var" let selector = "foo" let urlp = (Home, [(pack "p", pack "q")]) flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat [ "foo {\n background: #000;\n bar: baz;\n color: #F00;\n}\n" , "bin {\n" , " background-image: url(url);\n" , " bar: bar;\n color: #7F6405;\n fvarx: someval;\n unicode-test: שלום;\n" , " urlp: url(url?p=q);\n}\n" ] {- TODO it "cassiusFileDebugChange" $ do let var = "var" writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius") writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 2" celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius") writeFile "test/cassiuses/external2.cassius" "foo\n #{var}: 1" -} it "comments" $ do -- FIXME reconsider Hamlet comment syntax? celper "" [cassius|/* this is a comment */ /* another comment */ /*a third one*/|] it "cassius pseudo-class" $ flip celper [cassius| a:visited color: blue |] "a:visited{color:blue}" it "ignores a blank line" $ do celper "foo{bar:baz}" [cassius| foo bar: baz |] it "leading spaces" $ celper "foo{bar:baz}" [cassius| foo bar: baz |] it "cassius all spaces" $ celper "h1{color:green }" [cassius| h1 color: green |] it "cassius whitespace and colons" $ do celper "h1:hover{color:green ;font-family:sans-serif}" [cassius| h1:hover color: green font-family:sans-serif |] it "cassius trailing comments" $ 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 int = -5::Int celper "sel{bar:oof oof 3.14 -5}" [cassius| sel bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int} |] it "single dollar at and caret" $ do celper "sel{att:$@^}" [cassius| sel att: $@^ |] {- celper "sel{att:#{@{^{}" [cassius| sel att: #\{@\{^{ |] -} it "dollar operator" $ do let val = (1, (2, 3)) :: (Integer, (Integer, Integer)) celper "sel{att:2}" [cassius| sel att: #{ show $ fst $ snd val } |] celper "sel{att:2}" [cassius| sel att: #{ show $ fst $ snd $ val} |] it "embedded slash" $ do celper "sel{att:///}" [cassius| sel att: /// |] it "multi cassius" $ do celper "foo{bar:baz;bar:bin}" [cassius| foo bar: baz bar: bin |] it "lucius" $ do let var = "var" let urlp = (Home, [(pack "p", pack "q")]) flip celper [lucius| 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}); } |] $ concat [ "foo{background:#000;bar:baz;color:#F00}" , "bin{" , "background-image:url(url);" , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" , "urlp:url(url?p=q)}" ] it "lucius file" $ do let var = "var" let urlp = (Home, [(pack "p", pack "q")]) flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat [ "foo{background:#000;bar:baz;color:#F00}" , "bin{" , "background-image:url(url);" , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" , "urlp:url(url?p=q)}" ] it "lucius file debug" caseLuciusFileDebug it "lucius nested" $ do celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius") celper "foo bar {\n baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius") celper "foo bar{baz:bin}" [lucius| foo { bar { baz: bin; } } |] celper "foo1 bar,foo2 bar{baz:bin}" [lucius| foo1, foo2 { bar { baz: bin; } } |] it "lucius charset" $ do celper (concat ["@charset \"utf-8\";" , "#content ul{list-style:none;padding:0 5em}" , "#content ul li{padding:1em 0}" , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}" ]) [lucius| @charset "utf-8"; #content ul { list-style: none; padding: 0 5em; li { padding: 1em 0; a { color: #419a56; font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif; font-weight: bold; text-transform: uppercase; white-space: nowrap; } } } |] it "lucius media" $ do celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius") celper "@media only screen {\n foo bar {\n baz: bin;\n }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius") celper "@media only screen{foo bar{baz:bin}}" [lucius| @media only screen{ foo { bar { baz: bin; } } } |] {- it "cassius removes whitespace" $ do celper "foo{bar:baz}" [cassius| foo bar : baz |] -} it "lucius trailing comments" $ celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|] it "lucius variables" $ celper "foo{bar:baz}" [lucius| @myvar: baz; foo { bar: #{myvar}; } |] it "lucius CDO/CDC tokens" $ celper "*{a:b}" [lucius| |] it "lucius @import statements" $ celper "@import url(\"bla.css\");" [lucius| @import url("bla.css"); |] it "lucius simple escapes" $ celper "*{a:test}" [lucius| * { a: t\65 st; } |] it "lucius bounded escapes" $ celper "*{a:teft}" [lucius| * { a: t\000065ft; } |] it "lucius case-insensitive keywords" $ celper "@media foo {}" [lucius| @MeDIa foo { } |] it "lucius @page statements" $ celper "@page :right{a:b;c:d}" [lucius| @page :right { a:b; c:d; } |] it "lucius @font-face statements" $ celper "@font-face{a:b;c:d}" [lucius| @font-face { a:b; c:d; } |] it "lucius runtime" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")] it "lucius runtime variables" $ Right (T.pack "foo {\n bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") [] it "lucius whtiespace" $ Right (T.pack "@media foo {\n bar {\n baz: bin;\n baz2: bin2;\n }\n}\n") @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") [] it "variables inside value" $ celper "foo{foo:XbarY}" [lucius| @bar: bar; foo { foo:X#{bar}Y; } |] it "variables in media selector" $ celper "@media (max-width: 400px){foo{color:red}}" [lucius| @mobileWidth: 400px; @media (max-width: #{mobileWidth}){ foo { color: red; } } |] it "URLs in import" $ celper "@import url(\"suburl\");" [lucius| @import url("@{Sub SubUrl}"); |] it "vars in charset" $ do let charset = "mycharset" celper "@charset mycharset;" [lucius| @charset #{charset}; |] it "keyframes" $ celper "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius| @keyframes mymove { from { top: 0px; } to { top: 200px; } } |] it "prefixed keyframes" $ celper "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius| @-webkit-keyframes mymove { from { top: 0px; } to { top: 200px; } } |] it "mixins" $ do let bins = [luciusMixin| bin:bin2; /* FIXME not currently implementing sublocks in mixins foo2 { x: y } */ |] :: Mixin -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| celper "foo{bar:baz;bin:bin2}" [lucius| foo { bar: baz; ^{bins} } |] it "more complicated mixins" $ do let transition val = [luciusMixin| -webkit-transition: #{val}; -moz-transition: #{val}; -ms-transition: #{val}; -o-transition: #{val}; transition: #{val}; |] celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}" [lucius| .some-class { ^{transition "all 4s ease"} } |] it "runtime mixin" $ do let bins = [luciusMixin| bin:bin2; /* FIXME not currently implementing sublocks in mixins foo2 { x: y } */ |] :: Mixin -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius| Right (T.pack "foo{bar:baz;bin:bin2}") @=? luciusRTMixin (T.pack "foo { bar: baz; ^{bins} }") True [(TS.pack "bins", RTVMixin bins)] it "luciusFileReload mixin" $ do let mixin = [luciusMixin|foo:bar;baz:bin|] flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat [ "selector {\n foo: bar;\n baz: bin;\n}\n" ] it "& subblocks" $ celper "foo:bar{baz:bin}" [lucius| foo { &:bar { baz: bin; } } |] data Url = Home | Sub SubUrl data SubUrl = SubUrl render :: Url -> [(Text, Text)] -> Text render Home qs = pack "url" `mappend` showParams qs render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs showParams :: [(Text, Text)] -> Text showParams [] = pack "" showParams z = pack $ '?' : intercalate "&" (map go z) where go (x, y) = go' x ++ '=' : go' y go' = concatMap encodeUrlChar . unpack -- | Taken straight from web-encodings; reimplemented here to avoid extra -- dependencies. encodeUrlChar :: Char -> String encodeUrlChar c -- List of unreserved characters per RFC 3986 -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding | 'A' <= c && c <= 'Z' = [c] | 'a' <= c && c <= 'z' = [c] | '0' <= c && c <= '9' = [c] encodeUrlChar c@'-' = [c] encodeUrlChar c@'_' = [c] encodeUrlChar c@'.' = [c] encodeUrlChar c@'~' = [c] encodeUrlChar ' ' = "+" encodeUrlChar y = let (a, c) = fromEnum y `divMod` 16 b = a `mod` 16 showHex' x | x < 10 = toEnum $ x + (fromEnum '0') | x < 16 = toEnum $ x - 10 + (fromEnum 'A') | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] celper :: String -> CssUrl Url -> Assertion celper res h = do let x = renderCssUrl render h T.pack res @=? x caseCassius :: Assertion caseCassius = do let var = "var" let urlp = (Home, [(pack "p", pack "q")]) flip celper [cassius| 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}) |] $ concat [ "foo{background:#000;bar:baz;color:#F00}" , "bin{" , "background-image:url(url);" , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" , "urlp:url(url?p=q)}" ] caseCassiusFile :: Assertion caseCassiusFile = do let var = "var" let selector = "foo" let urlp = (Home, [(pack "p", pack "q")]) flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat [ "foo{background:#000;bar:baz;color:#F00}" , "bin{" , "background-image:url(url);" , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;" , "urlp:url(url?p=q)}" ] instance Show Url where show _ = "FIXME remove this instance show Url" caseLuciusFileDebug :: Assertion caseLuciusFileDebug = do let var = "var" writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" celper "foo {\n var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}" celper "foo {\n var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius") writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}" shakespeare-css-1.0.6.2/test/cassiuses/0000755000000000000000000000000012172720705016111 5ustar0000000000000000shakespeare-css-1.0.6.2/test/cassiuses/external-media.lucius0000644000000000000000000000012412172720705022233 0ustar0000000000000000@media only screen{ foo { bar { baz: bin; } } } shakespeare-css-1.0.6.2/test/cassiuses/external-nested.lucius0000644000000000000000000000010412172720705022434 0ustar0000000000000000@topvarbin: bin; foo { bar { baz: #{topvarbin}; } } shakespeare-css-1.0.6.2/test/cassiuses/external1.lucius0000644000000000000000000000037012172720705021242 0ustar0000000000000000foo { 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}); } shakespeare-css-1.0.6.2/test/cassiuses/external2.cassius0000644000000000000000000000001712172720705021407 0ustar0000000000000000foo #{var}: 2shakespeare-css-1.0.6.2/test/cassiuses/external2.lucius0000644000000000000000000000001612172720705021240 0ustar0000000000000000foo{#{var}: 1}shakespeare-css-1.0.6.2/test/cassiuses/external1.cassius0000644000000000000000000000035712172720705021415 0ustar0000000000000000#{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}) shakespeare-css-1.0.6.2/test/cassiuses/mixin.lucius0000644000000000000000000000002312172720705020456 0ustar0000000000000000selector{^{mixin}}