diff --git a/clay.cabal b/clay.cabal --- a/clay.cabal +++ b/clay.cabal @@ -1,5 +1,5 @@ Name: clay -Version: 0.5.1 +Version: 0.6 Synopsis: CSS preprocessor as embedded Haskell. Description: Clay is a CSS preprocessor like LESS and Sass, but implemented as an embedded @@ -11,8 +11,11 @@ . The API documentation can be found in the top level module "Clay". . - > 0.5 -> 0.5.1 - > - Fixed bug in fontFamily renderer. + > 0.5.1 -> 0.6 + > - Simplified implementation of size rendering. + > - Implemented @font-face construct. By James Fisher. + > - Make hsl(a) colors actually print percentage values. + > - Changed the renderer to haul @font-face to the top level. Author: Sebastiaan Visser Maintainer: Sebastiaan Visser @@ -45,6 +48,7 @@ Clay.Elements Clay.Filter Clay.Font + Clay.FontFace Clay.Geometry Clay.Gradient Clay.Media diff --git a/src/Clay.hs b/src/Clay.hs --- a/src/Clay.hs +++ b/src/Clay.hs @@ -56,6 +56,10 @@ , queryNot , queryOnly +-- * Define font-faces. + +, fontFace + -- * Pseudo elements and classes. , module Clay.Pseudo @@ -83,6 +87,7 @@ , module Clay.Display , module Clay.Dynamic , module Clay.Font +, module Clay.FontFace , module Clay.Geometry , module Clay.Gradient , module Clay.Text @@ -121,6 +126,7 @@ import Clay.Display hiding (table) import Clay.Dynamic import Clay.Font hiding (menu, caption, small, icon) +import Clay.FontFace import Clay.Geometry import Clay.Gradient import Clay.Size diff --git a/src/Clay/Color.hs b/src/Clay/Color.hs --- a/src/Clay/Color.hs +++ b/src/Clay/Color.hs @@ -16,20 +16,22 @@ data Color = Rgba Integer Integer Integer Integer - | Hsla Integer Integer Integer Integer + | Hsla Integer Float Float Integer | Other Value deriving Show -- * Color constructors. -rgba, hsla :: Integer -> Integer -> Integer -> Integer -> Color - +rgba :: Integer -> Integer -> Integer -> Integer -> Color rgba = Rgba -hsla = Hsla -rgb, hsl :: Integer -> Integer -> Integer -> Color - +rgb :: Integer -> Integer -> Integer -> Color rgb r g b = rgba r g b 255 + +hsla :: Integer -> Float -> Float -> Integer -> Color +hsla = Hsla + +hsl :: Integer -> Float -> Float -> Color hsl r g b = hsla r g b 255 grayish :: Integer -> Color @@ -42,40 +44,34 @@ setR :: Integer -> Color -> Color setR r (Rgba _ g b a) = Rgba r g b a -setR r (Hsla _ g b a) = Hsla r g b a -setR _ (Other o) = Other o +setR _ o = o setG :: Integer -> Color -> Color setG g (Rgba r _ b a) = Rgba r g b a -setG g (Hsla r _ b a) = Hsla r g b a -setG _ (Other o) = Other o +setG _ o = o setB :: Integer -> Color -> Color setB b (Rgba r g _ a) = Rgba r g b a -setB b (Hsla r g _ a) = Hsla r g b a -setB _ (Other o) = Other o +setB _ o = o setA :: Integer -> Color -> Color setA a (Rgba r g b _) = Rgba r g b a setA a (Hsla r g b _) = Hsla r g b a -setA _ (Other o) = Other o +setA _ o = o -- * Computing with colors. (*.) :: Color -> Integer -> Color (*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a -(*.) (Hsla r g b a) i = Hsla (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a -(*.) (Other o) _ = Other o +(*.) o _ = o (+.) :: Color -> Integer -> Color (+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a -(+.) (Hsla r g b a) i = Hsla (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a -(+.) (Other o) _ = Other o +(+.) o _ = o (-.) :: Color -> Integer -> Color (-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a -(-.) (Hsla r g b a) i = Hsla (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a -(-.) (Other o) _ = Other o +(-.) o _ = o clamp :: Integer -> Integer clamp i = max (min i 255) 0 @@ -87,10 +83,11 @@ case clr of Rgba r g b 255 -> Value $mconcat ["rgb(", p r, ",", p g, ",", p b, ")"] Rgba r g b a -> Value $mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"] - Hsla h s l 255 -> Value $mconcat ["hsl(", p h, ",", p s, ",", p l, ")"] - Hsla h s l a -> Value $mconcat ["hsla(", p h, ",", p s, ",", p l, ",", ah a, ")"] + Hsla h s l 255 -> Value $mconcat ["hsl(", p h, ",", f s, ",", f l, ")"] + Hsla h s l a -> Value $mconcat ["hsla(", p h, ",", f s, ",", f l, ",", ah a, ")"] Other o -> o where p = fromString . show + f = fromString . printf "%.4f%%" ah = fromString . printf "%.4f" . (/ (256 :: Double)) . fromIntegral instance None Color where none = Other "none" diff --git a/src/Clay/Common.hs b/src/Clay/Common.hs --- a/src/Clay/Common.hs +++ b/src/Clay/Common.hs @@ -10,6 +10,8 @@ module Clay.Common where import Clay.Property +import Data.String (IsString) +import Data.Monoid (Monoid, (<>)) ------------------------------------------------------------------------------- @@ -50,3 +52,9 @@ , ( "", "" ) ] +------------------------------------------------------------------------------- + +-- | Syntax for CSS function call. + +call :: (IsString s, Monoid s) => s -> s -> s +call fn arg = fn <> "(" <> arg <> ")" diff --git a/src/Clay/FontFace.hs b/src/Clay/FontFace.hs new file mode 100644 --- /dev/null +++ b/src/Clay/FontFace.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Clay.FontFace + ( FontFaceFormat (..) + , FontFaceSrc (..) + , fontFaceSrc + ) where + +import Clay.Common (call) +import Clay.Property (Prefixed (Plain), Value(Value), Val (value), quote) +import Clay.Stylesheet (Css, key) + +import Data.Monoid ((<>)) +import Data.Functor((<$>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) + +------------------------------------------------------------------------------- + +data FontFaceFormat = WOFF | TrueType | OpenType | EmbeddedOpenType | SVG + deriving Show + +-- | name of format according to CSS specification +formatName :: FontFaceFormat -> Text +formatName format = case format of + WOFF -> "woff" + TrueType -> "truetype" + OpenType -> "opentype" + EmbeddedOpenType -> "embedded-opentype" + SVG -> "svg" + +------------------------------------------------------------------------------- + +data FontFaceSrc + = FontFaceSrcUrl Text (Maybe FontFaceFormat) + | FontFaceSrcLocal Text + deriving Show + +instance Val FontFaceSrc where + value src = Value $ Plain $ case src of + FontFaceSrcLocal name -> call "local" (quote name) + FontFaceSrcUrl url mformat -> + (call "url" $ quote url) + <> (fromMaybe "" $ call "format" . quote . formatName <$> mformat) + +------------------------------------------------------------------------------- + +fontFaceSrc :: [FontFaceSrc] -> Css +fontFaceSrc = key "src" diff --git a/src/Clay/Property.hs b/src/Clay/Property.hs --- a/src/Clay/Property.hs +++ b/src/Clay/Property.hs @@ -34,6 +34,9 @@ plain (Prefixed xs) = "" `fromMaybe` lookup "" xs plain (Plain p ) = p +quote :: Text -> Text +quote t = "\"" <> replace "\"" "\\\"" t <> "\"" + ------------------------------------------------------------------------------- newtype Key a = Key { unKeys :: Prefixed } @@ -57,7 +60,7 @@ deriving (Show, Monoid, IsString) instance Val Literal where - value (Literal t) = Value (Plain ("\"" <> replace "\"" "\\\"" t <> "\"")) + value (Literal t) = Value (Plain (quote t)) instance Val Integer where value = fromString . show diff --git a/src/Clay/Render.hs b/src/Clay/Render.hs --- a/src/Clay/Render.hs +++ b/src/Clay/Render.hs @@ -77,20 +77,6 @@ then (<> "\n/* Generated with Clay, http://fvisser.nl/clay */") else id -rules :: Config -> [App] -> [Rule] -> Builder -rules cfg sel rs = mconcat - [ rule cfg sel (mapMaybe property rs) - , newline cfg - , (\(a, b) -> rules cfg (a : sel) b) `foldMap` mapMaybe nested rs - , (\(a, b) -> query cfg a sel b) `foldMap` mapMaybe queries rs - ] - where property (Property k v) = Just (k, v) - property _ = Nothing - nested (Nested a ns ) = Just (a, ns) - nested _ = Nothing - queries (Query q ns ) = Just (q, ns) - queries _ = Nothing - query :: Config -> MediaQuery -> [App] -> [Rule] -> Builder query cfg q sel rs = mconcat @@ -104,12 +90,11 @@ ] mediaQuery :: MediaQuery -> Builder -mediaQuery (MediaQuery no ty fs) = - mconcat +mediaQuery (MediaQuery no ty fs) = mconcat [ "@media " , case no of - Nothing -> "" - Just Not -> "not " + Nothing -> "" + Just Not -> "not " Just Only -> "only " , mediaType ty , mconcat ((" and " <>) . feature <$> fs) @@ -123,13 +108,31 @@ case mv of Nothing -> fromText k Just (Value v) -> mconcat - [ "(" - , fromText k - , ": " - , fromText (plain v) - , ")" - ] + [ "(" , fromText k , ": " , fromText (plain v) , ")" ] +face :: Config -> [Rule] -> Builder +face cfg rs = mconcat + [ "@font-face" + , rules cfg [] rs + ] + +rules :: Config -> [App] -> [Rule] -> Builder +rules cfg sel rs = mconcat + [ rule cfg sel (mapMaybe property rs) + , newline cfg + , (\(a, b) -> rules cfg (a : sel) b) `foldMap` mapMaybe nested rs + , (\(a, b) -> query cfg a sel b) `foldMap` mapMaybe queries rs + , (\ns -> face cfg ns) `foldMap` mapMaybe faces rs + ] + where property (Property k v) = Just (k, v) + property _ = Nothing + nested (Nested a ns ) = Just (a, ns) + nested _ = Nothing + queries (Query q ns ) = Just (q, ns) + queries _ = Nothing + faces (Face ns ) = Just ns + faces _ = Nothing + rule :: Config -> [App] -> [(Key (), Value)] -> Builder rule _ _ [] = mempty rule cfg sel props = @@ -145,7 +148,7 @@ ] merger :: [App] -> Selector -merger [] = error "this should be fixed!" +merger [] = "" -- error "this should be fixed!" merger (x:xs) = case x of Rule.Child s -> case xs of [] -> s; _ -> merger xs |> s diff --git a/src/Clay/Size.hs b/src/Clay/Size.hs --- a/src/Clay/Size.hs +++ b/src/Clay/Size.hs @@ -42,7 +42,6 @@ where import Data.Monoid -import Data.Text (pack) import Clay.Common import Clay.Property @@ -65,27 +64,27 @@ -- | Size in pixels. px :: Integer -> Size Abs -px i = Size (value (pack (show i) <> "px")) +px i = Size (value i <> "px") -- | Size in points. pt :: Double -> Size Abs -pt i = Size (value (pack (show i) <> "pt")) +pt i = Size (value i <> "pt") -- | Size in em's. em :: Double -> Size Abs -em i = Size (value (pack (show i) <> "em")) +em i = Size (value i <> "em") -- | Size in ex'es. ex :: Double -> Size Abs -ex i = Size (value (pack (show i) <> "ex")) +ex i = Size (value i <> "ex") -- | Size in percentages. pct :: Double -> Size Rel -pct i = Size (value (pack (show i) <> "%")) +pct i = Size (value i <> "%") instance Num (Size Abs) where fromInteger = px @@ -129,12 +128,12 @@ -- | Angle in degrees. deg :: Double -> Angle Deg -deg i = Angle (value (pack (show i) <> "deg")) +deg i = Angle (value i <> "deg") -- | Angle in radians. rad :: Double -> Angle Rad -rad i = Angle (value (pack (show i) <> "rad")) +rad i = Angle (value i <> "rad") instance Num (Angle Deg) where fromInteger = deg . fromInteger diff --git a/src/Clay/Stylesheet.hs b/src/Clay/Stylesheet.hs --- a/src/Clay/Stylesheet.hs +++ b/src/Clay/Stylesheet.hs @@ -36,6 +36,7 @@ = Property (Key ()) Value | Nested App [Rule] | Query MediaQuery [Rule] + | Face [Rule] deriving Show newtype StyleM a = S (Writer [Rule] a) @@ -121,3 +122,9 @@ queryOnly :: MediaType -> [Feature] -> Css -> Css queryOnly ty fs (S rs) = S (tell [Query (MediaQuery (Just Only) ty fs) (execWriter rs)]) +------------------------------------------------------------------------------- + +-- | Define a new font-face. + +fontFace :: Css -> Css +fontFace (S rs) = S (tell [Face (execWriter rs)])