diff --git a/clay.cabal b/clay.cabal --- a/clay.cabal +++ b/clay.cabal @@ -1,5 +1,5 @@ Name: clay -Version: 0.8.0.1 +Version: 0.9 Synopsis: CSS preprocessor as embedded Haskell. Description: Clay is a CSS preprocessor like LESS and Sass, but implemented as an embedded @@ -11,9 +11,19 @@ . The API documentation can be found in the top level module "Clay". . - > 0.8 -> 0.8.0.1 - > - Widened dependency on text. - > Thanks to bgamari. + > 0.8 -> 0.9 + > - Added list-style-type property. + > - Added some CSS3 selectors and pseudo-classes. + > - Added some missing HTML5 elements. + > - Added keyframes support. + > - Fixed bug in linear in transition. + > - Added Initial and Unset type classes. + > - Added animation related styling rules. + > - Restored old renderer. + > - Fixed bunch of warnings. + > - Added :last-child pseudo selector. + > - Stub test suite + > Thanks to Sergei Trofimovich, Levi Ad, Ian D. Bollinger, Ben Gamari and Oly Mi! Author: Sebastiaan Visser @@ -36,6 +46,7 @@ Exposed-Modules: Clay + Clay.Animation Clay.Attributes Clay.Background Clay.Border @@ -50,6 +61,7 @@ Clay.FontFace Clay.Geometry Clay.Gradient + Clay.List Clay.Media Clay.Mask Clay.Property @@ -66,7 +78,7 @@ GHC-Options: -Wall Build-Depends: base >= 4 && < 5, - mtl >= 1 && < 2.2, + mtl >= 1 && < 2.3, text >= 0.11 && < 1.2 Test-Suite Test-Clay @@ -74,9 +86,11 @@ HS-Source-Dirs: src Main-Is: Test.hs Build-Depends: - base >= 4 && < 5, - HUnit >= 1.2 && < 1.3, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4 + base >= 4 && < 5, + mtl >= 1 && < 2.3, + text >= 0.11 && < 1.2, + HUnit >= 1.2 && < 1.3, + test-framework >= 0.8 && < 0.9, + test-framework-hunit >= 0.3 && < 0.4 Ghc-Options: -Wall diff --git a/src/Clay.hs b/src/Clay.hs --- a/src/Clay.hs +++ b/src/Clay.hs @@ -45,7 +45,9 @@ , attr , (@=) +, (^=) , ($=) +, (*=) , (~=) , (|=) @@ -56,6 +58,11 @@ , queryNot , queryOnly +-- * Apply key-frame animation. + +, keyframes +, keyframesFromTo + -- * Define font-faces. , fontFace @@ -90,9 +97,11 @@ , module Clay.FontFace , module Clay.Geometry , module Clay.Gradient +, module Clay.List , module Clay.Text , module Clay.Transform , module Clay.Transition +, module Clay.Animation , module Clay.Mask , module Clay.Filter @@ -109,7 +118,7 @@ import Clay.Selector import Clay.Property -import Clay.Pseudo +import Clay.Pseudo hiding (default_, required, root, lang) import Clay.Elements hiding (link, em) import Clay.Attributes hiding ( content, class_, target, checked, disabled @@ -129,10 +138,12 @@ import Clay.FontFace import Clay.Geometry import Clay.Gradient +import Clay.List import Clay.Size import Clay.Text hiding (pre) import Clay.Transform import Clay.Transition +import Clay.Animation import Clay.Mask hiding (clear) import Clay.Filter hiding (url, opacity) diff --git a/src/Clay/Animation.hs b/src/Clay/Animation.hs new file mode 100644 --- /dev/null +++ b/src/Clay/Animation.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE + OverloadedStrings + , GeneralizedNewtypeDeriving + #-} +module Clay.Animation +( + +-- * The animation propery. + + animation +, animations + +-- * Animation-delay. + +, animationDelay +, animationDelays + +-- * Animation-direction. + +, AnimationDirection +, animationDirection +, animationDirections +, alternate +, reverse +, alternateReverse + +-- * Animation-duration. + +, animationDuration +, animationDurations + +, IterationCount +, animationIterationCount +, animationIterationCounts +, infinite +, iterationCount + +-- * Animation-action-name. + +, AnimationName +, animationName + +-- * Animation-play-state. + +, PlayState +, animationPlayState +, running +, paused + +-- * Animation-fill-mode. + +, FillMode +, animationFillMode +, forwards +, backwards + +-- * Animation-timing-function. + +, animationTimingFunction + +) +where + +import Data.Monoid +import Data.String (IsString) +import Prelude hiding (reverse) + +import Clay.Common +import Clay.Property +import Clay.Stylesheet +import Clay.Time +import Clay.Transition + + +animation + :: AnimationName + -> Time + -> TimingFunction + -> Time + -> IterationCount + -> AnimationDirection + -> FillMode + -> Css +animation p de f du i di fm = prefixed (browsers <> "animation") (p ! de ! f ! du ! i ! di ! fm) + +animations + :: [ ( AnimationName + , Time + , TimingFunction + , Time + , IterationCount + , AnimationDirection + , FillMode + ) + ] -> Css +animations = prefixed (browsers <> "animation") + . map (\(p, de, f, du, i, di, fm) -> value (p ! de ! f ! du ! i ! di ! fm)) + +------------------------------------------------------------------------------- + +animationDelay :: Time -> Css +animationDelay = prefixed (browsers <> "animation-delay") + +animationDelays :: [Time] -> Css +animationDelays = prefixed (browsers <> "animation-delay") + +------------------------------------------------------------------------------- + +newtype AnimationDirection = AnimationDirection Value + deriving (Val, Other, Normal) + +animationDirection :: AnimationDirection -> Css +animationDirection = prefixed (browsers <> "animation-direction") + +animationDirections :: [AnimationDirection] -> Css +animationDirections = prefixed (browsers <> "animation-direction") + +alternate, reverse, alternateReverse :: AnimationDirection +alternate = AnimationDirection "alternate" +reverse = AnimationDirection "reverse" +alternateReverse = AnimationDirection "alternate-reverse" + +------------------------------------------------------------------------------- + +animationDuration :: Time -> Css +animationDuration = prefixed (browsers <> "animation-duration") + +animationDurations :: [Time] -> Css +animationDurations = prefixed (browsers <> "animation-duration") + +------------------------------------------------------------------------------- + +newtype IterationCount = IterationCount Value + deriving (Val, Other, Normal) + +animationIterationCount :: IterationCount -> Css +animationIterationCount = prefixed (browsers <> "animation-iteration-count") + +animationIterationCounts :: [IterationCount] -> Css +animationIterationCounts = prefixed (browsers <> "animation-iteration-count") + +infinite :: IterationCount +infinite = IterationCount "infinite" + +iterationCount :: Double -> IterationCount +iterationCount = IterationCount . value + +------------------------------------------------------------------------------- + +newtype AnimationName = AnimationName Value + deriving (Val, Other, IsString, Initial, Inherit, Unset) + +animationName :: AnimationName -> Css +animationName = prefixed (browsers <> "animation-name") + +------------------------------------------------------------------------------- + +newtype PlayState = PlayState Value + deriving (Val, Other) + +animationPlayState :: PlayState -> Css +animationPlayState = prefixed (browsers <> "animation-play-state") + +running, paused :: PlayState +running = PlayState "running" +paused = PlayState "paused" + +------------------------------------------------------------------------------- + +newtype FillMode = FillMode Value + deriving (Val, Other, None) + +animationFillMode :: FillMode -> Css +animationFillMode = prefixed (browsers <> "animation-fill-mode") + +forwards, backwards :: FillMode +forwards = FillMode "forwards" +backwards = FillMode "backwards" + +------------------------------------------------------------------------------- + +animationTimingFunction :: TimingFunction -> Css +animationTimingFunction = prefixed (browsers <> "animation-timing-function") + diff --git a/src/Clay/Common.hs b/src/Clay/Common.hs --- a/src/Clay/Common.hs +++ b/src/Clay/Common.hs @@ -15,13 +15,15 @@ ------------------------------------------------------------------------------- -class All a where all :: a -class Auto a where auto :: a -class Inherit a where inherit :: a -class None a where none :: a -class Normal a where normal :: a -class Visible a where visible :: a -class Hidden a where hidden :: a +class All a where all :: a +class Auto a where auto :: a +class Inherit a where inherit :: a +class None a where none :: a +class Normal a where normal :: a +class Visible a where visible :: a +class Hidden a where hidden :: a +class Initial a where initial :: a +class Unset a where unset :: a -- | The other type class is used to escape from the type safety introduced by -- embedding CSS properties into the typed world of Clay. `Other` allows you to @@ -37,6 +39,8 @@ instance Visible Value where visible = "visible" instance Hidden Value where hidden = "hidden" instance Other Value where other = id +instance Initial Value where initial = "initial" +instance Unset Value where unset = "unset" ------------------------------------------------------------------------------- diff --git a/src/Clay/Dynamic.hs b/src/Clay/Dynamic.hs --- a/src/Clay/Dynamic.hs +++ b/src/Clay/Dynamic.hs @@ -37,7 +37,6 @@ import Clay.Property import Clay.Stylesheet import Data.Monoid hiding (All) -import Prelude (($)) -------------------------------------------------------------------------------- -- Enabling user interface elements: the 'user-input' property diff --git a/src/Clay/Elements.hs b/src/Clay/Elements.hs --- a/src/Clay/Elements.hs +++ b/src/Clay/Elements.hs @@ -26,11 +26,11 @@ body, br, button, canvas, caption, code, col, colgroup, datalist, dd, del, details, dfn, dialog, div, dl, dt, em, embed, fieldset, figcaption, figure, footer, h1, h2, h3, h4, h5, h6, head, header, hgroup, hr, html, i, iframe, - img, input, ins, kbd, keygen, legend, li, link, map, mark, menu, meta, meter, - nav, noscript, object, ol, optgroup, option, output, p, param, pre, progress, - q, rp, rt, ruby, s, samp, script, section, select, small, source, strong, - sub, summary, sup, table, tbody, td, textarea, tfoot, th, thead, time, tr, - track, u, ul, var, video, wbr :: Selector + img, input, ins, kbd, keygen, legend, li, link, main_, map, mark, math, menu, + meta, meter, nav, noscript, object, ol, optgroup, option, output, p, param, + pre, progress, q, rp, rt, ruby, s, samp, script, section, select, small, + source, strong, sub, summary, sup, svg, table, tbody, td, template, textarea, + tfoot, th, thead, time, tr, track, u, ul, var, video, wbr :: Selector a = "a" address = "address" @@ -87,11 +87,13 @@ legend = "legend" li = "li" link = "link" +main_ = "main" map = "map" mark = "mark" menu = "menu" meta = "meta" meter = "meter" +math = "math" nav = "nav" noscript = "noscript" object = "object" @@ -118,9 +120,11 @@ sub = "sub" summary = "summary" sup = "sup" +svg = "svg" table = "table" tbody = "tbody" td = "td" +template = "template" textarea = "textarea" tfoot = "tfoot" th = "th" diff --git a/src/Clay/Geometry.hs b/src/Clay/Geometry.hs --- a/src/Clay/Geometry.hs +++ b/src/Clay/Geometry.hs @@ -17,8 +17,6 @@ ) where -import Prelude hiding (Left, Right) - import Clay.Property import Clay.Stylesheet import Clay.Size diff --git a/src/Clay/List.hs b/src/Clay/List.hs new file mode 100644 --- /dev/null +++ b/src/Clay/List.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Clay.List +( ListStyleType +, listStyleType +, disc +, decimal +, hiragana +) +where + +import Clay.Common +import Clay.Property +import Clay.Stylesheet + +newtype ListStyleType = ListStyleType Value + deriving (Val, Initial, Inherit, None, Other) + +disc, decimal, hiragana :: ListStyleType + +disc = ListStyleType "disc" +decimal = ListStyleType "decimal" +hiragana = ListStyleType "hiragana" + +listStyleType :: ListStyleType -> Css +listStyleType = key "list-style-type" diff --git a/src/Clay/Property.hs b/src/Clay/Property.hs --- a/src/Clay/Property.hs +++ b/src/Clay/Property.hs @@ -9,7 +9,7 @@ import Data.String import Data.Text (Text, replace) -data Prefixed = Prefixed [(Text, Text)] | Plain Text +data Prefixed = Prefixed { unPrefixed :: [(Text, Text)] } | Plain { unPlain :: Text } deriving Show instance IsString Prefixed where diff --git a/src/Clay/Pseudo.hs b/src/Clay/Pseudo.hs --- a/src/Clay/Pseudo.hs +++ b/src/Clay/Pseudo.hs @@ -13,7 +13,7 @@ after = ":after" before = ":before" -link, visited, active, hover, focus, firstChild :: Refinement +link, visited, active, hover, focus, firstChild, lastChild :: Refinement link = ":link" visited = ":visited" @@ -21,20 +21,35 @@ hover = ":hover" focus = ":focus" firstChild = ":first-child" - -firstOfType, lastOfType, empty, target, checked, enabled, disabled :: Refinement +lastChild = ":last-child" -firstOfType = ":first-of-type" -lastOfType = ":last-of-type" -empty = ":empty" -target = ":target" -checked = ":checked" -enabled = ":enabled" -disabled = ":disabled" +checked, default_, disabled, empty, enabled, firstOfType, indeterminate, + inRange, invalid, lastOfType, onlyChild, onlyOfType, optional, + outOfRange, required, root, target, valid :: Refinement -nthChild, nthLastChild, nthOfType :: Text -> Refinement +checked = ":checked" +default_ = ":default" +disabled = ":disabled" +empty = ":empty" +enabled = ":enabled" +firstOfType = ":first-of-type" +indeterminate = ":indeterminate" +inRange = ":in-range" +invalid = ":invalid" +lastOfType = ":last-of-type" +onlyChild = ":only-child" +onlyOfType = ":only-of-type" +optional = ":optional" +outOfRange = ":out-of-range" +required = ":required" +root = ":root" +target = ":target" +valid = ":valid" -nthChild n = func "nth-child" [n] -nthLastChild n = func "nth-last-child" [n] -nthOfType n = func "nth-of-type" [n] +lang, nthChild, nthLastChild, nthLastOfType, nthOfType :: Text -> Refinement +lang n = func "lang" [n] +nthChild n = func "nth-child" [n] +nthLastChild n = func "nth-last-child" [n] +nthLastOfType n = func "nth-last-of-type" [n] +nthOfType n = func "nth-of-type" [n] diff --git a/src/Clay/Render.hs b/src/Clay/Render.hs --- a/src/Clay/Render.hs +++ b/src/Clay/Render.hs @@ -15,7 +15,7 @@ import Data.Foldable (foldMap) import Data.List (sort) import Data.Maybe -import Data.Text (Text) +import Data.Text (Text, pack) import Data.Text.Lazy.Builder import Prelude hiding ((**)) @@ -23,7 +23,8 @@ import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.IO as Lazy -import Clay.Stylesheet hiding (Child, query) +import Clay.Stylesheet hiding (Child, query, rule) +import Clay.Common (browsers) import Clay.Property import Clay.Selector @@ -75,64 +76,62 @@ -- used by default. render :: Css -> Lazy.Text -render = renderWith pretty +render = renderWith pretty [] -- | Render a stylesheet with a custom configuration and an optional outer -- scope. -renderWith :: Config -> Css -> Lazy.Text -renderWith cfg (S c) +renderWith :: Config -> [App] -> Css -> Lazy.Text +renderWith cfg top = renderBanner cfg . toLazyText - . cssRules cfg - . flattenRules - . execWriter - $ c + . rules cfg top + . runS ------------------------------------------------------------------------------- --- | The AST of a CSS3 file. - -data Css3 - = Css3Query MediaQuery [Css3] - | Css3Rule [App] [(Key (), Value)] - | Css3Font [(Key (), Value)] - -flattenRules :: [Rule] -> [Css3] -flattenRules rules = - let - property p = case p of - Property k v -> (k, v) - _ -> error "only properties are allowed in @font-face" - - nestApp app css = case css of - Css3Query q cs -> Css3Query q $ map (nestApp app) cs - Css3Rule as ps -> Css3Rule (app:as) ps - Css3Font ps -> Css3Font ps - - (props, nests, qrys, faces) = foldr - (\r (ps,ns,qs,fs) -> case r of - Property k v -> ((k, v):ps, ns, qs, fs) - Nested a rs' -> ( ps, (a, rs'):ns, qs, fs) - Query q rs' -> ( ps, ns, (q, rs'):qs, fs) - Face rs' -> ( ps, ns, qs, rs':fs)) - ([],[],[],[]) - rules - in - (if null props then [] else [Css3Rule [] props]) ++ - concatMap (\(app, rs') -> map (nestApp app) (flattenRules rs')) nests ++ - map (\(q, rs') -> Css3Query q (flattenRules rs')) qrys ++ - map (\ rs' -> Css3Font $ map property rs') faces +renderBanner :: Config -> Lazy.Text -> Lazy.Text +renderBanner cfg + | banner cfg = (<> b) + | otherwise = id + where b = "\n/* Generated with Clay, http://fvisser.nl/clay */" -------------------------------------------------------------------------------- +kframe :: Config -> Keyframes -> Builder +kframe cfg (Keyframes ident xs) = + foldMap + ( \(browser, _) -> + mconcat [ "@" <> fromText browser <> "keyframes " + , fromText ident + , newline cfg + , "{" + , newline cfg + , foldMap (frame cfg) xs + , "}" + , newline cfg + , newline cfg + ] + ) + (unPrefixed browsers) -renderBanner :: Config -> Lazy.Text -> Lazy.Text -renderBanner cfg = - if banner cfg - then (<> "\n/* Generated with Clay, http://fvisser.nl/clay */") - else id +frame :: Config -> (Double, [Rule]) -> Builder +frame cfg (p, rs) = + mconcat + [ fromText (pack (show p)) + , "% " + , rules cfg [] rs + ] -------------------------------------------------------------------------------- +query :: Config -> MediaQuery -> [App] -> [Rule] -> Builder +query cfg q sel rs = + mconcat + [ mediaQuery q + , newline cfg + , "{" + , newline cfg + , rules cfg sel rs + , "}" + , newline cfg + ] mediaQuery :: MediaQuery -> Builder mediaQuery (MediaQuery no ty fs) = mconcat @@ -155,16 +154,46 @@ Just (Value v) -> mconcat [ "(" , fromText k , ": " , fromText (plain v) , ")" ] -cssRules :: Config -> [Css3] -> Builder -cssRules cfg = (mconcat .) $ map $ \c -> mconcat $ case c of - Css3Query q cs -> [ mediaQuery q, block $ cssRules cfg cs ] - Css3Rule sel ps -> [ selector cfg (merger $ reverse sel), propertyBlock ps ] - Css3Font ps -> [ "@font-face", propertyBlock ps ] - where - propertyBlock = block . properties cfg . concatMap collect - block inner = mconcat [ nl, "{", nl, inner, "}", nl, nl ] - nl = newline cfg +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 + , kframe cfg `foldMap` mapMaybe kframes rs + , face cfg `foldMap` mapMaybe faces rs + , (\(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 + kframes (Keyframe fs ) = Just fs; + kframes _ = Nothing + faces (Face ns ) = Just ns + faces _ = Nothing + +rule :: Config -> [App] -> [(Key (), Value)] -> Builder +rule _ _ [] = mempty +rule cfg sel props = + let xs = collect =<< props + in mconcat + [ selector cfg (merger sel) + , newline cfg + , "{" + , newline cfg + , properties cfg xs + , "}" + , newline cfg + ] + merger :: [App] -> Selector merger [] = "" -- error "this should be fixed!" merger (x:xs) = @@ -192,9 +221,13 @@ finalSemi = if finalSemicolon cfg then ";" else "" in (<> new) $ (<> finalSemi) $ intersperse (";" <> new) $ flip map xs $ \p -> case p of - Left w -> if warn cfg then ind <> "/* no value for " <> fromText w <> " */" <> new else mempty + Left w -> if warn cfg + then ind <> "/* no value for " <> fromText w <> " */" <> new + else mempty Right (k, v) -> - let pad = if align cfg then fromText (Text.replicate (width - Text.length k) " ") else "" + let pad = if align cfg + then fromText (Text.replicate (width - Text.length k) " ") + else "" in mconcat [ind, fromText k, pad, ":", sep cfg, fromText v] selector :: Config -> Selector -> Builder @@ -212,13 +245,16 @@ predicate :: Predicate -> Builder predicate ft = mconcat $ case ft of - Id a -> [ "#", fromText a ] - Class a -> [ ".", fromText a ] - Attr a -> [ "[", fromText a, "]" ] - AttrVal a v -> [ "[", fromText a, "='", fromText v, "']" ] - AttrEnds a v -> [ "[", fromText a, "$='", fromText v, "']" ] - AttrSpace a v -> [ "[", fromText a, "~='", fromText v, "']" ] - AttrHyph a v -> [ "[", fromText a, "|='", fromText v, "']" ] - Pseudo a -> [ ":", fromText a ] - PseudoFunc a p -> [ ":", fromText a, "(", intersperse "," (map fromText p), ")" ] + Id a -> [ "#", fromText a ] + Class a -> [ ".", fromText a ] + Attr a -> [ "[", fromText a, "]" ] + AttrVal a v -> [ "[", fromText a, "='", fromText v, "']" ] + AttrBegins a v -> [ "[", fromText a, "^='", fromText v, "']" ] + AttrEnds a v -> [ "[", fromText a, "$='", fromText v, "']" ] + AttrContains a v -> [ "[", fromText a, "*='", fromText v, "']" ] + AttrSpace a v -> [ "[", fromText a, "~='", fromText v, "']" ] + AttrHyph a v -> [ "[", fromText a, "|='", fromText v, "']" ] + Pseudo a -> [ ":", fromText a ] + PseudoFunc a p -> [ ":", fromText a, "(", intersperse "," (map fromText p), ")" ] + diff --git a/src/Clay/Selector.hs b/src/Clay/Selector.hs --- a/src/Clay/Selector.hs +++ b/src/Clay/Selector.hs @@ -102,12 +102,24 @@ (@=) :: Text -> Text -> Refinement (@=) a = Refinement . pure . AttrVal a +-- | Filter elements based on the presence of a certain attribute that begins +-- with the selected value. + +(^=) :: Text -> Text -> Refinement +(^=) a = Refinement . pure . AttrBegins a + -- | Filter elements based on the presence of a certain attribute that ends -- with the specified value. ($=) :: Text -> Text -> Refinement ($=) a = Refinement . pure . AttrEnds a +-- | Filter elements based on the presence of a certain attribute that contains +-- the specified value as a substring. + +(*=) :: Text -> Text -> Refinement +(*=) a = Refinement . pure . AttrContains a + -- | Filter elements based on the presence of a certain attribute that have the -- specified value contained in a space separated list. @@ -123,15 +135,17 @@ ------------------------------------------------------------------------------- data Predicate - = Id Text - | Class Text - | Attr Text - | AttrVal Text Text - | AttrEnds Text Text - | AttrSpace Text Text - | AttrHyph Text Text - | Pseudo Text - | PseudoFunc Text [Text] + = Id Text + | Class Text + | Attr Text + | AttrVal Text Text + | AttrBegins Text Text + | AttrEnds Text Text + | AttrContains Text Text + | AttrSpace Text Text + | AttrHyph Text Text + | Pseudo Text + | PseudoFunc Text [Text] deriving (Eq, Ord, Show) newtype Refinement = Refinement { unFilter :: [Predicate] } diff --git a/src/Clay/Size.hs b/src/Clay/Size.hs --- a/src/Clay/Size.hs +++ b/src/Clay/Size.hs @@ -92,9 +92,11 @@ (*) = error "times not implemented for Size" abs = error "abs not implemented for Size" signum = error "signum not implemented for Size" + negate = error "negate not implemented for Size" instance Fractional (Size Abs) where fromRational = em . fromRational + recip = error "recip not implemented for Size" instance Num (Size Rel) where fromInteger = pct . fromInteger @@ -102,9 +104,11 @@ (*) = error "times not implemented for Size" abs = error "abs not implemented for Size" signum = error "signum not implemented for Size" + negate = error "negate not implemented for Size" instance Fractional (Size Rel) where fromRational = pct . fromRational + recip = error "recip not implemented for Size" ------------------------------------------------------------------------------- @@ -141,9 +145,11 @@ (*) = error "times not implemented for Angle" abs = error "abs not implemented for Angle" signum = error "signum not implemented for Angle" + negate = error "negate not implemented for Angle" instance Fractional (Angle Deg) where fromRational = deg . fromRational + recip = error "recip not implemented for Angle" instance Num (Angle Rad) where fromInteger = rad . fromInteger @@ -151,7 +157,9 @@ (*) = error "times not implemented for Angle" abs = error "abs not implemented for Angle" signum = error "signum not implemented for Angle" + negate = error "negate not implemented for Angle" instance Fractional (Angle Rad) where fromRational = rad . fromRational + recip = error "recip not implemented for Angle" diff --git a/src/Clay/Stylesheet.hs b/src/Clay/Stylesheet.hs --- a/src/Clay/Stylesheet.hs +++ b/src/Clay/Stylesheet.hs @@ -1,8 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Clay.Stylesheet where -import Data.Text (Text) +import Control.Applicative +import Control.Arrow (second) import Control.Monad.Writer hiding (All) +import Data.Text (Text) import Clay.Selector hiding (Child) import Clay.Property @@ -32,16 +34,26 @@ | Sub Selector deriving Show +data Keyframes = Keyframes Text [(Double, [Rule])] + deriving Show + data Rule = Property (Key ()) Value | Nested App [Rule] | Query MediaQuery [Rule] | Face [Rule] + | Keyframe Keyframes deriving Show newtype StyleM a = S (Writer [Rule] a) - deriving Monad + deriving (Functor, Applicative, Monad) +runS :: Css -> [Rule] +runS (S a) = execWriter a + +rule :: Rule -> Css +rule a = S (tell [a]) + -- | The `Css` context is used to collect style rules which are mappings from -- selectors to style properties. The `Css` type is a computation in the -- `StyleM` monad that just collects and doesn't return anything. @@ -53,7 +65,7 @@ -- words: can be converted to a `Value`. key :: Val a => Key a -> a -> Css -key k v = S $ tell [Property (cast k) (value v)] +key k v = rule $ Property (cast k) (value v) -- | Add a new style property to the stylesheet with the specified `Key` and -- value, like `key` but use a `Prefixed` key. @@ -80,51 +92,60 @@ -- outer scope it will be composed with `deep`. (?) :: Selector -> Css -> Css -(?) sel (S rs) = S (tell [Nested (Sub sel) (execWriter rs)]) +(?) sel rs = rule $ Nested (Sub sel) (runS rs) -- | Assign a stylesheet to a selector. When the selector is nested inside an -- outer scope it will be composed with `|>`. ( Css -> Css -( Css -> Css -(&) p (S rs) = S (tell [Nested (Self p) (execWriter rs)]) +(&) p rs = rule $ Nested (Self p) (runS rs) -- | Root is used to add style rules to the top scope. root :: Selector -> Css -> Css -root sel (S rs) = S (tell [Nested (Root sel) (execWriter rs)]) +root sel rs = rule $ Nested (Root sel) (runS rs) -- | Pop is used to add style rules to selectors defined in an outer scope. The -- counter specifies how far up the scope stack we want to add the rules. pop :: Int -> Css -> Css -pop i (S rs) = S (tell [Nested (Pop i) (execWriter rs)]) +pop i rs = rule $ Nested (Pop i) (runS rs) ------------------------------------------------------------------------------- -- | Apply a set of style rules when the media type and feature queries apply. query :: MediaType -> [Feature] -> Css -> Css -query ty fs (S rs) = S (tell [Query (MediaQuery Nothing ty fs) (execWriter rs)]) +query ty fs rs = rule $ Query (MediaQuery Nothing ty fs) (runS rs) -- | Apply a set of style rules when the media type and feature queries do not apply. queryNot :: MediaType -> [Feature] -> Css -> Css -queryNot ty fs (S rs) = S (tell [Query (MediaQuery (Just Not) ty fs) (execWriter rs)]) +queryNot ty fs rs = rule $ Query (MediaQuery (Just Not) ty fs) (runS rs) -- | Apply a set of style rules only when the media type and feature queries apply. queryOnly :: MediaType -> [Feature] -> Css -> Css -queryOnly ty fs (S rs) = S (tell [Query (MediaQuery (Just Only) ty fs) (execWriter rs)]) +queryOnly ty fs rs = rule $ Query (MediaQuery (Just Only) ty fs) (runS rs) ------------------------------------------------------------------------------- +keyframes :: Text -> [(Double, Css)] -> Css +keyframes n xs = rule $ Keyframe (Keyframes n (map (second runS) xs)) + +keyframesFromTo :: Text -> Css -> Css -> Css +keyframesFromTo n a b = keyframes n [(0, a), (100, b)] + +------------------------------------------------------------------------------- + -- | Define a new font-face. fontFace :: Css -> Css -fontFace (S rs) = S (tell [Face (execWriter rs)]) +fontFace rs = rule $ Face (runS rs) + diff --git a/src/Clay/Time.hs b/src/Clay/Time.hs --- a/src/Clay/Time.hs +++ b/src/Clay/Time.hs @@ -39,7 +39,9 @@ (*) = error "times not implemented for Time" abs = error "abs not implemented for Time" signum = error "signum not implemented for Time" + negate = error "negate not implemented for Time" instance Fractional Time where fromRational = sec . fromRational + recip = error "recip not implemented for Time" diff --git a/src/Clay/Transition.hs b/src/Clay/Transition.hs --- a/src/Clay/Transition.hs +++ b/src/Clay/Transition.hs @@ -24,7 +24,7 @@ , TimingFunction , transitionTimingFunction -, ease, easeIn, easeOut, easeInOut, easeLinear, stepStart, stepStop +, ease, easeIn, easeOut, easeInOut, linear, stepStart, stepStop , stepsStart, stepsStop , cubicBezier @@ -71,13 +71,13 @@ newtype TimingFunction = TimingFunction Value deriving (Val, Other, Auto) -ease, easeIn, easeOut, easeInOut, easeLinear, stepStart, stepStop :: TimingFunction +ease, easeIn, easeOut, easeInOut, linear, stepStart, stepStop :: TimingFunction ease = other "ease" easeIn = other "easeIn" easeOut = other "easeOut" easeInOut = other "easeInOut" -easeLinear = other "easeLinear" +linear = other "linear" stepStart = other "stepStart" stepStop = other "stepStop" diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -9,5 +9,5 @@ main :: IO () main = defaultMain - [ testCase "empty Clay produces empty compact CSS" $ renderWith compact (return ()) @?= "" + [ testCase "empty Clay produces empty compact CSS" $ renderWith compact [] (return ()) @?= "" ]