clay 0.6 → 0.16.1
raw patch · 36 files changed
Files
- CHANGELOG +163/−0
- CONTRIBUTING.md +53/−0
- README.md +13/−0
- clay.cabal +43/−12
- spec/Spec.hs +4/−0
- src/Clay.hs +49/−2
- src/Clay/Animation.hs +184/−0
- src/Clay/Background.hs +4/−3
- src/Clay/Border.hs +56/−11
- src/Clay/Box.hs +138/−3
- src/Clay/Color.hs +118/−21
- src/Clay/Comments.hs +29/−0
- src/Clay/Common.hs +90/−22
- src/Clay/Display.hs +155/−9
- src/Clay/Dynamic.hs +0/−1
- src/Clay/Elements.hs +9/−5
- src/Clay/Filter.hs +9/−9
- src/Clay/Flexbox.hs +120/−0
- src/Clay/Font.hs +32/−19
- src/Clay/FontFace.hs +10/−5
- src/Clay/Geometry.hs +108/−8
- src/Clay/Gradient.hs +3/−5
- src/Clay/Grid.hs +775/−0
- src/Clay/List.hs +97/−0
- src/Clay/Mask.hs +0/−2
- src/Clay/Media.hs +42/−6
- src/Clay/Property.hs +34/−15
- src/Clay/Pseudo.hs +60/−16
- src/Clay/Render.hs +199/−74
- src/Clay/Selector.hs +52/−27
- src/Clay/Size.hs +261/−39
- src/Clay/Stylesheet.hs +87/−13
- src/Clay/Text.hs +203/−11
- src/Clay/Time.hs +2/−1
- src/Clay/Transform.hs +61/−17
- src/Clay/Transition.hs +27/−17
+ CHANGELOG view
@@ -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.
+ CONTRIBUTING.md view
@@ -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+```
+ README.md view
@@ -0,0 +1,13 @@+# Clay++[](https://github.com/sebastiaanvisser/clay/actions/workflows/ci.yml)+[](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`.
clay.cabal view
@@ -1,5 +1,5 @@ Name: clay-Version: 0.6+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,13 +10,8 @@ The project is described on <http://fvisser.nl/clay>. . The API documentation can be found in the top level module "Clay".- .- > 0.5.1 -> 0.6- > - Simplified implementation of size rendering.- > - Implemented @font-face construct. By James Fisher.- > - Make hsl(a) colors actually print percentage values.- > - Changed the renderer to haul @font-face to the top level. + Author: Sebastiaan Visser Maintainer: Sebastiaan Visser <code@fvisser.nl> Homepage: http://fvisser.nl/clay@@ -25,9 +20,25 @@ License: BSD3 License-File: LICENSE Category: Web, Graphics-Cabal-Version: >= 1.6+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@@ -37,20 +48,25 @@ Exposed-Modules: Clay+ Clay.Animation Clay.Attributes Clay.Background 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 Clay.Property@@ -64,8 +80,23 @@ Clay.Transform Clay.Transition - GHC-Options: -Wall Build-Depends:- base >= 4 && < 5,- mtl >= 1 && < 2.2,- text >= 0.11 && < 0.12+ 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: spec, src+ Build-Tools: hspec-discover+ main-is: Spec.hs+ Build-Depends:+ 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
+ spec/Spec.hs view
@@ -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
src/Clay.hs view
@@ -8,6 +8,8 @@ , pretty , compact +, renderSelector+ -- * The @Css@ monad for collecting style rules. , Css@@ -20,6 +22,10 @@ , (-:) +-- ** Comments+-- $comments+, commenting+ -- * The selector language. , Selector@@ -33,6 +39,7 @@ , (|>) , (#) , (|+)+, (|~) -- ** Refining selectors. @@ -45,7 +52,9 @@ , attr , (@=)+, (^=) , ($=)+, (*=) , (~=) , (|=) @@ -56,10 +65,23 @@ , queryNot , queryOnly +-- * Apply key-frame animation.++, keyframes+, keyframesFromTo+ -- * Define font-faces. , fontFace +-- * !important++, important++-- * Import other CSS files++, importUrl+ -- * Pseudo elements and classes. , module Clay.Pseudo@@ -86,13 +108,17 @@ , 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 , module Clay.Transition+, module Clay.Animation , module Clay.Mask , module Clay.Filter @@ -102,14 +128,14 @@ ) where -import Prelude hiding ((**))+import Prelude () import Clay.Render import Clay.Stylesheet import Clay.Selector import Clay.Property -import Clay.Pseudo+import Clay.Pseudo hiding (default_, required, root, lang) import Clay.Elements hiding (link, em) import Clay.Attributes hiding ( content, class_, target, checked, disabled@@ -122,17 +148,22 @@ 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) import Clay.Transform import Clay.Transition+import Clay.Animation import Clay.Mask hiding (clear) import Clay.Filter hiding (url, opacity) @@ -141,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 '@/* */@'.
+ src/Clay/Animation.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE+ OverloadedStrings+ , GeneralizedNewtypeDeriving+ #-}+module Clay.Animation+(++-- * The animation propery.++ animation+, animations++-- * Animation-delay.++, animationDelay+, animationDelays++-- * Animation-direction.++, AnimationDirection+, animationDirection+, animationDirections+, alternate+, reverse+, alternateReverse++-- * Animation-duration.++, animationDuration+, animationDurations++, IterationCount+, animationIterationCount+, animationIterationCounts+, infinite+, iterationCount++-- * Animation-action-name.++, AnimationName+, animationName++-- * Animation-play-state.++, PlayState+, animationPlayState+, running+, paused++-- * Animation-fill-mode.++, FillMode+, animationFillMode+, forwards+, backwards++-- * Animation-timing-function.++, animationTimingFunction++)+where++import Data.Monoid+import Data.String (IsString)+import Prelude hiding (reverse)++import Clay.Common+import Clay.Property+import Clay.Stylesheet+import Clay.Time+import Clay.Transition+++animation+ :: AnimationName+ -> Time+ -> TimingFunction+ -> Time+ -> IterationCount+ -> AnimationDirection+ -> FillMode+ -> Css+animation p de f du i di fm = prefixed (browsers <> "animation") (p ! de ! f ! du ! i ! di ! fm)++animations+ :: [ ( AnimationName+ , Time+ , TimingFunction+ , Time+ , IterationCount+ , AnimationDirection+ , FillMode+ )+ ] -> Css+animations = prefixed (browsers <> "animation")+ . map (\(p, de, f, du, i, di, fm) -> value (p ! de ! f ! du ! i ! di ! fm))++-------------------------------------------------------------------------------++animationDelay :: Time -> Css+animationDelay = prefixed (browsers <> "animation-delay")++animationDelays :: [Time] -> Css+animationDelays = prefixed (browsers <> "animation-delay")++-------------------------------------------------------------------------------++newtype AnimationDirection = AnimationDirection Value+ deriving (Val, Other, Normal)++animationDirection :: AnimationDirection -> Css+animationDirection = prefixed (browsers <> "animation-direction")++animationDirections :: [AnimationDirection] -> Css+animationDirections = prefixed (browsers <> "animation-direction")++alternate, reverse, alternateReverse :: AnimationDirection+alternate = AnimationDirection "alternate"+reverse = AnimationDirection "reverse"+alternateReverse = AnimationDirection "alternate-reverse"++-------------------------------------------------------------------------------++animationDuration :: Time -> Css+animationDuration = prefixed (browsers <> "animation-duration")++animationDurations :: [Time] -> Css+animationDurations = prefixed (browsers <> "animation-duration")++-------------------------------------------------------------------------------++newtype IterationCount = IterationCount Value+ deriving (Val, Other, Normal)++animationIterationCount :: IterationCount -> Css+animationIterationCount = prefixed (browsers <> "animation-iteration-count")++animationIterationCounts :: [IterationCount] -> Css+animationIterationCounts = prefixed (browsers <> "animation-iteration-count")++infinite :: IterationCount+infinite = IterationCount "infinite"++iterationCount :: Number -> IterationCount+iterationCount = IterationCount . value++-------------------------------------------------------------------------------++newtype AnimationName = AnimationName Value+ deriving (Val, Other, IsString, Initial, Inherit, Unset)++animationName :: AnimationName -> Css+animationName = prefixed (browsers <> "animation-name")++-------------------------------------------------------------------------------++newtype PlayState = PlayState Value+ deriving (Val, Other)++animationPlayState :: PlayState -> Css+animationPlayState = prefixed (browsers <> "animation-play-state")++running, paused :: PlayState+running = PlayState "running"+paused = PlayState "paused"++-------------------------------------------------------------------------------++newtype FillMode = FillMode Value+ deriving (Val, Other, None)++animationFillMode :: FillMode -> Css+animationFillMode = prefixed (browsers <> "animation-fill-mode")++forwards, backwards :: FillMode+forwards = FillMode "forwards"+backwards = FillMode "backwards"++-------------------------------------------------------------------------------++animationTimingFunction :: TimingFunction -> Css+animationTimingFunction = prefixed (browsers <> "animation-timing-function")+
src/Clay/Background.hs view
@@ -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
src/Clay/Border.hs view
@@ -8,16 +8,16 @@ -- * Border properties. , border, borderTop, borderLeft, borderBottom, borderRight-, borderColor, borderLeftColor, borderRightColor, borderTopColor, borderBottomColor-, borderStyle, borderLeftStyle, borderRightStyle, borderTopStyle, borderBottomStyle-, borderWidth, borderLeftWidth, borderRightWidth, borderTopWidth, borderBottomWidth+, borderColor4, borderColor, borderLeftColor, borderRightColor, borderTopColor, borderBottomColor+, borderStyle4, borderStyle, borderLeftStyle, borderRightStyle, borderTopStyle, borderBottomStyle+, borderWidth4, borderWidth, borderLeftWidth, borderRightWidth, borderTopWidth, borderBottomWidth -- * Outline properties. , outline, outlineTop, outlineLeft, outlineBottom, outlineRight-, outlineColor, outlineLeftColor, outlineRightColor, outlineTopColor, outlineBottomColor-, outlineStyle, outlineLeftStyle, outlineRightStyle, outlineTopStyle, outlineBottomStyle-, outlineWidth, outlineLeftWidth, outlineRightWidth, outlineTopWidth, outlineBottomWidth+, outlineColor4, outlineColor, outlineLeftColor, outlineRightColor, outlineTopColor, outlineBottomColor+, outlineStyle4, outlineStyle, outlineLeftStyle, outlineRightStyle, outlineTopStyle, outlineBottomStyle+, outlineWidth4, outlineWidth, outlineLeftWidth, outlineRightWidth, outlineTopWidth, outlineBottomWidth , outlineOffset -- * Border radius.@@ -25,6 +25,10 @@ , borderRadius , borderTopLeftRadius, borderTopRightRadius , borderBottomLeftRadius, borderBottomRightRadius++-- * Collapsing borders model for a table+, borderCollapse+, borderSpacing, borderSpacing2 ) where @@ -33,6 +37,7 @@ import Clay.Color import Clay.Common import Clay.Size+import Clay.Display newtype Stroke = Stroke Value deriving (Val, Other, Inherit, Auto, None)@@ -51,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)@@ -59,6 +64,9 @@ borderBottom a b c = key "border-bottom" (a ! b ! c) borderRight a b c = key "border-right" (a ! b ! c) +borderColor4 :: Color -> Color -> Color -> Color -> Css+borderColor4 a b c d = key "border-color" (a ! b ! c ! d)+ borderColor, borderLeftColor, borderRightColor, borderTopColor, borderBottomColor :: Color -> Css borderColor = key "border-color"@@ -67,6 +75,9 @@ borderTopColor = key "border-top-color" borderBottomColor = key "border-bottom-color" +borderStyle4 :: Stroke -> Stroke -> Stroke -> Stroke -> Css+borderStyle4 a b c d = key "border-style" (a ! b ! c ! d)+ borderStyle, borderLeftStyle, borderRightStyle, borderTopStyle, borderBottomStyle :: Stroke -> Css borderStyle = key "border-style"@@ -75,8 +86,11 @@ borderTopStyle = key "border-top-style" borderBottomStyle = key "border-bottom-style" -borderWidth, borderLeftWidth, borderRightWidth, borderTopWidth, borderBottomWidth :: 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 LengthUnit -> Css+ borderWidth = key "border-width" borderLeftWidth = key "border-left-width" borderRightWidth = key "border-right-width"@@ -85,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)@@ -93,6 +107,9 @@ outlineBottom a b c = key "outline-bottom" (a ! b ! c) outlineRight a b c = key "outline-right" (a ! b ! c) +outlineColor4 :: Color -> Color -> Color -> Color -> Css+outlineColor4 a b c d = key "outline-color" (a ! b ! c ! d)+ outlineColor, outlineLeftColor, outlineRightColor, outlineTopColor, outlineBottomColor :: Color -> Css outlineColor = key "outline-color"@@ -101,6 +118,9 @@ outlineTopColor = key "outline-top-color" outlineBottomColor = key "outline-bottom-color" +outlineStyle4 :: Stroke -> Stroke -> Stroke -> Stroke -> Css+outlineStyle4 a b c d = key "outline-style" (a ! b ! c ! d)+ outlineStyle, outlineLeftStyle, outlineRightStyle, outlineTopStyle, outlineBottomStyle :: Stroke -> Css outlineStyle = key "outline-style"@@ -109,15 +129,18 @@ outlineTopStyle = key "outline-top-style" outlineBottomStyle = key "outline-bottom-style" -outlineWidth, outlineLeftWidth, outlineRightWidth, outlineTopWidth, outlineBottomWidth :: 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 LengthUnit -> Css+ outlineWidth = key "outline-width" outlineLeftWidth = key "outline-left-width" outlineRightWidth = key "outline-right-width" outlineTopWidth = key "outline-top-width" outlineBottomWidth = key "outline-bottom-width" -outlineOffset :: Size Abs -> Css+outlineOffset :: Size LengthUnit -> Css outlineOffset = key "outline-offset" -------------------------------------------------------------------------------@@ -133,3 +156,25 @@ borderBottomLeftRadius a b = key "border-bottom-left-radius" (a ! b) borderBottomRightRadius a b = key "border-bottom-right-radius" (a ! b) +-------------------------------------------------------------------------------++{- newtype Collapse = Collapse Value+ deriving (Val, Initial, Inherit, Other)++collapseCollapse, collapseSeparate :: Collapse++collapseCollapse = Collapse "collapse"+collapseSeparate = Collapse "separate" -}++{- Due conflict with Visibility collapse+ Preferred just to add separate to Visibility+ Because (borderCollapse collapseCollapse) sounds bad -}++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)
src/Clay/Box.hs view
@@ -3,18 +3,31 @@ ( 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 import Clay.Property import Clay.Stylesheet import Clay.Size+import Clay.Border ------------------------------------------------------------------------------- @@ -34,9 +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 | <shadow>#+-- > where +-- > <shadow> = inset? && <length>{2,4} && <color>?+-- > +-- > where +-- > <color> = <rgb()> | <rgba()> | <hsl()> | <hsla()> | <hex-color> | <named-color> | currentcolor | <deprecated-system-color>+-- > +-- > where +-- > <rgb()> = rgb( [ [ <percentage>{3} | <number>{3} ] [ / <alpha-value> ]? ] | [ [ <percentage>#{3} | <number>#{3} ] , <alpha-value>? ] )+-- > <rgba()> = rgba( [ [ <percentage>{3} | <number>{3} ] [ / <alpha-value> ]? ] | [ [ <percentage>#{3} | <number>#{3} ] , <alpha-value>? ] )+-- > <hsl()> = hsl( [ <hue> <percentage> <percentage> [ / <alpha-value> ]? ] | [ <hue>, <percentage>, <percentage>, <alpha-value>? ] )+-- > <hsla()> = hsla( [ <hue> <percentage> <percentage> [ / <alpha-value> ]? ] | [ <hue>, <percentage>, <percentage>, <alpha-value>? ] )+-- > +-- > where +-- > <alpha-value> = <number> | <percentage>+-- > <hue> = <number> | <angle> +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." #-}
src/Clay/Color.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Clay.Color where -import Data.Monoid+import Data.Char (isHexDigit) 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 @@ -15,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@@ -54,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"@@ -101,18 +199,17 @@ parse :: Text -> Color parse t = case Text.uncons t of- Just ('#', cs) | Text.all isHex cs ->+ 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 where hex a b = either err fst (Text.hexadecimal (Text.singleton a <> Text.singleton b))- isHex a = (a >= 'a' && a <= 'f') || (a >= 'A' && a <= 'F') || (a >= '0' && a <= '9') err = error "Invalid color string" -------------------------------------------------------------------------------
+ src/Clay/Comments.hs view
@@ -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))
src/Clay/Common.hs view
@@ -9,19 +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 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@@ -29,27 +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+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 ] -------------------------------------------------------------------------------@@ -58,3 +113,16 @@ 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)
src/Clay/Display.hs view
@@ -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,10 +34,20 @@ , scroll , overflow, overflowX, overflowY +-- * Overscroll+, Overscroll+, overscrollBehavior+, overscrollBehavior2+, overscrollBehaviorX+, overscrollBehaviorY+, overscrollBehaviorBlock+, overscrollBehaviorInline+ -- * Visibility. , Visibility-, collapse+, collapse, separate+ , visibility -- Clipping.@@ -61,16 +71,32 @@ , visiblePainted, visibleFill, visibleStroke, painted , fillEvents, strokeEvents, allEvents +-- * Vertical align.++, VerticalAlign(..)+, middle, vAlignSub, vAlignSuper, textTop, textBottom, vAlignTop, vAlignBottom, vAlignBaseline++-- * Cursor++, Cursor(..)+, 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) ------------------------------------------------------------------------------- @@ -104,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"@@ -119,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@@ -129,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"@@ -165,11 +194,37 @@ ------------------------------------------------------------------------------- +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) -collapse :: Visibility+separate, collapse :: Visibility+ collapse = Visibility "collapse"+separate = Visibility "separate" visibility :: Visibility -> Css visibility = key "visibility"@@ -187,7 +242,7 @@ ------------------------------------------------------------------------------- -opacity :: Double -> Css+opacity :: Number -> Css opacity = key "opacity" zIndex :: Integer -> Css@@ -211,3 +266,94 @@ pointerEvents :: PointerEvents -> Css pointerEvents = key "pointer-events"++-------------------------------------------------------------------------------++class (Val a) => VerticalAlign a where+ verticalAlign :: a -> Css+ verticalAlign = key "vertical-align"++newtype VerticalAlignValue = VerticalAlignValue Value deriving (Val, Baseline)++instance VerticalAlign VerticalAlignValue+instance VerticalAlign (Size a)++middle,vAlignSub,vAlignSuper,textTop,textBottom,vAlignTop,vAlignBottom,vAlignBaseline :: VerticalAlignValue++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,None)++instance Cursor (CursorValue a)++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"+seResize = CursorValue "se-resize"+swResize = CursorValue "sw-resize"+ewResize = CursorValue "ew-resize"+nsResize = CursorValue "ns-resize"+neswResize = CursorValue "nesw-resize"+nwseResize = CursorValue "nwse-resize"++-- Zooming+zoomIn = CursorValue "zoom-in"+zoomOut = CursorValue "zoom-out"
src/Clay/Dynamic.hs view
@@ -37,7 +37,6 @@ import Clay.Property import Clay.Stylesheet import Data.Monoid hiding (All)-import Prelude (($)) -------------------------------------------------------------------------------- -- Enabling user interface elements: the 'user-input' property
src/Clay/Elements.hs view
@@ -26,11 +26,11 @@ body, br, button, canvas, caption, code, col, colgroup, datalist, dd, del, details, dfn, dialog, div, dl, dt, em, embed, fieldset, figcaption, figure, footer, h1, h2, h3, h4, h5, h6, head, header, hgroup, hr, html, i, iframe,- img, input, ins, kbd, keygen, legend, li, link, map, mark, menu, meta, meter,- nav, noscript, object, ol, optgroup, option, output, p, param, pre, progress,- q, rp, rt, ruby, s, samp, script, section, select, small, source, strong,- sub, summary, sup, table, tbody, td, textarea, tfoot, th, thead, time, tr,- track, u, ul, var, video, wbr :: Selector+ img, input, ins, kbd, keygen, legend, li, link, main_, map, mark, math, menu,+ meta, meter, nav, noscript, object, ol, optgroup, option, output, p, param,+ pre, progress, q, rp, rt, ruby, s, samp, script, section, select, small,+ source, strong, sub, summary, sup, svg, table, tbody, td, template, textarea,+ tfoot, th, thead, time, tr, track, u, ul, var, video, wbr :: Selector a = "a" address = "address"@@ -87,11 +87,13 @@ legend = "legend" li = "li" link = "link"+main_ = "main" map = "map" mark = "mark" menu = "menu" meta = "meta" meter = "meter"+math = "math" nav = "nav" noscript = "noscript" object = "object"@@ -118,9 +120,11 @@ sub = "sub" summary = "summary" sup = "sup"+svg = "svg" table = "table" tbody = "tbody" td = "td"+template = "template" textarea = "textarea" tfoot = "tfoot" th = "th"
src/Clay/Filter.hs view
@@ -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 <> ")")
+ src/Clay/Flexbox.hs view
@@ -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)
src/Clay/Font.hs view
@@ -23,6 +23,8 @@ , sansSerif , serif , monospace+, cursive+, fantasy -- * Font-size. @@ -62,10 +64,9 @@ where import Control.Applicative-import Data.Text (pack)+import Data.Text (pack, Text) import Data.Monoid import Prelude hiding (Left, Right)-import Data.Text (Text) import Clay.Color import Clay.Common@@ -77,6 +78,8 @@ -- multiple value types. This allows us to combine different font aspects into -- a shorthand syntax. Fonts require a mandatory part and have a optional a -- part.+--+-- <http://www.w3.org/TR/css3-fonts/#font-prop> class Val a => Font a where font :: a -> Css@@ -96,10 +99,11 @@ (Size a) (Maybe (Size a)) [Text]- [Text]+ [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)@@ -117,24 +121,33 @@ ------------------------------------------------------------------------------- -fontFamily :: [Text] -> [Text] -> Css-fontFamily a b = key "font-family" $- let sep = if null a || null b then "" else ", "- in value (Literal <$> a) <> sep <> value b+-- | The five generic font families.+--+-- <http://www.w3.org/TR/css3-fonts/#generic-font-families>. -sansSerif :: Text-sansSerif = "sans-serif"+newtype GenericFontFamily = GenericFontFamily Value+ deriving (Val, Inherit, Auto, Other) -serif :: Text-serif = "serif"+sansSerif, serif, monospace, cursive, fantasy :: GenericFontFamily -monospace :: Text-monospace = "monospace"+sansSerif = GenericFontFamily "sans-serif"+serif = GenericFontFamily "serif"+monospace = GenericFontFamily "monospace"+cursive = GenericFontFamily "cursive"+fantasy = GenericFontFamily "fantasy" +-- | The `fontFamily` style rules takes to lists of font families: zero or more+-- custom font-families and preferably one or more generic font families.++fontFamily :: [Text] -> [GenericFontFamily] -> Css+fontFamily a b = key "font-family" $+ let sep = if null a || null b then "" else ", "+ in value (Literal <$> a) <> sep <> value b+ ------------------------------------------------------------------------------- newtype FontSize = FontSize Value- deriving (Val, Inherit, Auto)+ deriving (Val, Inherit, Auto, Other) xxSmall, xSmall, small, medium, large, xLarge, xxLarge, smaller, larger :: FontSize @@ -157,7 +170,7 @@ ------------------------------------------------------------------------------- newtype FontStyle = FontStyle Value- deriving (Val, Inherit, Normal)+ deriving (Val, Inherit, Normal, Other) italic, oblique :: FontStyle @@ -170,7 +183,7 @@ ------------------------------------------------------------------------------- newtype FontVariant = FontVariant Value- deriving (Val, Inherit, Normal)+ deriving (Val, Inherit, Normal, Other) smallCaps :: FontVariant smallCaps = FontVariant "small-caps"@@ -181,7 +194,7 @@ ------------------------------------------------------------------------------- newtype FontWeight = FontWeight Value- deriving (Val, Inherit, Normal)+ deriving (Val, Inherit, Normal, Other) bold, bolder, lighter :: FontWeight @@ -198,7 +211,7 @@ ------------------------------------------------------------------------------- newtype NamedFont = NamedFont Value- deriving Val+ deriving (Val, Other) caption, icon, menu, messageBox, smallCaption, statusBar :: NamedFont
src/Clay/FontFace.hs view
@@ -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"@@ -39,8 +44,8 @@ value src = Value $ Plain $ case src of FontFaceSrcLocal name -> call "local" (quote name) FontFaceSrcUrl url mformat ->- (call "url" $ quote url)- <> (fromMaybe "" $ call "format" . quote . formatName <$> mformat)+ call "url" (quote url)+ <> fromMaybe "" (call "format" . quote . formatName <$> mformat) -------------------------------------------------------------------------------
src/Clay/Geometry.hs view
@@ -7,6 +7,12 @@ -- * Sizing. , width, height, minWidth, minHeight, maxWidth, maxHeight +-- ** Aspect ratio.+, AspectRatio+, aspectRatio+, (%)+, withFallback+ -- * Padding. , padding , paddingTop, paddingLeft, paddingRight, paddingBottom@@ -17,15 +23,16 @@ ) where -import Prelude hiding (Left, Right)-+import qualified Data.Ratio as R+import Data.String (fromString)+import Clay.Common import Clay.Property import Clay.Stylesheet import Clay.Size ------------------------------------------------------------------------------- -size, top, left, bottom, right :: Size Abs -> Css+size, top, left, bottom, right :: Size a -> Css size = key "size" top = key "top"@@ -44,10 +51,104 @@ ------------------------------------------------------------------------------- -padding :: Size Abs -> Size Abs -> Size Abs -> Size Abs -> Css+-- | 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) -paddingTop, paddingLeft, paddingRight, paddingBottom :: Size Abs -> Css+paddingTop, paddingLeft, paddingRight, paddingBottom :: Size a -> Css paddingTop = key "padding-top" paddingLeft = key "padding-left"@@ -56,13 +157,12 @@ ------------------------------------------------------------------------------- -margin :: Size Abs -> Size Abs -> Size Abs -> Size Abs -> Css+margin :: Size a -> Size a -> Size a -> Size a -> Css margin a b c d = key "margin" (a ! b ! c ! d) -marginTop, marginLeft, marginRight, marginBottom :: Size Abs -> Css+marginTop, marginLeft, marginRight, marginBottom :: Size a -> Css marginTop = key "margin-top" marginLeft = key "margin-left" marginRight = key "margin-right" marginBottom = key "margin-bottom"-
src/Clay/Gradient.hs view
@@ -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))]
+ src/Clay/Grid.hs view
@@ -0,0 +1,775 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++-- | Partial implementation of+-- | <https://alligator.io/css/css-grid-layout-grid-areas grid area CSS API>.+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
+ src/Clay/List.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}+module Clay.List+( ListStyleType+, listStyleType+, disc+, armenian+, circleListStyle+, cjkIdeographic+, decimal+, decimalLeadingZero+, georgian+, hebrew+, hiragana+, hiraganaIroha+, katakana+, katakanaIroha+, lowerAlpha+, lowerGreek+, lowerLatin+, lowerRoman+, square+, upperAlpha+, upperLatin+, upperRoman++, ListStylePosition+, listStylePosition+, inside+, outside++, ListStyleImage+, listStyleImage+, imageUrl++, listStyle+)+where++import Data.Text (Text)++import Clay.Common+import Clay.Property+import Clay.Stylesheet++newtype ListStyleType = ListStyleType Value+ deriving (Val, Initial, Inherit, None, Other)++disc, armenian, circleListStyle, cjkIdeographic, decimal, decimalLeadingZero, georgian+ , hebrew, hiragana, hiraganaIroha, katakana, katakanaIroha, lowerAlpha+ , lowerGreek, lowerLatin, lowerRoman, square, upperAlpha, upperLatin, upperRoman :: ListStyleType++disc = ListStyleType "disc"+armenian = ListStyleType "armenian"+circleListStyle = ListStyleType "circle"+cjkIdeographic = ListStyleType "cjk-ideographic"+decimal = ListStyleType "decimal"+decimalLeadingZero = ListStyleType "decimal-leading-zero"+georgian = ListStyleType "georgian"+hebrew = ListStyleType "hebrew"+hiragana = ListStyleType "hiragana"+hiraganaIroha = ListStyleType "hiragana-iroha"+katakana = ListStyleType "katakana"+katakanaIroha = ListStyleType "katakana-iroha"+lowerAlpha = ListStyleType "lower-alpha"+lowerGreek = ListStyleType "lower-greek"+lowerLatin = ListStyleType "lower-latin"+lowerRoman = ListStyleType "lower-roman"+square = ListStyleType "square"+upperAlpha = ListStyleType "upper-alpha"+upperLatin = ListStyleType "upper-latin"+upperRoman = ListStyleType "upper-roman"++listStyleType :: ListStyleType -> Css+listStyleType = key "list-style-type"++newtype ListStylePosition = ListStylePosition Value+ deriving (Val, Initial, Inherit, Other)++inside, outside :: ListStylePosition++inside = ListStylePosition "inside"+outside = ListStylePosition "outside"++listStylePosition :: ListStylePosition -> Css+listStylePosition = key "list-style-position"++newtype ListStyleImage = ListStyleImage Value+ deriving (Val, Initial, Inherit, None, Other)++listStyleImage :: ListStyleImage -> Css+listStyleImage = key "list-style-image"++imageUrl :: Text -> ListStyleImage+imageUrl u = ListStyleImage ("url(" <> value (Literal u) <> ")")++listStyle :: ListStyleType -> ListStylePosition -> ListStyleImage -> Css+listStyle a b c = key "list-style" (a ! b ! c)
src/Clay/Mask.hs view
@@ -57,8 +57,6 @@ ) where -import Data.Monoid- import Clay.Background import Clay.Common import Clay.Property
src/Clay/Media.hs view
@@ -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"))
src/Clay/Property.hs view
@@ -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)-import Text.Printf -data Prefixed = Prefixed [(Text, Text)] | Plain Text- deriving Show+data Prefixed = Prefixed { unPrefixed :: [(Text, Text)] } | Plain { unPlain :: Text }+ 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))@@ -65,8 +68,8 @@ instance Val Integer where value = fromString . show -instance Val Double where- value = fromString . printf "%.5f"+data E5 = E5+instance HasResolution E5 where resolution _ = 100000 instance Val Value where value = id@@ -83,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 !
src/Clay/Pseudo.hs view
@@ -1,40 +1,84 @@ {-# 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 -link, visited, active, hover, focus, firstChild :: 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" visited = ":visited" active = ":active" hover = ":hover" focus = ":focus" firstChild = ":first-child"+lastChild = ":last-child" -firstOfType, lastOfType, empty, target, checked, enabled, disabled :: Refinement+checked, default_, disabled, empty, enabled, firstOfType, indeterminate,+ inRange, invalid, lastOfType, onlyChild, onlyOfType, optional,+ outOfRange, required, root, target, valid :: Refinement -firstOfType = ":first-of-type"-lastOfType = ":last-of-type"-empty = ":empty"-target = ":target"-checked = ":checked"-enabled = ":enabled"-disabled = ":disabled"+checked = ":checked"+default_ = ":default"+disabled = ":disabled"+empty = ":empty"+enabled = ":enabled"+firstOfType = ":first-of-type"+indeterminate = ":indeterminate"+inRange = ":in-range"+invalid = ":invalid"+lastOfType = ":last-of-type"+onlyChild = ":only-child"+onlyOfType = ":only-of-type"+optional = ":optional"+outOfRange = ":out-of-range"+required = ":required"+root = ":root"+target = ":target"+valid = ":valid" -nthChild, nthLastChild, nthOfType :: Text -> Refinement+lang, nthChild, nthLastChild, nthLastOfType, nthOfType :: Text -> Refinement -nthChild n = func "nth-child" [n]-nthLastChild n = func "nth-last-child" [n]-nthOfType n = func "nth-of-type" [n]+lang n = func "lang" [n]+nthChild n = func "nth-child" [n]+nthLastChild n = func "nth-last-child" [n]+nthLastOfType n = func "nth-last-of-type" [n]+nthOfType n = func "nth-of-type" [n] +-- | 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)
src/Clay/Render.hs view
@@ -4,50 +4,96 @@ , 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)-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)-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- , warn :: Bool- , align :: Bool- , banner :: Bool+ { 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. pretty :: Config-pretty = Config " " "\n" " " True True True+pretty = Config+ { 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. compact :: Config-compact = Config "" "" "" False False True+compact = Config+ { 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. @@ -64,28 +110,65 @@ -- scope. renderWith :: Config -> [App] -> Css -> Lazy.Text-renderWith cfg top (S c)+renderWith cfg top = renderBanner cfg . toLazyText . rules cfg top- . execWriter- $ c+ . runS +-- | Render a single CSS `Selector`.++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 =- if banner cfg- then (<> "\n/* Generated with Clay, http://fvisser.nl/clay */")- else id+renderBanner cfg+ | banner cfg = withBanner+ | otherwise = id +withBanner :: Lazy.Text -> Lazy.Text+withBanner = (<> "\n/* Generated with Clay, http://fvisser.nl/clay */")++kframe :: Config -> Keyframes -> Builder+kframe cfg (Keyframes ident xs) =+ foldMap+ ( \(browser, _) ->+ mconcat [ "@" <> fromText browser <> "keyframes "+ , fromText ident+ , newline cfg+ , lbrace cfg+ , newline cfg+ , foldMap (frame cfg) xs+ , rbrace cfg+ , newline cfg+ , newline cfg+ ]+ )+ (unPrefixed browsers)++frame :: Config -> (Number, [Rule]) -> Builder+frame cfg (p, rs) =+ mconcat+ [ fromText (cssNumberText p)+ , "% "+ , rules cfg [] rs+ ]+ query :: Config -> MediaQuery -> [App] -> [Rule] -> Builder query cfg q sel rs = mconcat [ mediaQuery q , newline cfg- , "{"+ , lbrace cfg , newline cfg , rules cfg sel rs- , "}"+ , rbrace cfg , newline cfg ] @@ -106,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) , ")" ] @@ -120,30 +203,47 @@ rules cfg sel rs = mconcat [ rule cfg sel (mapMaybe property rs) , newline cfg- , (\(a, b) -> rules cfg (a : sel) b) `foldMap` mapMaybe nested rs- , (\(a, b) -> query cfg a sel b) `foldMap` mapMaybe queries rs- , (\ns -> face cfg ns) `foldMap` mapMaybe faces rs+ , imp cfg `foldMap` mapMaybe imports rs+ , kframe cfg `foldMap` mapMaybe kframes rs+ , face cfg `foldMap` mapMaybe faces rs+ , (\(a, b) -> rules cfg (a : sel) b) `foldMap` mapMaybe nested rs+ , (\(a, b) -> query cfg a sel b) `foldMap` mapMaybe queries rs ]- where property (Property k v) = Just (k, v)- property _ = Nothing- nested (Nested a ns ) = Just (a, ns)- nested _ = Nothing- queries (Query q ns ) = Just (q, ns)- queries _ = Nothing- faces (Face ns ) = Just ns- faces _ = 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 -rule :: Config -> [App] -> [(Key (), Value)] -> Builder+imp :: Config -> Text -> Builder+imp cfg t =+ mconcat+ [ "@import url("+ , fromText t+ , ");"+ , newline cfg ]++-- | A key-value pair with associated comment.+type KeyVal = ([Modifier], Key (), Value)++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 ] @@ -157,49 +257,74 @@ 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)- ind = indentation cfg- new = newline cfg- in flip foldMap xs $ \p ->+ let width = 1 + maximum (Text.length <$> keys xs)+ ind = indentation cfg+ new = newline cfg+ finalSemi = if finalSemicolon cfg then ";" else ""+ in (<> new) $ (<> finalSemi) $ intercalate (";" <> new) $ flip map xs $ \p -> case p of- Left w -> if warn cfg then ind <> "/* no value for " <> fromText w <> " */" <> new else mempty- Right (k, v) ->- let pad = if align cfg then fromText (Text.replicate (width - Text.length k) " ") else ""- in mconcat [ind, fromText k, pad, ":", sep cfg, fromText v, ";", new]+ Warning w -> if warn cfg+ then ind <> "/* no value for " <> fromText w <> " */" <> new+ else mempty+ KeyValRep ms k v ->+ let pad = if align cfg+ then fromText (Text.replicate (width - Text.length k) " ")+ else ""+ 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 length ft == 0 then ["*"] else [""]+ Star -> if null ft then ["*"] else [""] Elem t -> [fromText t] 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)+ 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, "']" ]- AttrEnds a v -> [ "[", fromText a, "$='", fromText v, "']" ]- AttrSpace a v -> [ "[", fromText a, "~='", fromText v, "']" ]- AttrHyph a v -> [ "[", fromText a, "|='", fromText v, "']" ]- Pseudo a -> [ ":", fromText a ]- PseudoFunc a p -> [ ":", fromText a, "(", intersperse "," (map fromText p), ")" ]+ Id a -> [ "#" , fromText a ]+ Class a -> [ "." , fromText a ]+ Attr a -> [ "[" , fromText a, "]" ]+ AttrVal a v -> [ "[" , fromText a, "='", fromText v, "']" ]+ AttrBegins a v -> [ "[" , fromText a, "^='", fromText v, "']" ]+ AttrEnds a v -> [ "[" , fromText a, "$='", fromText v, "']" ]+ AttrContains a v -> [ "[" , fromText a, "*='", fromText v, "']" ]+ AttrSpace a v -> [ "[" , fromText a, "~='", fromText v, "']" ]+ AttrHyph a v -> [ "[" , fromText a, "|='", fromText v, "']" ]+ Pseudo a -> [ ":" , fromText a ]+ PseudoFunc a p -> [ ":" , fromText a, "(", intercalate "," (map fromText p), ")" ]+ PseudoElem a -> [ "::", fromText a ]
src/Clay/Selector.hs view
@@ -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@@ -102,12 +105,24 @@ (@=) :: Text -> Text -> Refinement (@=) a = Refinement . pure . AttrVal a +-- | Filter elements based on the presence of a certain attribute that begins+-- with the selected value.++(^=) :: Text -> Text -> Refinement+(^=) a = Refinement . pure . AttrBegins a+ -- | Filter elements based on the presence of a certain attribute that ends -- with the specified value. ($=) :: Text -> Text -> Refinement ($=) a = Refinement . pure . AttrEnds a +-- | Filter elements based on the presence of a certain attribute that contains+-- the specified value as a substring.++(*=) :: Text -> Text -> Refinement+(*=) a = Refinement . pure . AttrContains a+ -- | Filter elements based on the presence of a certain attribute that have the -- specified value contained in a space separated list. @@ -120,32 +135,39 @@ (|=) :: Text -> Text -> Refinement (|=) a = Refinement . pure . AttrHyph a + ------------------------------------------------------------------------------- data Predicate- = Id Text- | Class Text- | Attr Text- | AttrVal Text Text- | AttrEnds Text Text- | AttrSpace Text Text- | AttrHyph Text Text- | Pseudo Text- | PseudoFunc Text [Text]+ = Id Text+ | Class Text+ | Attr Text+ | AttrVal Text Text+ | AttrBegins Text Text+ | AttrEnds Text Text+ | AttrContains Text Text+ | AttrSpace Text Text+ | AttrHyph Text Text+ | Pseudo Text+ | PseudoFunc Text [Text]+ | 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] @@ -157,6 +179,7 @@ | Child f f | Deep f f | Adjacent f f+ | Sibling f f | Combined f f deriving Show @@ -170,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 = (<>)
src/Clay/Size.hs view
@@ -1,28 +1,65 @@ {-# 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 --- * Shorthands for mutli size-valued properties.+-- * Calculation operators for calc +, (@+@)+, (@-@)+, (@*)+, (*@)+, (@/)++-- * Shorthands for properties that can be applied separately to each box side.+ , sym , sym2 , sym3@@ -32,16 +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@@ -49,101 +92,255 @@ ------------------------------------------------------------------------------- --- | Sizes can be relative like percentages.-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") -instance Num (Size Abs) where- fromInteger = px+-- | SimpleSize in vw's (1vw = 1% of viewport width).+vw i = SimpleSize (cssNumberText i <> "vw")++-- | SimpleSize in vh's (1vh = 1% of viewport height).+vh i = SimpleSize (cssNumberText i <> "vh")++-- | 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" abs = error "abs not implemented for Size" signum = error "signum not implemented for Size"+ negate = error "negate not implemented for Size" -instance Fractional (Size Rel) where+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 :: (Size a -> Size a -> Size a -> Size a -> Css) -> Size a -> Css+sym :: (a -> a -> a -> a -> Css) -> a -> Css sym k a = k a a a a -sym3 :: (Size a -> Size a -> Size a -> Size a -> Css) -> Size a -> Size a -> Size a -> Css+sym3 :: (tb -> l -> tb -> r -> Css) -> tb -> l -> r -> Css sym3 k tb l r = k tb l tb r -sym2 :: (Size a -> Size a -> Size a -> Size a -> Css) -> Size a -> Size 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" (*) = error "times not implemented for Angle" abs = error "abs not implemented for Angle" signum = error "signum not implemented for Angle"+ negate = error "negate not implemented for Angle" instance Fractional (Angle Deg) where fromRational = deg . fromRational+ recip = error "recip not implemented for Angle" instance Num (Angle Rad) where fromInteger = rad . fromInteger@@ -151,7 +348,32 @@ (*) = error "times not implemented for Angle" abs = error "abs not implemented for Angle" signum = error "signum not implemented for Angle"+ negate = error "negate not implemented for Angle" instance Fractional (Angle Rad) where fromRational = rad . fromRational+ recip = error "recip not implemented for Angle" +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"
src/Clay/Stylesheet.hs view
@@ -1,8 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-} module Clay.Stylesheet where +import Control.Applicative+import Control.Arrow (second)+import Control.Monad.Writer (Writer, execWriter, tell)+import Data.Maybe (isJust)+import Data.String (IsString) import Data.Text (Text)-import Control.Monad.Writer hiding (All) import Clay.Selector hiding (Child) import Clay.Property@@ -22,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@@ -32,28 +55,46 @@ | Sub Selector deriving Show +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]+ | Keyframe Keyframes+ | Import Text deriving Show newtype StyleM a = S (Writer [Rule] a)- deriving Monad+ deriving (Functor, Applicative, Monad) +runS :: Css -> [Rule]+runS (S a) = execWriter a++rule :: Rule -> Css+rule a = S (tell [a])+ -- | The `Css` context is used to collect style rules which are mappings from -- selectors to style properties. The `Css` type is a computation in the -- `StyleM` monad that just collects and doesn't return anything. 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 = S $ tell [Property (cast k) (value v)]+key k v = rule $ Property [] (cast k) (value v) -- | Add a new style property to the stylesheet with the specified `Key` and -- value, like `key` but use a `Prefixed` key.@@ -80,51 +121,84 @@ -- outer scope it will be composed with `deep`. (?) :: Selector -> Css -> Css-(?) sel (S rs) = S (tell [Nested (Sub sel) (execWriter rs)])+(?) sel rs = rule $ Nested (Sub sel) (runS rs) -- | Assign a stylesheet to a selector. When the selector is nested inside an -- outer scope it will be composed with `|>`. (<?) :: Selector -> Css -> Css-(<?) sel (S rs) = S (tell [Nested (Child sel) (execWriter rs)])+(<?) sel rs = rule $ Nested (Child sel) (runS rs) -- | Assign a stylesheet to a filter selector. When the selector is nested -- inside an outer scope it will be composed with the `with` selector. (&) :: Refinement -> Css -> Css-(&) p (S rs) = S (tell [Nested (Self p) (execWriter rs)])+(&) p rs = rule $ Nested (Self p) (runS rs) -- | Root is used to add style rules to the top scope. root :: Selector -> Css -> Css-root sel (S rs) = S (tell [Nested (Root sel) (execWriter rs)])+root sel rs = rule $ Nested (Root sel) (runS rs) -- | Pop is used to add style rules to selectors defined in an outer scope. The -- counter specifies how far up the scope stack we want to add the rules. pop :: Int -> Css -> Css-pop i (S rs) = S (tell [Nested (Pop i) (execWriter rs)])+pop i rs = rule $ Nested (Pop i) (runS rs) ------------------------------------------------------------------------------- -- | Apply a set of style rules when the media type and feature queries apply. query :: MediaType -> [Feature] -> Css -> Css-query ty fs (S rs) = S (tell [Query (MediaQuery Nothing ty fs) (execWriter rs)])+query ty fs rs = rule $ Query (MediaQuery Nothing ty fs) (runS rs) -- | Apply a set of style rules when the media type and feature queries do not apply. queryNot :: MediaType -> [Feature] -> Css -> Css-queryNot ty fs (S rs) = S (tell [Query (MediaQuery (Just Not) ty fs) (execWriter rs)])+queryNot ty fs rs = rule $ Query (MediaQuery (Just Not) ty fs) (runS rs) -- | Apply a set of style rules only when the media type and feature queries apply. queryOnly :: MediaType -> [Feature] -> Css -> Css-queryOnly ty fs (S rs) = S (tell [Query (MediaQuery (Just Only) ty fs) (execWriter rs)])+queryOnly ty fs rs = rule $ Query (MediaQuery (Just Only) ty fs) (runS rs) ------------------------------------------------------------------------------- +keyframes :: Text -> [(Number, Css)] -> Css+keyframes n xs = rule $ Keyframe (Keyframes n (map (second runS) xs))++keyframesFromTo :: Text -> Css -> Css -> Css+keyframesFromTo n a b = keyframes n [(0, a), (100, b)]++-------------------------------------------------------------------------------+ -- | Define a new font-face. fontFace :: Css -> Css-fontFace (S rs) = S (tell [Face (execWriter rs)])+fontFace rs = rule $ Face (runS rs)+++-- | Import a CSS file from a URL++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
src/Clay/Text.hs view
@@ -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@@ -67,14 +99,14 @@ , attrContent , stringContent , uriContent+, urlContent , openQuote, closeQuote, noOpenQuote, noCloseQuote ) where -import Data.Monoid import Data.String-import Data.Text (Text)+import Data.Text (Text, pack) import Clay.Background import Clay.Border@@ -113,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+--+-- > <length-percentage> && hanging? && each-line?+-- > where+-- > <length-percentage> = <length> | <percentage>+ 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 @@ -144,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" @@ -162,13 +218,16 @@ textAlign :: TextAlign -> Css textAlign = key "text-align" +textAlignLast :: TextAlign -> Css+textAlignLast = key "text-align-last"+ ------------------------------------------------------------------------------- newtype WhiteSpace = WhiteSpace Value deriving (Val, Normal, Inherit, Other) whiteSpace :: WhiteSpace -> Css-whiteSpace = key "whiteSpace"+whiteSpace = key "white-space" pre, nowrap, preWrap, preLine :: WhiteSpace @@ -218,8 +277,139 @@ ------------------------------------------------------------------------------- +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)++-------------------------------------------------------------------------------+ newtype Content = Content Value- deriving (Val, None, Normal, Inherit)+ deriving (Val, None, Normal, Inherit, Initial) attrContent :: Text -> Content attrContent a = Content ("attr(" <> value a <> ")")@@ -230,6 +420,9 @@ uriContent :: Text -> Content uriContent u = Content ("uri(" <> value (Literal u) <> ")") +urlContent :: Text -> Content+urlContent u = Content ("url(" <> value (Literal u) <> ")")+ openQuote, closeQuote, noOpenQuote, noCloseQuote :: Content openQuote = Content "open-quote"@@ -244,4 +437,3 @@ contents cs = key "content" (noCommas cs) -- TODO: counters-
src/Clay/Time.hs view
@@ -12,7 +12,6 @@ ) where -import Data.Monoid import Data.Text (pack) import Clay.Common@@ -39,7 +38,9 @@ (*) = error "times not implemented for Time" abs = error "abs not implemented for Time" signum = error "signum not implemented for Time"+ negate = error "negate not implemented for Time" instance Fractional Time where fromRational = sec . fromRational+ recip = error "recip not implemented for Time"
src/Clay/Transform.hs view
@@ -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
src/Clay/Transition.hs view
@@ -24,7 +24,8 @@ , TimingFunction , transitionTimingFunction-, ease, easeIn, easeOut, easeInOut, easeLinear, 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,41 +57,50 @@ 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, easeLinear, stepStart, stepStop :: TimingFunction+ease, easeIn, easeOut, easeInOut, linear, stepStart, stepEnd, stepStop :: TimingFunction ease = other "ease"-easeIn = other "easeIn"-easeOut = other "easeOut"-easeInOut = other "easeInOut"-easeLinear = other "easeLinear"-stepStart = other "stepStart"-stepStop = other "stepStop"+easeIn = other "ease-in"+easeOut = other "ease-out"+easeInOut = other "ease-in-out"+linear = other "linear"+stepStart = other "step-start"+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 -------------------------------------------------------------------------------