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