1{-# OPTIONS_HADDOCK hide #-} 2-- | This module is only being exposed to work around a GHC bug, its API is not stable 3 4{-# LANGUAGE TemplateHaskell #-} 5{-# LANGUAGE GeneralizedNewtypeDeriving #-} 6{-# LANGUAGE FlexibleInstances #-} 7module Text.Internal.CssCommon where 8 9import Text.Internal.Css 10import Text.MkSizeType 11import qualified Data.Text as TS 12import Text.Printf (printf) 13import Language.Haskell.TH 14import Data.Word (Word8) 15import Data.Bits 16import qualified Data.Text.Lazy as TL 17 18renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text 19renderCssUrl r s = renderCss $ s r 20 21data Color = Color Word8 Word8 Word8 22 deriving Show 23instance ToCss Color where 24 toCss (Color r g b) = 25 let (r1, r2) = toHex r 26 (g1, g2) = toHex g 27 (b1, b2) = toHex b 28 in fromText $ TS.pack $ '#' : 29 if r1 == r2 && g1 == g2 && b1 == b2 30 then [r1, g1, b1] 31 else [r1, r2, g1, g2, b1, b2] 32 where 33 toHex :: Word8 -> (Char, Char) 34 toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15) 35 toChar :: Word8 -> Char 36 toChar c 37 | c < 10 = mkChar c 0 '0' 38 | otherwise = mkChar c 10 'A' 39 mkChar :: Word8 -> Word8 -> Char -> Char 40 mkChar a b' c = 41 toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c) 42 43colorRed :: Color 44colorRed = Color 255 0 0 45 46colorBlack :: Color 47colorBlack = Color 0 0 0 48 49-- CSS size wrappers 50 51-- | Create a CSS size, e.g. $(mkSize "100px"). 52mkSize :: String -> ExpQ 53mkSize s = appE nameE valueE 54 where [(value, unit)] = reads s :: [(Double, String)] 55 absoluteSizeE = varE $ mkName "absoluteSize" 56 nameE = case unit of 57 "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter") 58 "em" -> conE $ mkName "EmSize" 59 "ex" -> conE $ mkName "ExSize" 60 "in" -> appE absoluteSizeE (conE $ mkName "Inch") 61 "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter") 62 "pc" -> appE absoluteSizeE (conE $ mkName "Pica") 63 "pt" -> appE absoluteSizeE (conE $ mkName "Point") 64 "px" -> conE $ mkName "PixelSize" 65 "%" -> varE $ mkName "percentageSize" 66 _ -> error $ "In mkSize, invalid unit: " ++ unit 67 valueE = litE $ rationalL (toRational value) 68 69-- | Absolute size units. 70data AbsoluteUnit = Centimeter 71 | Inch 72 | Millimeter 73 | Pica 74 | Point 75 deriving (Eq, Show) 76 77-- | Not intended for direct use, see 'mkSize'. 78data AbsoluteSize = AbsoluteSize 79 { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting. 80 , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters. 81 } 82 83-- | Absolute size unit convertion rate to centimeters. 84absoluteUnitRate :: AbsoluteUnit -> Rational 85absoluteUnitRate Centimeter = 1 86absoluteUnitRate Inch = 2.54 87absoluteUnitRate Millimeter = 0.1 88absoluteUnitRate Pica = 12 * absoluteUnitRate Point 89absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch 90 91-- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'. 92absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize 93absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit) 94 95instance Show AbsoluteSize where 96 show (AbsoluteSize unit value') = printf "%f" value ++ suffix 97 where value = fromRational (value' / absoluteUnitRate unit) :: Double 98 suffix = case unit of 99 Centimeter -> "cm" 100 Inch -> "in" 101 Millimeter -> "mm" 102 Pica -> "pc" 103 Point -> "pt" 104 105instance Eq AbsoluteSize where 106 (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2 107 108instance Ord AbsoluteSize where 109 compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2 110 111instance Num AbsoluteSize where 112 (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2) 113 (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2) 114 (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2) 115 abs (AbsoluteSize u v) = AbsoluteSize u (abs v) 116 signum (AbsoluteSize u v) = AbsoluteSize u (abs v) 117 fromInteger x = AbsoluteSize Centimeter (fromInteger x) 118 119instance Fractional AbsoluteSize where 120 (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2) 121 fromRational x = AbsoluteSize Centimeter (fromRational x) 122 123instance ToCss AbsoluteSize where 124 toCss = fromText . TS.pack . show 125 126-- | Not intended for direct use, see 'mkSize'. 127data PercentageSize = PercentageSize 128 { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%. 129 } 130 deriving (Eq, Ord) 131 132-- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'. 133percentageSize :: Rational -> PercentageSize 134percentageSize value = PercentageSize (value / 100) 135 136instance Show PercentageSize where 137 show (PercentageSize value') = printf "%f" value ++ "%" 138 where value = fromRational (value' * 100) :: Double 139 140instance Num PercentageSize where 141 (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2) 142 (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2) 143 (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2) 144 abs (PercentageSize v) = PercentageSize (abs v) 145 signum (PercentageSize v) = PercentageSize (abs v) 146 fromInteger x = PercentageSize (fromInteger x) 147 148instance Fractional PercentageSize where 149 (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2) 150 fromRational x = PercentageSize (fromRational x) 151 152instance ToCss PercentageSize where 153 toCss = fromText . TS.pack . show 154 155-- | Converts number and unit suffix to CSS format. 156showSize :: Rational -> String -> String 157showSize value' unit = printf "%f" value ++ unit 158 where value = fromRational value' :: Double 159 160mkSizeType "EmSize" "em" 161mkSizeType "ExSize" "ex" 162mkSizeType "PixelSize" "px" 163