diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,163 @@ +CHANGELOG + + 0.16.1: + - Add support for overscroll-behaviour + Thanks to Sylvain Henry + + 0.16.0: + - Add grid size and location support. + - Derive `Stretch` for justified content + - Add `AspectRatio` + - Promote `not` to a type class + - Render CSS refinements + - Bugfixes & improved test suite + Thanks to Leonard Monnier, Yoo Chung, Skyfold, qwbarch, David Fox + + 0.15.0: + - Add `all` media type. + - Support `prefers-color-scheme` media feature. + - Use `matrix` rather than `matrix3d` + - Add media type `all` + - Add some relative units + - Add CSS properties related to hyphenation + - Use `Number` type instead of `Double` as an argument type in many places + - Fix rendering of `Number` type + Thanks to Yoo Chung, Charles Bayley and David Fox + + 0.14.0: + - Drop support for GHC 8.2 + - Added `text-align-last` + - Fix typo in `stepsStart` + - Added clay-examples + - Fix `cubicBezier` and other issues + Thanks to Vasiliy Yorkin, Florian Grignon, Nick Saunders, David Fox, Ben Sima, Murakami Kennzo, Owen Shepherd, Anton Gushcha, Temur Saidkhodjaev, Rob Bassi, Alex Sayers, and further contributors. + + 0.13.3: + - Improve README + - Relax types for `sym2` and `sym3` combinators + - Add new cursors + Thanks to Sridhar Ratnakumar, Brad Ediger and Alexandre Esteves. + + 0.13.2: + - Bump hspec versions + Thanks to Julien Dehos and Sean Parsons. + + 0.13.1: + - 'Clay.Size': Add 'sticky: Position'. + - Adhere to Semigroup-Monoid-Hierarchy + - 'Clay.Transition': Add 'stepEnd: TimingFunction' + Thanks to Sean Parsons, Elliot Cameron, Simon Jakobi and Olivier Sohn. + + 0.13.0: + - Added commenting to append comment to a property. + - Comments are displayed by default in pretty but not compact mode. + - Rewrite boxShadow functionality with BoxShadow newtype for arguments. + - Added 'important' to append !important to values. + - Update eachLine and hanging to work as spec (for textIndent). + - Rename (internal) intersperse function to intercalate. + - Not pseudo takes selector. + Thanks to dbaynard and sebastiaanvisser. + + 0.10 -> 0.10.1 + - Expose a render function for single selectors. + - Added super for vertical-align. + - Added support for border-collapse. + - Allow initial for the content property. + - Added support for CSS import. + Thanks to Heather, Collin J. Doering, Fraser Murray and Jonathan Fischoff. + + 0.9 -> 0.10 + - Bumped up text requirement. + - Added cursor property. + - Added vertical-align property. + - Removed Abs constraint from Geometry functions. + - Added support for rem dimensions. + - Added support for ListStyle. + Thanks to Lorenzo Bolla, Fraser Murray, Heather and Sergey! + + 0.9 -> 0.9.0.1 + - Fixed bug in easing properties. + + 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! + + 0.8 -> 0.8.0.1 + - Widened dependency on text. + Thanks to bgamari. + + 0.7 -> 0.8 + - Print prettier doubles. + - Loosen type of sym functions. + - Added some missing multi-side properties. + - Added content URL support. + - Added inset box shadows. + Thanks Deck and James Fisher. + + 0.6 -> 0.7 + - Stop printing banner in compact mode. + - Generic font family as datatype. + - Only drop final semicolon if doing compact printing. + + 0.5.1 -> 0.6 + - Simplified implementation of size rendering. + - Implemented @font-face construct. By James Fisher. + - Make hsl(a) colors actually print percentage values. + - Changed the renderer to haul @font-face to the top level. + + 0.5 -> 0.5.1 + - Fixed bug in fontFamily renderer. + + 0.4 -> 0.5 + - Generalized the borderRadius function. + - Fixed some small issues in Dynamic. + + 0.3 -> 0.4 + - Added dynamic presentation. (thanks to chrisdone) + - Float now has its own value, don't incorrectly share side. (thanks to chrisdone) + - Added nil size constructor. + - Slightly improved the gradient syntax. + - Expose the Propery module by default. + - Introduced shared 'all' value. + + 0.2 -> 0.3 + - Fixed value grammar of radial gradients. + - Added mask related properties. + - Allow multiple box-shadows. + - Added filter property. + - Also render value prefix when both key and value are prefixed. + + 0.1.1 -> 0.2 + - Rotate takes only one argument. + - Added opacity property. + - Print Clay banner in CSS comments by default. + - Fixed bug in font-family rendering (Firefox only). + - Added outline related properties. + - Fixed bug in monospace font family. + + 0.1 -> 0.1.1 + - Fixed bug in visibility property. + Thanks to Conrad Indiono for the pull request. + + 0.0.1 -> 0.1 + + - Fixed bug in combined selector rendering. + - Fixed bug in font familty fallback category rendering. + - Added maxWidth and maxHeight. + - Fixed example code. + - Fixed overflowX/overflowY bug. + - Added some show instance for debugging purposes. + - Don't print the star (*) selector in the case of refinements. + - Refinements applied to the top level magically introduce star selector. + Thanks to listx, bergmark, Cynede, chrisdone, Primigenus, Sigrlami for the + pull requests and bug reports. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,53 @@ +# Build setup + +Ideally, you build this project with [`nix`](https://nixos.org/nix/): + +``` +git clone git@github.com:sebastiaanvisser/clay.git +cd clay +nix-build +``` + +This will build `clay` for the current default version of GHC. +To build for a particular version, +set the `GHC_VERSION` environment variable: + +``` +GHC_VERSION=ghc881 nix-build +``` + +To find out which GHC versions our nix setup provides: + +``` +$ nix eval '(builtins.attrNames (import (builtins.fetchTarball (import ./nix/nixpkgs.nix)) {}).haskell.compiler)' +[ "ghc8102Binary" "ghc8102BinaryMinimal" "ghc8104" "ghc865Binary" "ghc884" "ghc901" "ghcHEAD" "integer-simple" "native-bignum" ] +``` + +# Building your pull request + +You are heartily encouraged to close an issue by contributing a pull request that fixes it :) +To test whether your fix will build, +ideally you should build it for all GHC versions: + +``` +nix-build all-ghcs.nix +``` + +You can see all supported versions in `.travis.yml`. +If your fix breaks an older version, do not despair. +As long as the last three versions work, +you can delete older GHC versions from `.travis.yml` in your pull request, +and deprecation of that version will be considered. + +If you fix an important bug or contribute a new feature, +consider adding a line to `CHANGELOG` describing what you have changed. + +# Running tests locally + +Tests will be run with the above `nix-build` calls, but if you want to run them +without doing a full nix build, you can do so with cabal: + +``` +nix-shell +cabal test +``` diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# Clay + +[![build](https://github.com/sebastiaanvisser/clay/actions/workflows/ci.yml/badge.svg)](https://github.com/sebastiaanvisser/clay/actions/workflows/ci.yml) +[![Hackage](https://img.shields.io/hackage/v/clay.svg)](https://hackage.haskell.org/package/clay) + +Clay is a CSS preprocessor like LESS and Sass, but implemented as an embedded +domain specific language (EDSL) in Haskell. This means that all CSS selectors +and style rules are first class Haskell functions, which makes reuse and +composability easy. + +The project is described on [the project homepage](http://fvisser.nl/clay). + +The API documentation can be found in the top level module `Clay`. diff --git a/clay.cabal b/clay.cabal --- a/clay.cabal +++ b/clay.cabal @@ -1,5 +1,5 @@ Name: clay -Version: 0.10.1 +Version: 0.16.1 Synopsis: CSS preprocessor as embedded Haskell. Description: Clay is a CSS preprocessor like LESS and Sass, but implemented as an embedded @@ -10,14 +10,6 @@ The project is described on . . The API documentation can be found in the top level module "Clay". - . - > 0.10 -> 0.10.1 - > - Expose a render function for single selectors. - > - Added super for vertical-align. - > - Added support for border-collapse. - > - Allow initial for the content property. - > - Added support for CSS import. - > Thanks to Heather, Collin J. Doering, Fraser Murray and Jonathan Fischoff. Author: Sebastiaan Visser @@ -28,9 +20,25 @@ License: BSD3 License-File: LICENSE Category: Web, Graphics -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Build-Type: Simple +Extra-Source-Files: + README.md CHANGELOG CONTRIBUTING.md + +Tested-With: + GHC==8.4.4, + GHC==8.6.5, + GHC==8.8.4, + GHC==8.10.7, + GHC==9.0.2, + GHC==9.2.2, + GHC==9.4.2, + GHC==9.6.6, + GHC==9.8.1, + GHC==9.10.1, + GHC==9.12.1 + Source-Repository head Type: git Location: git://github.com/sebastiaanvisser/clay.git @@ -46,15 +54,18 @@ Clay.Border Clay.Box Clay.Color + Clay.Comments Clay.Common Clay.Dynamic Clay.Display Clay.Elements Clay.Filter + Clay.Flexbox Clay.Font Clay.FontFace Clay.Geometry Clay.Gradient + Clay.Grid Clay.List Clay.Media Clay.Mask @@ -69,22 +80,23 @@ Clay.Transform Clay.Transition - GHC-Options: -Wall Build-Depends: - base >= 4 && < 5, - mtl >= 1 && < 2.3, - text >= 0.11 && < 1.3 + base >= 4.11 && < 4.22, + mtl >= 1, + text >= 0.11 + GHC-Options: -Wall -Wcompat + Default-Language: Haskell2010 Test-Suite Test-Clay Type: exitcode-stdio-1.0 - HS-Source-Dirs: src - Main-Is: Test.hs + HS-Source-Dirs: spec, src + Build-Tools: hspec-discover + main-is: Spec.hs Build-Depends: - base >= 4 && < 5, - mtl >= 1 && < 2.3, - text >= 0.11 && < 1.3, - HUnit >= 1.2 && < 1.3, - test-framework >= 0.8 && < 0.9, - test-framework-hunit >= 0.3 && < 0.4 - Ghc-Options: -Wall - + base >= 4.11 && < 4.22, + mtl >= 1, + text >= 0.11, + hspec >= 2.2.0, + hspec-discover >= 2.2.0 + GHC-Options: -Wall -Wcompat + Default-Language: Haskell2010 diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1,4 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} + +-- Automatically provides a main function +-- If you have trouble with this, make sure hspec-discover is installed and in your PATH diff --git a/src/Clay.hs b/src/Clay.hs --- a/src/Clay.hs +++ b/src/Clay.hs @@ -22,6 +22,10 @@ , (-:) +-- ** Comments +-- $comments +, commenting + -- * The selector language. , Selector @@ -35,6 +39,7 @@ , (|>) , (#) , (|+) +, (|~) -- ** Refining selectors. @@ -69,8 +74,12 @@ , fontFace --- * Import other CSS files +-- * !important +, important + +-- * Import other CSS files + , importUrl -- * Pseudo elements and classes. @@ -99,10 +108,12 @@ , module Clay.Box , module Clay.Display , module Clay.Dynamic +, module Clay.Flexbox , module Clay.Font , module Clay.FontFace , module Clay.Geometry , module Clay.Gradient +, module Clay.Grid , module Clay.List , module Clay.Text , module Clay.Transform @@ -117,7 +128,7 @@ ) where -import Prelude hiding ((**)) +import Prelude () import Clay.Render import Clay.Stylesheet @@ -137,13 +148,16 @@ import Clay.Box import Clay.Color import Clay.Time +import Clay.Comments (commenting) import Clay.Common import Clay.Display hiding (table) import Clay.Dynamic +import Clay.Flexbox hiding (flex, nowrap, wrap) import Clay.Font hiding (menu, caption, small, icon) import Clay.FontFace import Clay.Geometry import Clay.Gradient +import Clay.Grid import Clay.List import Clay.Size import Clay.Text hiding (pre) @@ -158,3 +172,19 @@ -- Because a large part of the names export by "Clay.Media" clash with names -- export by other modules we don't re-export it here and recommend you to -- import the module qualified. + +-- $comments +-- +-- It is occasionally useful to output comments in the generated css. +-- 'commenting' appends comments (surrounded by '@ /* @' and '@ */@') to the +-- values of the supplied 'Css' as +-- +-- > key: value /* comment */; +-- +-- Placing the comments before the semicolon ensures they are obviously +-- grouped with the preceding value when rendered compactly. +-- +-- Note that /every/ generated line in the generated content will feature the +-- comment. +-- +-- An empty comment generates '@/* */@'. diff --git a/src/Clay/Animation.hs b/src/Clay/Animation.hs --- a/src/Clay/Animation.hs +++ b/src/Clay/Animation.hs @@ -142,7 +142,7 @@ infinite :: IterationCount infinite = IterationCount "infinite" -iterationCount :: Double -> IterationCount +iterationCount :: Number -> IterationCount iterationCount = IterationCount . value ------------------------------------------------------------------------------- diff --git a/src/Clay/Background.hs b/src/Clay/Background.hs --- a/src/Clay/Background.hs +++ b/src/Clay/Background.hs @@ -84,6 +84,8 @@ , Location , Loc +, Val +, location ) where @@ -143,13 +145,12 @@ ------------------------------------------------------------------------------- newtype BackgroundSize = BackgroundSize Value - deriving (Val, Other, Inherit) + deriving (Val, Other, Inherit, Contain) instance Auto BackgroundSize where auto = auto `by` auto -contain, cover :: BackgroundSize +cover :: BackgroundSize -contain = BackgroundSize "contain" cover = BackgroundSize "cover" by :: Size a -> Size b -> BackgroundSize diff --git a/src/Clay/Border.hs b/src/Clay/Border.hs --- a/src/Clay/Border.hs +++ b/src/Clay/Border.hs @@ -28,6 +28,7 @@ -- * Collapsing borders model for a table , borderCollapse +, borderSpacing, borderSpacing2 ) where @@ -55,7 +56,7 @@ ------------------------------------------------------------------------------- -border, borderTop, borderLeft, borderBottom, borderRight :: Stroke -> Size Abs -> Color -> Css +border, borderTop, borderLeft, borderBottom, borderRight :: Size LengthUnit -> Stroke -> Color -> Css border a b c = key "border" (a ! b ! c) borderTop a b c = key "border-top" (a ! b ! c) @@ -85,10 +86,10 @@ borderTopStyle = key "border-top-style" borderBottomStyle = key "border-bottom-style" -borderWidth4 :: Size Abs -> Size Abs -> Size Abs -> Size Abs -> Css +borderWidth4 :: Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css borderWidth4 a b c d = key "border-width" (a ! b ! c ! d) -borderWidth, borderLeftWidth, borderRightWidth, borderTopWidth, borderBottomWidth :: Size Abs -> Css +borderWidth, borderLeftWidth, borderRightWidth, borderTopWidth, borderBottomWidth :: Size LengthUnit -> Css borderWidth = key "border-width" borderLeftWidth = key "border-left-width" @@ -98,7 +99,7 @@ ------------------------------------------------------------------------------- -outline, outlineTop, outlineLeft, outlineBottom, outlineRight :: Stroke -> Size Abs -> Color -> Css +outline, outlineTop, outlineLeft, outlineBottom, outlineRight :: Stroke -> Size LengthUnit -> Color -> Css outline a b c = key "outline" (a ! b ! c) outlineTop a b c = key "outline-top" (a ! b ! c) @@ -128,10 +129,10 @@ outlineTopStyle = key "outline-top-style" outlineBottomStyle = key "outline-bottom-style" -outlineWidth4 :: Size Abs -> Size Abs -> Size Abs -> Size Abs -> Css +outlineWidth4 :: Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Css outlineWidth4 a b c d = key "outline-width" (a ! b ! c ! d) -outlineWidth, outlineLeftWidth, outlineRightWidth, outlineTopWidth, outlineBottomWidth :: Size Abs -> Css +outlineWidth, outlineLeftWidth, outlineRightWidth, outlineTopWidth, outlineBottomWidth :: Size LengthUnit -> Css outlineWidth = key "outline-width" outlineLeftWidth = key "outline-left-width" @@ -139,7 +140,7 @@ outlineTopWidth = key "outline-top-width" outlineBottomWidth = key "outline-bottom-width" -outlineOffset :: Size Abs -> Css +outlineOffset :: Size LengthUnit -> Css outlineOffset = key "outline-offset" ------------------------------------------------------------------------------- @@ -171,3 +172,9 @@ borderCollapse :: Visibility -> Css borderCollapse = key "border-collapse" + +borderSpacing :: Size a -> Css +borderSpacing a = key "border-spacing" a + +borderSpacing2 :: Size a -> Size a -> Css +borderSpacing2 a b = key "border-spacing" (a ! b) diff --git a/src/Clay/Box.hs b/src/Clay/Box.hs --- a/src/Clay/Box.hs +++ b/src/Clay/Box.hs @@ -3,13 +3,24 @@ ( BoxType , paddingBox, borderBox, contentBox , boxSizing +-- * @box-shadow@ +-- $box-shadow , boxShadow +, shadow +, shadowWithBlur +, shadowWithSpread +, bsInset +, bsColor +-- ** Deprecated +-- $box-shadow-deprecated +, boxShadow' +, boxShadowWithSpread , boxShadows , insetBoxShadow ) where -import Data.Monoid +import Data.List.NonEmpty (NonEmpty) import Clay.Color import Clay.Common @@ -36,13 +47,131 @@ ------------------------------------------------------------------------------- -boxShadow :: Size a -> Size a -> Size a -> Color -> Css -boxShadow x y w c = prefixed (browsers <> "box-shadow") (x ! y ! w ! c) +-- $box-shadow +-- +-- === Formal argument syntax +-- +-- > none | # +-- > where +-- > = inset? && {2,4} && ? +-- > +-- > where +-- > = | | | | | | currentcolor | +-- > +-- > where +-- > = rgb( [ [ {3} | {3} ] [ / ]? ] | [ [ #{3} | #{3} ] , ? ] ) +-- > = rgba( [ [ {3} | {3} ] [ / ]? ] | [ [ #{3} | #{3} ] , ? ] ) +-- > = hsl( [ [ / ]? ] | [ , , , ? ] ) +-- > = hsla( [ [ / ]? ] | [ , , , ? ] ) +-- > +-- > where +-- > = | +-- > = | -boxShadows :: [(Size a, Size a, Size a, Color)] -> Css -boxShadows = prefixed (browsers <> "box-shadow") . map (\(a, b, c, d) -> a ! b ! c ! d) +newtype BoxShadow = BoxShadow Value + deriving (Val, Inherit, Initial, Unset, None, Other) +-- | This function will usually take a singleton list, but requiring a (non-empty) +-- list prevents accidentally applying the modifiers ('bsInset', 'bsColor') +-- incorrectly. +-- +-- 'pure' (from "Control.Applicative") creates a singleton list. +-- +-- > boxShadow . pure $ none +-- > boxShadow . pure $ shadow (px 1) (px 1) +-- +-- Use with @{-# LANGUAGE OverloadedLists #-}@ for the simplest list syntax. +-- Note that sometimes when @{-# LANGUAGE OverloadedLists #-}@ is active, GHC +-- has troubles identifying what type the list should be converted to. Examples: +-- 1) "forM_ [0..10] $ \x -> ..." +-- 2) "[left, top, right, bottom] `forM_` ($ pct 4)" +-- +-- > boxShadow [none] +-- > boxShadow [shadow (px 1) (px 1)] +-- +-- This is recommended for supplying multiple 'BoxShadow' values. +-- +-- > boxShadow [shadowWithBlur (em 2) (em 1), bsInset . bsColor red $ shadow (px 1) (px 2)] +boxShadow :: NonEmpty BoxShadow -> Css +boxShadow = prefixed (browsers <> "box-shadow") . value + +shadow + :: Size a -- ^ Horizontal offset + -> Size a -- ^ Vertical offset + -> BoxShadow +shadow x y = BoxShadow . value $ (x ! y) + +shadowWithBlur + :: Size a -- ^ Horizontal offset + -> Size a -- ^ Vertical offset + -> Size a -- ^ Blur radius + -> BoxShadow +shadowWithBlur x y w = BoxShadow . value $ (x ! y ! w) + +-- | While this function is the correct type to work with the 'sym', 'sym2' +-- or 'sym3' functions, such applications are unlikely to be meaningful. +shadowWithSpread + :: Size a -- ^ Horizontal offset + -> Size a -- ^ Vertical offset + -> Size a -- ^ Blur radius + -> Size a -- ^ Spread radius + -> BoxShadow +shadowWithSpread x y blurRadius spreadRadius = + BoxShadow . value $ (x ! y ! blurRadius ! spreadRadius) + +-- | Adapt the provided @box-shadow@ with the @inset@ prefix. +-- +-- > boxShadow . pure . bsInset +bsInset :: BoxShadow -> BoxShadow +bsInset (BoxShadow v) = BoxShadow . value $ ("inset" :: Value, v) + +-- | Supply a color to the provided @box-shadow@. +bsColor :: Color -> BoxShadow -> BoxShadow +bsColor c (BoxShadow v) = BoxShadow . value $ (v, c) +infixr 9 `bsColor` + ------------------------------------------------------------------------------- +-- $box-shadow-deprecated +-- +-- The old implementation was both restrictive and slightly off-spec. It +-- shall be discontinued in a future release. The 'boxShadow' name has already +-- been taken, so the functionality that used to provide is now provided by +-- 'boxShadow\''. + +-- | This is the drop-in replacement for the old 'boxShadow' function (< 0.13). +-- It is possible to continue for now +boxShadow' :: Size a -> Size a -> Size a -> Color -> Css +boxShadow' x y w c = prefixed (browsers <> "box-shadow") (x ! y ! w ! c) +{-# DEPRECATED boxShadow' "This function is only present for compatibility purposes and will be removed." #-} + +-- | Replace calls to this function as follows (using -XOverloadedLists) +-- +-- > boxShadowWithSpread x y rb rs c +-- +-- > boxShadow [c `bsColor` shadowWithSpread x y rb rs] +boxShadowWithSpread :: Size a -> Size a -> Size a -> Size a -> Color -> Css +boxShadowWithSpread x y blurRadius spreadRadius color = + prefixed (browsers <> "box-shadow") (x ! y ! blurRadius ! spreadRadius ! color) +{-# DEPRECATED boxShadowWithSpread "This function has been replaced with shadowWithSpread and bsColor and will be removed." #-} + +-- | Replace calls to this function as follows (using -XOverloadedLists) +-- +-- > boxShadows [(x1, y1, rb1, c1), (x2, y2, rb2, c2)] +-- +-- > boxShadow +-- > [ c1 `bsColor` shadowWithBlur x1 y1 rb1 +-- > , c2 `bsColor` shadowWithBlur x2 y2 rb2 +-- > ] +boxShadows :: [(Size a, Size a, Size a, Color)] -> Css +boxShadows = prefixed (browsers <> "box-shadow") . map (\(a, b, c, d) -> a ! b ! c ! d) +{-# DEPRECATED boxShadows "This function is replaced with boxShadow and will be removed." #-} + +-- | Replace calls to this function as follows (using -XOverloadedLists) +-- +-- > insetBoxShadow s x y rb c +-- +-- > boxShadow [bsInset $ c `bsColor` shadowWithBlur x y rb] insetBoxShadow :: Stroke -> Size a -> Size a -> Size a -> Color -> Css insetBoxShadow x y w c z = prefixed (browsers <> "box-shadow") (x ! y ! w ! c ! z) +{-# DEPRECATED insetBoxShadow "This function has been replaced with shadowWithSpread, bsInset and bsColor and will be removed." #-} diff --git a/src/Clay/Color.hs b/src/Clay/Color.hs --- a/src/Clay/Color.hs +++ b/src/Clay/Color.hs @@ -2,11 +2,10 @@ module Clay.Color where import Data.Char (isHexDigit) -import Data.Monoid import Data.String -import Data.Text (Text) import Text.Printf +import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Read as Text @@ -16,24 +15,24 @@ -- * Color datatype. data Color - = Rgba Integer Integer Integer Integer - | Hsla Integer Float Float Integer + = Rgba Integer Integer Integer Float + | Hsla Integer Float Float Float | Other Value - deriving Show + deriving (Show, Eq) -- * Color constructors. -rgba :: Integer -> Integer -> Integer -> Integer -> Color +rgba :: Integer -> Integer -> Integer -> Float -> Color rgba = Rgba rgb :: Integer -> Integer -> Integer -> Color -rgb r g b = rgba r g b 255 +rgb r g b = rgba r g b 1 -hsla :: Integer -> Float -> Float -> Integer -> Color +hsla :: Integer -> Float -> Float -> Float -> Color hsla = Hsla hsl :: Integer -> Float -> Float -> Color -hsl r g b = hsla r g b 255 +hsl r g b = hsla r g b 1 grayish :: Integer -> Color grayish g = rgb g g g @@ -55,41 +54,139 @@ setB b (Rgba r g _ a) = Rgba r g b a setB _ o = o -setA :: Integer -> Color -> Color +setA :: Float -> Color -> Color setA a (Rgba r g b _) = Rgba r g b a setA a (Hsla r g b _) = Hsla r g b a setA _ o = o +-- * Color conversions. + +toRgba :: Color -> Color +toRgba color = + case color of + Hsla h s l a -> toRgba' rgb' a + where sextant = fromIntegral h / 60.0 + chroma = (s *) . (1.0 -) . abs $ (2.0 * l) - 1.0 + x = (chroma *) . (1.0 -) . abs $ (sextant `fracMod` 2) - 1.0 + lightnessAdjustment = l - (chroma / 2.0) + + toRgbPart component = truncate . (* 255.0) $ component + lightnessAdjustment + toRgba' (r, g, b) = Rgba (toRgbPart r) (toRgbPart g) (toRgbPart b) + + rgb' | h >= 0 && h < 60 = (chroma, x , 0) + | h >= 60 && h < 120 = (x , chroma, 0) + | h >= 120 && h < 180 = (0 , chroma, x) + | h >= 180 && h < 240 = (0 , x , chroma) + | h >= 240 && h < 300 = (x , 0 , chroma) + | otherwise = (chroma, 0 , x) + + c@(Rgba _ _ _ _) -> c + + Other _ -> error "Invalid to pass Other to toRgba." + + +toHsla :: Color -> Color +toHsla color = + case color of + Rgba redComponent greenComponent blueComponent alphaComponent -> Hsla h (decimalRound s 3) (decimalRound l 3) alphaComponent + where r = fromIntegral redComponent / 255.0 + g = fromIntegral greenComponent / 255.0 + b = fromIntegral blueComponent / 255.0 + + minColor = minimum [r, g, b] + maxColor = maximum [r, g, b] + delta = maxColor - minColor + + l = (minColor + maxColor) / 2.0 + s = if delta == 0.0 then 0.0 + else (delta /) . (1.0 -) . abs $ (2.0 * l) - 1.0 + + h' | delta == 0.0 = 0.0 + | r == maxColor = ((g - b) / delta) `fracMod` 6.0 + | g == maxColor = ((b - r) / delta) + 2.0 + | otherwise = ((r - g) / delta) + 4.0 + + h'' = truncate $ 60 * h' + h = if h'' < 0 then h''+ 360 else h'' + + c@(Hsla _ _ _ _) -> c + + Other _ -> error "Invalid to pass Other to toHsla." + -- * Computing with colors. (*.) :: Color -> Integer -> Color (*.) (Rgba r g b a) i = Rgba (clamp (r * i)) (clamp (g * i)) (clamp (b * i)) a (*.) o _ = o +infixl 7 *. (+.) :: Color -> Integer -> Color (+.) (Rgba r g b a) i = Rgba (clamp (r + i)) (clamp (g + i)) (clamp (b + i)) a (+.) o _ = o +infixl 6 +. (-.) :: Color -> Integer -> Color (-.) (Rgba r g b a) i = Rgba (clamp (r - i)) (clamp (g - i)) (clamp (b - i)) a (-.) o _ = o +infixl 6 -. -clamp :: Integer -> Integer -clamp i = max (min i 255) 0 +clamp :: Ord a => Num a => a -> a +clamp i = max (min i (fromIntegral (255 :: Integer))) (fromIntegral (0 :: Integer)) +lighten :: Float -> Color -> Color +lighten factor color = + case color of + c@(Hsla {}) -> toHsla $ lighten factor (toRgba c) + c@(Rgba {}) -> lerp factor c (Rgba 255 255 255 255) + Other _ -> error "Other cannot be lightened." + +darken :: Float -> Color -> Color +darken factor color = + case color of + c@(Hsla {}) -> toHsla $ darken factor (toRgba c) + c@(Rgba {}) -> lerp factor c (Rgba 0 0 0 255) + Other _ -> error "Other cannot be darkened." + +lerp :: Float -> Color -> Color -> Color +lerp factor startColor boundColor = + case (startColor, boundColor) of + (Other _, _) -> error "Other cannot be lerped." + (_, Other _) -> error "Other cannot be lerped." + (color@(Hsla {}), bound) -> toHsla $ lerp factor (toRgba color) bound + + (start, color@(Hsla {})) -> toHsla $ lerp factor start (toRgba color) + + (Rgba r g b a, Rgba r' g' b' a') -> + Rgba + (lerpComponent factor r r') + (lerpComponent factor g g') + (lerpComponent factor b b') + (lerpAlpha factor a a') + where lerpComponent :: Float -> Integer -> Integer -> Integer + lerpComponent amount start bound = + let difference = bound - start + adjustment = truncate $ fromIntegral difference * amount + in clamp $ start + adjustment + lerpAlpha :: Float -> Float -> Float -> Float + lerpAlpha amount start bound = + let difference = bound - start + adjustment = fromIntegral $ (truncate $ difference * amount :: Integer) + in clamp $ start + adjustment + ------------------------------------------------------------------------------- instance Val Color where value clr = case clr of - Rgba r g b 255 -> Value $mconcat ["rgb(", p r, ",", p g, ",", p b, ")"] - Rgba r g b a -> Value $mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"] - Hsla h s l 255 -> Value $mconcat ["hsl(", p h, ",", f s, ",", f l, ")"] - Hsla h s l a -> Value $mconcat ["hsla(", p h, ",", f s, ",", f l, ",", ah a, ")"] + Rgba r g b 1.0 -> Value $ mconcat ["#", p' r, p' g, p' b] + Rgba r g b a -> Value $ mconcat ["rgba(", p r, ",", p g, ",", p b, ",", ah a, ")"] + Hsla h s l 1.0 -> Value $ mconcat ["hsl(", p h, ",", f s, ",", f l, ")"] + Hsla h s l a -> Value $ mconcat ["hsla(", p h, ",", f s, ",", f l, ",", ah a, ")"] Other o -> o where p = fromString . show + p' = fromString . printf "%02x" f = fromString . printf "%.4f%%" - ah = fromString . printf "%.4f" . (/ (256 :: Double)) . fromIntegral + ah = fromString . take 6 . show instance None Color where none = Other "none" instance Auto Color where auto = Other "auto" @@ -104,9 +201,9 @@ case Text.uncons t of Just ('#', cs) | Text.all isHexDigit cs -> case Text.unpack cs of - [a, b, c, d, e, f, g, h] -> rgba (hex a b) (hex c d) (hex e f) (hex g h) + [a, b, c, d, e, f, g, h] -> rgba (hex a b) (hex c d) (hex e f) (fromIntegral (hex g h :: Integer) / 255.0) [a, b, c, d, e, f ] -> rgb (hex a b) (hex c d) (hex e f) - [a, b, c, d ] -> rgba (hex a a) (hex b b) (hex c c) (hex d d) + [a, b, c, d ] -> rgba (hex a a) (hex b b) (hex c c) (fromIntegral (hex d d :: Integer) / 255.0) [a, b, c ] -> rgb (hex a a) (hex b b) (hex c c) _ -> err _ -> err diff --git a/src/Clay/Comments.hs b/src/Clay/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Clay/Comments.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +module Clay.Comments where + +import Data.Maybe (isNothing) +import Data.List (partition) + +import Clay.Stylesheet + +-- | Annotate the supplied 'Css' with the supplied comment. +-- Comments work with 'OverloadedStrings'. This will annotate every non-nested +-- value. +commenting :: CommentText -> Css -> Css +commenting c css = foldMap (rule . addComment c) $ runS css +infixl 3 `commenting` + +-- The last case indicates there may be something wrong in the typing, as +-- it shouldn't be possible to comment a wrong rule. In practice, this implementation +-- means only the directly applied property rule is affected, i.e. no nested +-- rules. That could be changed by adding recursive cases. +addComment :: CommentText -> Rule -> Rule +addComment c (Property (PartitionComments xs (Just cs)) k v) = let c1 = Comment $ cs <> "; " <> c in + Property (c1 : xs) k v +addComment c (Property ms k v ) = Property (Comment c : ms) k v +addComment _ r = r + +pattern PartitionComments :: [Modifier] -> Maybe CommentText -> [Modifier] +pattern PartitionComments xs cs <- (fmap (foldMap _Comment) . partition (isNothing . _Comment) -> (xs, cs)) diff --git a/src/Clay/Common.hs b/src/Clay/Common.hs --- a/src/Clay/Common.hs +++ b/src/Clay/Common.hs @@ -9,21 +9,26 @@ module Clay.Common where +import Data.Text (Text) import Clay.Property import Data.String (IsString) -import Data.Monoid (Monoid, (<>)) ------------------------------------------------------------------------------- -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 +class All a where all :: a +class Auto a where auto :: a +class Baseline a where baseline :: a +class Center a where center :: 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 +class Contain a where contain :: a +class Revert a where revert :: a +class RevertLayer a where revertLayer :: 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 @@ -31,29 +36,75 @@ class Other a where other :: Value -> a -instance All Value where all = "all" -instance Auto Value where auto = "auto" -instance Inherit Value where inherit = "inherit" -instance Normal Value where normal = "normal" -instance None Value where none = "none" -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" +allValue :: Value +allValue = "all" +autoValue :: Value +autoValue = "auto" +baselineValue :: Value +baselineValue = "baseline" +centerValue :: Value +centerValue = "center" +inheritValue :: Value +inheritValue = "inherit" +normalValue :: Value +normalValue = "normal" +noneValue :: Value +noneValue = "none" +visibleValue :: Value +visibleValue = "visible" +hiddenValue :: Value +hiddenValue = "hidden" +initialValue :: Value +initialValue = "initial" +unsetValue :: Value +unsetValue = "unset" +containValue :: Value +containValue = "contain" +revertValue :: Value +revertValue = "revert" +revertLayerValue :: Value +revertLayerValue = "revert-layer" +instance All Value where all = allValue +instance Auto Value where auto = autoValue +instance Baseline Value where baseline = baselineValue +instance Center Value where center = centerValue +instance Inherit Value where inherit = inheritValue +instance Normal Value where normal = normalValue +instance None Value where none = noneValue +instance Visible Value where visible = visibleValue +instance Hidden Value where hidden = hiddenValue +instance Other Value where other = id +instance Initial Value where initial = initialValue +instance Unset Value where unset = unsetValue +instance Contain Value where contain = containValue +instance Revert Value where revert = revertValue +instance RevertLayer Value where revertLayer = revertLayerValue + ------------------------------------------------------------------------------- -- | Common list browser prefixes to make experimental properties work in -- different browsers. +webkitPrefix :: (Text, Text) +webkitPrefix = ( "-webkit-", "" ) + +emptyPrefix :: (Text, Text) +emptyPrefix = ( "", "" ) + +webkit :: Prefixed +webkit = Prefixed $ + [ webkitPrefix + , emptyPrefix + ] + browsers :: Prefixed -browsers = Prefixed - [ ( "-webkit-", "" ) - , ( "-moz-", "" ) - , ( "-ms-", "" ) - , ( "-o-", "" ) - , ( "", "" ) +browsers = Prefixed $ + [ webkitPrefix + , ( "-moz-", "" ) + , ( "-ms-", "" ) + , ( "-o-", "" ) + , emptyPrefix ] ------------------------------------------------------------------------------- @@ -63,3 +114,15 @@ call :: (IsString s, Monoid s) => s -> s -> s call fn arg = fn <> "(" <> arg <> ")" +------------------------------------------------------------------------------- + +-- | Some auxiliary mathematical functions. + +fracMod :: RealFrac a => a -> a -> a +fracMod x y = (x -) . (* y) $ evenMultiples x y + where evenMultiples x' y' = fromIntegral (truncate (x' / y') :: Integer) + +decimalRound :: RealFrac a => a -> Int -> a +decimalRound x decimalPlaces = shiftedAndRounded x / powersOf10 + where powersOf10 = 10 ^ decimalPlaces + shiftedAndRounded x' = fromIntegral (round $ x' * powersOf10 :: Integer) diff --git a/src/Clay/Display.hs b/src/Clay/Display.hs --- a/src/Clay/Display.hs +++ b/src/Clay/Display.hs @@ -17,13 +17,13 @@ , Position , position -, static, absolute, fixed, relative +, static, absolute, fixed, relative, sticky -- * Display , Display , display -, inline, block, listItem, runIn, inlineBlock, table, inlineTable, tableRowGroup +, inline, block, listItem, runIn, inlineBlock, table, displayTable, inlineTable, tableRowGroup , tableHeaderGroup, tableFooterGroup, tableRow, tableColumnGroup, tableColumn , tableCell, tableCaption, displayNone, displayInherit, flex , inlineFlex, grid, inlineGrid @@ -34,6 +34,15 @@ , scroll , overflow, overflowX, overflowY +-- * Overscroll +, Overscroll +, overscrollBehavior +, overscrollBehavior2 +, overscrollBehaviorX +, overscrollBehaviorY +, overscrollBehaviorBlock +, overscrollBehaviorInline + -- * Visibility. , Visibility @@ -65,24 +74,29 @@ -- * Vertical align. , VerticalAlign(..) -, baseline, middle, vAlignSub, vAlignSuper, textTop, textBottom, vAlignTop, vAlignBottom +, middle, vAlignSub, vAlignSuper, textTop, textBottom, vAlignTop, vAlignBottom, vAlignBaseline -- * Cursor , Cursor(..) -, crosshair, cursorDefault, pointer, move, eResize, neResize, nwResize, nResize, seResize, swResize, sResize, wResize, cursorText, wait, cursorProgress, help, cursorUrl - +, cursorUrl +, cursorDefault +, contextMenu, help, pointer, cursorProgress, wait +, cell, crosshair, cursorText, vText +, alias, cursorCopy, move, noDrop, notAllowed, grab, grabbing +, allScroll, colResize, rowResize, nResize, eResize, sResize, wResize +, neResize, nwResize, seResize, swResize, ewResize, nsResize, neswResize, nwseResize +, zoomIn, zoomOut ) where -import Data.Monoid import Data.String import Clay.Size import Clay.Property import Clay.Stylesheet import Clay.Common -import Data.Text (Text) +import Data.Text (Text) ------------------------------------------------------------------------------- @@ -116,12 +130,13 @@ newtype Position = Position Value deriving (Val, Other, Inherit) -static, absolute, fixed, relative :: Position +static, absolute, fixed, relative, sticky :: Position static = Position "static" absolute = Position "absolute" fixed = Position "fixed" relative = Position "relative" +sticky = Position $ Value (webkit <> Plain "sticky") position :: Position -> Css position = key "position" @@ -131,7 +146,7 @@ newtype Display = Display Value deriving (Val, Other, None, Inherit) -inline, block, listItem, runIn, inlineBlock, table, inlineTable, tableRowGroup, +inline, block, listItem, runIn, inlineBlock, table, displayTable, inlineTable, tableRowGroup, tableHeaderGroup, tableFooterGroup, tableRow, tableColumnGroup, tableColumn, tableCell, tableCaption, displayNone, displayInherit, flex, inlineFlex, grid, inlineGrid :: Display @@ -141,6 +156,8 @@ listItem = Display "list-item" runIn = Display "runIn" inlineBlock = Display "inline-block" +displayTable = Display "table" +{-# DEPRECATED table "Use `displayTable` instead." #-} table = Display "table" inlineTable = Display "inline-table" tableRowGroup = Display "table-row-Group" @@ -177,8 +194,32 @@ ------------------------------------------------------------------------------- +newtype Overscroll = Overscroll Value + deriving (Val, Other, None, Auto, Contain, Inherit, Initial, Unset, Revert, RevertLayer) + +-- | Specify both X and Y overscroll at once +overscrollBehavior :: Overscroll -> Css +overscrollBehavior = key "overscroll-behavior" + +overscrollBehavior2 :: Overscroll -> Overscroll -> Css +overscrollBehavior2 x y = key "overscroll-behavior" (x ! y) + +overscrollBehaviorX :: Overscroll -> Css +overscrollBehaviorX = key "overscroll-behavior-x" + +overscrollBehaviorY :: Overscroll -> Css +overscrollBehaviorY = key "overscroll-behavior-y" + +overscrollBehaviorBlock :: Overscroll -> Css +overscrollBehaviorBlock = key "overscroll-behavior-block" + +overscrollBehaviorInline :: Overscroll -> Css +overscrollBehaviorInline = key "overscroll-behavior-inline" + +------------------------------------------------------------------------------- + newtype Visibility = Visibility Value - deriving (Val, Other, Auto, Inherit, Hidden, Visible) + deriving (Val, Other, Inherit, Hidden, Unset, Visible) separate, collapse :: Visibility @@ -201,7 +242,7 @@ ------------------------------------------------------------------------------- -opacity :: Double -> Css +opacity :: Number -> Css opacity = key "opacity" zIndex :: Integer -> Css @@ -232,50 +273,87 @@ verticalAlign :: a -> Css verticalAlign = key "vertical-align" -newtype VerticalAlignValue a = VerticalAlignValue Value deriving (Val) +newtype VerticalAlignValue = VerticalAlignValue Value deriving (Val, Baseline) -instance VerticalAlign (VerticalAlignValue a) +instance VerticalAlign VerticalAlignValue instance VerticalAlign (Size a) -baseline,middle,vAlignSub,vAlignSuper,textTop,textBottom,vAlignTop,vAlignBottom :: VerticalAlignValue Value +middle,vAlignSub,vAlignSuper,textTop,textBottom,vAlignTop,vAlignBottom,vAlignBaseline :: VerticalAlignValue -baseline = VerticalAlignValue "baseline" middle = VerticalAlignValue "middle" vAlignSub = VerticalAlignValue "sub" +vAlignBaseline = baseline vAlignSuper = VerticalAlignValue "super" textTop = VerticalAlignValue "text-top" textBottom = VerticalAlignValue "text-bottom" vAlignTop = VerticalAlignValue "top" vAlignBottom = VerticalAlignValue "bottom" -------------------------------------------------------------------------------- +------------------------------------------------------------------------------- class (Val a) => Cursor a where cursor :: a -> Css cursor = key "cursor" -newtype CursorValue a = CursorValue Value deriving (Val,Inherit,Auto) +newtype CursorValue a = CursorValue Value deriving (Val,Inherit,Auto,None) instance Cursor (CursorValue a) -crosshair,cursorDefault,pointer,move,eResize,neResize,nwResize,nResize,seResize,swResize,sResize,wResize,cursorText,wait,cursorProgress,help :: CursorValue Value - -crosshair = CursorValue "crosshair" -cursorDefault = CursorValue "cursorDefault" +cursorUrl :: Text -> CursorValue Value +cursorUrl u = CursorValue $ value ("url(\"" <> u <> "\")") + +-- Using the classification from https://developer.mozilla.org/en-US/docs/Web/CSS/cursor +cursorDefault + , contextMenu, help, pointer, cursorProgress, wait + , cell, crosshair, cursorText, vText + , alias, cursorCopy, move, noDrop, notAllowed, grab, grabbing + , allScroll, colResize, rowResize, nResize, eResize, sResize, wResize + , neResize, nwResize, seResize, swResize, ewResize, nsResize, neswResize, nwseResize + , zoomIn, zoomOut :: CursorValue Value + +-- General +cursorDefault = CursorValue "default" + +-- Links & status +contextMenu = CursorValue "context-menu" +help = CursorValue "help" pointer = CursorValue "pointer" +cursorProgress = CursorValue "progress" +wait = CursorValue "wait" + +-- Selection +cell = CursorValue "cell" +crosshair = CursorValue "crosshair" +cursorText = CursorValue "text" +vText = CursorValue "vertical-text" + +-- Drag & drop +alias = CursorValue "alias" +cursorCopy = CursorValue "copy" move = CursorValue "move" +noDrop = CursorValue "no-drop" +notAllowed = CursorValue "not-allowed" +grab = CursorValue "grab" +grabbing = CursorValue "grabbing" + +-- Resizing & scrolling +allScroll = CursorValue "all-scroll" +colResize = CursorValue "col-resize" +rowResize = CursorValue "row-resize" +nResize = CursorValue "n-resize" eResize = CursorValue "e-resize" +sResize = CursorValue "s-resize" +wResize = CursorValue "w-resize" + neResize = CursorValue "ne-resize" nwResize = CursorValue "nw-resize" -nResize = CursorValue "n-resize" seResize = CursorValue "se-resize" swResize = CursorValue "sw-resize" -sResize = CursorValue "sResize" -wResize = CursorValue "sResize" -cursorText = CursorValue "text" -wait = CursorValue "wait" -cursorProgress = CursorValue "progress" -help = CursorValue "help" +ewResize = CursorValue "ew-resize" +nsResize = CursorValue "ns-resize" +neswResize = CursorValue "nesw-resize" +nwseResize = CursorValue "nwse-resize" -cursorUrl :: Text -> CursorValue Value -cursorUrl u = CursorValue $ value ("url(\"" <> u <> "\")") +-- Zooming +zoomIn = CursorValue "zoom-in" +zoomOut = CursorValue "zoom-out" diff --git a/src/Clay/Filter.hs b/src/Clay/Filter.hs --- a/src/Clay/Filter.hs +++ b/src/Clay/Filter.hs @@ -49,33 +49,33 @@ url :: Text -> Filter url u = Filter ("url(" <> value u <> ")") -blur :: Size Abs -> Filter +blur :: Size LengthUnit -> Filter blur i = Filter ("blur(" <> value i <> ")") -brightness :: Double -> Filter +brightness :: Number -> Filter brightness i = Filter ("brightness(" <> value i <> ")") -contrast :: Size Rel -> Filter +contrast :: Size Percentage -> Filter contrast i = Filter ("contrast(" <> value i <> ")") -dropShadow :: Size Abs -> Size Abs -> Size Abs -> Color -> Filter +dropShadow :: Size LengthUnit -> Size LengthUnit -> Size LengthUnit -> Color -> Filter dropShadow x y s c = Filter ("drop-shadow(" <> value (x ! y ! s ! c) <> ")") -grayscale :: Size Rel -> Filter +grayscale :: Size Percentage -> Filter grayscale g = Filter ("grayscale(" <> value g <> ")") hueRotate :: Angle a -> Filter hueRotate h = Filter ("hue-rotate(" <> value h <> ")") -invert :: Size Rel -> Filter +invert :: Size Percentage -> Filter invert i = Filter ("invert(" <> value i <> ")") -opacity :: Size Rel -> Filter +opacity :: Size Percentage -> Filter opacity i = Filter ("opacity(" <> value i <> ")") -saturate :: Size Rel -> Filter +saturate :: Size Percentage -> Filter saturate i = Filter ("saturate(" <> value i <> ")") -sepia :: Size Rel -> Filter +sepia :: Size Percentage -> Filter sepia i = Filter ("sepia(" <> value i <> ")") diff --git a/src/Clay/Flexbox.hs b/src/Clay/Flexbox.hs new file mode 100644 --- /dev/null +++ b/src/Clay/Flexbox.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, OverloadedStrings #-} +module Clay.Flexbox where + +import Clay.Common (Auto, Baseline, Center, Inherit, Other) +import Clay.Property +import Clay.Size (Size) +import Clay.Stylesheet +import Data.String (fromString) + +-- | CSS Flexible Box Layout +-- http://dev.w3.org/csswg/css-flexbox-1 + +class FlexEnd a where flexEnd :: a +class FlexStart a where flexStart :: a +class SpaceAround a where spaceAround :: a +class SpaceBetween a where spaceBetween :: a +class SpaceEvenly a where spaceEvenly :: a +class Stretch a where stretch :: a + +instance FlexEnd Value where flexEnd = "flex-end" +instance FlexStart Value where flexStart = "flex-start" +instance SpaceAround Value where spaceAround = "space-around" +instance SpaceBetween Value where spaceBetween = "space-between" +instance SpaceEvenly Value where spaceEvenly = "space-evenly" +instance Stretch Value where stretch = "stretch" + +------------------------------------------------------------------------------- + +newtype AlignContentValue = AlignContentValue Value + deriving (Val, Other, Inherit, FlexStart, FlexEnd + , Center, SpaceBetween, SpaceAround, SpaceEvenly, Stretch) + +alignContent :: AlignContentValue -> Css +alignContent = key "align-content" + +------------------------------------------------------------------------------- + +newtype AlignItemsValue = AlignItemValue Value + deriving (Val, Other, Inherit, Baseline + , Center, FlexEnd, FlexStart, Stretch) + +alignItems :: AlignItemsValue -> Css +alignItems = key "align-items" + +------------------------------------------------------------------------------- + +newtype AlignSelfValue = AlignSelfValue Value + deriving (Val, Other, Inherit, Auto, Baseline + , Center, FlexEnd, FlexStart, Stretch) + +alignSelf :: AlignSelfValue -> Css +alignSelf = key "align-self" + +------------------------------------------------------------------------------- + +flex :: Int -> Int -> Size b -> Css +flex g s b = key "flex" (gs ! ss ! value b) + where gs = fromString (show g) :: Value + ss = fromString (show s) :: Value + +------------------------------------------------------------------------------- + +flexBasis :: Size a -> Css +flexBasis = key "flex-basis" + +------------------------------------------------------------------------------- + +newtype FlexDirection = FlexDirection Value + deriving (Val, Other) + +row, rowReverse, column, columnReverse :: FlexDirection + +row = FlexDirection "row" +rowReverse = FlexDirection "row-reverse" +column = FlexDirection "column" +columnReverse = FlexDirection "column-reverse" + +flexDirection :: FlexDirection -> Css +flexDirection = key "flex-direction" + +------------------------------------------------------------------------------- + +flexFlow :: FlexDirection -> FlexWrap -> Css +flexFlow d w = key "flex-flow" (d ! w) + +------------------------------------------------------------------------------- + +flexGrow :: Int -> Css +flexGrow i = key "flex-grow" (fromString (show i) :: Value) + +flexShrink :: Int -> Css +flexShrink i = key "flex-shrink" (fromString (show i) :: Value) + +------------------------------------------------------------------------------- + +newtype FlexWrap = FlexWrap Value + deriving (Val, Other) + +nowrap, wrap, wrapReverse :: FlexWrap + +nowrap = FlexWrap "nowrap" +wrap = FlexWrap "wrap" +wrapReverse = FlexWrap "wrap-reverse" + +flexWrap :: FlexWrap -> Css +flexWrap = key "flex-wrap" + +------------------------------------------------------------------------------- + +newtype JustifyContentValue = JustifyContentValue Value + deriving (Val, Other, Inherit, Center, FlexEnd + , FlexStart, SpaceAround, SpaceBetween, SpaceEvenly, Stretch) + +justifyContent :: JustifyContentValue -> Css +justifyContent = key "justify-content" + +------------------------------------------------------------------------------- + +order :: Int -> Css +order i = key "order" (fromString (show i) :: Value) diff --git a/src/Clay/Font.hs b/src/Clay/Font.hs --- a/src/Clay/Font.hs +++ b/src/Clay/Font.hs @@ -102,7 +102,8 @@ [GenericFontFamily] instance Val (Required a) where - value (Required a Nothing c d) = value (a ! (Literal <$> c) ! d) + value (Required a Nothing c d) = value a <> " " <> (value $ Literal <$> c) <> sep <> value d + where sep = if null c || null d then "" else "," value (Required a (Just b) c d) = value ((value a <> "/" <> value b) ! (Literal <$> c) ! d) instance Font ( Required a) diff --git a/src/Clay/FontFace.hs b/src/Clay/FontFace.hs --- a/src/Clay/FontFace.hs +++ b/src/Clay/FontFace.hs @@ -9,20 +9,25 @@ import Clay.Property (Prefixed (Plain), Value(Value), Val (value), quote) import Clay.Stylesheet (Css, key) -import Data.Monoid ((<>)) -import Data.Functor((<$>)) import Data.Maybe (fromMaybe) import Data.Text (Text) ------------------------------------------------------------------------------- -data FontFaceFormat = WOFF | TrueType | OpenType | EmbeddedOpenType | SVG +data FontFaceFormat + = WOFF + | WOFF2 + | TrueType + | OpenType + | EmbeddedOpenType + | SVG deriving Show -- | name of format according to CSS specification formatName :: FontFaceFormat -> Text formatName format = case format of WOFF -> "woff" + WOFF2 -> "woff2" TrueType -> "truetype" OpenType -> "opentype" EmbeddedOpenType -> "embedded-opentype" diff --git a/src/Clay/Geometry.hs b/src/Clay/Geometry.hs --- a/src/Clay/Geometry.hs +++ b/src/Clay/Geometry.hs @@ -7,6 +7,12 @@ -- * Sizing. , width, height, minWidth, minHeight, maxWidth, maxHeight +-- ** Aspect ratio. +, AspectRatio +, aspectRatio +, (%) +, withFallback + -- * Padding. , padding , paddingTop, paddingLeft, paddingRight, paddingBottom @@ -17,6 +23,9 @@ ) where +import qualified Data.Ratio as R +import Data.String (fromString) +import Clay.Common import Clay.Property import Clay.Stylesheet import Clay.Size @@ -42,6 +51,100 @@ ------------------------------------------------------------------------------- +-- | Represents an aspect ratio for use with 'aspectRatio'. +-- +-- A fixed ratio can be formed from two integers: +-- +-- >>> let _ = 4%3 :: AspectRatio +-- +-- An aspect ratio can also be converted from a 'Rational': +-- +-- >>> let _ = fromRational 0.5 :: AspectRatio +-- +data AspectRatio = AspectRatio Rational + | AspectRatioValue Value + | AspectRatioWithFallback (AspectRatio, AspectRatio) + +instance Auto AspectRatio where auto = AspectRatioValue auto +instance Inherit AspectRatio where inherit = AspectRatioValue inherit +instance Initial AspectRatio where initial = AspectRatioValue initial +instance Unset AspectRatio where unset = AspectRatioValue unset +instance Other AspectRatio where other = AspectRatioValue + +-- | An 'AspectRatio' can be converted from an 'Integer', +-- but other operations are not supported. +instance Num AspectRatio where + fromInteger = AspectRatio . toRational + (+) = error "plus not implemented for AspectRatio" + (*) = error "times not implemented for AspectRatio" + abs = error "abs not implemented for AspectRatio" + signum = error "signum not implemented for AspectRatio" + negate = error "negate not implemented for AspectRatio" + +-- | An 'AspectRatio' can be converted from a 'Rational', +-- but other operations are not supported. +instance Fractional AspectRatio where + fromRational = AspectRatio + recip = error "recip not implemented for AspectRatio" + +instance Val AspectRatio where + value (AspectRatioValue v) = v + value (AspectRatio r) = v + where v = fromString $ numerator <> "/" <> denominator :: Value + numerator = show (R.numerator r) + denominator = show (R.denominator r) + value (AspectRatioWithFallback (a, b)) = value a <> " " <> value b + +-- | Defines the width to height ratio of an element. +-- At least one of the width or height must be of automatic size, +-- otherwise the aspect ratio will be ignored. +-- +-- It can be given a fixed ratio of the width to the height: +-- +-- >>> renderWith compact [] $ aspectRatio (4%3) +-- "{aspect-ratio:4/3}" +-- +-- It can also be the intrinsic aspect ratio for the element: +-- +-- >>> renderWith compact [] $ aspectRatio auto +-- "{aspect-ratio:auto}" +-- +-- It can be told to use the intrinsic aspect ratio for the element, +-- but to use a fixed ratio while it is unknown or if the element does not have one: +-- +-- >>> renderWith compact [] $ aspectRatio $ auto `withFallback` (4%3) +-- "{aspect-ratio:auto 4/3}" +-- +-- Corresponds to the +-- [@aspect-ratio@](https://developer.mozilla.org/en-US/docs/Web/CSS/aspect-ratio) +-- property in CSS. +aspectRatio :: AspectRatio -> Css +aspectRatio = key "aspect-ratio" + +-- | The aspect ratio of the width to the height for use with 'aspectRatio'. +-- +-- Note that this is /not/ the same @%@ operator from the "Data.Ratio" module, +-- although they do both semantically represent ratios. The same symbol is used +-- to signify that the return value is a ratio. +(%) :: Integer -> Integer -> AspectRatio +(%) m n = fromRational $ (R.%) m n + +-- The same as the normal % operator. +infixl 7 % + +-- | Returns an aspect ratio specifying that the intrinsic aspect +-- ratio should be used, but when it is unknown or there is none, +-- a fixed ratio can be used as a fallback. +withFallback :: AspectRatio -> AspectRatio -> AspectRatio +withFallback x@(AspectRatioValue "auto") y@(AspectRatio _) = + AspectRatioWithFallback (x, y) +withFallback x@(AspectRatio _) y@(AspectRatioValue "auto") = + AspectRatioWithFallback (x, y) +withFallback _ _ = + error "Arguments for aspectRatio . withFallback must be auto and a ratio in either order" + +------------------------------------------------------------------------------- + padding :: Size a -> Size a -> Size a -> Size a -> Css padding a b c d = key "padding" (a ! b ! c ! d) @@ -63,4 +166,3 @@ marginLeft = key "margin-left" marginRight = key "margin-right" marginBottom = key "margin-bottom" - diff --git a/src/Clay/Gradient.hs b/src/Clay/Gradient.hs --- a/src/Clay/Gradient.hs +++ b/src/Clay/Gradient.hs @@ -36,15 +36,13 @@ ) where -import Data.Monoid - import Clay.Color import Clay.Common import Clay.Property import Clay.Size import Clay.Background -type Ramp = [(Color, Size Rel)] +type Ramp = [(Color, Size Percentage)] ------------------------------------------------------------------------------- @@ -81,7 +79,7 @@ ellipse :: Extend -> Radial ellipse ext = Radial ("ellipse " <> value ext) -circular :: Size Abs -> Radial +circular :: Size LengthUnit -> Radial circular radius = Radial (value (radius, radius)) elliptical :: Size a -> Size a -> Radial @@ -115,5 +113,5 @@ ramp xs = value (map (\(a, b) -> value (value a, value b)) xs) shortcut :: (Ramp -> BackgroundImage) -> Color -> Color -> BackgroundImage -shortcut g f t = g [(f, 0), (t, 100)] +shortcut g f t = g [(f, (pct 0)), (t, (pct 100))] diff --git a/src/Clay/Grid.hs b/src/Clay/Grid.hs new file mode 100644 --- /dev/null +++ b/src/Clay/Grid.hs @@ -0,0 +1,775 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +-- | Partial implementation of +-- | . +module Clay.Grid +( + -- * Grid + -- + -- $gridIntro + gridGap + , gridTemplateColumns + + -- * Size and location + -- + -- $sizeAndLocationIntro + + -- ** Data types and type classes + , GridLine + , ToGridLine + , GridLines2 + , ToGridLines2 + , GridLines4 + , ToGridLines4 + , OneGridLine + , TwoGridLines + , ThreeGridLines + , FourGridLines + , CustomIdentGrid + , customIdentToText + , partialMkCustomIdentGrid + , ToSpan + + -- ** Style properties + -- + -- $invalidValues + , gridArea + , gridColumn + , gridColumnStart + , gridColumnEnd + , gridRow + , gridRowStart + , gridRowEnd + + -- ** Keywords + , (//) + , span_ +) +where + +import qualified Clay.Common as Com +import Clay.Property (Val, Value, noCommas, value) +import Clay.Size (Size) +import Clay.Stylesheet (Css, key) +import Data.Char (isNumber) +import Data.Text (Text) +import qualified Data.Text as T +import Prelude + +-- $gridIntro +-- @grid-gap@ and @grid-template@ CSS properties. +-- +-- === Example +-- For the below CSS code: +-- +-- @ +-- .grid1 { +-- display: grid; +-- width: max-content; +-- } +-- +-- .grid3 { +-- display: grid; +-- width: max-content; +-- } +-- +-- \@media (min-width: 40.0rem) { +-- .grid3 { +-- display: grid; +-- grid-template-columns: 1fr 1fr 1fr; +-- grid-gap: 1rem; +-- width: max-content; +-- } +-- } +-- @ +-- +-- The corresponding clay code is: +-- +-- @ +-- ".grid1" ? do +-- display grid +-- width maxContent +-- ".grid3" ? do +-- display grid +-- width maxContent +-- query M.screen [M.minWidth (rem 40)] $ ".grid3" ? do +-- display grid +-- gridTemplateColumns [fr 1, fr 1, fr 1] +-- gridGap $ rem 1 +-- width maxContent +-- @ + +-- | Property sets the gaps (gutters) between rows and columns. +gridGap :: Size a -> Css +gridGap = key "grid-gap" + +-- | Property defines the line names and track sizing functions of the grid columns. +gridTemplateColumns :: [Size a] -> Css +gridTemplateColumns = key "grid-template-columns" . noCommas + +-- $sizeAndLocationIntro +-- +-- == CSS documentation +-- The below functions are based on +-- [MDN Web Docs](https://developer.mozilla.org/en-US/docs/Web/CSS) +-- CSS documentation. +-- +-- === __Naming note__ +-- In this documentation, as the functions are polymorphic we sometimes +-- refer to the CSS types as used in the +-- [mdm web docs_](https://developer.mozilla.org/en-US/docs/Web/CSS) +-- rather than the Haskell types. +-- For example, @grid-line@ is used instead of 'GridLine' as a the argument +-- might be provided as a 'GridLine' but also as an 'Integer', 'String', etc. +-- +-- == Pragma +-- #pragma# +-- If you want to avoid specifying the types of the arguments, enable +-- the @ExtendedDefaultRules@ GHC language pragma as well as the +-- @-Wno-type-defaults@ GHC option to avoid compilation warnings. +-- +-- @ +-- {-# LANGUAGE ExtendedDefaultRules #-} +-- {-# OPTIONS_GHC -Wno-type-defaults #-} +-- @ +-- +-- === __Examples__ +-- With the above enabled, you can write: +-- +-- >> gridRowStart 2 +-- +-- >> gridRowStart "somegridarea" +-- +-- If you do not enable those, then you must write: +-- +-- >> gridRowStart (2 :: Integer) +-- +-- >> gridRowStart ("somegridarea" :: String) +-- +-- === __Note__ +-- If you decide to enable the above, it is advisable to have your Clay +-- CSS code in its own module, so the behaviour of the rest of your code +-- is not affected. +-- +-- == Examples +-- Examples are provided through the documentation for the various functions. +-- Further examples can be found in the source code of the test suite +-- in the GridSpec.hs module. + +-- | A @grid-line@ value. +-- +-- A @grid-line@ value specifies a size and location in a grid. +-- +-- === __Note__ +-- To know more about @grid-line@ value, see for example the documentation of +-- the [grid-row-start](https://developer.mozilla.org/en-US/docs/Web/CSS/grid-row-start) +-- CSS property. +data GridLine + + -- | 'Integer' value. + -- + -- __NOTE:__ 'Integer' value of 0 is invalid. + = Coordinate Integer + + -- | @custom-ident@ with an optional 'Integer' value. + -- + -- __NOTE:__ 'Integer' value of 0 is invalid. + | GridLineCustomIdent CustomIdentGrid (Maybe Integer) + + -- | @span@ CSS keyword with an optional @custom-ident@ + -- | and/or 'Integer' value. + -- + -- __NOTE:__ negative 'Integer' or 0 are invalid. + | Span (Maybe CustomIdentGrid) (Maybe Integer) + + -- | Other grid line values: @auto@, @inherit@, @initial@, @unset@. + | OtherGridLine Value + deriving (Eq, Show) + +class ToGridLine a where + -- | Convert the provided type to a 'GridLine'. + toGridLine :: a -> GridLine + +instance ToGridLine GridLine where + toGridLine = id + +instance ToGridLine Integer where + -- | __NOTE:__ 'Integer' value of 0 is invalid. + toGridLine = Coordinate + +-- | @custom-ident@ value. +instance ToGridLine CustomIdentGrid where + toGridLine x = GridLineCustomIdent x Nothing + +-- | @custom-ident@ value. +instance ToGridLine String where + toGridLine = toGridLine . partialMkCustomIdentGrid . T.pack + +-- | Both @custom-ident@ and `Integer` values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLine (CustomIdentGrid, Integer) where + toGridLine (x, y) = GridLineCustomIdent x (Just y) + +-- | Both @custom-ident@ and `Integer` values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLine (String, Integer) where + toGridLine (x, y) = toGridLine (partialMkCustomIdentGrid $ T.pack x, y) + +-- | One or two @grid-line@ values. +data GridLines2 + -- | One @grid-line@ value. + = One2 OneGridLine + -- | Two @grid-line@ values. + | Two2 TwoGridLines + +class ToGridLines2 a where + + -- | Convert the provided type to 'GridLines2' (one or two @grid-line@ values). + toGridLines2 :: a -> GridLines2 + +-- | One @grid-line@ value. +instance ToGridLines2 GridLine where + toGridLines2 = One2 . OneGridLine + +-- | One @grid-line@ value. +instance ToGridLines2 OneGridLine where + toGridLines2 = One2 + +-- | Two @grid-line@ values. +instance ToGridLines2 TwoGridLines where + toGridLines2 = Two2 + +-- | One or two @grid-line@ values. +instance ToGridLines2 GridLines2 where + toGridLines2 = id + +-- | One 'Integer' value. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines2 Integer where + toGridLines2 = toGridLines2 . toGridLine + +-- | One @custom-ident@ value. +instance ToGridLines2 CustomIdentGrid where + toGridLines2 = toGridLines2 . toGridLine + +-- | One @custom-ident@ value. +instance ToGridLines2 String where + toGridLines2 = toGridLines2 . toGridLine + +-- | One time both a @custom-ident@ and 'Integer' values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines2 (CustomIdentGrid, Integer) where + toGridLines2 = toGridLines2 . toGridLine + +-- | One time both a @custom-ident@ and 'Integer' values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines2 (String, Integer) where + toGridLines2 = toGridLines2 . toGridLine + +-- | One, two, three or four @grid-line@ values. +data GridLines4 + + -- | One @grid-line@ value. + = One4 OneGridLine + + -- | Two @grid-line@ values. + | Two4 TwoGridLines + + -- | Three @grid-line@ values. + | Three4 ThreeGridLines + + -- | Four @grid-line@ values. + | Four4 FourGridLines + +class ToGridLines4 a where + -- | Convert the provided type to 'GridLines4' + -- (one, two, three or four @grid-line@ values). + toGridLines4 :: a -> GridLines4 + +-- | One @grid-line@ value. +instance ToGridLines4 GridLine where + toGridLines4 = One4 . OneGridLine + +-- | One @grid-line@ value. +instance ToGridLines4 OneGridLine where + toGridLines4 = One4 + +-- | Two @grid-line@ values. +instance ToGridLines4 TwoGridLines where + toGridLines4 = Two4 + +-- | Three @grid-line@ values. +instance ToGridLines4 ThreeGridLines where + toGridLines4 = Three4 + +-- | Four @grid-line@ values. +instance ToGridLines4 FourGridLines where + toGridLines4 = Four4 + +-- | One, two, three or four @grid-line@ values. +instance ToGridLines4 GridLines4 where + toGridLines4 = id + +-- | One 'Integer' value. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines4 Integer where + toGridLines4 = toGridLines4 . toGridLine + +-- | One @custom-ident@ value. +instance ToGridLines4 CustomIdentGrid where + toGridLines4 = toGridLines4 . toGridLine + +-- | One @custom-ident@ value. +instance ToGridLines4 String where + toGridLines4 = toGridLines4 . toGridLine + +-- | One time both a @custom-ident@ and 'Integer' values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines4 (CustomIdentGrid, Integer) where + toGridLines4 = toGridLines4 . toGridLine + +-- | One time both a @custom-ident@ and 'Integer' values, provided as a pair. +-- +-- __NOTE:__ 'Integer' value of 0 is invalid. +instance ToGridLines4 (String, Integer) where + toGridLines4 = toGridLines4 . toGridLine + +-- | One 'GridLine' value. +newtype OneGridLine = OneGridLine GridLine + +-- | Two 'GridLine' values. +data TwoGridLines = TwoGridLines GridLine GridLine + +-- | Three 'GridLine' values. +data ThreeGridLines = ThreeGridLines GridLine GridLine GridLine + +-- | Four 'GridLine' values. +data FourGridLines = FourGridLines GridLine GridLine GridLine GridLine + +-- | CSS @custom-ident@. +-- +-- The data constructor is not exported. Use the 'partialMkCustomIdentGrid' +-- smart constructor to create a 'CustomIdentGrid'. +-- +-- === __Note__ +-- In CSS, some values for @custom-ident@ are invalid depending on the CSS +-- property the @custom-ident@ is used with. +-- Consequently, the @custom-ident@ is only for CSS grid. +newtype CustomIdentGrid = CustomIdentGrid Text deriving (Eq, Ord, Read, Show) + +-- | Convert a 'CustomIdentGrid' to 'Text'. +-- +-- === __Note__ +-- The function is defined on its own as the newtype constructor +-- of 'CustomIdentGrid'is not exported. +customIdentToText :: CustomIdentGrid -> Text +customIdentToText (CustomIdentGrid x) = x + +-- | Create a 'CustomIdentGrid'. +-- +-- __WARNING__: this function is partial. An error will be raised if: +-- +-- * "span" is provided as a value (this is a reserved keyword in this context) +-- * a number is provided as first character +-- * __If__ a hyphen (-) is provided as first character: +-- +-- ** a number is provided as second character +-- ** a hyphen (-) is provided as second character. +-- +-- === __Note__ +-- The above is a partial implementation of the CSS custom-ident naming rules. +-- If you stick to the following charset @[a-zA-z0-9-_]@ the checks will be effective +-- and your CSS custom-ident will be a valid one. +-- On the other hand, the following will not be checked: +-- +-- * character escaping (for example @\?@) or unicode +-- * characters provided as hexadecimal number (for example @\0x03BB@) +-- * characters outside of the above charset. +-- +-- More information regarding this topic can be found on +-- [mdm web docs_](https://developer.mozilla.org/en-US/docs/Web/CSS/custom-ident) +partialMkCustomIdentGrid :: Text -> CustomIdentGrid +partialMkCustomIdentGrid "span" = error "Custom-ident for a grid property cannot be named span" +partialMkCustomIdentGrid txt = checkText + where + checkText = checkHead (fst unconsTxt) + + checkHead :: Char -> CustomIdentGrid + checkHead c + | isNumber c = error "Custom-ident cannot start with a number" + | c == '-' = checkSecond second + | otherwise = CustomIdentGrid txt + + checkSecond (Just s) + | s == '-' = + error "Custom-ident cannot start with two hyphens" + | isNumber s = + error "Custom-ident cannot start with a hyphen followed by a number" + | otherwise = CustomIdentGrid txt + checkSecond Nothing = CustomIdentGrid txt + + unconsTxt = case T.uncons txt of + Nothing -> error "Custom-ident cannot be empty" + Just (f, r) -> (f, r) + + second :: Maybe Char + second = fst <$> T.uncons (snd unconsTxt) + +-- $invalidValues +-- +-- #partial# +-- The below functions are partial. They will raise an error if +-- provided with a @grid-line@ value which is: +-- +-- * an 'Integer' value of 0 +-- * a pair with an 'Integer' component of value 0 +-- * a 'span_' function provided with an 'Integer' value of 0 or negative +-- * a 'span_' function provided with a pair value with +-- an 'Integer' component of 0 or negative. +-- * an invalid @custom-ident@ value, see 'partialMkCustomIdentGrid'. + +-- | Property shorthand specifies a grid item's size and location +-- within a grid. +-- +-- One to four @grid-line@ values can be specified. +-- Grid-line values must be separated by a '(//)' operator. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridArea (auto :: GridLine) +-- +-- > gridArea "somegridarea" +-- +-- > gridArea $ ("somegridarea", 4) // ("someothergridarea", 2) +-- +-- > gridArea $ 1 // 3 // 4 +gridArea :: ToGridLines4 a => a -> Css +gridArea x = key "grid-area" (partialToGridLines4 x) + +-- | Property shorthand specifies a grid item's size and location +-- within a grid column. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridColumn (auto :: GridLine) +-- +-- > gridColumn $ span_ 3 +-- +-- > gridColumn $ span_ ("somegridarea", 5) +-- +-- > gridColumn $ span_ 3 // 6 +gridColumn :: ToGridLines2 a => a -> Css +gridColumn x = key "grid-column" (partialToGridLines2 x) + +-- | Property specifies a grid item's start position within the grid column. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridColumnStart (inherit :: GridLine) +-- +-- > gridColumnStart 2 +-- +-- > gridColumnStart ("somegridarea", 4) +-- +-- > gridColumnStart $ span_ ("somegridarea", 5) +gridColumnStart :: ToGridLine a => a -> Css +gridColumnStart x = key "grid-column-start" (partialToGridLine x) + +-- | Property specifies a grid item's end position within the grid column. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridColumnEnd (initial :: GridLine) +-- +-- > gridColumnEnd 2 +-- +-- > gridColumnEnd "somegridarea" +-- +-- > gridColumnEnd $ span_ "somegridarea" +gridColumnEnd :: ToGridLine a => a -> Css +gridColumnEnd x = key "grid-column-end" (partialToGridLine x) + +-- | Property shorthand specifies a grid item's size and location +-- within a grid row. +-- +-- One or two @grid-line@ values can be specified. +-- @grid-line@ values must be separated by a '(//)' operator. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridRow (unset :: GridLine) +-- +-- > gridRow $ span_ 3 +-- +-- > gridRow $ span_ 3 // 6 +-- +-- > gridRow $ span_ ("somegridarea", 5) // span_ 2 +gridRow :: ToGridLines2 a => a -> Css +gridRow x = key "grid-row" (partialToGridLines2 x) + +-- | Property specifies a grid item's start position within the grid row. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridRowStart (initial :: GridLine) +-- +-- > gridRowStart (-2) +-- +-- > gridRowStart $ span_ "somegridarea" +-- +-- > gridRowStart "somegridarea" +gridRowStart :: ToGridLine a => a -> Css +gridRowStart x = key "grid-row-start" (partialToGridLine x) + +-- | Property specifies a grid item's end position within the grid row. +-- +-- __WARNING:__ this function is partial. See above "Clay.Grid#partial". +-- +-- ==== __Examples__ +-- +-- The below examples assume that the @ExtendedDefaultRules@ GHC language +-- pragma is enabled. See above "Clay.Grid#pragma". +-- +-- > gridRowEnd (auto :: GridLine) +-- +-- > gridRowEnd (-2) +-- +-- > gridRowEnd ("somegridarea", 4) +-- +-- > gridRowEnd $ span_ 3 +gridRowEnd :: ToGridLine a => a -> Css +gridRowEnd x = key "grid-row-end" (partialToGridLine x) + +class Slash a r | a -> r where + -- | `/` CSS operator. + -- Separates @grid-line@ values. + (//) :: ToGridLine b => a -> b -> r + +instance Slash GridLine TwoGridLines where + x // y = TwoGridLines x (toGridLine y) + +instance Slash Integer TwoGridLines where + x // y = TwoGridLines (toGridLine x) (toGridLine y) + +instance Slash CustomIdentGrid TwoGridLines where + x // y = TwoGridLines (toGridLine x) (toGridLine y) + +instance Slash String TwoGridLines where + x // y = TwoGridLines (toGridLine x) (toGridLine y) + +instance Slash (CustomIdentGrid, Integer) TwoGridLines where + x // y = TwoGridLines (toGridLine x) (toGridLine y) + +instance Slash (String, Integer) TwoGridLines where + x // y = TwoGridLines (toGridLine x) (toGridLine y) + +instance Slash TwoGridLines ThreeGridLines where + (TwoGridLines xx xy) // y = ThreeGridLines xx xy (toGridLine y) + +instance Slash ThreeGridLines FourGridLines where + (ThreeGridLines xx xy xz) // y = FourGridLines xx xy xz (toGridLine y) + +class ToSpan a where + + -- | @span@ CSS keyword, contributes to the grid item's placement. + span_ :: a -> GridLine + +-- | Contributes the nth grid line to the grid item's placement. +-- +-- __NOTE:__ negative 'Integer' or 0 values are invalid. +instance ToSpan Integer where + span_ x = Span Nothing (Just x) + +-- | One line from the provided name is counted. +instance ToSpan String where + span_ x = Span (Just . partialMkCustomIdentGrid $ T.pack x) Nothing + +-- | Nth lines from the provided name are counted. +-- +-- __NOTE:__ negative 'Integer' or 0 values are invalid. +instance ToSpan (String, Integer) where + span_ (x, y) = Span (Just . partialMkCustomIdentGrid $ T.pack x) (Just y) + +-- | Keyword indicating that the property contributes nothing +-- to the grid item's placement. +instance Com.Auto GridLine where + auto = OtherGridLine $ value ("auto" :: Text) + +-- | Keyword `inherit` applied to a 'GridLine'. +instance Com.Inherit GridLine where + inherit = OtherGridLine $ value ("inherit" :: Text) + +-- | Keyword `initial` applied to a 'GridLine'. +instance Com.Initial GridLine where + initial = OtherGridLine $ value ("initial" :: Text) + +-- | Keyword `unset` applied to a 'GridLine'. +instance Com.Unset GridLine where + unset = OtherGridLine $ value ("unset" :: Text) + +-- | Convertion of 'GridLine' to 'Clay.Property.Value'. +instance Val GridLine where + value (OtherGridLine val) = val + value (Coordinate x) = value x + value (GridLineCustomIdent x y) = + value $ customIdentToText x <> foldMap ((" " <>) . tshow) y + value (Span x y) = + value $ "span" <> foldMap ((" " <>) + . customIdentToText) x <> foldMap ((" " <>) . tshow) y + +instance Val OneGridLine where + value (OneGridLine x) = value x + +instance Val TwoGridLines where + value (TwoGridLines x y) = + value x <> value (" / " :: Text) <> value y + +instance Val ThreeGridLines where + value (ThreeGridLines x y z) = + value x + <> value (" / " :: Text) <> value y + <> value (" / " :: Text) <> value z + +instance Val FourGridLines where + value (FourGridLines xx xy xz yx) = + value xx + <> value (" / " :: Text) <> value xy + <> value (" / " :: Text) <> value xz + <> value (" / " :: Text) <> value yx + +instance Val GridLines2 where + value (One2 x) = value x + value (Two2 x) = value x + +instance Val GridLines4 where + value (One4 x) = value x + value (Two4 x) = value x + value (Three4 x) = value x + value (Four4 x) = value x + +-- | Private partial function checking a 'GridLine'. +-- +-- An error is raised when: +-- - An 'Integer' value of 0 is provided. +-- - A negative 'Integer' value is provided for a 'Span' constructor. +-- +-- Otherwise, the initially provided 'GridLine' value is returned. +partialCheckGridLine :: GridLine -> GridLine +partialCheckGridLine gridLine = case gridLine of + Coordinate 0 -> errorValue 0 + GridLineCustomIdent _ (Just 0) -> errorValue 0 + s@(Span _ (Just n)) -> if n < 1 + then errorValue n + else s + _ -> gridLine + where + errorValue n = error ("Value " ++ show n ++ " is invalid") + +-- | Private partial function checking 'OneGridLine'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialCheckOneGridLine :: OneGridLine -> OneGridLine +partialCheckOneGridLine (OneGridLine gridLine) = + OneGridLine (partialCheckGridLine gridLine) + +-- | Private partial function checking 'TwoGridLines'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialCheckTwoGridLines :: TwoGridLines -> TwoGridLines +partialCheckTwoGridLines (TwoGridLines gridLine1 gridLine2) = + TwoGridLines (partialCheckGridLine gridLine1) (partialCheckGridLine gridLine2) + +-- | Private partial function checking 'ThreeGridLines'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialCheckThreeGridLines :: ThreeGridLines -> ThreeGridLines +partialCheckThreeGridLines (ThreeGridLines gridLine1 gridLine2 gridLine3) = + ThreeGridLines + (partialCheckGridLine gridLine1) + (partialCheckGridLine gridLine2) + (partialCheckGridLine gridLine3) + +-- | Private partial function checking 'FourGridLines'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialCheckFourGridLines :: FourGridLines -> FourGridLines +partialCheckFourGridLines + (FourGridLines gridLine1 gridLine2 gridLine3 gridLine4) = + FourGridLines + (partialCheckGridLine gridLine1) + (partialCheckGridLine gridLine2) + (partialCheckGridLine gridLine3) + (partialCheckGridLine gridLine4) + +-- | Private partial function converting its argument to 'GridLine'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialToGridLine :: ToGridLine a => a -> GridLine +partialToGridLine = partialCheckGridLine . toGridLine + +-- | Private partial function converting its argument to 'GridLines2'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialToGridLines2 :: ToGridLines2 a => a -> GridLines2 +partialToGridLines2 x = partialGridLine' gridLines + where + gridLines = toGridLines2 x + partialGridLine' (One2 gl) = One2 (partialCheckOneGridLine gl) + partialGridLine' (Two2 gl) = Two2 (partialCheckTwoGridLines gl) + +-- | Private partial function converting its argument to 'GridLines4'. +-- +-- An error is raised if an invalid value is found, see 'partialCheckGridLine'. +partialToGridLines4 :: ToGridLines4 a => a -> GridLines4 +partialToGridLines4 x = partialGridLine' gridLines + where + gridLines = toGridLines4 x + partialGridLine' (One4 gl) = One4 (partialCheckOneGridLine gl) + partialGridLine' (Two4 gl) = Two4 (partialCheckTwoGridLines gl) + partialGridLine' (Three4 gl) = Three4 (partialCheckThreeGridLines gl) + partialGridLine' (Four4 gl) = Four4 (partialCheckFourGridLines gl) + +-- | Private utility function to show 'Text' instead of 'String'. +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/src/Clay/List.hs b/src/Clay/List.hs --- a/src/Clay/List.hs +++ b/src/Clay/List.hs @@ -36,7 +36,6 @@ ) where -import Data.Monoid import Data.Text (Text) import Clay.Common @@ -75,7 +74,7 @@ listStyleType = key "list-style-type" newtype ListStylePosition = ListStylePosition Value - deriving (Val, Initial, Inherit, None, Other) + deriving (Val, Initial, Inherit, Other) inside, outside :: ListStylePosition diff --git a/src/Clay/Mask.hs b/src/Clay/Mask.hs --- a/src/Clay/Mask.hs +++ b/src/Clay/Mask.hs @@ -57,8 +57,6 @@ ) where -import Data.Monoid - import Clay.Background import Clay.Common import Clay.Property diff --git a/src/Clay/Media.hs b/src/Clay/Media.hs --- a/src/Clay/Media.hs +++ b/src/Clay/Media.hs @@ -4,16 +4,20 @@ -- * Media types. - aural, braille, handheld, print, projection -, screen, tty, tv, embossed + all, screen, print +-- ** Deprecated. + +-- | These media types were deprecated by Media Queries 4. +, aural, braille, handheld, projection, tty, tv, embossed + -- * Geometrical features. , width, minWidth, maxWidth, height, minHeight, maxHeight, deviceWidth , minDeviceWidth, maxDeviceWidth, deviceHeight, minDeviceHeight , maxDeviceHeight --- * Aspect ration features. +-- * Aspect ratio features. , aspectRatio, minAspectRatio, maxAspectRatio, deviceAspectRatio , minDeviceAspectRatio, maxDeviceAspectRatio @@ -33,6 +37,16 @@ , Resolution , dpi , dppx + +-- * Preference related features. + +, prefersColorScheme + +-- ** Preference related values. + +, ColorScheme +, light +, dark ) where @@ -40,7 +54,7 @@ import Data.Text (Text, pack) import Data.Monoid -import Clay.Common +import Clay.Common hiding (all) import Clay.Size import Clay.Property import Clay.Stylesheet @@ -49,14 +63,18 @@ ------------------------------------------------------------------------------- -aural, braille, handheld, print, projection +all, aural, braille, handheld, print, projection , screen, tty, tv, embossed :: MediaType +-- | Suitable for all devices. +all = MediaType "all" aural = MediaType "aural" braille = MediaType "braille" handheld = MediaType "handheld" +-- | Intended primarily for printed material or in a print layout. print = MediaType "print" projection = MediaType "projection" +-- | Intended primarily for screen-based devices. screen = MediaType "screen" tty = MediaType "tty" tv = MediaType "tv" @@ -72,7 +90,7 @@ width, minWidth, maxWidth, height, minHeight, maxHeight, deviceWidth , minDeviceWidth, maxDeviceWidth, deviceHeight, minDeviceHeight - , maxDeviceHeight :: Size Abs -> Feature + , maxDeviceHeight :: Size LengthUnit -> Feature width = with "width" minWidth = with "min-width" @@ -132,3 +150,21 @@ dppx :: Integer -> Resolution dppx i = Resolution (value (pack (show i) <> "dppx")) +------------------------------------------------------------------------------- + +-- | Feature detecting whether user prefers light or dark color scheme. +prefersColorScheme :: ColorScheme -> Feature +prefersColorScheme = with "prefers-color-scheme" + +-- | A color scheme preferred by a user. +newtype ColorScheme = ColorScheme Value + deriving (Val, Other) + +-- | User indicates that they prefer a light theme with their interface, +-- or that they have not indicated a preference. +light :: ColorScheme +light = ColorScheme (value (pack "light")) + +-- | User indicates that they prefer a dark theme with their interface. +dark :: ColorScheme +dark = ColorScheme (value (pack "dark")) diff --git a/src/Clay/Property.hs b/src/Clay/Property.hs --- a/src/Clay/Property.hs +++ b/src/Clay/Property.hs @@ -2,22 +2,25 @@ module Clay.Property where import Control.Arrow (second) -import Control.Monad.Writer import Data.Fixed (Fixed, HasResolution (resolution), showFixed) import Data.List (partition, sort) +import Data.List.NonEmpty (NonEmpty, toList) import Data.Maybe import Data.String import Data.Text (Text, replace) data Prefixed = Prefixed { unPrefixed :: [(Text, Text)] } | Plain { unPlain :: Text } - deriving Show + deriving (Show, Eq) instance IsString Prefixed where fromString s = Plain (fromString s) +instance Semigroup Prefixed where + (<>) = merge + instance Monoid Prefixed where mempty = "" - mappend = merge + mappend = (<>) merge :: Prefixed -> Prefixed -> Prefixed merge (Plain x ) (Plain y ) = Plain (x <> y) @@ -40,7 +43,7 @@ ------------------------------------------------------------------------------- newtype Key a = Key { unKeys :: Prefixed } - deriving (Show, Monoid, IsString) + deriving (Show, Semigroup, Monoid, IsString) cast :: Key a -> Key () cast (Key k) = Key k @@ -48,7 +51,7 @@ ------------------------------------------------------------------------------- newtype Value = Value { unValue :: Prefixed } - deriving (Show, Monoid, IsString) + deriving (Show, Semigroup, Monoid, IsString, Eq) class Val a where value :: a -> Value @@ -57,7 +60,7 @@ value t = Value (Plain t) newtype Literal = Literal Text - deriving (Show, Monoid, IsString) + deriving (Show, Semigroup, Monoid, IsString) instance Val Literal where value (Literal t) = Value (Plain (quote t)) @@ -68,12 +71,6 @@ data E5 = E5 instance HasResolution E5 where resolution _ = 100000 -instance Val Double where - value = fromString . showFixed' . realToFrac - where - showFixed' :: Fixed E5 -> String - showFixed' = showFixed True - instance Val Value where value = id @@ -89,16 +86,32 @@ value (Right a) = value a instance Val a => Val [a] where - value xs = intersperse "," (map value xs) + value xs = intercalate "," (map value xs) -intersperse :: Monoid a => a -> [a] -> a -intersperse _ [] = mempty -intersperse s (x:xs) = foldl (\a b -> a <> s <> b) x xs +instance Val a => Val (NonEmpty a) where + value = value . toList +intercalate :: Monoid a => a -> [a] -> a +intercalate _ [] = mempty +intercalate s (x:xs) = foldl (\a b -> a `mappend` s `mappend` b) x xs + ------------------------------------------------------------------------------- +-- | A number type to represent the CSS @number@ type. +-- It has fixed precision, supporting up to 5 decimal places. +newtype Number = Number { unNumber :: Fixed E5 } + deriving (Enum, Eq, Fractional, Num, Ord, Read, Real, RealFrac, Show) + +instance Val Number where + value = Value . Plain . cssNumberText + +cssNumberText :: Number -> Text +cssNumberText = fromString . showFixed True . unNumber + +------------------------------------------------------------------------------- + noCommas :: Val a => [a] -> Value -noCommas xs = intersperse " " (map value xs) +noCommas xs = intercalate " " (map value xs) infixr ! diff --git a/src/Clay/Pseudo.hs b/src/Clay/Pseudo.hs --- a/src/Clay/Pseudo.hs +++ b/src/Clay/Pseudo.hs @@ -1,18 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Clay.Pseudo where import Data.Text (Text) +import Clay.Render (renderSelector, renderRefinement) import Clay.Selector +import qualified Data.Text.Lazy as Lazy + -- List of specific pseudo classes, from: -- https://developer.mozilla.org/en-US/docs/CSS/Pseudo-classes -after, before :: Refinement +-- * Pseudo elements -after = ":after" -before = ":before" +after, before, firstLetter, firstLine, selection, backdrop :: Refinement +after = "::after" +before = "::before" +firstLetter = "::first-letter" +firstLine = "::first-line" +selection = "::selection" +backdrop = "::backdrop" + +-- * Pseudo classes link, visited, active, hover, focus, firstChild, lastChild :: Refinement link = ":link" @@ -53,3 +65,20 @@ nthLastChild n = func "nth-last-child" [n] nthLastOfType n = func "nth-last-of-type" [n] nthOfType n = func "nth-of-type" [n] + +-- | The 'not' pseudo selector can be applied to both a 'Refinement' +-- +-- > input # not checked +-- +-- or a 'Selector' +-- +-- > not p + +class Not a where + not :: a -> Refinement + +instance Not Selector where + not r = func "not" [Lazy.toStrict (renderSelector r)] + +instance Not Refinement where + not r = func "not" (Lazy.toStrict <$> renderRefinement r) diff --git a/src/Clay/Render.hs b/src/Clay/Render.hs --- a/src/Clay/Render.hs +++ b/src/Clay/Render.hs @@ -4,42 +4,46 @@ , pretty , compact , render +, htmlInline , putCss , renderWith - , renderSelector +, renderRefinement +, withBanner ) where -import Control.Applicative -import Control.Monad.Writer -import Data.Either -import Data.Foldable (foldMap) -import Data.List (sort) -import Data.Maybe -import Data.Text (Text, pack) -import Data.Text.Lazy.Builder -import Prelude hiding ((**)) +import Control.Applicative +import Control.Monad.Writer +import Data.List (sort) +import Data.Maybe +import Data.Text (Text) +import Data.Text.Lazy.Builder +import Prelude hiding ((**)) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.IO as Lazy +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.IO as Lazy -import Clay.Stylesheet hiding (Child, query, rule) -import Clay.Common (browsers) -import Clay.Property -import Clay.Selector +import Clay.Common (browsers) +import Clay.Property +import Clay.Selector +import Clay.Stylesheet hiding (Child, query, rule) -import qualified Clay.Stylesheet as Rule +import qualified Clay.Stylesheet as Rule + data Config = Config { indentation :: Builder , newline :: Builder , sep :: Builder + , lbrace :: Builder + , rbrace :: Builder , finalSemicolon :: Bool , warn :: Bool , align :: Bool , banner :: Bool + , comments :: Bool } -- | Configuration to print to a pretty human readable CSS output. @@ -49,10 +53,13 @@ { indentation = " " , newline = "\n" , sep = " " + , lbrace = "{" + , rbrace = "}" , finalSemicolon = True , warn = True , align = True , banner = True + , comments = True } -- | Configuration to print to a compacted unreadable CSS output. @@ -62,12 +69,31 @@ { indentation = "" , newline = "" , sep = "" + , lbrace = "{" + , rbrace = "}" , finalSemicolon = False , warn = False , align = False , banner = False + , comments = False } +-- | Configuration to print to a compacted unreadable CSS output for embedding inline with HTML. + +htmlInline :: Config +htmlInline = Config + { indentation = "" + , newline = "" + , sep = "" + , lbrace = "" + , rbrace = "" + , finalSemicolon = False + , warn = False + , align = False + , banner = False + , comments = False + } + -- | Render to CSS using the default configuration (`pretty`) and directly -- print to the standard output. @@ -95,14 +121,20 @@ renderSelector :: Selector -> Lazy.Text renderSelector = toLazyText . selector compact +-- | Render a CSS `Refinement`. +renderRefinement :: Refinement -> [Lazy.Text] +renderRefinement r = toLazyText . predicate <$> unFilter r + ------------------------------------------------------------------------------- renderBanner :: Config -> Lazy.Text -> Lazy.Text renderBanner cfg - | banner cfg = (<> b) + | banner cfg = withBanner | otherwise = id - where b = "\n/* Generated with Clay, http://fvisser.nl/clay */" +withBanner :: Lazy.Text -> Lazy.Text +withBanner = (<> "\n/* Generated with Clay, http://fvisser.nl/clay */") + kframe :: Config -> Keyframes -> Builder kframe cfg (Keyframes ident xs) = foldMap @@ -110,20 +142,20 @@ mconcat [ "@" <> fromText browser <> "keyframes " , fromText ident , newline cfg - , "{" + , lbrace cfg , newline cfg , foldMap (frame cfg) xs - , "}" + , rbrace cfg , newline cfg , newline cfg ] ) (unPrefixed browsers) -frame :: Config -> (Double, [Rule]) -> Builder +frame :: Config -> (Number, [Rule]) -> Builder frame cfg (p, rs) = mconcat - [ fromText (pack (show p)) + [ fromText (cssNumberText p) , "% " , rules cfg [] rs ] @@ -133,10 +165,10 @@ mconcat [ mediaQuery q , newline cfg - , "{" + , lbrace cfg , newline cfg , rules cfg sel rs - , "}" + , rbrace cfg , newline cfg ] @@ -157,7 +189,7 @@ feature :: Feature -> Builder feature (Feature k mv) = case mv of - Nothing -> fromText k + Nothing -> mconcat [ "(", fromText k, ")" ] Just (Value v) -> mconcat [ "(" , fromText k , ": " , fromText (plain v) , ")" ] @@ -177,18 +209,18 @@ , (\(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 - imports (Import i ) = Just i - imports _ = Nothing + where property (Property m k v) = Just (m, 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 + imports (Import i ) = Just i + imports _ = Nothing imp :: Config -> Text -> Builder imp cfg t = @@ -198,18 +230,20 @@ , ");" , newline cfg ] +-- | A key-value pair with associated comment. +type KeyVal = ([Modifier], Key (), Value) -rule :: Config -> [App] -> [(Key (), Value)] -> Builder +rule :: Config -> [App] -> [KeyVal] -> Builder rule _ _ [] = mempty rule cfg sel props = let xs = collect =<< props in mconcat [ selector cfg (merger sel) , newline cfg - , "{" + , lbrace cfg , newline cfg , properties cfg xs - , "}" + , rbrace cfg , newline cfg ] @@ -223,34 +257,50 @@ Pop i -> merger (drop i (x:xs)) Self f -> case xs of [] -> star `with` f; _ -> merger xs `with` f -collect :: (Key (), Value) -> [Either Text (Text, Text)] -collect (Key ky, Value vl) = - case (ky, vl) of +data Representation + = Warning Text + | KeyValRep [Modifier] Text Text + deriving (Show) + +keys :: [Representation] -> [Text] +keys = mapMaybe f + where + f (KeyValRep _ k _) = Just k + f _ = Nothing + +collect :: KeyVal -> [Representation] +collect (ms, Key ky, Value vl) = case (ky, vl) of ( Plain k , Plain v ) -> [prop k v] ( Prefixed ks , Plain v ) -> flip map ks $ \(p, k) -> prop (p <> k) v ( Plain k , Prefixed vs ) -> flip map vs $ \(p, v) -> prop k (p <> v) - ( Prefixed ks , Prefixed vs ) -> flip map ks $ \(p, k) -> (Left (p <> k) `maybe` (prop (p <> k) . mappend p)) (lookup p vs) - where prop k v = Right (k, v) + ( Prefixed ks , Prefixed vs ) -> flip map ks $ \(p, k) -> (Warning (p <> k) `maybe` (prop (p <> k) . mappend p)) (lookup p vs) + where prop k v = KeyValRep ms k v -properties :: Config -> [Either Text (Text, Text)] -> Builder +properties :: Config -> [Representation] -> Builder properties cfg xs = - let width = 1 + maximum (Text.length . fst <$> rights xs) + let width = 1 + maximum (Text.length <$> keys xs) ind = indentation cfg new = newline cfg finalSemi = if finalSemicolon cfg then ";" else "" - in (<> new) $ (<> finalSemi) $ intersperse (";" <> new) $ flip map xs $ \p -> + in (<> new) $ (<> finalSemi) $ intercalate (";" <> new) $ flip map xs $ \p -> case p of - Left w -> if warn cfg + Warning w -> if warn cfg then ind <> "/* no value for " <> fromText w <> " */" <> new else mempty - Right (k, v) -> + KeyValRep ms k v -> let pad = if align cfg then fromText (Text.replicate (width - Text.length k) " ") else "" - in mconcat [ind, fromText k, pad, ":", sep cfg, fromText v] + imptant = maybe "" ((" " <>) . fromText) . foldMap _Important $ ms + comm = case (foldMap _Comment ms, comments cfg) of + (Just c, True) -> " /* " <> fromText (unCommentText c) <> " */" + _ -> mempty + in mconcat [ind, fromText k, pad, ":", sep cfg, fromText v, imptant, comm] selector :: Config -> Selector -> Builder -selector cfg = intersperse ("," <> newline cfg) . rec +selector Config { lbrace = "", rbrace = "" } = rec + where rec _ = "" +selector cfg = intercalate ("," <> newline cfg) . rec where rec (In (SelectorF (Refinement ft) p)) = (<> foldMap predicate (sort ft)) <$> case p of Star -> if null ft then ["*"] else [""] @@ -258,22 +308,23 @@ Child a b -> ins " > " <$> rec a <*> rec b Deep a b -> ins " " <$> rec a <*> rec b Adjacent a b -> ins " + " <$> rec a <*> rec b + Sibling a b -> ins " ~ " <$> rec a <*> rec b Combined a b -> rec a ++ rec b where ins s a b = a <> s <> b 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, "']" ] - 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), ")" ] - + 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, "(", intercalate "," (map fromText p), ")" ] + PseudoElem a -> [ "::", fromText a ] diff --git a/src/Clay/Selector.hs b/src/Clay/Selector.hs --- a/src/Clay/Selector.hs +++ b/src/Clay/Selector.hs @@ -1,18 +1,16 @@ {-# LANGUAGE OverloadedStrings , FlexibleInstances - , FlexibleContexts , GeneralizedNewtypeDeriving , StandaloneDeriving , UndecidableInstances + , ViewPatterns + , PatternGuards #-} module Clay.Selector where -import Control.Applicative -import Data.Monoid import Data.String import Data.Text (Text) -import Prelude hiding (foldl) import qualified Data.Text as Text @@ -53,6 +51,11 @@ (|+) :: Selector -> Selector -> Selector (|+) a b = In (SelectorF (Refinement []) (Adjacent a b)) +-- | The general sibling selector composer. Maps to @sel1 ~ sel2@ in CSS. + +(|~) :: Selector -> Selector -> Selector +(|~) a b = In (SelectorF (Refinement []) (Sibling a b)) + -- | Named alias for `#`. with :: Selector -> Refinement -> Selector @@ -132,6 +135,7 @@ (|=) :: Text -> Text -> Refinement (|=) a = Refinement . pure . AttrHyph a + ------------------------------------------------------------------------------- data Predicate @@ -146,20 +150,24 @@ | AttrHyph Text Text | Pseudo Text | PseudoFunc Text [Text] + | PseudoElem Text deriving (Eq, Ord, Show) newtype Refinement = Refinement { unFilter :: [Predicate] } - deriving Show + deriving (Show, Semigroup, Monoid) instance IsString Refinement where - fromString = filterFromText . fromString + fromString = refinementFromText . fromString -filterFromText :: Text -> Refinement -filterFromText t = Refinement $ +refinementFromText :: Text -> Refinement +refinementFromText t = Refinement $ case Text.uncons t of Just ('#', s) -> [Id s] Just ('.', s) -> [Class s] - Just (':', s) -> [Pseudo s] + Just (':', s) + | Just (':',s') <- Text.uncons s + -> [PseudoElem s'] + | otherwise -> [Pseudo s] Just ('@', s) -> [Attr s] _ -> [Attr t] @@ -171,6 +179,7 @@ | Child f f | Deep f f | Adjacent f f + | Sibling f f | Combined f f deriving Show @@ -184,16 +193,18 @@ type Selector = Fix SelectorF instance IsString (Fix SelectorF) where - fromString = text . fromString + fromString = selectorFromText . fromString -text :: Text -> Selector -text t = In $ +selectorFromText :: Text -> Selector +selectorFromText t = case Text.uncons t of - Just ('#', s) -> SelectorF (Refinement [Id s]) Star - Just ('.', s) -> SelectorF (Refinement [Class s]) Star - _ -> SelectorF (Refinement []) (Elem t) + Just (c, _) | elem c ("#.:@" :: [Char]) + -> with star (refinementFromText t) + _ -> In $ SelectorF (Refinement []) (Elem t) -instance Monoid (Fix SelectorF) where - mempty = error "Selector is a semigroup" - mappend a b = In (SelectorF (Refinement []) (Combined a b)) +instance Semigroup (Fix SelectorF) where + a <> b = In (SelectorF (Refinement []) (Combined a b)) +instance Monoid (Fix SelectorF) where + mempty = error "Selector is a semigroup" + mappend = (<>) diff --git a/src/Clay/Size.hs b/src/Clay/Size.hs --- a/src/Clay/Size.hs +++ b/src/Clay/Size.hs @@ -1,27 +1,63 @@ {-# LANGUAGE - EmptyDataDecls - , OverloadedStrings + OverloadedStrings , GeneralizedNewtypeDeriving , FlexibleInstances + , ExistentialQuantification + , StandaloneDeriving + , TypeFamilies + , EmptyDataDecls #-} module Clay.Size ( -- * Size type. Size -, Abs -, Rel +, LengthUnit +, Percentage , nil +, unitless -- * Size constructors. +, cm +, mm +, inches , px , pt +, pc , em , ex +, ch , pct , rem +, lh +, rlh +, vw +, vh +, vmin +, vmax +, vb +, vi +, svw +, svh +, lvw +, lvh +, dvw +, dvh +, fr +, maxContent +, minContent +, available +, fitContent +-- * Calculation operators for calc + +, (@+@) +, (@-@) +, (@*) +, (*@) +, (@/) + -- * Shorthands for properties that can be applied separately to each box side. , sym @@ -33,17 +69,22 @@ , Angle , Deg , Rad +, Grad +, Turn -- * Constructing angles. , deg , rad +, grad +, turn ) where import Data.Monoid import Prelude hiding (rem) +import Data.Text (Text) import Clay.Common import Clay.Property @@ -51,61 +92,164 @@ ------------------------------------------------------------------------------- --- | Sizes can be relative like percentages or rems. -data Rel +-- | Sizes can be given using a length unit (e.g. em, px). +data LengthUnit --- | Sizes can be absolute like pixels, points, etc. -data Abs +-- | Sizes can be given in percentages. +data Percentage -newtype Size a = Size Value - deriving (Val, Auto, Normal, Inherit, None, Other) +-- | When combining percentages with units using calc, we get a combination +data Combination +data Size a = + SimpleSize Text | + forall b c. SumSize (Size b) (Size c) | + forall b c. DiffSize (Size b) (Size c) | + MultSize Number (Size a) | + DivSize Number (Size a) | + OtherSize Value + +deriving instance Show (Size a) + +sizeToText :: Size a -> Text +sizeToText (SimpleSize txt) = txt +sizeToText (SumSize a b) = mconcat ["(", sizeToText a, " + ", sizeToText b, ")"] +sizeToText (DiffSize a b) = mconcat ["(", sizeToText a, " - ", sizeToText b, ")"] +sizeToText (MultSize a b) = mconcat ["(", cssNumberText a, " * ", sizeToText b, ")"] +sizeToText (DivSize a b) = mconcat ["(", sizeToText b, " / ", cssNumberText a, ")"] +sizeToText (OtherSize a) = plain $ unValue a + +instance Val (Size a) where + value (SimpleSize a) = value a + value (OtherSize a) = a + value s = Value $ browsers <> Plain ("calc" <> sizeToText s) + +instance Auto (Size a) where auto = OtherSize Clay.Common.autoValue +instance Normal (Size a) where normal = OtherSize Clay.Common.normalValue +instance Inherit (Size a) where inherit = OtherSize Clay.Common.inheritValue +instance None (Size a) where none = OtherSize Clay.Common.noneValue +instance Other (Size a) where other a = OtherSize a + +-- | Zero size. nil :: Size a -nil = Size "0" +nil = SimpleSize "0" +-- | Unitless size (as recommended for line-height). +unitless :: Number -> Size a +unitless i = SimpleSize ((plain . unValue . value) i) + +cm, mm, inches, px, pt, pc :: Number -> Size LengthUnit + +-- | Size in centimeters. +cm i = SimpleSize (cssNumberText i <> "cm") + +-- | Size in millimeters. +mm i = SimpleSize (cssNumberText i <> "mm") + +-- | Size in inches (1in = 2.54 cm). +inches i = SimpleSize (cssNumberText i <> "in") + -- | Size in pixels. +px i = SimpleSize (cssNumberText i <> "px") -px :: Integer -> Size Abs -px i = Size (value i <> "px") +-- | Size in points (1pt = 1/72 of 1in). +pt i = SimpleSize (cssNumberText i <> "pt") --- | Size in points. +-- | Size in picas (1pc = 12pt). +pc i = SimpleSize (cssNumberText i <> "pc") -pt :: Double -> Size Abs -pt i = Size (value i <> "pt") +em, ex, ch, rem, lh, rlh, vw, vh, vmin, vmax, vb, vi, svw, svh, lvw, lvh, dvw, dvh, fr :: Number -> Size LengthUnit --- | Size in em's. +-- | Size in em's (computed cssNumberText of the font-size). +em i = SimpleSize (cssNumberText i <> "em") -em :: Double -> Size Abs -em i = Size (value i <> "em") +-- | SimpleSize in ex'es (x-height of the first avaliable font). +ex i = SimpleSize (cssNumberText i <> "ex") --- | Size in ex'es. +-- | SimpleSize in ch's (The width of the glyph "0" of the element's font). +ch i = SimpleSize (cssNumberText i <> "ch") -ex :: Double -> Size Abs -ex i = Size (value i <> "ex") +-- | SimpleSize in rem's (em's, but always relative to the root element). +rem i = SimpleSize (cssNumberText i <> "rem") --- | Size in percentages. +-- | SimpleSize in lh's (Line height of the element). +lh i = SimpleSize (cssNumberText i <> "lh") -pct :: Double -> Size Rel -pct i = Size (value i <> "%") +-- | SimpleSize in rlh's (lh's, but always relative to the root element). +rlh i = SimpleSize (cssNumberText i <> "rlh") --- | Size in rem's. +-- | SimpleSize in vw's (1vw = 1% of viewport width). +vw i = SimpleSize (cssNumberText i <> "vw") -rem :: Double -> Size Rel -rem i = Size (value i <> "rem") +-- | SimpleSize in vh's (1vh = 1% of viewport height). +vh i = SimpleSize (cssNumberText i <> "vh") -instance Num (Size Abs) where - fromInteger = px +-- | SimpleSize in vmin's (the smaller of vw or vh). +vmin i = SimpleSize (cssNumberText i <> "vmin") + +-- | SimpleSize in vmax's (the larger of vw or vh). +vmax i = SimpleSize (cssNumberText i <> "vmax") + +-- | SimpleSize in vb's (1vb = 1% of the parent's size in the direction of the root element's block axis). +vb i = SimpleSize (cssNumberText i <> "vb") + +-- | SimpleSize in vi's (1vi = 1% of the parent's size in the direction of the root element's inline axis). +vi i = SimpleSize (cssNumberText i <> "vi") + +-- | SimpleSize in svw's (1svw = 1% of the small viewport's width). +svw i = SimpleSize (cssNumberText i <> "svw") + +-- | SimpleSize in svh's (1svh = 1% of the small viewport's height). +svh i = SimpleSize (cssNumberText i <> "svh") + +-- | SimpleSize in lvw's (1lvw = 1% of the large viewport's width). +lvw i = SimpleSize (cssNumberText i <> "lvw") + +-- | SimpleSize in lvh's (1lvh = 1% of the large viewport's height). +lvh i = SimpleSize (cssNumberText i <> "lvh") + +-- | SimpleSize in dvw's (1dvw = 1% of the dynamic viewport's width). +dvw i = SimpleSize (cssNumberText i <> "dvw") + +-- | SimpleSize in dvh's (1dvh = 1% of the dynamic viewport's height). +dvh i = SimpleSize (cssNumberText i <> "dvh") + +-- | 'SimpleSize' in fr's (a fractional unit and 1fr is for 1 part of the available space in grid areas). +fr i = SimpleSize (cssNumberText i <> "fr") + +-- | SimpleSize for the intrinsic preferred width. +maxContent :: Size LengthUnit +maxContent = SimpleSize "max-content" + +-- | SimpleSize for the intrinsic minimum width. +minContent :: Size LengthUnit +minContent = SimpleSize "min-content" + +-- | SimpleSize for the containing block width minus horizontal margin, border, and padding. +available :: Size LengthUnit +available = SimpleSize "available" + +-- | The larger of the intrinsic minimum width or the smaller of the intrinsic preferred width and the available width. +fitContent :: Size LengthUnit +fitContent = SimpleSize "fit-content" + +-- | SimpleSize in percents. +pct :: Number -> Size Percentage +pct i = SimpleSize (cssNumberText i <> "%") + +instance Num (Size LengthUnit) where + fromInteger = px . fromInteger (+) = error "plus not implemented for Size" (*) = 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 +instance Fractional (Size LengthUnit) where + fromRational = px . fromRational recip = error "recip not implemented for Size" -instance Num (Size Rel) where +instance Num (Size Percentage) where fromInteger = pct . fromInteger (+) = error "plus not implemented for Size" (*) = error "times not implemented for Size" @@ -113,39 +257,79 @@ signum = error "signum not implemented for Size" negate = error "negate not implemented for Size" -instance Fractional (Size Rel) where +instance Fractional (Size Percentage) where fromRational = pct . fromRational recip = error "recip not implemented for Size" +-- | Type family to define what is the result of a calc operation + +type family SizeCombination sa sb where + SizeCombination Percentage Percentage = Percentage + SizeCombination LengthUnit LengthUnit = LengthUnit + SizeCombination a b = Combination + +-- | Plus operator to combine sizes into calc function +infixl 6 @+@ +(@+@) :: Size a -> Size b -> Size (SizeCombination a b) +a @+@ b = SumSize a b + +-- | Minus operator to combine sizes into calc function +infixl 6 @-@ +(@-@) :: Size a -> Size b -> Size (SizeCombination a b) +a @-@ b = DiffSize a b + +-- | Times operator to combine sizes into calc function +infixl 7 *@ +(*@) :: Number -> Size a -> Size a +a *@ b = MultSize a b + +-- | Reversed times operator to combine sizes into calc function +infixl 7 @* +(@*) :: Size a -> Number -> Size a +a @* b = MultSize b a + +-- | Division operator to combine sizes into calc function +infixl 7 @/ +(@/) :: Size a -> Number -> Size a +a @/ b = DivSize b a + ------------------------------------------------------------------------------- sym :: (a -> a -> a -> a -> Css) -> a -> Css sym k a = k a a a a -sym3 :: (a -> a -> a -> a -> Css) -> a -> a -> a -> Css +sym3 :: (tb -> l -> tb -> r -> Css) -> tb -> l -> r -> Css sym3 k tb l r = k tb l tb r -sym2 :: (a -> a -> a -> a -> Css) -> a -> a -> Css +sym2 :: (tb -> lr -> tb -> lr -> Css) -> tb -> lr -> Css sym2 k tb lr = k tb lr tb lr ------------------------------------------------------------------------------- data Deg data Rad +data Grad +data Turn newtype Angle a = Angle Value deriving (Val, Auto, Inherit, Other) -- | Angle in degrees. - -deg :: Double -> Angle Deg +deg :: Number -> Angle Deg deg i = Angle (value i <> "deg") -- | Angle in radians. - -rad :: Double -> Angle Rad +rad :: Number -> Angle Rad rad i = Angle (value i <> "rad") +-- | Angle in gradians (also knows as gons or grades). +grad :: Number -> Angle Grad +grad i = Angle (value i <> "grad") + +-- | Angle in turns. +turn :: Number -> Angle Turn +turn i = Angle (value i <> "turn") + instance Num (Angle Deg) where fromInteger = deg . fromInteger (+) = error "plus not implemented for Angle" @@ -170,3 +354,26 @@ fromRational = rad . fromRational recip = error "recip not implemented for Angle" +instance Num (Angle Grad) where + fromInteger = grad . fromInteger + (+) = error "plus not implemented for Angle" + (*) = 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 Grad) where + fromRational = grad . fromRational + recip = error "recip not implemented for Angle" + +instance Num (Angle Turn) where + fromInteger = turn . fromInteger + (+) = error "plus not implemented for Angle" + (*) = 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 Turn) where + fromRational = turn . 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,9 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Clay.Stylesheet where import Control.Applicative import Control.Arrow (second) -import Control.Monad.Writer hiding (All) +import Control.Monad.Writer (Writer, execWriter, tell) +import Data.Maybe (isJust) +import Data.String (IsString) import Data.Text (Text) import Clay.Selector hiding (Child) @@ -24,6 +29,22 @@ data Feature = Feature Text (Maybe Value) deriving Show +newtype CommentText = CommentText { unCommentText :: Text } + deriving (Show, IsString, Semigroup, Monoid) + +data Modifier + = Important + | Comment CommentText + deriving (Show) + +_Important :: Modifier -> Maybe Text +_Important Important = Just "!important" +_Important (Comment _) = Nothing + +_Comment :: Modifier -> Maybe CommentText +_Comment (Comment c) = Just c +_Comment Important = Nothing + ------------------------------------------------------------------------------- data App @@ -34,11 +55,11 @@ | Sub Selector deriving Show -data Keyframes = Keyframes Text [(Double, [Rule])] +data Keyframes = Keyframes Text [(Number, [Rule])] deriving Show data Rule - = Property (Key ()) Value + = Property [Modifier] (Key ()) Value | Nested App [Rule] | Query MediaQuery [Rule] | Face [Rule] @@ -61,12 +82,19 @@ type Css = StyleM () +instance Semigroup Css where + (<>) = liftA2 (<>) + +instance Monoid Css where + mempty = pure () + mappend = (<>) + -- | Add a new style property to the stylesheet with the specified `Key` and -- value. The value can be any type that is in the `Val' typeclass, with other -- words: can be converted to a `Value`. key :: Val a => Key a -> a -> Css -key k v = rule $ 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. @@ -137,7 +165,7 @@ ------------------------------------------------------------------------------- -keyframes :: Text -> [(Double, Css)] -> Css +keyframes :: Text -> [(Number, Css)] -> Css keyframes n xs = rule $ Keyframe (Keyframes n (map (second runS) xs)) keyframesFromTo :: Text -> Css -> Css -> Css @@ -156,3 +184,21 @@ importUrl :: Text -> Css importUrl l = rule $ Import l +------------------------------------------------------------------------------- + +-- | Indicate the supplied css should override css declarations that would +-- otherwise take precedence. +-- +-- Use sparingly. +important :: Css -> Css +important = foldMap (rule . addImportant) . runS + +-- The last case indicates there may be something wrong in the typing, as +-- it shouldn't be possible to make a non-property important. In practice, +-- this implementation means only the directly applied property rule is +-- affected, i.e. no nested rules. That could be changed by adding recursive cases. +addImportant :: Rule -> Rule +addImportant (Property ms@(filter (isJust . _Important) -> (_:_)) k v) = + Property ms k v +addImportant (Property ms k v ) = Property (Important : ms) k v +addImportant r = r diff --git a/src/Clay/Text.hs b/src/Clay/Text.hs --- a/src/Clay/Text.hs +++ b/src/Clay/Text.hs @@ -17,6 +17,7 @@ , textShadow -- * Text-indent. +-- $text-indent , TextIndent , textIndent @@ -34,6 +35,7 @@ , TextAlign , textAlign +, textAlignLast , justify, matchParent, start, end , alignSide , alignString @@ -59,6 +61,36 @@ , textTransform , capitalize, uppercase, lowercase, fullWidth +-- * Text-overflow. + +, TextOverflow +, textOverflow +, overflowClip, overflowEllipsis + +-- * Word-break. + +, WordBreak +, wordBreak +, breakAll +, keepAll + +-- * Overflow-wrap (and Word-wrap). + +, OverflowWrap +, overflowWrap +, wordWrap +, breakWord + +-- * Hyphenation. + +, hyphens +, hyphenateCharacter +, hyphenateLimitChars +, manual +, Hyphens +, HyphenateCharacter +, HyphenateLimit + -- * Content. , Content @@ -73,9 +105,8 @@ ) where -import Data.Monoid import Data.String -import Data.Text (Text) +import Data.Text (Text, pack) import Clay.Background import Clay.Border @@ -114,14 +145,38 @@ ------------------------------------------------------------------------------- +-- $text-indent +-- +-- Supply a length — optionally annotated with @each-line@ or @hanging@ or +-- both, or a global value. It is possible to apply the same annotation +-- multiple times, but it has no defined effect. +-- +-- Note browser support is currently (March 2018) non-existent, but the +-- Prince typesetting system supports the syntax. +-- +-- === Formal argument syntax +-- +-- > && hanging? && each-line? +-- > where +-- > = | + newtype TextIndent = TextIndent Value - deriving (Val, Inherit, Other) + deriving (Val, Inherit, Initial, Unset, Other) -eachLine, hanging :: TextIndent +-- | An internal function that ensures each-line and hanging are processed +-- correctly. +tagTextIndent :: Value -> TextIndent -> TextIndent +tagTextIndent v (TextIndent v0) = TextIndent . value $ (v0, v) -eachLine = TextIndent "each-line" -hanging = TextIndent "hanging" +-- | Annotate the supplied 'TextIndent' with @each-line@ or @hanging@ or +-- both. +-- +-- > eachLine . hanging . indent $ px 3 :: TextIndent +eachLine, hanging :: TextIndent -> TextIndent +eachLine = tagTextIndent "each-line" +hanging = tagTextIndent "hanging" + indent :: Size a -> TextIndent indent = TextIndent . value @@ -145,12 +200,12 @@ ------------------------------------------------------------------------------- newtype TextAlign = TextAlign Value - deriving (Val, Normal, Inherit, Other) + deriving (Val, Normal, Inherit, Other, Center) justify, matchParent, start, end :: TextAlign justify = TextAlign "justify" -matchParent = TextAlign "matchParent" +matchParent = TextAlign "match-parent" start = TextAlign "start" end = TextAlign "end" @@ -163,6 +218,9 @@ textAlign :: TextAlign -> Css textAlign = key "text-align" +textAlignLast :: TextAlign -> Css +textAlignLast = key "text-align-last" + ------------------------------------------------------------------------------- newtype WhiteSpace = WhiteSpace Value @@ -216,6 +274,137 @@ textTransform :: TextTransform -> Css textTransform = key "text-transform" + +------------------------------------------------------------------------------- + +newtype WordBreak = WordBreak Value + deriving (Val, Inherit, Initial, Unset, Normal) + +breakAll, keepAll :: WordBreak + +breakAll = WordBreak "break-all" +keepAll = WordBreak "keep-all" + +wordBreak :: WordBreak -> Css + +wordBreak = key "word-break" + +------------------------------------------------------------------------------- + +newtype OverflowWrap = OverflowWrap Value + deriving (Val, Inherit, Initial, Unset, Normal) + +breakWord :: OverflowWrap + +breakWord = OverflowWrap "break-word" + +overflowWrap, wordWrap :: OverflowWrap -> Css + +wordWrap = key "word-wrap" +overflowWrap = key "overflow-wrap" + +------------------------------------------------------------------------------- + +newtype TextOverflow = TextOverflow Value + deriving (Val, None, Inherit, Initial) + +overflowClip, overflowEllipsis :: TextOverflow + +overflowClip = TextOverflow "clip" +overflowEllipsis = TextOverflow "ellipsis" + +textOverflow :: TextOverflow -> Css +textOverflow = key "text-overflow" + +------------------------------------------------------------------------------- + +-- | Type for values which can be provided to 'hyphens'. +newtype Hyphens = Hyphens Value + deriving (Val, None, Auto, Initial, Inherit, Unset, Other) + +-- | Specifies how words should be hyphenated. +-- +-- Possible values are: +-- +-- ['none']: No hyphenation. +-- Words will not be hyphenated even if it is explicitly suggested for a word. +-- +-- ['manual']: Manual hyphenation. +-- Specific characters such as @­@ in a word will suggest break points. +-- This is the default. +-- +-- ['auto']: Automatic hyphenation. +-- The browser is free to hyphenate words as it sees fit. +-- However, explicitly suggested break points will take precedence. +-- +-- For example, +-- +-- >>> hyphens auto +-- +-- The hyphenation rules depend on the language, +-- which must be specified by the @lang@ attribute. +-- +-- For reference, see +-- [@hyphens@](https://developer.mozilla.org/en-US/docs/Web/CSS/hyphens). +hyphens :: Hyphens -> Css +hyphens = key "hyphens" + +-- | Value for 'hyphens' specifying that hyphenation be manual. +manual :: Hyphens +manual = Hyphens "manual" +-- 'manual' feels like it should be a function and type class in Clay.Common, +-- but @hyphens@ is the only CSS property which uses it as a specified value. + +-- | Type for values which can be provided to 'hyphenateCharacter'. +newtype HyphenateCharacter = HyphenateCharacter Value + deriving (Val, Auto, Initial, Inherit, Unset, Other) + +-- Allow a 'HyphenateCharacter' value to be specified directly with a string. +instance IsString HyphenateCharacter where + fromString = HyphenateCharacter . Value . Plain . quote . pack + +-- | Customizes the character used for hyphenation. +-- +-- For example, +-- +-- >>> hyphenateCharacter "~" +-- +-- For reference, see +-- [@hyphenate-character@](https://developer.mozilla.org/en-US/docs/Web/CSS/hyphenate-character). +hyphenateCharacter :: HyphenateCharacter -> Css +hyphenateCharacter = key "hyphenate-character" + +-- | Type for values which can be provded to 'hyphenateLimitChars'. +newtype HyphenateLimit = HyphenateLimit Value + deriving (Val, Auto, Initial, Inherit, Unset, Other) + +-- Allow a 'HyphenateLimit' value to be specified directly with a number. +instance Num HyphenateLimit where + fromInteger = HyphenateLimit . value + (+) = error "plus not implemented for HyphenateLimit" + (*) = error "times not implemented for HyphenateLimit" + abs = error "abs not implemented for HyphenateLimit" + signum = error "signum not implemented for HyphenateLimit" + negate = error "negate not implemented for HyphenateLimit" + +-- | Adjusts the minumum number of characters involved in hyphenation. +-- +-- I.e., specifies the minumum number of characters allowed in a breakable word, +-- before a break point, and after a break point when hyphenating a word. +-- +-- For example, +-- +-- >>> hyphenateLimitChars 14 auto auto +-- +-- For reference, see +-- [@hyphenate-limit-chars@](https://developer.mozilla.org/en-US/docs/Web/CSS/hyphenate-limit-chars). +hyphenateLimitChars + :: HyphenateLimit -- ^ Minimum length of a word which can be hyphenated. + -> HyphenateLimit -- ^ Minimum number of characters allowed before a break point. + -> HyphenateLimit -- ^ Minimum number of characters allowed after a break point. + -> Css +hyphenateLimitChars word before after = + key "hyphenate-limit-chars" (word ! before ! after) ------------------------------------------------------------------------------- diff --git a/src/Clay/Time.hs b/src/Clay/Time.hs --- a/src/Clay/Time.hs +++ b/src/Clay/Time.hs @@ -12,7 +12,6 @@ ) where -import Data.Monoid import Data.Text (pack) import Clay.Common diff --git a/src/Clay/Transform.hs b/src/Clay/Transform.hs --- a/src/Clay/Transform.hs +++ b/src/Clay/Transform.hs @@ -7,6 +7,18 @@ Transformation , transform , transforms +, TransformStyle +, transformStyle +, flat +, preserve3d +, TransformBox +, transformBox +, transformContentBox +, transformBorderBox +, fillBox +, strokeBox +, viewBox +, transformOrigin -- * Translating. @@ -39,7 +51,6 @@ ) where -import Data.Monoid import Prelude hiding (Left, Right) import Clay.Property @@ -58,16 +69,48 @@ ------------------------------------------------------------------------------- -scale :: Double -> Double -> Transformation +newtype TransformStyle = TransformStyle Value + deriving (Val, Inherit, Initial, Unset) + +transformStyle :: TransformStyle -> Css +transformStyle = prefixed (browsers <> "transform-style") + +flat, preserve3d :: TransformStyle +flat = TransformStyle "flat" +preserve3d = TransformStyle "preserve-3d" + +------------------------------------------------------------------------------- + +newtype TransformBox = TransformBox Value + deriving (Val, Inherit, Initial, Unset) + +transformBox :: TransformBox -> Css +transformBox = prefixed (browsers <> "transform-box") + +transformContentBox, transformBorderBox, fillBox, strokeBox, viewBox :: TransformBox +transformContentBox = TransformBox "contentBox" +transformBorderBox = TransformBox "borderBox" +fillBox = TransformBox "fillBox" +strokeBox = TransformBox "strokeBox" +viewBox = TransformBox "viewBox" + +------------------------------------------------------------------------------- + +transformOrigin :: [Size a] -> Css +transformOrigin = prefixed (browsers <> "transform-origin") . noCommas + +------------------------------------------------------------------------------- + +scale :: Number -> Number -> Transformation scale x y = Transformation ("scale(" <> value [x, y] <> ")") -scaleX, scaleY, scaleZ :: Double -> Transformation +scaleX, scaleY, scaleZ :: Number -> Transformation scaleX x = Transformation ("scaleX(" <> value x <> ")") scaleY y = Transformation ("scaleY(" <> value y <> ")") scaleZ z = Transformation ("scaleZ(" <> value z <> ")") -scale3d :: Double -> Double -> Double -> Transformation +scale3d :: Number -> Number -> Number -> Transformation scale3d x y z = Transformation ("scale3d(" <> value [x, y, z] <> ")") ------------------------------------------------------------------------------- @@ -81,22 +124,23 @@ rotateY y = Transformation ("rotateY(" <> value y <> ")") rotateZ z = Transformation ("rotateZ(" <> value z <> ")") -rotate3d :: Double -> Double -> Double -> Angle a -> Transformation +rotate3d :: Number -> Number -> Number -> Angle a -> Transformation rotate3d x y z a = Transformation ("rotate3d(" <> value [value x, value y, value z, value a] <> ")") ------------------------------------------------------------------------------- -translate :: Size Abs -> Size Abs -> Transformation -translate x y = Transformation ("translate(" <> value [x, y] <> ")") +translate :: Size a -> Size b -> Transformation +translate x y = Transformation ("translate(" <> value [value x, value y] <> ")") -translateX, translateY, translateZ :: Size Abs -> Transformation +translateX, translateY :: Size LengthUnit -> Transformation +translateZ :: Size LengthUnit -> Transformation translateX x = Transformation ("translateX(" <> value x <> ")") translateY y = Transformation ("translateY(" <> value y <> ")") translateZ z = Transformation ("translateZ(" <> value z <> ")") -translate3d :: Size Abs -> Size Abs -> Size Abs -> Transformation -translate3d x y z = Transformation ("translate3d(" <> value [x, y, z] <> ")") +translate3d :: Size a -> Size b -> Size LengthUnit -> Transformation +translate3d x y z = Transformation ("translate3d(" <> value [value x, value y, value z] <> ")") ------------------------------------------------------------------------------- @@ -110,16 +154,16 @@ ------------------------------------------------------------------------------- -perspective :: Double -> Transformation +perspective :: Number -> Transformation perspective p = Transformation ("perspective(" <> value p <> ")") -matrix :: Double -> Double -> Double -> Double -> Double -> Double -> Transformation -matrix u v w x y z = Transformation ("matrix3d(" <> value [ u, v, w, x, y, z ] <> ")") +matrix :: Number -> Number -> Number -> Number -> Number -> Number -> Transformation +matrix u v w x y z = Transformation ("matrix(" <> value [ u, v, w, x, y, z ] <> ")") -matrix3d :: Double -> Double -> Double -> Double - -> Double -> Double -> Double -> Double - -> Double -> Double -> Double -> Double - -> Double -> Double -> Double -> Double +matrix3d :: Number -> Number -> Number -> Number + -> Number -> Number -> Number -> Number + -> Number -> Number -> Number -> Number + -> Number -> Number -> Number -> Number -> Transformation matrix3d w0 x0 y0 z0 w1 x1 y1 z1 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,8 @@ , TimingFunction , transitionTimingFunction -, ease, easeIn, easeOut, easeInOut, linear, stepStart, stepStop +, transitionTimingFunctions +, ease, easeIn, easeOut, easeInOut, linear, stepStart, stepEnd, stepStop , stepsStart, stepsStop , cubicBezier @@ -35,7 +36,6 @@ ) where -import Data.Monoid import Data.Text (Text) import Clay.Common @@ -47,8 +47,9 @@ transition p d f e = prefixed (browsers <> "transition") (p ! d ! f ! e) transitions :: [(Text, Time, TimingFunction, Time)] -> Css -transitions = prefixed (browsers <> "transition") - . map (\(p, d, f, e) -> value (p ! d ! f ! e)) +transitions [] = key "transition" (none :: Value) +transitions x = prefixed (browsers <> "transition") + $ map (\(p, d, f, e) -> value (p ! d ! f ! e)) x ------------------------------------------------------------------------------- @@ -56,22 +57,24 @@ transitionProperty = key "transition-property" transitionProperties :: [Text] -> Css -transitionProperties = key "transition-property" +transitionProperties [] = key "transition-property" (none :: Value) +transitionProperties x = key "transition-property" x ------------------------------------------------------------------------------- transitionDuration :: Time -> Css transitionDuration = key "transition-duration" -transitionDurations :: [Time] -> Css -transitionDurations = key "transition-duration" +transitionDurations :: [Time] -> Css +transitionDurations [] = key "transition-duration" (none :: Value) +transitionDurations x = key "transition-duration" x ------------------------------------------------------------------------------- newtype TimingFunction = TimingFunction Value deriving (Val, Other, Auto) -ease, easeIn, easeOut, easeInOut, linear, stepStart, stepStop :: TimingFunction +ease, easeIn, easeOut, easeInOut, linear, stepStart, stepEnd, stepStop :: TimingFunction ease = other "ease" easeIn = other "ease-in" @@ -79,18 +82,25 @@ easeInOut = other "ease-in-out" linear = other "linear" stepStart = other "step-start" -stepStop = other "step-stop" +stepEnd = other "step-end" +stepStop = stepEnd +{-# DEPRECATED stepStop "Use `stepEnd` instead." #-} + stepsStart, stepsStop :: Integer -> TimingFunction -stepsStart s = other ("steps(" <> value s <> ", end)") +stepsStart s = other ("steps(" <> value s <> ", start)") stepsStop s = other ("steps(" <> value s <> ", end)") -cubicBezier :: Double -> Double -> Double -> Double -> TimingFunction -cubicBezier a b c d = other ("cubic-bezier(" <> value (a ! b ! c ! d) <> ")") +cubicBezier :: Number -> Number -> Number -> Number -> TimingFunction +cubicBezier a b c d = other ("cubic-bezier(" <> value [a, b, c, d] <> ")") transitionTimingFunction :: TimingFunction -> Css transitionTimingFunction = key "transition-timing-function" + +transitionTimingFunctions :: [TimingFunction] -> Css +transitionTimingFunctions [] = key "transition-timing-function" (none :: Value) +transitionTimingFunctions x = key "transition-timing-function" x ------------------------------------------------------------------------------- diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Test.Framework (defaultMain) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit.Base ((@?=)) - -import Clay.Render (renderWith, compact) - -main :: IO () -main = defaultMain - [ testCase "empty Clay produces empty compact CSS" $ renderWith compact [] (return ()) @?= "" - ]