diff --git a/Data/CSS.hs b/Data/CSS.hs new file mode 100644 --- /dev/null +++ b/Data/CSS.hs @@ -0,0 +1,379 @@ +-- | +-- Module: Data.CSS +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez +-- +-- This library implements a domain-specific language for cascading +-- style sheets as used in web pages. It allows you to specify your +-- style sheets in regular Haskell syntax and gives you all the +-- additional power of server-side document generation. + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + +module Data.CSS + ( -- * Tutorial + -- $tut + + -- ** Selectors and media + -- $tut_selectors + + -- ** Rendering + -- $tut_rendering + + -- ** Lengths + -- $tut_lengths + + -- ** Colors + -- $tut_colors + + -- ** Edge-oriented properties + -- $tut_edges + + -- ** Imports + -- $tut_imports + + -- ** Miscellaneous + -- *** Important properties + -- $tut_misc_important + + -- *** Inheriting + -- $tut_misc_inherit + + -- ** Optimizations + -- $tut_optimize + + -- * Reexports + module Data.CSS.Build, + module Data.CSS.Render, + module Data.CSS.Types + ) + where + +import Blaze.ByteString.Builder +import Control.Monad.Writer +import Data.ByteString (ByteString) +import Data.Colour +import Data.CSS.Build +import Data.CSS.Properties +import Data.CSS.Render +import Data.CSS.Types +import Web.Routes.RouteT + + +{- $tut + +Style sheets are values of type 'CSS'. This type denotes style sheets, +including for different media and is itself a monoid, so that you can +build your style sheets either in a chunk-by-chunk fashion or using a +writer monad. The latter is the recommended way, because it gives you +access to a large library of predefined properties with additional type +safety. It is recommended to enable the @OverloadedStrings@ extension +for this library and is assumed for the rest of this tutorial. + +Style properties are usually specified by using the predefined property +writers: + +> display InlineDisplay +> direction LeftToRight +> float LeftFloat + +If a property is not pre-defined you can set it by using 'setProp' or +its infix variant '$='. + +> setProp "font-family" ("times" :: PropValue) +> "text-decoration" $= ("underline" :: PropValue) + +The type signatures are necessary because the property value is actually +polymorphic and needs to be an instance of 'ToPropValue'. There are many +predefined instances: + +> "z-index" $= 15 +> "margin" $= ["1em", "2px"] + +These values will render as @15@ and @1em 2px@ respectively. + +-} + + +{- $tut_selectors + +In order to specify properties you first need to establish media types +and selectors. The simplest way to do this is to use 'onAll', 'onMedia' +and 'select': + +> stylesheet :: Writer CSS () +> stylesheet = +> onAll . select ["p"] $ do +> lineHeight . Just $ _Cm # 1 +> zIndex Nothing +> borderStyle . LeftEdge $ SolidBorder + +This will render as the following stylesheet: + +> p { +> line-height: 10mm; +> z-index: auto; +> border-left-style: solid; +> } + +To restrict the media to which the stylesheet applies just use 'onMedia' +instead of 'onAll': + +> onMedia ["print"] . select ["p"] $ ... + +This will render as: + +> @media print { +> p { /* ... */ } +> } + +Often it is convenient to specify properties for elements below the +current selection. You can use the 'below' combinator to do this: + +> onAll . select ["p"] $ do +> lineHeight . Just $ _Cm # 1 +> zIndex Nothing +> +> below ["em"] $ do +> margin . Edges $ [_Em # 0.2, _Ex # 1] +> padding . Edges $ [_Em # 0.1, _Ex # 0.5] + +The inner block specifies properties for @p em@, so the above will +render as the following stylesheet: + +> p { +> line-height: 10mm; +> z-index: auto; +> } +> +> p em { +> margin: 0.2em 1ex; +> padding: 0.1em 0.5ex; +> } + +You can also specify properties for multiple selectors simultaneously: + +> onAll . select ["html", "body"] $ do +> margin . Edges $ [zeroLen] +> padding . Edges $ [_Em # 1, _Ex # 2] +> +> below ["a", "p"] $ do +> backgroundColor black +> color limegreen + +This renders as the following stylesheet: + +> html, body { +> margin: 0; +> padding: 1em 2ex; +> } +> +> html a, body a, html p, body p { +> background-color: #000; +> color: #32cd32; +> } + +-} + + +{- $tut_rendering + +To render a stylesheet you can use 'fromCSS', 'renderCSS' or +'renderCSST'. All of these will give you a 'Builder'. You can then use +combinators like 'toByteString' or 'toByteStringIO' to turn it into a +'ByteString', send it to a client or write it to a file. + +The lowest level function is 'fromCSS', which will take a 'CSS' value +and give you a 'Builder': + +> fromCSS :: CSS -> Builder + +The most convenient way to write your stylesheets is to use a writer +monad, in which case you would use one of these functions instead, +depending on the shape of your monad: + +> renderCSS :: Writer CSS a -> Builder +> renderCSST :: (Monad m) => WriterT CSS m a -> m Builder + +The following example prints the stylesheet to stdout, assuming +@stylesheet@ is of type @'Writer' CSS ()@: + +> import qualified Data.ByteString as B +> +> toByteStringIO B.putStr . renderCSS $ stylesheet + +-} + + +{- $tut_lengths + +For convenience lengths can and should be specified by using predefined +prisms like '_Cm' (see 'HasLength'): + +> lineHeight $ Just (_Cm # 1) + +This will render as @line-height: 10mm@. All compatible lengths are +saved and rendered in a canonical unit. For example centimeters, +millimeters, inches, picas and points are all rendered as their +correspondingly scaled millimeter lengths, i.e. @'_In' \# 1@ will render +as @25.4mm@. + +For convenience there are also two ways to specify percental lengths. +The lengths @'_Percent' \# 150@ and @'_Factor' \# 1.5@ are equivalent +and both render as @150%@. + +There are also two special lengths, 'zeroLen' and 'autoLen', which +render as @0@ and @auto@ respectively. + +-} + + +{- $tut_colors + +Colors are specified by using the 'Colour' and 'AlphaColour' types from +the colour library. They are rendered as either @\#rgb@, @\#rrggbb@ or +@rgba(r,g,b,a)@ depending on what color you specify and whether it is +fully opaque. The following renders as @border-left-color: \#0f0@: + +> import Data.Colour.Names +> +> borderColor (LeftEdge lime) + +The colour library gives you both correct color space handling, sensible +operators for mixing colors and a large library of predefined colors in +the "Data.Colour.Names" module. To mix two colors you can use 'blend' +for mixing or 'over' for alpha blending: + +> blend 0.5 lime red +> (lime `withOpacity` 0.5) `over` black + +Colors are all rendered in the (non-linear) sRGB color space, as this is +the assumed color space by most user agents and screens. + +-} + + +{- $tut_edges + +Many CSS properties are edge-oriented, for example 'margin', 'padding' +and 'borderColor'. This library provides a unified interface to these +properties through the 'Edge' type. Examples: + +> margin . BottomEdge $ _Mm # 1 -- margin-bottom: 1mm +> margin . LeftEdge $ _Mm # 1 -- margin-left: 1mm +> margin . RightEdge $ _Mm # 1 -- margin-right: 1mm +> margin . TopEdge $ _Mm # 1 -- margin-top: 1mm + +To set all edges through the 'margin' property just use the 'Edges' +constructor: + +> margin . Edges $ [_Mm # 2, _Mm # 1] -- margin: 2mm 1mm +> margin . Edges $ [_Mm # 5] -- margin: 5mm + +You can also use the usual monadic combinators: + +> mapM_ margin [LeftEdge (_Mm # 3), +> RightEdge (_Mm # 4)] + +-} + + +{- $tut_imports + +To import an external stylesheet you can use 'importFrom' or +'importUrl'. The former allows you to specify raw URLs: + +> importFrom "screen" "/style/screen.css" + +In web frameworks like Happstack you would usually work on top of a +'MonadRoute'-based monad (like 'RouteT') as defined in the web-routes +library. In this case the 'importUrl' function allows you to use your +type-safe URLs conveniently: + +> importUrl "all" (Style "screen") + +To import a stylesheet for multiple media types, just use the import +functions multiple times for the same URL: + +> mapM_ (`importFrom` "/style/screen.css") ["screen", "print"] + +This will render as: + +> @import url("/style/screen.css") print, screen; + +-} + + +{- $tut_misc_important + +To set the @!important@ tag on a property you can use the 'important' +function: + +> important (display InlineDisplay) + +This renders as: + +> display: inline !important; + +-} + + +{- $tut_misc_inherit + +To inherit a property value use 'inherit'. You have to spell out the +property name in this case: + +> inherit "display" + +This renders as: + +> display: inherit; + +-} + + +{- $tut_optimize + +The underlying representation is a straightforward list of selectors and +properties. There may be closer or more efficient representations, but +all of them need to make some compromises along the way. Consider the +following stylesheet: + +> p { +> border-color: #0f0; +> border-color: rgba(0, 255, 0, 1); +> } + +You can optimize this to a single property, but which one? It depends +on whether the user agent supports CSS level 3, so we would need to make +assumptions. We also can't use a map of properties to a list of values. +Consider the following stylesheet: + +> p { +> border-bottom-color: #0f0; +> border-color: #f00; +> } + +The order of the properties does matter here, so we need to preserve it. +This rules out a map from properties to lists of values. The final +question is: Can we use a map from selectors to property lists? As it +turns out no, because CSS specificity does not always apply: + +> a:link { /* ... */ } +> a:blah { /* ... */ } + +These two selectors have the same specificity. CSS allows unsupported +pseudo-classes and user agents must ignore them, so in edge cases the +order can matter. + +Other than media types CSS does not seem to exhibit any commutativity, +so we use regular lists. Also since most authors use mostly +hand-written stylesheets with little property overlap the list +representation is usually faster anyway, so this choice seems to be +sensible. + +The only optimization performed by this library is the minified output +it produces. Pretty-printing is currently not supported. + +-} diff --git a/Data/CSS/Build.hs b/Data/CSS/Build.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Build.hs @@ -0,0 +1,131 @@ +-- | +-- Module: Data.CSS.Build +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Build + ( -- * Media types + onAll, + onMedia, + + -- * Selectors + select, + -- ** Selector modifiers + below, + local, + + -- * Setting properties + ($=), + important, + inherit, + setProp, + + -- * Auxiliary + importFrom, + importUrl + ) + where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Bc +import qualified Data.Map as M +import qualified Data.Set as S +import Control.Applicative +import Control.Lens +import Control.Monad.Reader +import Control.Monad.Writer.Class +import Data.CSS.Types +import Data.Set (Set) +import Data.Text (Text) +import Web.Routes.RouteT + + +-- | Set the given property to the given value. (infix 2) +-- +-- Infix version of 'setProp'. + +($=) :: + (ToPropValue a) + => PropName -- ^ Property to set. + -> a -- ^ Value to set the property to. + -> SetProp +prop $= val = do + BuildCfg mt sel <- ask + tell (CSS M.empty (M.singleton mt [Property sel prop (toPropValue val) False])) + +infix 2 $= + + +-- | Given children of the current selector. + +below :: (MonadWriter CSS m) => [Selector] -> m a -> m a +below sels = + censoring (cssProps . mapped . mapped . propSelector) + (liftA2 (\(Selector sel) (Selector sel') -> + Selector $ B.append (Bc.snoc sel' ' ') sel) + sels) + + +-- | Mark all property values important. + +important :: (MonadWriter CSS m) => m a -> m a +important = + censoring (cssProps . mapped . mapped . propImportant) + (const True) + + +-- | Import the given style sheet for the given media type. + +importFrom :: (MonadWriter CSS m) => MediaType -> Text -> m () +importFrom mt url = tell (CSS (M.singleton url (S.singleton mt)) M.empty) + + +-- | Import the given style sheet for the given media type. + +importUrl :: + (MonadRoute m, MonadWriter CSS m) + => MediaType + -> URL m + -> m () +importUrl mt = showURL >=> importFrom mt + + +-- | Set the given property to be inherited. + +inherit :: (MonadReader BuildCfg m, MonadWriter CSS m) => PropName -> m () +inherit = ($= PropValue "inherit") + + +-- | Specify stylesheets for all media, + +onAll :: (Monad m) => ReaderT (Set MediaType) m a -> m a +onAll = onMedia [MediaType "all"] + + +-- | Specify stylesheets for the given media. + +onMedia :: (Monad m) => [MediaType] -> ReaderT (Set MediaType) m a -> m a +onMedia = flip runReaderT . S.fromList + + +-- | Specify the selector. + +select :: + (Monad m) + => [Selector] + -> ReaderT BuildCfg m a + -> ReaderT (Set MediaType) m a +select sel (ReaderT c) = ReaderT $ \mt -> c (BuildCfg mt sel) + + +-- | Set the given property to the given value. +-- +-- Non-infix version of '$='. + +setProp :: + (ToPropValue a) + => PropName -- ^ Property to set. + -> a -- ^ Value to set the property to. + -> SetProp +setProp = ($=) diff --git a/Data/CSS/Properties.hs b/Data/CSS/Properties.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties.hs @@ -0,0 +1,25 @@ +-- | +-- Module: Data.CSS.Properties +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties + ( -- * Reexports + module Data.CSS.Properties.Classes, + module Data.CSS.Properties.Compat, + module Data.CSS.Properties.Font, + module Data.CSS.Properties.Layout, + module Data.CSS.Properties.Text, + module Data.CSS.Properties.Types, + module Data.CSS.Properties.UI + ) + where + +import Data.CSS.Properties.Classes +import Data.CSS.Properties.Compat +import Data.CSS.Properties.Font +import Data.CSS.Properties.Layout +import Data.CSS.Properties.Text +import Data.CSS.Properties.Types +import Data.CSS.Properties.UI diff --git a/Data/CSS/Properties/Classes.hs b/Data/CSS/Properties/Classes.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Classes.hs @@ -0,0 +1,79 @@ +-- | +-- Module: Data.CSS.Properties.Classes +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Classes + ( -- * Length prisms + HasLength(..), + HasAutoLength(..), + HasPercent(..) + ) + where + +import Control.Lens + + +-- | Class for length types with a notion of automatic length. + +class HasAutoLength len where + -- | Automatic length. + autoLen :: len a + + +-- | Class of types, which feature CSS lengths. +-- +-- Minimal complete definition: '_Em', '_Ex', '_Mm', '_Px', 'zeroLen'. + +class HasLength len where + -- | 'Length' in centimeters (@cm@). Compatible with '_In', '_Mm', + -- '_Pc' and '_Pt'. + _Cm :: (Fractional a, Real a) => Prism' (len a) a + _Cm = _Mm . iso (/ 10) (* 10) + + -- | 'Length' in units of the font size (@em@). + _Em :: (Fractional a, Real a) => Prism' (len a) a + + -- | 'Length' in units of the height of the @x@ character in the + -- current font (@ex@). + _Ex :: (Fractional a, Real a) => Prism' (len a) a + + -- | 'Length' in inches (@in@). Compatible with '_Cm', '_Mm', '_Pc' + -- and '_Pt'. + _In :: (Fractional a, Real a) => Prism' (len a) a + _In = _Mm . iso (/ 25.4) (* 25.4) + + -- | 'Length' in millimeters (@mm@). Compatible with '_Cm', '_In', + -- '_Pc' and '_Pt'. + _Mm :: (Fractional a, Real a) => Prism' (len a) a + + -- | 'Length' in picas (@pc@). Compatible with '_Cm', '_In', '_Mm' + -- and '_Pt'. + _Pc :: (Fractional a, Real a) => Prism' (len a) a + _Pc = _Mm . iso (/ (127/30)) (* (127/30)) + + -- | 'Length' in points (@pt@). Compatible with '_Cm', '_In', '_Mm' + -- and '_Pc'. + _Pt :: (Fractional a, Real a) => Prism' (len a) a + _Pt = _Mm . iso (/ (127/360)) (* (127/360)) + + -- | 'Length' in pixels (@px@). + _Px :: (Fractional a, Real a) => Prism' (len a) a + + -- | Zero length. + zeroLen :: len a + + +-- | Class for length types with percentages. +-- +-- Minimal complete definition: '_Factor'. + +class HasPercent len where + -- | Relative 'Length' by factor where 1 means 100% (@%@). + -- Compatible with '_Percent'. + _Factor :: (Fractional a, Real a) => Prism' (len a) a + + -- | Relative 'Length' in percent (@%@). Compatible with '_Factor'. + _Percent :: (Fractional a, Real a) => Prism' (len a) a + _Percent = _Factor . iso (* 100) (/ 100) diff --git a/Data/CSS/Properties/Compat.hs b/Data/CSS/Properties/Compat.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Compat.hs @@ -0,0 +1,43 @@ +-- | +-- Module: Data.CSS.Properties.Compat +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Compat + ( -- * Vendor prefixes + vendors + ) + where + +import qualified Data.ByteString as B +import Control.Lens +import Control.Monad.Writer.Class +import Data.CSS.Types + + +-- | Adds vendor-prefixed properties for all properties in the given +-- style sheet. The following vendors are currently added: +-- +-- * Microsoft (@-ms-@), +-- +-- * Mozilla (@-moz-@), +-- +-- * Opera (@-o-@), +-- +-- * WebKit (@-webkit-@). +-- +-- This combinator keeps the original (non-prefixed) property and does +-- not prefix properties that already have a vendor prefix. + +vendors :: + (MonadWriter CSS m) + => m a + -> m a +vendors = + censoring (cssProps . mapped) . concatMap $ \(Property sel (PropName name) val imp) -> + let prefix pfx = Property sel (PropName $ B.append pfx name) val imp + prefixes + | B.isPrefixOf "-" name = [""] + | otherwise = ["", "-moz-", "-ms-", "-o-", "-webkit-"] + in map prefix prefixes diff --git a/Data/CSS/Properties/Font.hs b/Data/CSS/Properties/Font.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Font.hs @@ -0,0 +1,124 @@ +-- | +-- Module: Data.CSS.Properties.Font +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Font + ( -- * Colors and background + backgroundAttachment, + backgroundColor, + backgroundImage, + backgroundImageUrl, + backgroundPosition, + backgroundRepeat, + color, + + -- * Fonts + fontFamily, + fontSize, + fontStyle, + fontVariant, + fontWeight, + + -- * Text decoration + textDecoration + ) + where + +import qualified Data.ByteString.Char8 as Bc +import Data.Colour +import Data.CSS.Properties.Types +import Data.CSS.Properties.Utils +import Data.CSS.Build +import Data.CSS.Types +import Data.Text (Text) +import Web.Routes.RouteT + + +-- | Set the @background-attachment@. + +backgroundAttachment :: BackgroundAttachment -> SetProp +backgroundAttachment = setProp "background-attachment" + + +-- | Set the @background-color@. + +backgroundColor :: (ColourOps f, ToPropValue (f a)) => f a -> SetProp +backgroundColor = setProp "background-color" + + +-- | Set the @background-image@. + +backgroundImage :: Maybe (CssUrl Text) -> SetProp +backgroundImage = setProp "background-image" . maybeProp "none" + + +-- | Set the @background-image@. + +backgroundImageUrl :: (MonadRoute m) => Maybe (URL m) -> SetPropM m +backgroundImageUrl img = do + renderUrl <- askRouteFn + backgroundImage . fmap (CssUrl . flip renderUrl []) $ img + + +-- | Set the @background-position@. + +backgroundPosition :: + (Real a, Real b) + => FactorLen Length a + -> FactorLen Length b + -> SetProp +backgroundPosition = curry (setProp "background-position") + + +-- | Set @background-repeat@. + +backgroundRepeat :: BackgroundRepeat -> SetProp +backgroundRepeat = setProp "background-repeat" + + +-- | Set the foreground @color@. + +color :: (ColourOps f, ToPropValue (f a)) => f a -> SetProp +color = setProp "color" + + +-- | Set the @font-family@ choices. + +fontFamily :: [FontFamily] -> SetProp +fontFamily = + setProp "font-family" . + PropValue . + Bc.intercalate "," . + map (_propValueStr . toPropValue) + + +-- | Set the @font-size@. + +fontSize :: (Real a) => FontSize a -> SetProp +fontSize = setProp "font-size" + + +-- | Set the @font-style@. + +fontStyle :: FontStyle -> SetProp +fontStyle = setProp "font-style" + + +-- | Set the @font-variant@. + +fontVariant :: FontVariant -> SetProp +fontVariant = setProp "font-variant" + + +-- | Set the @font-weight@. + +fontWeight :: FontWeight -> SetProp +fontWeight = setProp "font-weight" + + +-- | Set the @text-decoration@. + +textDecoration :: Maybe TextDecoration -> SetProp +textDecoration = setProp "text-decoration" . maybeProp "none" diff --git a/Data/CSS/Properties/Layout.hs b/Data/CSS/Properties/Layout.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Layout.hs @@ -0,0 +1,317 @@ +-- | +-- Module: Data.CSS.Properties.Layout +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Layout + ( -- * Borders + border, + borderColor, + borderStyle, + borderWidth, + + -- * Inline layout + lineHeight, + verticalAlign, + + -- * Margin and padding + margin, + padding, + -- ** Paged media + pageMargins, + pageBreakBefore, + pageBreakAfter, + pageBreakInside, + + -- * Position + edgePos, + position, + zIndex, + -- ** Float + clear, + float, + + -- * Size + -- ** Height + height, + minHeight, + maxHeight, + -- ** Width + width, + minWidth, + maxWidth, + + -- * Tables + borderCollapse, + borderSpacing, + captionSide, + emptyCells, + tableLayout, + + -- * Visibility + clip, + display, + overflow, + visibility + ) + where + +import qualified Data.ByteString as B +import Control.Monad.Reader +import Control.Monad.Writer.Class +import Data.Colour +import Data.CSS.Build +import Data.CSS.Properties.Types +import Data.CSS.Properties.Utils +import Data.CSS.Types +import Data.List +import Data.Set (Set) + + +-- | Set all @border@ properties for all edges. + +border :: + (ColourOps f, Real a, ToPropValue (f b)) + => BorderWidth a -- ^ Border width. + -> BorderStyle -- ^ Border style. + -> f b -- ^ Border color. + -> SetProp +border w s c = "border" $= (w, s, c) + + +-- | Collapse borders for tables (@border-collapse@)? + +borderCollapse :: Bool -> SetProp +borderCollapse c = + "border-collapse" $= PropValue (if c then "collapse" else "separate") + + +-- | Set the border color for the given edges (@border*-color@). + +borderColor :: (ColourOps f, ToPropValue (f a)) => Edge (f a) -> SetProp +borderColor = byEdge "border" "-color" + + +-- | Set the table's @border-spacing@ (up to two values). + +borderSpacing :: (Real a) => [Length a] -> SetProp +borderSpacing = setProp "border-spacing" + + +-- | Set the border style for the given edges (@border*-style@). + +borderStyle :: Edge BorderStyle -> SetProp +borderStyle = byEdge "border" "-style" + + +-- | Set the border width for the given edges (@border*-width@). + +borderWidth :: (Real a) => Edge (BorderWidth a) -> SetProp +borderWidth = byEdge "border" "-width" + + +-- | Set the given property by edge. + +byEdge :: + (ToPropValue a) + => PropName -- ^ Common prefix. + -> PropName -- ^ Common suffix. + -> Edge a -- ^ Edge-oriented specification. + -> SetProp +byEdge (PropName pfx) (PropName sfx) edge = + case edge of + BottomEdge p -> PropName (B.append (B.append pfx "-bottom") sfx) $= p + Edges ps -> PropName (B.append pfx sfx) $= ps + LeftEdge p -> PropName (B.append (B.append pfx "-left") sfx) $= p + RightEdge p -> PropName (B.append (B.append pfx "-right") sfx) $= p + TopEdge p -> PropName (B.append (B.append pfx "-top") sfx) $= p + + +-- | Set the @caption-side@. + +captionSide :: CaptionSide -> SetProp +captionSide = setProp "caption-side" + + +-- | Set the sides to @clear@. + +clear :: [FloatEdge] -> SetProp +clear es + | l && r = "clear" $= PropValue "both" + | l = "clear" $= PropValue "left" + | r = "clear" $= PropValue "right" + | otherwise = "clear" $= PropValue "none" + where + (l, r) = foldl' f (False, False) es + + f (_, r') LeftFloat = (True, r') + f (l', _) RightFloat = (l', True) + + +-- | Set the @clip@ mode to the given shape or @auto@. + +clip :: (Real a) => Maybe (ClipMode a) -> SetProp +clip = setProp "clip" . maybeProp "auto" + + +-- | Set the @display@ mode. + +display :: DisplayMode -> SetProp +display = setProp "display" + + +-- | Set edge positions (@top@, @right@, @bottom@, @left@). + +edgePos :: (Real a) => Edge (AutoLen (FactorLen Length) a) -> SetProp +edgePos (Edges ls) = + let edges l1 l2 l3 l4 = "top" $= l1 >> "right" $= l2 >> "bottom" $= l3 >> "left" $= l4 in + case ls of + l1:l2:l3:l4:_ -> edges l1 l2 l3 l4 + l1:l2:l3:_ -> edges l1 l2 l3 l2 + l1:l2:_ -> edges l1 l2 l1 l2 + l1:_ -> edges l1 l1 l1 l1 + [] -> return () +edgePos (BottomEdge l) = "bottom" $= l +edgePos (LeftEdge l) = "left" $= l +edgePos (RightEdge l) = "right" $= l +edgePos (TopEdge l) = "top" $= l + + +-- | Show @empty-cells@? + +emptyCells :: Bool -> SetProp +emptyCells s = + "empty-cells" $= PropValue (if s then "show" else "hide") + + +-- | Set @float@ side. + +float :: Maybe FloatEdge -> SetProp +float = setProp "float" . maybeProp "none" + + +-- | Set the @height@. + +height :: (Real a) => AutoLen (FactorLen Length) a -> SetProp +height = setProp "height" + + +-- | Set the @line-height@ to the given length or @normal@. + +lineHeight :: (Real a) => Maybe (FactorLen Length a) -> SetProp +lineHeight = setProp "line-height" . maybeProp "normal" + + +-- | Set the margin for the given edges (@margin*@). + +margin :: (Real a) => Edge (AutoLen (FactorLen Length) a) -> SetProp +margin = byEdge "margin" "" + + +-- | Set the @max-height@. + +maxHeight :: (Real a) => Maybe (FactorLen Length a) -> SetProp +maxHeight = setProp "max-height" . maybeProp "none" + + +-- | Set the @max-width@. + +maxWidth :: (Real a) => Maybe (FactorLen Length a) -> SetProp +maxWidth = setProp "max-width" . maybeProp "none" + + +-- | Set the @min-height@. + +minHeight :: (Real a) => FactorLen Length a -> SetProp +minHeight = setProp "min-height" + + +-- | Set the @min-width@. + +minWidth :: (Real a) => FactorLen Length a -> SetProp +minWidth = setProp "min-width" + + +-- | Set the @overflow@ handling mode. + +overflow :: OverflowMode -> SetProp +overflow = setProp "overflow" + + +-- | Set the padding for the given edges (@padding*@). + +padding :: (Real a) => Edge (FactorLen Length a) -> SetProp +padding = byEdge "padding" "" + + +-- | Specify the page margins for paged media. + +pageMargins :: + (MonadWriter CSS m, Real a) + => PageSelector -- ^ Optional selector below @\@page@. + -> Edge (AutoLen (FactorLen Length) a) -- ^ Margins. + -> ReaderT (Set MediaType) m () +pageMargins pageSel = select (sel pageSel) . margin + where + sel AllPages = [Selector "@page"] + sel FirstPage = [Selector "@page :first"] + sel LeftPages = [Selector "@page :left"] + sel RightPages = [Selector "@page :right"] + + +-- | Set page breaking behaviour after the element (@page-break-after@) +-- to the given value or @auto@. + +pageBreakAfter :: Maybe (PageBreak a) -> SetProp +pageBreakAfter = setProp "page-break-after" . maybeProp "auto" + + +-- | Set page breaking behaviour before the element +-- (@page-break-before@) to the given value or @auto@. + +pageBreakBefore :: Maybe (PageBreak a) -> SetProp +pageBreakBefore = setProp "page-break-before" . maybeProp "auto" + + +-- | Set page breaking behaviour inside the element +-- (@page-break-inside@) to the given value or @auto@. + +pageBreakInside :: Maybe (PageBreak InsideBreak) -> SetProp +pageBreakInside = setProp "page-break-inside" . maybeProp "auto" + + +-- | Set the @position@ mode. + +position :: PositionMode -> SetProp +position = setProp "position" + + +-- | Set the @table-layout@. + +tableLayout :: TableLayout -> SetProp +tableLayout = setProp "table-layout" + + +-- | Set the @vertical-align@ mode. + +verticalAlign :: (Real a) => VerticalAlign a -> SetProp +verticalAlign = setProp "vertical-align" + + +-- | Set the @visibility@ mode. + +visibility :: VisibilityMode -> SetProp +visibility = setProp "visibility" + + +-- | Set the @width@. + +width :: (Real a) => AutoLen (FactorLen Length) a -> SetProp +width = setProp "width" + + +-- | Set the @z-index@ to the given integer or @auto@. + +zIndex :: (Integral a) => Maybe a -> SetProp +zIndex = setProp "z-index" . maybeProp "auto" . fmap toInteger diff --git a/Data/CSS/Properties/Text.hs b/Data/CSS/Properties/Text.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Text.hs @@ -0,0 +1,210 @@ +-- | +-- Module: Data.CSS.Properties.Text +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Text + ( -- * Alignment and spacing + letterSpacing, + textAlign, + textIndent, + whiteSpace, + wordSpacing, + + -- * Direction + direction, + unicodeBidi, + + -- * Generated content + content, + contentUrl, + counterIncrement, + counterReset, + quotes, + + -- * List formatting + listStyle, + listStyleImage, + listStyleImageUrl, + listStylePosition, + listStyleType, + listStyleUrl, + + -- * Paged media + orphans, + widows, + + -- * Transformation + textTransform + ) + where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +import Data.ByteString (ByteString) +import Data.CSS.Build +import Data.CSS.Properties.Types +import Data.CSS.Properties.Utils +import Data.CSS.Types +import Data.CSS.Utils +import Data.Monoid +import Data.Text (Text) +import Web.Routes.RouteT + + +-- | Set the generated @content@ to the given list of parts or @normal@. + +content :: Maybe [ContentPart (CssUrl Text)] -> SetProp +content = setProp "content" . maybeProp "normal" + + +-- | Set the generated @content@ to the given list of parts or @normal@. + +contentUrl :: (MonadRoute m) => Maybe [ContentPart (URL m)] -> SetPropM m +contentUrl parts = do + renderUrl <- askRouteFn + content . fmap (map (fmap $ CssUrl . flip renderUrl [])) $ parts + + +-- | Increment the given counters by the given value +-- (@counter-increment@). + +counterIncrement :: (Integral a) => [(ByteString, a)] -> SetProp +counterIncrement [] = setProp "counter-increment" (PropValue "none") +counterIncrement cs = setProp "counter-increment" (map (formatCounter 1) cs) + + +-- | Reset the given counters to the given value (@counter-reset@). + +counterReset :: (Integral a) => [(ByteString, a)] -> SetProp +counterReset [] = setProp "counter-reset" (PropValue "none") +counterReset cs = setProp "counter-reset" (map (formatCounter 0) cs) + + +-- | Set the text @direction@. + +direction :: TextDirection -> SetProp +direction = setProp "direction" + + +-- | Format the given identifier/counter pair for 'counterIncrement' and +-- 'counterReset' with the given default value. + +formatCounter :: (Integral a) => a -> (ByteString, a) -> ByteString +formatCounter def (ctr, n) + | n == def = ctr + | otherwise = + toByteString $ + fromByteString ctr <> + fromChar ' ' <> + showReal n + + +-- | Set the @letter-spacing@ to the specified value or @normal@. + +letterSpacing :: (Real a) => Maybe (Length a) -> SetProp +letterSpacing = setProp "letter-spacing" . maybeProp "normal" + + +-- | Set all @list-style@ properties. + +listStyle :: ListStyle -> ListPosition -> Maybe (CssUrl Text) -> SetProp +listStyle style pos url = setProp "list-style" (style, pos, maybeProp "none" url) + + +-- | Set the @list-style-image@. + +listStyleImage :: Maybe (CssUrl Text) -> SetProp +listStyleImage = setProp "list-style-image" . maybeProp "none" + + +-- | Set the @list-style-image@. + +listStyleImageUrl :: (MonadRoute m) => Maybe (URL m) -> SetPropM m +listStyleImageUrl url = do + renderUrl <- askRouteFn + listStyleImage . fmap (CssUrl . flip renderUrl []) $ url + + +-- | Set the @list-style-position@. + +listStylePosition :: ListPosition -> SetProp +listStylePosition = setProp "list-style-position" + + +-- | Set the @list-style-type@. + +listStyleType :: ListStyle -> SetProp +listStyleType = setProp "list-style-type" + + +-- | Set all @list-style@ properties. + +listStyleUrl :: + (MonadRoute m) + => ListStyle + -> ListPosition + -> Maybe (URL m) + -> SetPropM m +listStyleUrl style pos url = do + renderUrl <- askRouteFn + listStyle style pos (fmap (CssUrl . flip renderUrl []) url) + + +-- | Set the @orphans@ threshold (minimum number of lines at the bottom +-- of a page). + +orphans :: (Integral a) => a -> SetProp +orphans = setProp "orphans" . toInteger + + +-- | Set the @quotes@ pairs (@none@ if empty). + +quotes :: [(CssString Text, CssString Text)] -> SetProp +quotes [] = setProp "quotes" (PropValue "none") +quotes qs = setProp "quotes" qs + + +-- | Set @text-align@. + +textAlign :: TextAlign -> SetProp +textAlign = setProp "text-align" + + +-- | Set the @text-indent@. + +textIndent :: (Real a) => FactorLen Length a -> SetProp +textIndent = setProp "text-indent" + + +-- | Set the @text-transform@. + +textTransform :: Maybe TextTransform -> SetProp +textTransform = setProp "text-transform" . maybeProp "none" + + +-- | Set the @unicode-bidi@ mode. + +unicodeBidi :: UnicodeBidiMode -> SetProp +unicodeBidi = setProp "unicode-bidi" + + +-- | Set the white space collapse and text wrapping modes +-- (@white-space@). + +whiteSpace :: TextWrapMode -> SetProp +whiteSpace = setProp "white-space" + + +-- | Set the @widows@ threshold (minimum number of lines at the top of a +-- page). + +widows :: (Integral a) => a -> SetProp +widows = setProp "widows" . toInteger + + +-- | Set the @word-spacing@ to the specified value or @normal@. + +wordSpacing :: (Real a) => Maybe (Length a) -> SetProp +wordSpacing = setProp "word-spacing" . maybeProp "normal" diff --git a/Data/CSS/Properties/Types.hs b/Data/CSS/Properties/Types.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Types.hs @@ -0,0 +1,886 @@ +-- | +-- Module: Data.CSS.Properties.Types +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Types + ( -- * Lengths + Length, + AutoLen, + FactorLen, + + -- * Generic CSS types + CssString(..), + CssUrl(..), + + -- * Edge-oriented + Edge(..), + + -- * Specific properties + -- ** Backgrounds + BackgroundAttachment(..), + BackgroundRepeat(..), + -- ** Borders + BorderStyle(..), + BorderWidth(..), + -- ** Fonts + FontFamily(..), + FontSize(..), + FontStyle(..), + FontVariant(..), + FontWeight(..), + -- ** Generated content + ContentPart(..), + -- ** Layout + ClipMode(..), + DisplayMode(..), + FloatEdge(..), + OverflowMode(..), + PositionMode(..), + VisibilityMode(..), + -- ** Lists + ListPosition(..), + ListStyle(..), + -- ** Paged media + PageBreak(..), AnyBreak, InsideBreak, + PageSelector(..), + -- ** Tables + CaptionSide(..), + TableLayout(..), + -- ** Text + TextAlign(..), + TextDecoration(..), + TextDirection(..), + TextTransform(..), + TextWrapMode(..), + UnicodeBidiMode(..), + VerticalAlign(..), + -- ** User interface + Cursor(..) + ) + where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 hiding (fromString) +import Control.Lens +import Data.ByteString (ByteString) +import Data.CSS.Properties.Classes +import Data.CSS.Properties.Utils +import Data.CSS.Types +import Data.CSS.Utils +import Data.Data +import Data.Foldable (Foldable(fold)) +import Data.List +import Data.Monoid +import Data.String +import Data.Text (Text) + + +-- | Length transformer to add automatic lengths. + +data AutoLen len a = AutoLen | NoAutoLen (len a) + deriving (Eq, Ord, Show) + +instance HasAutoLength (AutoLen len) where + autoLen = AutoLen + +instance (HasLength len) => HasLength (AutoLen len) where + _Cm = _NoAutoLen . _Cm + _Em = _NoAutoLen . _Em + _Ex = _NoAutoLen . _Ex + _Mm = _NoAutoLen . _Mm + _Px = _NoAutoLen . _Px + zeroLen = NoAutoLen zeroLen + +instance (HasPercent len) => HasPercent (AutoLen len) where + _Factor = _NoAutoLen . _Factor + +instance (ToPropValue (len a)) => ToPropValue (AutoLen len a) where + toPropBuilder AutoLen = fromByteString "auto" + toPropBuilder (NoAutoLen l) = toPropBuilder l + + +-- | Background attachment. + +data BackgroundAttachment + = FixedBgr -- ^ @fixed@ background. + | ScrollBgr -- ^ @scroll@ background. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue BackgroundAttachment where + toPropBuilder FixedBgr = fromByteString "fixed" + toPropBuilder ScrollBgr = fromByteString "scroll" + + +-- | Background repeating. + +data BackgroundRepeat + = NoRepeat -- ^ @no-repeat@. + | Repeat -- ^ @repeat@ both axes. + | RepeatX -- ^ @repeat-x@ axis. + | RepeatY -- ^ @repeat-y@ axis. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue BackgroundRepeat where + toPropBuilder NoRepeat = fromByteString "no-repeat" + toPropBuilder Repeat = fromByteString "repeat" + toPropBuilder RepeatX = fromByteString "repeat-x" + toPropBuilder RepeatY = fromByteString "repeat-y" + + +-- | Border style. + +data BorderStyle + = NoBorder + | HiddenBorder + | DottedBorder + | DashedBorder + | SolidBorder + | DoubleBorder + | GrooveBorder + | RidgeBorder + | InsetBorder + | OutsetBorder + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue BorderStyle where + toPropBuilder NoBorder = fromByteString "none" + toPropBuilder HiddenBorder = fromByteString "hidden" + toPropBuilder DottedBorder = fromByteString "dotted" + toPropBuilder DashedBorder = fromByteString "dashed" + toPropBuilder SolidBorder = fromByteString "solid" + toPropBuilder DoubleBorder = fromByteString "double" + toPropBuilder GrooveBorder = fromByteString "groove" + toPropBuilder RidgeBorder = fromByteString "ridge" + toPropBuilder InsetBorder = fromByteString "inset" + toPropBuilder OutsetBorder = fromByteString "outset" + + +-- | Border widths. + +data BorderWidth a + = BorderWidth (Length a) -- ^ Custom border width. + | MediumWidth -- ^ Medium border width. + | ThickWidth -- ^ Thick border width. + | ThinWidth -- ^ Thin border width. + deriving (Eq, Ord, Show, Typeable) + +instance HasLength BorderWidth where + _Em = _BorderWidth . _Em + _Ex = _BorderWidth . _Ex + _Mm = _BorderWidth . _Mm + _Px = _BorderWidth . _Px + zeroLen = BorderWidth zeroLen + +instance (Real a) => ToPropValue (BorderWidth a) where + toPropBuilder (BorderWidth l) = toPropBuilder l + toPropBuilder MediumWidth = fromByteString "medium" + toPropBuilder ThickWidth = fromByteString "thick" + toPropBuilder ThinWidth = fromByteString "thin" + + +-- | Table caption sides. + +data CaptionSide + = BottomSide -- ^ Table's @bottom@ side. + | TopSide -- ^ Table's @top@ side. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue CaptionSide where + toPropBuilder BottomSide = fromByteString "bottom" + toPropBuilder TopSide = fromByteString "top" + + +-- | Clipping modes. + +data ClipMode a + -- | Rectangular clipping region. + = ClipRect (AutoLen Length a) + (AutoLen Length a) + (AutoLen Length a) + (AutoLen Length a) + deriving (Eq, Ord, Show, Typeable) + +instance (Real a) => ToPropValue (ClipMode a) where + toPropBuilder (ClipRect t r b l) = + fromByteString "rect(" <> + toPropBuilder t <> fromChar ',' <> + toPropBuilder r <> fromChar ',' <> + toPropBuilder b <> fromChar ',' <> + toPropBuilder l <> fromChar ')' + + +-- | Parts for the @content@ property. + +data ContentPart url + = AttrPart ByteString -- ^ @attr(x)@ part. + | CloseQuotePart -- ^ @close-quote@ part. + | CounterPart ByteString (Maybe ListStyle) -- ^ @counter(x, y)@ part. + | CountersPart ByteString Text (Maybe ListStyle) -- ^ @counters(x, y)@ part. + | NoCloseQuotePart -- ^ @no-close-quote@ part. + | NoOpenQuotePart -- ^ @no-open-quote@ part. + | OpenQuotePart -- ^ @open-quote@ part. + | TextPart (CssString Text) -- ^ Text part. + | UriPart url -- ^ @url(x)@ part. + deriving (Data, Eq, Functor, Ord, Read, Show, Typeable) + +instance IsString (ContentPart url) where + fromString = TextPart . fromString + +instance (ToPropValue url) => ToPropValue (ContentPart url) where + toPropBuilder part = + case part of + AttrPart attr -> bs "attr(" <> bs attr <> ch ')' + CloseQuotePart -> bs "close-quote" + NoCloseQuotePart -> bs "no-close-quote" + NoOpenQuotePart -> bs "no-open-quote" + OpenQuotePart -> bs "open-quote" + UriPart url -> toPropBuilder url + CounterPart name (Just DecimalList) -> + bs "counter(" <> bs name <> ch ')' + CounterPart name style -> + bs "counter(" <> + bs name <> ch ',' <> + maybeBuilder "none" style <> + ch ')' + CountersPart name sep (Just DecimalList) -> + bs "counters(" <> + bs name <> ch ',' <> + cssString sep <> + ch ')' + CountersPart name sep style -> + bs "counters(" <> + bs name <> ch ',' <> + cssString sep <> ch ',' <> + maybeBuilder "none" style <> + ch ')' + TextPart text -> toPropBuilder text + + where + bs = fromByteString + ch = fromChar + + +-- | CSS strings. + +newtype CssString a = CssString { getCssString :: a } + deriving (Data, Eq, Foldable, Functor, Ord, Read, Show, Traversable, Typeable) + +instance (IsString a) => IsString (CssString a) where + fromString = CssString . fromString + +instance ToPropValue (CssString Text) where + toPropBuilder = cssString . getCssString + + +-- | CSS URLs. + +newtype CssUrl a = CssUrl { getCssUrl :: a } + deriving (Data, Eq, Foldable, Functor, Ord, Read, Show, Traversable, Typeable) + +instance (IsString a) => IsString (CssUrl a) where + fromString = CssUrl . fromString + +instance ToPropValue (CssUrl Text) where + toPropBuilder (CssUrl url) = + fromByteString "url(" <> + cssString url <> + fromChar ')' + + +-- | Cursors. + +data Cursor url + = CrosshairCursor -- ^ @crosshair@ cursor. + | CursorFrom [url] -- ^ Cursor from one of the given URLs. + | DefaultCursor -- ^ @default@ cursor. + | EResizeCursor -- ^ @e-resize@ cursor. + | HelpCursor -- ^ @help@ cursor. + | MoveCursor -- ^ @move@ cursor. + | NResizeCursor -- ^ @n-resize@ cursor. + | NeResizeCursor -- ^ @ne-resize@ cursor. + | NwResizeCursor -- ^ @nw-resize@ cursor. + | PointerCursor -- ^ @pointer@ cursor. + | ProgressCursor -- ^ @progress@ cursor. + | SResizeCursor -- ^ @s-resize@ cursor. + | SeResizeCursor -- ^ @se-resize@ cursor. + | SwResizeCursor -- ^ @sw-resize@ cursor. + | TextCursor -- ^ @text@ cursor. + | WResizeCursor -- ^ @w-resize@ cursor. + | WaitCursor -- ^ @wait@ cursor. + deriving (Data, Eq, Foldable, Functor, Ord, Read, Show, Typeable, Traversable) + +instance (ToPropValue url) => ToPropValue (Cursor url) where + toPropBuilder CrosshairCursor = fromByteString "crosshair" + toPropBuilder DefaultCursor = fromByteString "default" + toPropBuilder EResizeCursor = fromByteString "e-resize" + toPropBuilder HelpCursor = fromByteString "help" + toPropBuilder MoveCursor = fromByteString "move" + toPropBuilder NResizeCursor = fromByteString "n-resize" + toPropBuilder NeResizeCursor = fromByteString "ne-resize" + toPropBuilder NwResizeCursor = fromByteString "nw-resize" + toPropBuilder PointerCursor = fromByteString "pointer" + toPropBuilder ProgressCursor = fromByteString "progress" + toPropBuilder SResizeCursor = fromByteString "s-resize" + toPropBuilder SeResizeCursor = fromByteString "se-resize" + toPropBuilder SwResizeCursor = fromByteString "sw-resize" + toPropBuilder TextCursor = fromByteString "text" + toPropBuilder WResizeCursor = fromByteString "w-resize" + toPropBuilder WaitCursor = fromByteString "wait" + toPropBuilder (CursorFrom us) = + fold . + intersperse (fromChar ',') . + map toPropBuilder $ us + + +-- | Display modes. + +data DisplayMode + = BlockDisplay -- ^ @block@ display. + | InlineBlockDisplay -- ^ @inline-block@ display. + | InlineDisplay -- ^ @inline@ display. + | ListItemDisplay -- ^ @list-item@ display + | NoneDisplay -- ^ @none@ display. + + | TableDisplay -- ^ @table@ display. + | InlineTableDisplay -- ^ @inline-table@ display. + | TableRowGroupDisplay -- ^ @table-row-group@ display. + | TableColumnDisplay -- ^ @table-column@ display. + | TableColumnGroupDisplay -- ^ @table-column-group@ display. + | TableHeaderGroupDisplay -- ^ @table-header-group@ display. + | TableFooterGroupDisplay -- ^ @table-footer-group@ display. + | TableRowDisplay -- ^ @table-row@ display. + | TableCellDisplay -- ^ @table-cell@ display. + | TableCaptionDisplay -- ^ @table-caption@ display. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue DisplayMode where + toPropBuilder BlockDisplay = fromByteString "block" + toPropBuilder InlineBlockDisplay = fromByteString "inline-block" + toPropBuilder InlineDisplay = fromByteString "inline" + toPropBuilder InlineTableDisplay = fromByteString "inline-table" + toPropBuilder ListItemDisplay = fromByteString "list-item" + toPropBuilder NoneDisplay = fromByteString "none" + toPropBuilder TableCaptionDisplay = fromByteString "table-caption" + toPropBuilder TableCellDisplay = fromByteString "table-cell" + toPropBuilder TableColumnDisplay = fromByteString "table-column" + toPropBuilder TableColumnGroupDisplay = fromByteString "table-column-group" + toPropBuilder TableDisplay = fromByteString "table" + toPropBuilder TableFooterGroupDisplay = fromByteString "table-footer-group" + toPropBuilder TableHeaderGroupDisplay = fromByteString "table-header-group" + toPropBuilder TableRowDisplay = fromByteString "table-row" + toPropBuilder TableRowGroupDisplay = fromByteString "table-row-group" + + +-- | Edge-oriented specifications. + +data Edge a + = Edges [a] -- ^ All edges. + | BottomEdge a -- ^ Bottom edge. + | LeftEdge a -- ^ Left edge. + | RightEdge a -- ^ Right edge. + | TopEdge a -- ^ Top edge. + deriving (Data, Eq, Foldable, Functor, Ord, Read, Show, Traversable, Typeable) + + +-- | Length transformer to add percental lengths. + +data FactorLen len a = FactorLen a | NoFactorLen (len a) + deriving (Eq, Ord, Show) + +instance (HasAutoLength len) => HasAutoLength (FactorLen len) where + autoLen = NoFactorLen autoLen + +instance (HasLength len) => HasLength (FactorLen len) where + _Cm = _NoFactorLen . _Cm + _Em = _NoFactorLen . _Em + _Ex = _NoFactorLen . _Ex + _Mm = _NoFactorLen . _Mm + _Px = _NoFactorLen . _Px + zeroLen = NoFactorLen zeroLen + +instance HasPercent (FactorLen len) where + _Factor = prism FactorLen ex + where + ex (FactorLen x) = Right x + ex len = Left len + +instance (Real a, ToPropValue (len a)) => ToPropValue (FactorLen len a) where + toPropBuilder (FactorLen x) = showReal (100*x) <> fromChar '%' + toPropBuilder (NoFactorLen l) = toPropBuilder l + + +-- | Floating edge. + +data FloatEdge = LeftFloat | RightFloat + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue FloatEdge where + toPropBuilder LeftFloat = fromByteString "left" + toPropBuilder RightFloat = fromByteString "right" + + +-- | Font families. + +data FontFamily + = CursiveFont -- ^ Generic @cursive@ font. + | FantasyFont -- ^ Generic @fantasy@ font. + | MonospaceFont -- ^ Generic @monospace@ font. + | SansSerifFont -- ^ Generic @sans-serif@ font. + | SerifFont -- ^ Generic @serif@ font. + | NamedFont (CssString Text) -- ^ Specific named font. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance IsString FontFamily where + fromString = NamedFont . fromString + +instance ToPropValue FontFamily where + toPropBuilder CursiveFont = fromByteString "cursive" + toPropBuilder FantasyFont = fromByteString "fantasy" + toPropBuilder MonospaceFont = fromByteString "monospace" + toPropBuilder SansSerifFont = fromByteString "sans-serif" + toPropBuilder SerifFont = fromByteString "serif" + toPropBuilder (NamedFont ff) = toPropBuilder ff + + +-- | Font sizes. + +data FontSize a + = XXSmallSize -- ^ Absolutely @xx-small@ size. + | XSmallSize -- ^ Absolutely @x-small@ size. + | SmallSize -- ^ Absolutely @small@ size. + | MediumSize -- ^ Absolutely @medium@ size. + | LargeSize -- ^ Absolutely @large@ size. + | XLargeSize -- ^ Absolutely @x-large@ size. + | XXLargeSize -- ^ Absolutely @xx-large@ size. + + | LargerSize -- ^ Relatively @larger@ size. + | SmallerSize -- ^ Relatively @smaller@ size. + + | LengthSize (FactorLen Length a) -- ^ Specific font size. + deriving (Eq, Ord, Show, Typeable) + +instance HasLength FontSize where + _Em = _LengthSize . _Em + _Ex = _LengthSize . _Ex + _Mm = _LengthSize . _Mm + _Px = _LengthSize . _Px + zeroLen = LengthSize zeroLen + +instance HasPercent FontSize where + _Factor = _LengthSize . _Factor + +instance (Real a) => ToPropValue (FontSize a) where + toPropBuilder LargeSize = fromByteString "large" + toPropBuilder LargerSize = fromByteString "larger" + toPropBuilder MediumSize = fromByteString "medium" + toPropBuilder SmallSize = fromByteString "small" + toPropBuilder SmallerSize = fromByteString "smaller" + toPropBuilder XLargeSize = fromByteString "x-large" + toPropBuilder XSmallSize = fromByteString "x-small" + toPropBuilder XXLargeSize = fromByteString "xx-large" + toPropBuilder XXSmallSize = fromByteString "xx-small" + toPropBuilder (LengthSize l) = toPropBuilder l + + +-- | Font styles. + +data FontStyle + = ItalicStyle -- ^ Select @italic@ style. + | ObliqueStyle -- ^ Select @oblique@ style. + | NormalStyle -- ^ Select @normal@ style. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue FontStyle where + toPropBuilder ItalicStyle = fromByteString "italic" + toPropBuilder ObliqueStyle = fromByteString "oblique" + toPropBuilder NormalStyle = fromByteString "normal" + + +-- | Font variants. + +data FontVariant + = NormalVariant -- ^ Select @normal@ font. + | SmallCapsVariant -- ^ Select @small-caps@ font. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue FontVariant where + toPropBuilder NormalVariant = fromByteString "normal" + toPropBuilder SmallCapsVariant = fromByteString "small-caps" + + +-- | Font weight. + +data FontWeight + = BolderWeight -- ^ Relatively @bolder@ font weight. + | LighterWeight -- ^ Relatively @lighter@ font weight. + | FontWeight Int -- ^ Specific font weight (1-9), 4 = @normal@, 7 = @bold@. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue FontWeight where + toPropBuilder BolderWeight = fromByteString "bolder" + toPropBuilder LighterWeight = fromByteString "lighter" + toPropBuilder (FontWeight 4) = fromByteString "normal" + toPropBuilder (FontWeight 7) = fromByteString "bold" + toPropBuilder (FontWeight w) = showReal (100*w) + + +-- | Length transformer to add lengths in various CSS units. + +data Length a + = EmLen a -- ^ Font sizes. + | ExLen a -- ^ Vertical sizes of the letter @x@. + | MmLen a -- ^ Millimeters. + | PxLen a -- ^ Pixels. + | ZeroLen -- ^ Zero. + deriving (Eq, Ord, Show, Typeable) + +instance HasLength Length where + _Em = prism (orZeroLen EmLen) ex + where + ex (EmLen x) = Right x + ex ZeroLen = Right 0 + ex len = Left len + + _Ex = prism (orZeroLen ExLen) ex + where + ex (ExLen x) = Right x + ex ZeroLen = Right 0 + ex len = Left len + + _Mm = prism (orZeroLen MmLen) ex + where + ex (MmLen x) = Right x + ex ZeroLen = Right 0 + ex len = Left len + + _Px = prism (orZeroLen PxLen) ex + where + ex (PxLen x) = Right x + ex ZeroLen = Right 0 + ex len = Left len + + zeroLen = ZeroLen + +instance (Real a) => ToPropValue (Length a) where + toPropBuilder (EmLen x) = showReal x <> fromByteString "em" + toPropBuilder (ExLen x) = showReal x <> fromByteString "ex" + toPropBuilder (MmLen x) = showReal x <> fromByteString "mm" + toPropBuilder (PxLen x) = showReal x <> fromByteString "px" + toPropBuilder ZeroLen = fromChar '0' + + +-- | List number/bullet position. + +data ListPosition + = InsideList -- ^ @inside@ the box. + | OutsideList -- ^ @outside@ of the box. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue ListPosition where + toPropBuilder InsideList = fromByteString "inside" + toPropBuilder OutsideList = fromByteString "outside" + + +-- | List number/bullet styles. + +data ListStyle + = ArmenianList -- ^ @armenian@ numbering. + | CircleList -- ^ @circle@ bullets. + | DecimalLeadingZeroList -- ^ @decimal-leading-zero@ numbering. + | DecimalList -- ^ @decimal@ numbering. + | DiscList -- ^ @disc@ bullets. + | GeorgianList -- ^ @georgian@ numbering. + | LowerAlphaList -- ^ @lower-alpha@ numbering. + | LowerGreekList -- ^ @lower-greek@ numbering. + | LowerLatinList -- ^ @lower-latin@ numbering. + | LowerRomanList -- ^ @lower-roman@ numbering. + | SquareList -- ^ @square@ bullets. + | UpperAlphaList -- ^ @upper-alpha@ numbering. + | UpperLatinList -- ^ @upper-latin@ numbering. + | UpperRomanList -- ^ @upper-roman@ numbering. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue ListStyle where + toPropBuilder ArmenianList = fromByteString "armenian" + toPropBuilder CircleList = fromByteString "circle" + toPropBuilder DecimalLeadingZeroList = fromByteString "decimal-leading-zero" + toPropBuilder DecimalList = fromByteString "decimal" + toPropBuilder DiscList = fromByteString "disc" + toPropBuilder GeorgianList = fromByteString "georgian" + toPropBuilder LowerAlphaList = fromByteString "lower-alpha" + toPropBuilder LowerGreekList = fromByteString "lower-greek" + toPropBuilder LowerLatinList = fromByteString "lower-latin" + toPropBuilder LowerRomanList = fromByteString "lower-roman" + toPropBuilder SquareList = fromByteString "square" + toPropBuilder UpperAlphaList = fromByteString "upper-alpha" + toPropBuilder UpperLatinList = fromByteString "upper-latin" + toPropBuilder UpperRomanList = fromByteString "upper-roman" + + +-- | Overflow handling mode. + +data OverflowMode + = AutoOverflow -- ^ @auto@ overflow handling. + | HiddenOverflow -- ^ @hidden@ overflow handling. + | ScrollOverflow -- ^ @scroll@ overflow handling. + | VisibleOverflow -- ^ @visible@ overflow handling. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue OverflowMode where + toPropBuilder AutoOverflow = fromByteString "auto" + toPropBuilder HiddenOverflow = fromByteString "hidden" + toPropBuilder ScrollOverflow = fromByteString "scroll" + toPropBuilder VisibleOverflow = fromByteString "visible" + + +-- | Page break rules. + +data PageBreak :: * -> * where + AlwaysBreak :: PageBreak AnyBreak + AvoidBreak :: PageBreak InsideBreak + LeftBreak :: PageBreak AnyBreak + RightBreak :: PageBreak AnyBreak + +instance ToPropValue (PageBreak a) where + toPropBuilder AlwaysBreak = fromByteString "always" + toPropBuilder AvoidBreak = fromByteString "avoid" + toPropBuilder LeftBreak = fromByteString "left" + toPropBuilder RightBreak = fromByteString "right" + +-- | Page break context: any. +data AnyBreak + +-- | Page break context: @page-break-inside@. +data InsideBreak + + +-- | Page selectors for paged media. + +data PageSelector + = AllPages -- ^ Select all pages (@\@page@). + | FirstPage -- ^ Select first page (@\@page :first@). + | LeftPages -- ^ Select all left pages (@\@page :left@). + | RightPages -- ^ Select all right pages (@\@page :right@). + deriving (Data, Eq, Ord, Read, Show, Typeable) + + +-- | Position modes. + +data PositionMode + = AbsolutePos -- ^ @absolute@ positioning. + | FixedPos -- ^ @fixed@ positioning. + | RelativePos -- ^ @relative@ positioning. + | StaticPos -- ^ @static@ positioning. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue PositionMode where + toPropBuilder AbsolutePos = fromByteString "absolute" + toPropBuilder FixedPos = fromByteString "fixed" + toPropBuilder RelativePos = fromByteString "relative" + toPropBuilder StaticPos = fromByteString "static" + + +-- | Table layout. + +data TableLayout + = AutoLayout -- ^ @auto@ layout. + | FixedLayout -- ^ @fixed@ layout. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TableLayout where + toPropBuilder AutoLayout = fromByteString "auto" + toPropBuilder FixedLayout = fromByteString "fixed" + + +-- | Text alignment. + +data TextAlign + = CenterAlign -- ^ @center@ alignment. + | JustifyAlign -- ^ @justify@ alignment. + | LeftAlign -- ^ @left@ alignment. + | RightAlign -- ^ @right@ alignment. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TextAlign where + toPropBuilder CenterAlign = fromByteString "center" + toPropBuilder JustifyAlign = fromByteString "justify" + toPropBuilder LeftAlign = fromByteString "left" + toPropBuilder RightAlign = fromByteString "right" + + +-- | Text decoration. + +data TextDecoration + = BlinkText -- ^ @blink@ text. + | LineThroughText -- ^ @line-through@ text. + | OverlineText -- ^ @overline@ text. + | UnderlineText -- ^ @underline@ text. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TextDecoration where + toPropBuilder BlinkText = fromByteString "blink" + toPropBuilder LineThroughText = fromByteString "line-through" + toPropBuilder OverlineText = fromByteString "overline" + toPropBuilder UnderlineText = fromByteString "underline" + + +-- | Text direction. + +data TextDirection + = LeftToRight + | RightToLeft + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TextDirection where + toPropBuilder LeftToRight = fromByteString "ltr" + toPropBuilder RightToLeft = fromByteString "rtl" + + +-- | Text transformation modes. + +data TextTransform + = CapitalizeText -- ^ @capitalize@ transform. + | LowercaseText -- ^ @lowercase@ transform. + | UppercaseText -- ^ @uppercase@ transform. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TextTransform where + toPropBuilder CapitalizeText = fromByteString "capitalize" + toPropBuilder LowercaseText = fromByteString "lowercase" + toPropBuilder UppercaseText = fromByteString "uppercase" + + +-- | Text wrapping modes. + +data TextWrapMode + = NormalWrapping -- ^ @normal@ wrapping. + | NowrapWrapping -- ^ @nowrap@ wrapping. + | PreLineWrapping -- ^ @pre-line@ wrapping. + | PreWrapWrapping -- ^ @pre-wrap@ wrapping. + | PreWrapping -- ^ @pre@ wrapping. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue TextWrapMode where + toPropBuilder NormalWrapping = fromByteString "normal" + toPropBuilder NowrapWrapping = fromByteString "nowrap" + toPropBuilder PreLineWrapping = fromByteString "pre-line" + toPropBuilder PreWrapWrapping = fromByteString "pre-wrap" + toPropBuilder PreWrapping = fromByteString "pre" + + +-- | Unicode bidi embedding mode. + +data UnicodeBidiMode + = EmbedBidi -- ^ @embed@ mode. + | NormalBidi -- ^ @normal@ mode. + | OverrideBidi -- ^ @bidi-override@ mode. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue UnicodeBidiMode where + toPropBuilder EmbedBidi = fromByteString "embed" + toPropBuilder NormalBidi = fromByteString "normal" + toPropBuilder OverrideBidi = fromByteString "bidi-override" + + +-- | Vertical text/box alignment. + +data VerticalAlign a + = BaselineAlign + | BottomAlign + | LengthAlign (FactorLen Length a) + | MiddleAlign + | SubAlign + | SuperAlign + | TextBottomAlign + | TextTopAlign + | TopAlign + deriving (Eq, Ord, Show, Typeable) + +instance HasLength VerticalAlign where + _Em = _LengthAlign . _Em + _Ex = _LengthAlign . _Ex + _Mm = _LengthAlign . _Mm + _Px = _LengthAlign . _Px + zeroLen = LengthAlign zeroLen + +instance HasPercent VerticalAlign where + _Factor = _LengthAlign . _Factor + +instance (Real a) => ToPropValue (VerticalAlign a) where + toPropBuilder BaselineAlign = fromByteString "baseline" + toPropBuilder BottomAlign = fromByteString "bottom" + toPropBuilder MiddleAlign = fromByteString "middle" + toPropBuilder SubAlign = fromByteString "sub" + toPropBuilder SuperAlign = fromByteString "super" + toPropBuilder TextBottomAlign = fromByteString "text-bottom" + toPropBuilder TextTopAlign = fromByteString "text-top" + toPropBuilder TopAlign = fromByteString "top" + toPropBuilder (LengthAlign x) = toPropBuilder x + + +-- | Visibility modes. + +data VisibilityMode + = CollapseVisibility -- ^ @collapse@ visibility. + | HiddenVisibility -- ^ @hidden@ visibility. + | VisibleVisibility -- ^ @visible@ visibility. + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance ToPropValue VisibilityMode where + toPropBuilder CollapseVisibility = fromByteString "collapse" + toPropBuilder HiddenVisibility = fromByteString "hidden" + toPropBuilder VisibleVisibility = fromByteString "visible" + + +-- | Helper prism for border widths. + +_BorderWidth :: Prism' (BorderWidth a) (Length a) +_BorderWidth = prism BorderWidth ex + where + ex (BorderWidth l) = Right l + ex w = Left w + + +-- | Helper prism for 'VerticalAlign'. + +_LengthAlign :: Prism' (VerticalAlign a) (FactorLen Length a) +_LengthAlign = prism LengthAlign ex + where + ex (LengthAlign x) = Right x + ex va = Left va + + +-- | Helper prism for 'FontSize'. + +_LengthSize :: Prism' (FontSize a) (FactorLen Length a) +_LengthSize = prism LengthSize ex + where + ex (LengthSize x) = Right x + ex fs = Left fs + + +-- | Helper prism for non-automatic lengths. + +_NoAutoLen :: Prism' (AutoLen len a) (len a) +_NoAutoLen = prism NoAutoLen ex + where + ex (NoAutoLen l) = Right l + ex len = Left len + + +-- | Helper prism for non-automatic lengths. + +_NoFactorLen :: Prism' (FactorLen len a) (len a) +_NoFactorLen = prism NoFactorLen ex + where + ex (NoFactorLen l) = Right l + ex len = Left len + + +-- | Helper function to convert a length to 'zeroLen' if it's zero. + +orZeroLen :: (Eq a, HasLength len, Num a) => (a -> len a) -> (a -> len a) +orZeroLen _ 0 = zeroLen +orZeroLen f x = f x diff --git a/Data/CSS/Properties/UI.hs b/Data/CSS/Properties/UI.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/UI.hs @@ -0,0 +1,69 @@ +-- | +-- Module: Data.CSS.Properties.UI +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.UI + ( -- * Cursor + cursor, + cursorUrl, + + -- * Outlines + outline, + outlineColor, + outlineStyle, + outlineWidth + ) + where + +import Data.Colour +import Data.CSS.Build +import Data.CSS.Properties.Types +import Data.CSS.Properties.Utils +import Data.CSS.Types +import Data.Text (Text) +import Web.Routes.RouteT + + +-- | Set the @cursor@ to the specified value or @auto@. + +cursor :: Maybe (Cursor (CssUrl Text)) -> SetProp +cursor = setProp "cursor" . maybeProp "auto" + + +-- | Set the @cursor@ to the specified value or @auto@. + +cursorUrl :: (MonadRoute m) => Maybe (Cursor (URL m)) -> SetPropM m +cursorUrl c = do + renderUrl <- askRouteFn + cursor . fmap (fmap (CssUrl . flip renderUrl [])) $ c + + +-- | Set the @outline@ properties. + +outline :: + (ColourOps f, Real b, ToPropValue (f a)) + => Maybe (f a) -- ^ Color or @invert@. + -> BorderStyle -- ^ Outline style. + -> BorderWidth b -- ^ Outline width. + -> SetProp +outline col style w = setProp "outline" (maybeProp "invert" col, style, w) + + +-- | Set the @outline-color@ to the given color or @invert@. + +outlineColor :: (ColourOps f, ToPropValue (f a)) => Maybe (f a) -> SetProp +outlineColor = setProp "outline-color" . maybeProp "invert" + + +-- | Set the @outline-style@. + +outlineStyle :: BorderStyle -> SetProp +outlineStyle = setProp "outline-style" + + +-- | Set the @outline-width@. + +outlineWidth :: (Real a) => BorderWidth a -> SetProp +outlineWidth = setProp "outline-width" diff --git a/Data/CSS/Properties/Utils.hs b/Data/CSS/Properties/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Properties/Utils.hs @@ -0,0 +1,30 @@ +-- | +-- Module: Data.CSS.Properties.Utils +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Properties.Utils + ( -- * Maybe builders + maybeBuilder, + maybeProp + ) + where + +import Blaze.ByteString.Builder +import Data.ByteString (ByteString) +import Data.CSS.Types + + +-- | Convenience wrapper around 'maybe' for properties. Renders as the +-- given bytestring if 'Nothing'. + +maybeBuilder :: (ToPropValue a) => ByteString -> Maybe a -> Builder +maybeBuilder str = maybe (fromByteString str) toPropBuilder + + +-- | Convenience wrapper around 'maybe' for properties. Renders as the +-- given bytestring if 'Nothing'. + +maybeProp :: (ToPropValue a) => ByteString -> Maybe a -> PropValue +maybeProp str = maybe (PropValue str) toPropValue diff --git a/Data/CSS/Render.hs b/Data/CSS/Render.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Render.hs @@ -0,0 +1,81 @@ +-- | +-- Module: Data.CSS.Render +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Render + ( -- * Rendering + renderCSS, + renderCSST, + -- ** Helpers + fromCSS + ) + where + +import qualified Data.Map as M +import qualified Data.Set as S +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Control.Monad.Writer +import Data.CSS.Types +import Data.CSS.Utils +import Data.Foldable (fold, foldMap) +import Data.List + + +-- | Render the given raw stylesheet to a 'Builder'. + +fromCSS :: CSS -> Builder +fromCSS (CSS imports medias) = + foldMap (uncurry fromImport) (M.toAscList imports) <> + foldMap (uncurry media) (M.toAscList medias) + + where + bs = fromByteString + + fromImport uri mts + | S.member "all" mts = bs "@import url(" <> cssString uri <> bs ");" + | otherwise = + bs "@import url(" <> cssString uri <> fromChar ')' <> + (fold . intersperse (fromChar ',') . map (bs . _mediaTypeStr) . S.toAscList) mts <> + fromChar ';' + + media mts props + | null props = mempty + | S.null mts = mempty + | S.member "all" mts = properties0 props + | otherwise = + bs "@media " <> + (commasBS . map _mediaTypeStr . S.toList) mts <> + fromChar '{' <> + properties0 props <> + fromChar '}' + + properties0 [] = mempty + properties0 (Property sels (PropName name) (PropValue val) imp : props) = + (commasBS . map _selectorStr) sels <> fromChar '{' <> + bs name <> fromChar ':' <> bs val <> + (if imp then fromByteString " !important" else mempty) <> + properties sels props + + properties _ [] = fromChar '}' + properties sels' props0@(Property sels (PropName name) (PropValue val) imp : props) + | sels' == sels = + fromChar ';' <> + bs name <> fromChar ':' <> bs val <> + (if imp then fromByteString " !important" else mempty) <> + properties sels props + | otherwise = fromChar '}' <> properties0 props0 + + +-- | Render the given stylesheet. + +renderCSS :: Writer CSS a -> Builder +renderCSS = fromCSS . execWriter + + +-- | Render the given stylesheet. + +renderCSST :: (Monad m) => WriterT CSS m a -> m Builder +renderCSST = liftM fromCSS . execWriterT diff --git a/Data/CSS/Types.hs b/Data/CSS/Types.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Types.hs @@ -0,0 +1,245 @@ +-- | +-- Module: Data.CSS.Types +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +{-# LANGUAGE IncoherentInstances #-} + +module Data.CSS.Types + ( -- * Style sheets + CSS(..), cssImports, cssProps, + Property(..), propName, propSelector, propValue, propImportant, + -- ** CSS building + BuildCfg(..), bcMedia, bcSelector, + SetProp, + SetPropM, + -- ** Auxiliary types + MediaType(..), mediaTypeStr, + PropName(..), propNameStr, + PropValue(..), propValueStr, + Selector(..), selectorStr, + + -- * Type classes + ToPropValue(..) + ) + where + +import qualified Data.ByteString.Char8 as Bc +import qualified Data.ByteString.Lazy as Bl +import qualified Data.ByteString.UTF8 as Bu +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as Tl +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 as Blaze +import Control.Lens.TH +import Control.Monad.Reader.Class +import Control.Monad.Writer.Class +import Data.Bits +import Data.ByteString (ByteString) +import Data.Char +import Data.Colour +import Data.Colour.SRGB +import Data.Colour.SRGB.Linear +import Data.CSS.Utils +import Data.Data +import Data.Int +import Data.Map (Map) +import Data.Monoid +import Data.Ratio +import Data.Set (Set) +import Data.String +import Data.Text (Text) +import Data.Word + + +-- | Types that feature a conversion function to 'PropValue'. + +class ToPropValue a where + toPropBuilder :: a -> Builder + toPropBuilder = fromByteString . _propValueStr . toPropValue + + toPropValue :: a -> PropValue + toPropValue = PropValue . toByteString . toPropBuilder + +instance ToPropValue Double where toPropBuilder = showReal +instance ToPropValue Float where toPropBuilder = showReal +instance ToPropValue Int where toPropBuilder = showReal +instance ToPropValue Int8 where toPropBuilder = showReal +instance ToPropValue Int16 where toPropBuilder = showReal +instance ToPropValue Int32 where toPropBuilder = showReal +instance ToPropValue Int64 where toPropBuilder = showReal +instance ToPropValue Integer where toPropBuilder = showReal +instance ToPropValue Word where toPropBuilder = showReal +instance ToPropValue Word8 where toPropBuilder = showReal +instance ToPropValue Word16 where toPropBuilder = showReal +instance ToPropValue Word32 where toPropBuilder = showReal +instance ToPropValue Word64 where toPropBuilder = showReal +instance (Integral a) => ToPropValue (Ratio a) where toPropBuilder = showReal + +instance ToPropValue ByteString where toPropValue = PropValue +instance ToPropValue Bl.ByteString where toPropValue = PropValue . Bl.toStrict +instance ToPropValue Char where toPropValue = PropValue . Bu.fromString . return +instance ToPropValue [Char] where toPropValue = PropValue . Bu.fromString +instance ToPropValue Text where toPropValue = PropValue . T.encodeUtf8 +instance ToPropValue Tl.Text where toPropValue = PropValue . T.encodeUtf8 . Tl.toStrict + +instance (Floating a, RealFrac a) => ToPropValue (AlphaColour a) where + toPropBuilder col + | t >= 1 = toPropBuilder col' + | t <= 0 = fromByteString "rgba(0,0,0,0)" + | otherwise = + fromByteString "rgba(" <> + Blaze.fromString (show r) <> fromChar ',' <> + Blaze.fromString (show g) <> fromChar ',' <> + Blaze.fromString (show b) <> fromChar ',' <> + showReal t <> fromChar ')' + + where + t = alphaChannel col + RGB r' g' b' = fmap (/ t) . toRGB $ col `over` black + col' = rgb r' g' b' + RGB r g b = toSRGB24 col' + +instance (Floating a, RealFrac a) => ToPropValue (Colour a) where + toPropBuilder col = + fromChar '#' <> + maybe (colorHex r <> colorHex g <> colorHex b) id + (fmap mconcat $ mapM colorShortHex [r, g, b]) + + where + RGB r g b = toSRGB24 col + +instance (ToPropValue a) => ToPropValue [a] where + toPropValue = + PropValue . + Bc.intercalate " " . + map (_propValueStr . toPropValue) + +instance (ToPropValue a, ToPropValue b) => ToPropValue (a, b) where + toPropBuilder (a, b) = + toPropBuilder a <> fromChar ' ' <> toPropBuilder b + +instance (ToPropValue a, ToPropValue b, ToPropValue c) => ToPropValue (a, b, c) where + toPropBuilder (a, b, c) = + toPropBuilder a <> fromChar ' ' <> + toPropBuilder b <> fromChar ' ' <> + toPropBuilder c + + +-- | CSS builder configuration. + +data BuildCfg = + BuildCfg { + _bcMedia :: Set MediaType, -- ^ Current media type. + _bcSelector :: [Selector] -- ^ Current selector. + } + deriving (Data, Eq, Ord, Read, Show, Typeable) + + +-- | Cascading style sheets. + +data CSS = + CSS { + _cssImports :: Map Text (Set MediaType), -- ^ External stylesheets (url, media-type). + _cssProps :: Map (Set MediaType) [Property] -- ^ Properties. + } + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance Monoid CSS where + mempty = CSS M.empty M.empty + + mappend (CSS is1 ps1) (CSS is2 ps2) = + CSS (M.unionWith S.union is1 is2) (M.unionWith (++) ps1 ps2) + + +-- | Media types, e.g. @all@ or @print@. + +newtype MediaType = MediaType { _mediaTypeStr :: ByteString } + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance IsString MediaType where + fromString = MediaType . Bu.fromString + + +-- | Style properties. + +data Property = + Property { + _propSelector :: [Selector], -- ^ Selector for this property. + _propName :: PropName, -- ^ Property name. + _propValue :: PropValue, -- ^ Property value. + _propImportant :: Bool -- ^ @!important@ property? + } + deriving (Data, Eq, Ord, Read, Show, Typeable) + + +-- | Property names, e.g. @font-family@. + +newtype PropName = PropName { _propNameStr :: ByteString } + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance IsString PropName where + fromString = PropName . Bu.fromString + + +-- | Property values, e.g. @sans-serif@. + +newtype PropValue = PropValue { _propValueStr :: ByteString } + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance IsString PropValue where + fromString = PropValue . Bu.fromString + +instance ToPropValue PropValue where + toPropValue = id + + +-- | Selectors, e.g. @*@ or @#content p@. + +newtype Selector = Selector { _selectorStr :: ByteString } + deriving (Data, Eq, Ord, Read, Show, Typeable) + +instance IsString Selector where + fromString = Selector . Bu.fromString + + +-- | Property setter. + +type SetProp = forall m. SetPropM m + + +-- | Parametric property setter. + +type SetPropM m = (MonadReader BuildCfg m, MonadWriter CSS m) => m () + + +-- | Convert the given color byte to its hex representation. + +colorHex :: Word8 -> Builder +colorHex x = + fromChar (intToDigit (fromIntegral $ shiftR x 4)) <> + fromChar (intToDigit (fromIntegral $ x .&. 0x0F)) + + +-- | Convert the given color byte to its short hex representation if +-- available. + +colorShortHex :: Word8 -> Maybe Builder +colorShortHex x + | hi == lo = Just (fromChar (intToDigit (fromIntegral lo))) + | otherwise = Nothing + where + hi = shiftR x 4 + lo = x .&. 0x0F + + +makeLenses ''BuildCfg +makeLenses ''CSS +makeLenses ''MediaType +makeLenses ''Property +makeLenses ''PropName +makeLenses ''PropValue +makeLenses ''Selector diff --git a/Data/CSS/Utils.hs b/Data/CSS/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/CSS/Utils.hs @@ -0,0 +1,95 @@ +-- | +-- Module: Data.CSS.Utils +-- Copyright: (c) 2013 Ertugrul Soeylemez +-- License: BSD3 +-- Maintainer: Ertugrul Soeylemez + +module Data.CSS.Utils + ( -- * Builder utilities + commas, + commasBS, + cssString, + showHexInt, + showReal + ) + where + +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 +import Data.ByteString (ByteString) +import Data.Char +import Data.Foldable (fold) +import Data.List +import Data.Monoid +import Data.Text (Text) + + +-- | Render the given list of builders separated by commas. + +commas :: [Builder] -> Builder +commas = fold . intersperse (fromChar ',') + + +-- | Render the given list of builders separated by commas. + +commasBS :: [ByteString] -> Builder +commasBS = commas . map fromByteString + + +-- | Renders the given CSS string in double-quotes, escaped as +-- necessary. + +cssString :: Text -> Builder +cssString s0 = fromChar '"' <> str s0 <> fromChar '"' + where + str s' = + case T.uncons s' of + Nothing -> mempty + Just ('"', s) -> fromByteString "\\\"" <> str s + Just ('\\', s) -> fromByteString "\\\\" <> str s + Just (c, s) + | isControl c -> fromChar '\\' <> showHexInt 6 (ord c) <> str s + | otherwise -> fromChar c <> str s + + +-- | @showHexInt p n@ builds the hexadecimal representation of @n@ with +-- at least @p@ digits. Prepends zeroes to fill. + +showHexInt :: (Integral a) => Int -> a -> Builder +showHexInt p n | n < 0 = fromChar '-' <> showHexInt p (negate n) +showHexInt p 0 = fromByteString (B.replicate (max 0 p) '0') +showHexInt p' n' = + p `seq` showHexInt p n <> + fromChar (intToDigit $ fromIntegral r) + + where + (n, r) = quotRem n' 16 + p = max 0 (pred p') + + +-- | Lossily convert the given 'Real' number into a decimal +-- representation suitable for CSS. + +showReal :: (Real a) => a -> Builder +showReal = showRat . toRational + where + showRat x | x < 0 = fromChar '-' <> showRat (negate x) + showRat x = + let (n, f) = properFraction x in + (if n == 0 then fromChar '0' else intP n) <> + (if f == 0 then mempty else fromChar '.' <> fromString (fracP 6 f)) + + intP :: Integer -> Builder + intP 0 = mempty + intP n = let (q, r) = quotRem n 10 in intP q <> fromChar (intToDigit $ fromInteger r) + + fracP _ 0 = "" + fracP 0 _ = "" + fracP i f' + | all (== '0') res = "" + | otherwise = res + where + (n, f) = properFraction (10*f') + res = intToDigit n : fracP (pred i) f diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +cascading license +Copyright (c) 2013, Ertugrul Soeylemez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of the author nor the names of any contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,165 @@ +Cascading +========= + +This library implements a domain-specific language for cascading style +sheets as used in web pages. It allows you to specify your style sheets +in regular Haskell syntax and gives you all the additional power of +server-side document generation. You can find examples below. To see a +full tutorial, have a look at the Haddock documentation of the +`Data.CSS` module. + + +Current status +-------------- + +Right now most of the CSS 2.1 specification is implemented. In +particular all non-appendix properties now have type-safe Haskell +counterparts in `Data.CSS.Properties`. + +The type safety goes very far to ensure conformance with the +specification, but some of it has been sacrificed for convenience and +API simplicity. + +### To do + + * Write automated unit tests. + * Write a pretty printer for debugging. + + +Performance +----------- + +The performance is based on and bound by blaze-builder, so is good +enough for most web applications. For a high-profile web site you may +want to cache the generated stylesheets. The easiest way to do this is +to use regular Haskell sharing. This gets you very close to the best +possible performance: + + stylesheet :: ByteString + stylesheet = + toByteString . renderCSS $ + {- actual stylesheet -} + +If your stylesheet is highly parametric, sharing will not work and you +can use memoization instead. See the [memoize], [MemoTrie] or +[monad-memo]. + +[memoize]: http://hackage.haskell.org/package/memoize +[MemoTrie]: http://hackage.haskell.org/package/MemoTrie +[monad-memo]: http://hackage.haskell.org/package/monad-memo + + +Rendering +--------- + +To render a stylesheet you can use `fromCSS`, `renderCSS` or +`renderCSST`. All of these will give you a `Builder`. You can then use +[blaze-builder] combinators like `toByteString` or `toByteStringIO` to +turn it into a `ByteString`, send it to a client or write it to a file. + +The following example, assuming that `stylesheet` is of type `Writer CSS +()`, prints the stylesheet to stdout: + + import qualified Data.ByteString as B + import Blaze.ByteString.Builder + import Data.CSS + + toByteStringIO B.putStr . renderCSS $ stylesheet + +[blaze-builder]: http://hackage.haskell.org/package/blaze-builder + + +Examples +-------- + +The recommended way to create your stylesheets is to use a writer monad +(transformer). This gives you a large library of predefined properties +covering most of CSS level 2.1. + +### Basic stylesheets + +The following is a basic stylesheet. The imports are listed here for +your convenience, but will be implied in further examples: + + import Control.Lens + import Control.Monad.Writer + import Data.Colour + import Data.CSS + import Data.CSS.Properties + + stylesheet :: Writer CSS () + stylesheet = + onAll $ do + select ["p"] $ do + margin . Edges $ [zeroLen] + padding . Edges $ [_Em # 1, _Ex # 2] + + select ["em"] $ do + fontWeight BolderWeight + +The type signature of `stylesheet` is very specialized. The actual type +is more general and makes it easier to interleave your stylesheets with +web framework operations if necessary: + + stylesheet :: (MonadWriter CSS m) => m () + +The style sheet will render as: + + p { + margin: 0; + padding: 1em 2ex; + } + + em { + font-weight: bolder; + } + + +### Media types + + stylesheet = do + onMedia ["print", "projection"] . select ["p"] $ do + margin . Edges $ [_Em # 0.4, _Ex # 0.1] + padding . Edges $ [zeroLen] + + onMedia ["screen"] . select ["p"] $ do + margin . Edges $ [_Em # 0.8, _Ex # 0.4] + padding . Edges $ [zeroLen] + +Renders as: + + @media print, projection { + p { + margin: 0.4em 0.1ex; + padding: 0; + } + } + + @media screen { + p { + margin: 0.8em 0.4ex; + padding: 0; + } + } + + +### Multiple selectors + + stylesheet = do + onAll . select ["p", "li"] $ do + margin . Edges $ [_Em # 0.4, _Ex # 0.1] + padding . Edges $ [zeroLen] + + below ["em", "strong"] $ + fontWeight BolderWeight + +Renders as: + + p, li { + margin: 0.4em 0.1ex; + padding: 0 + } + + p em, li em, p strong, li strong { + font-weight: bolder; + } diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,12 @@ +cascading setup script +Copyright (C) 2013, Ertugrul Soeylemez + +Please see the LICENSE file for terms and conditions of use, +modification and distribution of this package, including this file. + +> module Main where +> +> import Distribution.Simple +> +> main :: IO () +> main = defaultMain diff --git a/cascading.cabal b/cascading.cabal new file mode 100644 --- /dev/null +++ b/cascading.cabal @@ -0,0 +1,100 @@ +name: cascading +version: 0.1.0 +category: Web +synopsis: DSL for HTML CSS (Cascading Style Sheets) +maintainer: Ertugrul Söylemez +author: Ertugrul Söylemez +copyright: (c) 2013 Ertugrul Söylemez +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: README.md +description: + This library implements an HTML-specific domain-specific language + for cascading style sheets (CSS) in the spirit of blaze-html. See + the documentation of the Data.CSS module for a tutorial. + +Source-repository head + type: darcs + location: http://hub.darcs.net/ertes/cascading + +library + build-depends: + base >= 4.5 && < 5, + blaze-builder >= 0.3 && < 1, + bytestring >= 0.10 && < 1, + colour >= 2.3 && < 3, + containers >= 0.5 && < 1, + lens >= 3.9 && < 4, + mtl >= 2.0 && < 3, + text >= 0.11 && < 1, + utf8-string >= 0.3 && < 1, + web-routes >= 0.27 && < 1 + default-language: Haskell2010 + default-extensions: + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveTraversable + FlexibleContexts + FlexibleInstances + GADTs + KindSignatures + OverloadedStrings + RankNTypes + TemplateHaskell + other-extensions: + IncoherentInstances + ghc-options: -W + exposed-modules: + Data.CSS + Data.CSS.Build + Data.CSS.Properties + Data.CSS.Properties.Classes + Data.CSS.Properties.Compat + Data.CSS.Properties.Font + Data.CSS.Properties.Layout + Data.CSS.Properties.Text + Data.CSS.Properties.Types + Data.CSS.Properties.UI + Data.CSS.Properties.Utils + Data.CSS.Render + Data.CSS.Types + Data.CSS.Utils + +-- test-suite tests +-- type: exitcode-stdio-1.0 +-- build-depends: +-- base >= 4.5 && < 5, +-- cascading, +-- QuickCheck, +-- test-framework, +-- test-framework-quickcheck2, +-- test-framework-th +-- default-language: Haskell2010 +-- default-extensions: +-- TemplateHaskell +-- ghc-options: -W -threaded -rtsopts -with-rtsopts=-N +-- hs-source-dirs: test +-- main-is: Props.hs + +-- test-suite cascading-test +-- type: exitcode-stdio-1.0 +-- build-depends: +-- base >= 4.5 && < 5, +-- blaze-builder, +-- blaze-html, +-- bytestring, +-- cascading, +-- colour, +-- containers, +-- happstack-server, +-- lens, +-- mtl +-- default-language: Haskell2010 +-- default-extensions: +-- OverloadedStrings +-- ghc-options: -threaded -rtsopts +-- hs-source-dirs: test +-- main-is: Test.hs