shakespeare-css 1.0.7.4 → 1.1.0
raw patch · 17 files changed
+3/−2002 lines, 17 filesdep −HUnitdep −hspecdep −parsecdep ~shakespeare
Dependencies removed: HUnit, hspec, parsec, process, shakespeare-css, template-haskell, text, transformers
Dependency ranges changed: shakespeare
Files
- Text/Cassius.hs +0/−68
- Text/Css.hs +0/−537
- Text/CssCommon.hs +0/−161
- Text/IndentToBrace.hs +0/−105
- Text/Lucius.hs +0/−391
- Text/MkSizeType.hs +0/−73
- shakespeare-css.cabal +3/−37
- test.hs +0/−5
- test/ShakespeareCssTest.hs +0/−583
- test/cassiuses/external-media.lucius +0/−7
- test/cassiuses/external-nested.lucius +0/−6
- test/cassiuses/external1.cassius +0/−11
- test/cassiuses/external1.lucius +0/−13
- test/cassiuses/external2.cassius +0/−2
- test/cassiuses/external2.lucius +0/−1
- test/cassiuses/mixin.lucius +0/−1
- test/cassiuses/reload-import.cassius +0/−1
− Text/Cassius.hs
@@ -1,68 +0,0 @@-{-# 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 Text.Shakespeare (VarType)-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
− Text/Css.hs
@@ -1,537 +0,0 @@-{-# 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)-import Text.Shakespeare (VarType (..))--#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 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 cs:rest) =- (scope, rest'')- where- (scope, rest') = go rest- rest'' =- ContentRaw ('@' : dec ++ " ")- : cs- ++ ContentRaw ";"- : 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 () ()|]
− Text/CssCommon.hs
@@ -1,161 +0,0 @@-{-# 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
@@ -1,105 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Text.IndentToBrace- ( i2b- ) where--import Control.Monad.Trans.Writer (execWriter, tell, Writer)-import Data.List (isInfixOf)-import qualified Data.Text as T--i2b :: String -> String-i2b = ($ [])- . execWriter- . mapM_ unnest- . map addClosingCount- . nest- . map toL- . stripComments- . lines- . filter (/= '\r')--stripComments :: [String] -> [String]-stripComments =- map T.unpack . go False . map T.pack- where- go _ [] = []-- go False (l:ls) =- let (before, after') = T.breakOn "/*" l- in case T.stripPrefix "/*" after' of- Nothing -> l : go False ls- Just after ->- let (x:xs) = go True $ after : ls- in before `T.append` x : xs- go True (l:ls) =- let (_, after') = T.breakOn "*/" l- in case T.stripPrefix "*/" after' of- Nothing -> T.empty : go True ls- Just after -> go False $ after : ls--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 = 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
@@ -1,391 +0,0 @@-{-# 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)-import Text.Shakespeare (VarType)---- |------ >>> 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-#ifdef GHC_7_4- qAddDependentFile fp-#endif- 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' "<!--" <|> 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', "}"]
− Text/MkSizeType.hs
@@ -1,73 +0,0 @@--- | Internal functions to generate CSS size wrapper types.-module Text.MkSizeType (mkSizeType) where--import Language.Haskell.TH.Syntax--mkSizeType :: String -> String -> Q [Dec]-mkSizeType name' unit = return [ dataDec name- , showInstanceDec name unit- , numInstanceDec name- , fractionalInstanceDec name- , toCssInstanceDec name ]- where name = mkName $ name'--dataDec :: Name -> Dec-dataDec name = DataD [] name [] [constructor] derives- where constructor = NormalC name [(NotStrict, ConT $ mkName "Rational")]- derives = map mkName ["Eq", "Ord"]--showInstanceDec :: Name -> String -> Dec-showInstanceDec name unit' = InstanceD [] (instanceType "Show" name) [showDec]- where showSize = VarE $ mkName "showSize"- x = mkName "x"- unit = LitE $ StringL unit'- showDec = FunD (mkName "show") [Clause [showPat] showBody []]- showPat = ConP name [VarP x]- showBody = NormalB $ AppE (AppE showSize $ VarE x) unit--numInstanceDec :: Name -> Dec-numInstanceDec name = InstanceD [] (instanceType "Num" name) decs- where decs = map (binaryFunDec name) ["+", "*", "-"] ++- map (unariFunDec1 name) ["abs", "signum"] ++- [unariFunDec2 name "fromInteger"]--fractionalInstanceDec :: Name -> Dec-fractionalInstanceDec name = InstanceD [] (instanceType "Fractional" name) decs- where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"]--toCssInstanceDec :: Name -> Dec-toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec]- where toCssDec = FunD (mkName "toCss") [Clause [] showBody []]- showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show')- -- FIXME this whole section makes me a little nervous- from = VarE (mkName "fromLazyText")- pack = VarE (mkName "TL.pack")- dot = VarE (mkName ".")- show' = VarE (mkName "show")--instanceType :: String -> Name -> Type-instanceType className name = AppT (ConT $ mkName className) (ConT name)--binaryFunDec :: Name -> String -> Dec-binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []]- where pat1 = ConP name [VarP v1]- pat2 = ConP name [VarP v2]- body = NormalB $ AppE (ConE name) result- result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2)- fun = mkName fun'- v1 = mkName "v1"- v2 = mkName "v2"--unariFunDec1 :: Name -> String -> Dec-unariFunDec1 name fun' = FunD fun [Clause [pat] body []]- where pat = ConP name [VarP v]- body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v))- fun = mkName fun'- v = mkName "v"--unariFunDec2 :: Name -> String -> Dec-unariFunDec2 name fun' = FunD fun [Clause [pat] body []]- where pat = VarP x- body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x))- fun = mkName fun'- x = mkName "x"
shakespeare-css.cabal view
@@ -1,10 +1,10 @@ name: shakespeare-css-version: 1.0.7.4+version: 1.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Stick your haskell variables into css at compile time.+synopsis: Stick your haskell variables into css at compile time. (deprecated) 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.@@ -18,44 +18,10 @@ cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/shakespearean-templates-extra-source-files:- test/cassiuses/*.cassius- test/cassiuses/*.lucius- test/ShakespeareCssTest.hs- test.hs library build-depends: base >= 4 && < 5- , shakespeare >= 1.2.1 && < 1.3- , 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-+ , shakespeare >= 2.0 source-repository head type: git
− test.hs
@@ -1,5 +0,0 @@-import Test.Hspec-import ShakespeareCssTest (spec)--main :: IO ()-main = hspec spec
− test/ShakespeareCssTest.hs
@@ -1,583 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -O0 #-} -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 "cassius single comment" caseCassiusSingleComment - it "cassius leading comment" caseCassiusLeadingComment - - 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| -<!-- --> <!-- -* { - a: b; -} ---> -|] - 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 "cassiusFileReload with import URL" $ do - celper - "@import url(url);\n" - $(cassiusFileReload "test/cassiuses/reload-import.cassius") - - 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)}" - ] - -caseCassiusSingleComment :: Assertion -caseCassiusSingleComment = - flip celper [cassius| - /* - this is a comment - */ - |] "" - -caseCassiusLeadingComment :: Assertion -caseCassiusLeadingComment = - flip celper [cassius| - /* - this is a comment - */ - sel1 - foo: bar - sel2 - baz: bin - |] "sel1{foo:bar}sel2{baz:bin}" - -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}"
− test/cassiuses/external-media.lucius
@@ -1,7 +0,0 @@-@media only screen{- foo {- bar {- baz: bin;- }- }-}
− test/cassiuses/external-nested.lucius
@@ -1,6 +0,0 @@-@topvarbin: bin;-foo {- bar {- baz: #{topvarbin};- }-}
− test/cassiuses/external1.cassius
@@ -1,11 +0,0 @@-#{selector}- background: #{colorBlack}- bar: baz- color: #{colorRed}-bin- background-image: url(@{Home})- bar: bar- color: #{(((Color 127) 100) 5)}- f#{var}x: someval- unicode-test: שלום- urlp: url(@?{urlp})
− test/cassiuses/external1.lucius
@@ -1,13 +0,0 @@-foo {- background: #{colorBlack};- bar: baz;- color: #{colorRed};-}-bin {- background-image: url(@{Home});- bar: bar;- color: #{(((Color 127) 100) 5)};- f#{var}x: someval;- unicode-test: שלום;- urlp: url(@?{urlp});-}
− test/cassiuses/external2.cassius
@@ -1,2 +0,0 @@-foo- #{var}: 2
− test/cassiuses/external2.lucius
@@ -1,1 +0,0 @@-foo{#{var}: 1}
− test/cassiuses/mixin.lucius
@@ -1,1 +0,0 @@-selector{^{mixin}}
− test/cassiuses/reload-import.cassius
@@ -1,1 +0,0 @@-@import url(@{Home})