shakespeare 2.0.12.1 → 2.0.13
raw patch · 8 files changed
+715/−704 lines, 8 files
Files
- ChangeLog.md +4/−0
- Text/Cassius.hs +2/−2
- Text/Css.hs +0/−537
- Text/CssCommon.hs +0/−160
- Text/Internal/Css.hs +540/−0
- Text/Internal/CssCommon.hs +163/−0
- Text/Lucius.hs +2/−2
- shakespeare.cabal +4/−3
ChangeLog.md view
@@ -1,3 +1,7 @@+### 2.0.13++* Expose Text.Internal.Css [#205](https://github.com/yesodweb/shakespeare/pull/205)+ ### 2.0.12.1 * New contentHash parser breaks hash hrefs [#200](https://github.com/yesodweb/shakespeare/issues/200)
Text/Cassius.hs view
@@ -40,13 +40,13 @@ , cassiusUsedIdentifiers ) where -import Text.Css+import Text.Internal.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.Internal.CssCommon import Text.Lucius (lucius) import qualified Text.Lucius import Text.IndentToBrace (i2b)
− 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,160 +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 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/Internal/Css.hs view
@@ -0,0 +1,540 @@+{-# OPTIONS_HADDOCK hide #-}+-- | This module is only being exposed to work around a GHC bug, its API is not stable++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+module Text.Internal.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/Internal/CssCommon.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_HADDOCK hide #-}+-- | This module is only being exposed to work around a GHC bug, its API is not stable++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.Internal.CssCommon where++import Text.Internal.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 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/Lucius.hs view
@@ -51,14 +51,14 @@ , luciusUsedIdentifiers ) where -import Text.CssCommon+import Text.Internal.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 Text.Internal.Css import Data.Char (isSpace, toLower, toUpper) import Numeric (readHex) import Control.Applicative ((<$>))
shakespeare.cabal view
@@ -1,5 +1,5 @@ name: shakespeare-version: 2.0.12.1+version: 2.0.13 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -66,11 +66,12 @@ Text.Shakespeare.Base Text.Shakespeare Text.TypeScript+ Text.Internal.Css+ Text.Internal.CssCommon other-modules: Text.Hamlet.Parse- Text.Css Text.MkSizeType Text.IndentToBrace- Text.CssCommon+ ghc-options: -Wall if flag(test_export)