atomic-css (empty) → 0.1.0
raw patch · 30 files changed
+3040/−0 lines, 30 filesdep +atomic-cssdep +basedep +bytestring
Dependencies added: atomic-css, base, bytestring, casing, containers, effectful-core, file-embed, html-entities, http-types, skeletest, text
Files
- CHANGELOG.md +43/−0
- LICENSE +30/−0
- README.md +197/−0
- atomic-css.cabal +117/−0
- embed/reset.css +1/−0
- src/Web/Atomic.hs +99/−0
- src/Web/Atomic/Attributes.hs +16/−0
- src/Web/Atomic/CSS.hs +203/−0
- src/Web/Atomic/CSS/Box.hs +130/−0
- src/Web/Atomic/CSS/Layout.hs +269/−0
- src/Web/Atomic/CSS/Reset.hs +23/−0
- src/Web/Atomic/CSS/Select.hs +66/−0
- src/Web/Atomic/CSS/Text.hs +55/−0
- src/Web/Atomic/CSS/Transition.hs +37/−0
- src/Web/Atomic/Html.hs +143/−0
- src/Web/Atomic/Html/Tag.hs +59/−0
- src/Web/Atomic/Render.hs +189/−0
- src/Web/Atomic/Types.hs +17/−0
- src/Web/Atomic/Types/Attributable.hs +58/−0
- src/Web/Atomic/Types/ClassName.hs +72/−0
- src/Web/Atomic/Types/Rule.hs +140/−0
- src/Web/Atomic/Types/Selector.hs +79/−0
- src/Web/Atomic/Types/Style.hs +242/−0
- src/Web/Atomic/Types/Styleable.hs +115/−0
- test/Spec.hs +2/−0
- test/Test/AttributeSpec.hs +57/−0
- test/Test/RenderSpec.hs +301/−0
- test/Test/RuleSpec.hs +101/−0
- test/Test/StyleSpec.hs +121/−0
- test/Test/UtilitySpec.hs +58/−0
+ CHANGELOG.md view
@@ -0,0 +1,43 @@+# Revision history for atomic-css++## atomic-css 0.1.0++This package renamed to atomic-css with a focus on css utilities. View, Url and other Hyperbole-specific types moved to Hyperbole. Still provides an Html monad+Major rewrite of Library and API+ * New interface with operators: (@) for attributes, (~) to utilities+ * Defining custom CSS and new utilities is more intuitive++## web-view 0.7.0++* stack, popup, offset, layer - more intuitive interface+* added Web.View.Url.renderPath+* Style class+* added code, lists++## web-view 0.6.0++* stack - layout children on top of each other+* ChildCombinator: apply styles to direct children+* `Mod` is now `Mod context`, allowing for type-safe `Mod`s+* fixed: escaping in auto-generated `<style>`+* Refactored: selectors and rendering++## web-view 0.5.0++* Rendering improvements+* extClass to add external css class+* inline elements+* Url: no longer lowercases automatically. Show/Read instance+* ++## web-view 0.4.0++* Added new Mods. Length type. Improved Url type++## web-view 0.3.1++* Cleanup. Refactored Mods++## web-view 0.2.3 -- 2023-11-27++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Sean Hess++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sean Hess nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,197 @@+Atomic CSS+============++[][hackage]++Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI+++### Write Haskell instead of CSS++Style your html with composable CSS utility functions:++```haskell+el ~ bold . pad 8 $ "Hello World"+```++This renders as the following HTML with embedded CSS utility classes:++```html+<style type='text/css'>+.bold { font-weight:bold }+.p-8 { padding:0.500rem }+</style>++<div class='bold p-8'>Hello World</div>+```++Instead of relying on the fickle cascade, factor and compose styles with the full power of Haskell functions!++```haskell+header = bold+h1 = header . fontSize 32+h2 = header . fontSize 24+page = flexCol . gap 10 . pad 10++example = el ~ page $ do+ el ~ h1 $ "My Page"+ el ~ h2 $ "Introduction"+ el "lorem ipsum..."+```++This approach is inspired by Tailwindcss' [Utility Classes](https://tailwindcss.com/docs/styling-with-utility-classes)+++### Intuitive Flexbox Layouts++Create complex layouts with `row`, `col`, `grow`, and `space`++```haskell+holygrail = do+ col ~ grow $ do+ row "Top Bar"+ row ~ grow $ do+ col "Left Sidebar"+ col ~ grow $ "Main Content"+ col "Right Sidebar"+ row "Bottom Bar"+```++### Stateful Styles++We can apply utilities when certain states apply. For example, to change the background on hover:++```haskell+button ~ bg Primary . hover (bg PrimaryLight) $ "Hover Me"+```++Media states allow us to create responsive designs++```haskell+el ~ width 100 . media (MinWidth 800) (width 400) $ do+ "Big if window > 800"+```+++### Embedded CSS++Only the utilities used in a given html fragment are rendered:++ >>> renderText $ el ~ bold $ "Hello"+ + <style type='text/css'>.bold { font-weight:bold }</style>+ <div class='bold'>Hello</div>+++### Try Example Project with Nix++If you want to get a feel for atomic-css without cloning the project run `nix run github:seanhess/atomic-css` to run the example webserver locally++Import Flake+------------++You can import this flake's overlay to add `atomic-css` to `overriddenHaskellPackages` and which provides a ghc966 and ghc982 package set that satisfy `atomic-css`'s dependencies.++```nix+{+ inputs = {+ nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";+ atomic-css.url = "github:seanhess/atomic-css"; # or "path:/path/to/cloned/atomic-css";+ flake-utils.url = "github:numtide/flake-utils";+ };++ outputs = { self, nixpkgs, atomic-css, flake-utils, ... }:+ flake-utils.lib.eachDefaultSystem (+ system:+ let+ pkgs = import nixpkgs {+ inherit system;+ overlays = [ atomic-css.overlays.default ];+ };+ haskellPackagesOverride = pkgs.overriddenHaskellPackages.ghc966.override (old: {+ overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: { })) (hfinal: hprev: {+ # your overrides here+ });+ });+ in+ {+ devShells.default = haskellPackagesOverride.shellFor {+ packages = p: [ p.atomic-css ];+ };+ }+ );+}+```++Local Development+-----------------++### Recommended ghcid command++If you want to work on both the atomic-css library and example code, this `ghcid` command will run and reload the examples server as you change any non-testing code.++```+ghcid --command="cabal repl exe:example lib:atomic-css" --run=Main.main --warnings --reload=./embed/preflight.css+```++If you want to work on the test suite, this will run the tests each time any library code is changed.++```+ghcid --command="cabal repl test lib:atomic-css" --run=Main.main --warnings --reload=./embed/preflight.css+```++### Nix++- `nix flake check` will build the library, example executable and devShell with ghc-9.8.2 and ghc-9.6.6+ - This is what the CI on GitHub runs+- `nix run` or `nix run .#ghc982-example` to start the example project with GHC 9.8.2+ - `nix run .#ghc966-example` to start the example project with GHC 9.6.6+- `nix develop` or `nix develop .#ghc982-shell` to get a shell with all dependencies installed for GHC 9.8.2. + - `nix develop .#ghc966-shell` to get a shell with all dependencies installed for GHC 9.6.6. +- `nix build`, `nix build .#ghc982-atomic-css` and `nix build .#ghc966-atomic-css` builds the library with the `overriddenHaskellPackages`+ - If you want to import this flake, use the overlay+- `nix flake update nixpkgs` will update the Haskell package sets and development tools++### Common Nix Issues++#### Not Allowed to Refer to GHC++If you get an error like:++```+error: output '/nix/store/64k8iw0ryz76qpijsnl9v87fb26v28z8-my-haskell-package-1.0.0.0' is not allowed to refer to the following paths:+ /nix/store/5q5s4a07gaz50h04zpfbda8xjs8wrnhg-ghc-9.6.3+```++Follow these [instructions](https://nixos.org/manual/nixpkgs/unstable/#haskell-packaging-helpers)++#### Dependencies Incorrect++You will need to update the overlay, look for where it says `"${packageName}" = hfinal.callCabal2nix packageName src { };` and add a line like `Diff = hfinal.callHackage "Diff" "0.5" { };` with the package and version you need.++#### Missing Files++Check the `include` inside the `nix-filter.lib` to see if all files needed by cabal are there.++Learn More+----------++View Documentation on [Hackage][hackage]+* https://hackage.haskell.org/package/atomic-css++View on Github+* https://github.com/seanhess/atomic-css++View [Examples](https://github.com/seanhess/atomic-css/blob/latest/example/app/Main.hs)+++[hackage]: https://hackage.haskell.org/package/atomic-css+++Contributors+------------++* [Sean Hess](https://github.com/seanhess)+* [Kamil Figiela](https://github.com/kfigiela)+* [Pfalzgraf Martin](https://github.com/Skyfold)+
+ atomic-css.cabal view
@@ -0,0 +1,117 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: atomic-css+version: 0.1.0+synopsis: Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI+description: Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI . See documentation for the @Web.Atomic@ module below+category: Web+homepage: https://github.com/seanhess/atomic-css+bug-reports: https://github.com/seanhess/atomic-css/issues+author: Sean Hess+maintainer: seanhess@gmail.com+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 9.8.2+ , GHC == 9.6.6+extra-source-files:+ embed/reset.css+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/seanhess/atomic-css++library+ exposed-modules:+ Web.Atomic+ Web.Atomic.Attributes+ Web.Atomic.CSS+ Web.Atomic.CSS.Box+ Web.Atomic.CSS.Layout+ Web.Atomic.CSS.Reset+ Web.Atomic.CSS.Select+ Web.Atomic.CSS.Text+ Web.Atomic.CSS.Transition+ Web.Atomic.Html+ Web.Atomic.Html.Tag+ Web.Atomic.Render+ Web.Atomic.Types+ Web.Atomic.Types.Attributable+ Web.Atomic.Types.ClassName+ Web.Atomic.Types.Rule+ Web.Atomic.Types.Selector+ Web.Atomic.Types.Style+ Web.Atomic.Types.Styleable+ other-modules:+ Paths_atomic_css+ autogen-modules:+ Paths_atomic_css+ hs-source-dirs:+ src+ default-extensions:+ OverloadedStrings+ OverloadedRecordDot+ DuplicateRecordFields+ NoFieldSelectors+ TypeFamilies+ DerivingStrategies+ DefaultSignatures+ DeriveAnyClass+ ghc-options: -Wall -fdefer-typed-holes+ build-depends:+ base >=4.16 && <5+ , bytestring >=0.11 && <0.13+ , casing >0.1.3.0 && <0.2+ , containers >=0.6 && <1+ , effectful-core >=2.3 && <3+ , file-embed >=0.0.10 && <0.1+ , html-entities >=1.1.4.7 && <1.2+ , http-types ==0.12.*+ , text >=1.2 && <3+ default-language: GHC2021++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Test.AttributeSpec+ Test.RenderSpec+ Test.RuleSpec+ Test.StyleSpec+ Test.UtilitySpec+ Paths_atomic_css+ autogen-modules:+ Paths_atomic_css+ hs-source-dirs:+ test/+ default-extensions:+ OverloadedStrings+ OverloadedRecordDot+ DuplicateRecordFields+ NoFieldSelectors+ TypeFamilies+ DerivingStrategies+ DefaultSignatures+ DeriveAnyClass+ ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor+ build-depends:+ atomic-css+ , base >=4.16 && <5+ , bytestring >=0.11 && <0.13+ , casing >0.1.3.0 && <0.2+ , containers >=0.6 && <1+ , effectful-core >=2.3 && <3+ , file-embed >=0.0.10 && <0.1+ , html-entities >=1.1.4.7 && <1.2+ , http-types ==0.12.*+ , skeletest+ , text >=1.2 && <3+ default-language: GHC2021
+ embed/reset.css view
@@ -0,0 +1,1 @@+a,hr{color:inherit}progress,sub,sup{vertical-align:baseline}blockquote,body,dd,dl,fieldset,figure,h1,h2,h3,h4,h5,h6,hr,menu,ol,p,pre,ul,form{margin:0}dialog,fieldset,legend,menu,ol,ul{padding:0}*,::after,::before{box-sizing:border-box;border-width:0;border-style:solid;border-color:currentColor}::after,::before{--tw-content:''}html{line-height:1.5;-webkit-text-size-adjust:100%;-moz-tab-size:4;tab-size:4;font-family:ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, "Helvetica Neue", Arial, "Noto Sans", sans-serif, "Apple Color Emoji", "Segoe UI Emoji", "Segoe UI Symbol", "Noto Color Emoji";}body{line-height:inherit;height:100%;margin:0;padding:0;display:flex;flex-direction:column}hr{height:0;border-top-width:1px}abbr:where([title]){text-decoration:underline dotted}h1,h2,h3,h4,h5,h6{font-size:inherit;font-weight:inherit}a{text-decoration:inherit}b,strong{font-weight:bolder}code,kbd,pre,samp{font-family:ui-monospace, SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", "Courier New", monospace;font-size:1em}small{font-size:80%}sub,sup{font-size:75%;line-height:0;position:relative}sub{bottom:-.25em}sup{top:-.5em}table{text-indent:0;border-color:inherit;border-collapse:collapse}button,input,optgroup,select,textarea{font-family:inherit;font-feature-settings:inherit;font-variation-settings:inherit;font-size:100%;font-weight:inherit;line-height:inherit;color:inherit;margin:0;padding:0}button,select{text-transform:none}[type=button],[type=reset],[type=submit],button{-webkit-appearance:button;background-color:transparent;background-image:none}:-moz-focusring{outline:auto}:-moz-ui-invalid{box-shadow:none}::-webkit-inner-spin-button,::-webkit-outer-spin-button{height:auto}[type=search]{-webkit-appearance:textfield;outline-offset:-2px}::-webkit-search-decoration{-webkit-appearance:none}::-webkit-file-upload-button{-webkit-appearance:button;font:inherit}summary{display:list-item}menu,ol,ul{list-style:none}textarea{resize:vertical}input::placeholder,textarea::placeholder{opacity:1;color:#9ca3af}[role=button],button{cursor:pointer}:disabled{cursor:default}audio,canvas,embed,iframe,img,object,svg,video{display:block;vertical-align:middle}img,video{max-width:100%;height:auto}[hidden]{display:none}
+ src/Web/Atomic.hs view
@@ -0,0 +1,99 @@+{- |+Module: Web.Atomic+Copyright: (c) 2023 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI+-}+module Web.Atomic+ ( -- * Haskell functions instead of classes+ -- $use+ module Web.Atomic.Types++ -- ** Atomic CSS+ -- $css+ , module Web.Atomic.CSS++ -- ** Html Monad+ -- $html+ , Html+ , el+ , tag+ , none+ , raw+ , text++ -- ** Layout+ , module Web.Atomic.Html.Tag++ -- ** Rendering+ , renderText+ , renderLazyText+ , renderLazyByteString+ ) where++import Web.Atomic.CSS+import Web.Atomic.Html+import Web.Atomic.Render+import Web.Atomic.Types+import Web.Atomic.Html.Tag+++-- TODO: update readme++{- $html+Atomic-css also provides an Html Monad and combinator library with basic functions to generate html and add attributes with the `(@)` operator+-}+++{- $css+The main purpose of atomic-css is to provide CSS Utilities and the `(~)` operator to style HTML. These utilities can be used by any combinator library. See [Hyperbole](https://github.com/seanhess/hyperbole)++@+bold :: 'Styleable' h => 'CSS' h -> 'CSS' h+bold = utility "bold" ["font-weight" :. "bold"]++pad :: 'Styleable' h => 'PxRem' -> 'CSS' h -> 'CSS' h+pad px = utility ("pad" -. px) ["padding" :. 'style' px]++example = el ~ bold . pad 10 $ "Padded and bold"+@++Web.Atomic.CSS contains many useful utilities:+-}+++{- $use++Style your html with composable CSS utility functions:++@+'el' ~ 'bold' . 'pad' 8 $ "Hello World"+@++This renders as the following HTML with embedded CSS utility classes:++> <style type='text/css'>+> .bold { font-weight:bold }+> .p-8 { padding:0.500rem }+> </style>+>+> <div class='bold p-8'>Hello World</div>++Instead of relying on the fickle cascade for code reuse, factor and compose styles with the full power of Haskell functions!++> header = bold+> h1 = header . fontSize 32+> h2 = header . fontSize 24+> page = flexCol . gap 10 . pad 10+>+> example = el ~ page $ do+> el ~ h1 $ "My Page"+> el ~ h2 $ "Introduction"+> el "lorem ipsum..."++This approach is inspired by Tailwindcss' [Utility Classes](https://tailwindcss.com/docs/styling-with-utility-classes)+-}
+ src/Web/Atomic/Attributes.hs view
@@ -0,0 +1,16 @@+module Web.Atomic.Attributes+ ( Attributable (..)+ , class_+ , att+ , Name+ , AttValue+ , Attributes+ ) where++import Data.Map.Strict qualified as M+import Web.Atomic.Types+++class_ :: (Attributable h) => AttValue -> Attributes h -> Attributes h+class_ cnew (Attributes m) =+ Attributes $ M.insertWith (\a b -> a <> " " <> b) "class" cnew m
+ src/Web/Atomic/CSS.hs view
@@ -0,0 +1,203 @@+{- |+Module: Web.Atomic.CSS+Copyright: (c) 2023 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++Type-safe Atomic CSS with composable css utility classes and intuitive layouts. Inspired by Tailwindcss and Elm-UI++@+import Web.Atomic++example = do+ 'el' ~ 'flexCol' . 'gap' 10 $ do+ 'el' ~ 'bold' . 'fontSize' 32 $ "My page"+ 'el' "Hello!"+@++See [Web.Atomic](Web-Atomic.html) for a complete introduction+-}+module Web.Atomic.CSS+ ( -- * Atomic CSS+ Styleable ((~))+ , utility+ , css+ , cls++ -- * CSS Utilities++ -- ** Layout+ , display+ , Display (..)+ , visibility+ , Visibility (..)+ , width+ , height+ , minWidth+ , minHeight+ , position+ , Position (..)+ , inset+ , top+ , bottom+ , right+ , left+ , overflow++ -- ** Flexbox+ -- $flexbox+ , flexRow+ , flexCol+ , grow+ , flexDirection+ , FlexDirection (..)+ , flexWrap+ , FlexWrap (..)++ -- ** Window+ , zIndex++ -- ** Stack+ , stack+ , popup++ -- ** Box Model+ , pad+ , gap+ , margin+ , bg+ , border+ , borderWidth+ , borderColor+ , borderStyle+ , BorderStyle (..)+ , rounded+ , opacity+ , shadow+ , Shadow+ , Inner (..)++ -- ** Text+ , bold+ , fontSize+ , color+ , italic+ , underline+ , textAlign+ , Align (..)+ , whiteSpace+ , WhiteSpace (..)++ -- ** CSS Transitions+ , transition+ , TransitionProperty (..)++ -- ** Elements+ , list+ , ListType (..)+ , pointer++ -- ** Selector Modifiers+ , hover+ , active+ , even+ , odd+ , descendentOf+ , media+ , Media (..)++ -- ** Colors+ , ToColor (..)+ , HexColor (..)++ -- * CSS Reset+ , cssResetEmbed++ -- * Types+ , Property+ , Declaration (..)+ , Style+ , ToStyle (..)+ , PropertyStyle (..)+ , None (..)+ , Auto (..)+ , Normal (..)+ , Length (..)+ , PxRem (..)+ , Ms (..)+ , Wrap (..)+ , Sides (..)+ , CSS++ -- * Other+ , declarations+ , rules+ ) where++import Web.Atomic.CSS.Box hiding (sides, sides')+import Web.Atomic.CSS.Layout+import Web.Atomic.CSS.Reset+import Web.Atomic.CSS.Select hiding (addAncestor, addMedia, addPseudo)+import Web.Atomic.CSS.Text+import Web.Atomic.CSS.Transition+import Web.Atomic.Types+import Prelude hiding (even, odd, truncate)+++{- | Set the list style of an item++> tag "ol" $ do+> tag "li" ~ list Decimal $ "one"+> tag "li" ~ list Decimal $ "two"+> tag "li" ~ list Decimal $ "three"+-}+list :: (ToClassName l, PropertyStyle ListType l, Styleable h) => l -> CSS h -> CSS h+list a =+ utility ("list" -. a) ["list-style-type" :. propertyStyle @ListType a]+++data ListType+ = Decimal+ | Disc+ deriving (Show, ToClassName, ToStyle)+instance PropertyStyle ListType ListType+instance PropertyStyle ListType None+++{- | Use a button-like cursor when hovering over the element++Button-like elements:++> btn = pointer . bg Primary . hover (bg PrimaryLight)+>+> options = do+> el ~ btn $ "Login"+> el ~ btn $ "Sign Up"+-}+pointer :: (Styleable h) => CSS h -> CSS h+pointer = utility "pointer" ["cursor" :. "pointer"]+++{- $use++See+-}+++{- $flexbox++We can intuitively create layouts by combining of 'flexRow', 'flexCol', 'grow', and 'stack'++@+holygrail = do+ el ~ flexCol . grow $ do+ el ~ flexRow $ "Top Bar"+ el ~ flexRow . grow $ do+ el ~ flexCol $ "Left Sidebar"+ el ~ flexCol . grow $ "Main Content"+ el ~ flexCol $ "Right Sidebar"+ el ~ flexRow $ "Bottom Bar"+@+-}
+ src/Web/Atomic/CSS/Box.hs view
@@ -0,0 +1,130 @@+module Web.Atomic.CSS.Box where++import Web.Atomic.Types+++{- | Space surrounding the children of the element++To create even spacing around and between all elements combine with 'gap'++> el ~ flexCol . pad 10 . gap 10 $ do+> el "one"+> el "two"+> el "three"+-}+pad :: (Styleable h) => Sides Length -> CSS h -> CSS h+pad =+ sides "p" ("padding" <>)+++-- | The space between child elements. See 'pad'+gap :: (Styleable h) => Length -> CSS h -> CSS h+gap n = utility ("gap" -. n) ["gap" :. style n]+++-- | Element margin. Using 'gap' and 'pad' on parents is more intuitive and usually makes margin redundant+margin :: (Styleable h) => Sides Length -> CSS h -> CSS h+margin =+ sides "m" ("margin" <>)+++{- | Add a drop shadow to an element++> input ~ shadow Inner $ "Inset Shadow"+> button ~ shadow () $ "Click Me"+-}+shadow :: (Styleable h, PropertyStyle Shadow a, ToClassName a) => a -> CSS h -> CSS h+shadow a =+ utility ("shadow" -. a) ["box-shadow" :. propertyStyle @Shadow a]+++data Shadow+data Inner = Inner+ deriving (Show, ToClassName)+++instance PropertyStyle Shadow () where+ propertyStyle _ = "0 1px 3px 0 rgb(0 0 0 / 0.1), 0 1px 2px -1px rgb(0 0 0 / 0.1);"+instance PropertyStyle Shadow None where+ propertyStyle _ = "0 0 #0000;"+instance PropertyStyle Shadow Inner where+ propertyStyle _ = "inset 0 2px 4px 0 rgb(0 0 0 / 0.05);"+++-- | Set the background color. See 'ToColor'+bg :: (ToColor clr, Styleable h) => clr -> CSS h -> CSS h+bg c = utility ("bg" -. colorName c) ["background-color" :. style (colorValue c)]+++-- | Round the corners of the element+rounded :: (Styleable h) => Length -> CSS h -> CSS h+rounded n = utility ("rnd" -. n) ["border-radius" :. style n]+++{- | Set a border around the element++> el ~ border 1 $ "all sides"+> el ~ border (X 1) $ "only left and right"+-}+border :: (Styleable h) => Sides PxRem -> CSS h -> CSS h+border s = borderWidth s . borderStyle Solid+++borderStyle :: (Styleable h) => BorderStyle -> CSS h -> CSS h+borderStyle s = utility ("brds" -. s) ["border-style" :. style s]+++data BorderStyle+ = Solid+ | Dashed+ deriving (Show, ToStyle, ToClassName)+++borderWidth :: (Styleable h) => Sides PxRem -> CSS h -> CSS h+borderWidth =+ sides "brd" prop+ where+ prop "" = "border-width"+ prop p = "border" <> p <> "-width"+++-- | Set a border color. See 'ToColor'+borderColor :: (ToColor clr, Styleable h) => clr -> CSS h -> CSS h+borderColor c =+ utility ("brdc" -. colorName c) ["border-color" :. style (colorValue c)]+++opacity :: (Styleable h) => Float -> CSS h -> CSS h+opacity n =+ utility ("opacity" -. n) ["opacity" :. style n]+++-- | utilities for every side with (Sides a)+sides :: (Styleable h, ToStyle a, ToClassName a, Num a) => ClassName -> (Property -> Property) -> Sides a -> CSS h -> CSS h+sides c toProp =+ sides'+ (\a -> utility (c -. a) [toProp "" :. style a])+ (\a -> utility (c <> "t" -. a) [toProp "-top" :. style a])+ (\a -> utility (c <> "r" -. a) [toProp "-right" :. style a])+ (\a -> utility (c <> "b" -. a) [toProp "-bottom" :. style a])+ (\a -> utility (c <> "l" -. a) [toProp "-left" :. style a])+++-- | case analysis for (Sides a)+sides' :: (Styleable h, ToStyle a, ToClassName a, Num a) => (a -> CSS h -> CSS h) -> (a -> CSS h -> CSS h) -> (a -> CSS h -> CSS h) -> (a -> CSS h -> CSS h) -> (a -> CSS h -> CSS h) -> Sides a -> CSS h -> CSS h+sides' all_ top right bottom left s =+ case s of+ (All n) -> all_ n+ (Y n) -> top n . bottom n+ (X n) -> left n . right n+ (XY x y) -> top y . bottom y . left x . right x+ (TRBL t r b l) ->+ top t . right r . bottom b . left l+ (T x) -> top x+ (R x) -> right x+ (B x) -> bottom x+ (L x) -> left x+ (TR t r) -> top t . right r+ (TL t l) -> top t . left l+ (BR b r) -> bottom b . right r+ (BL b l) -> bottom b . left l
+ src/Web/Atomic/CSS/Layout.hs view
@@ -0,0 +1,269 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DerivingStrategies #-}++{- |+Module: Web.Atomic.CSS.Layout+Copyright: (c) 2023 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++We can intuitively create layouts by combining of 'flexRow', 'flexCol', 'grow', and 'stack'+++@+holygrail = do+ el ~ flexCol . grow $ do+ el ~ flexRow $ "Top Bar"+ el ~ flexRow . grow $ do+ el ~ flexCol $ "Left Sidebar"+ el ~ flexCol . grow $ "Main Content"+ el ~ flexCol $ "Right Sidebar"+ el ~ flexRow $ "Bottom Bar"+@++Also see 'Web.Atomic.Html.Tag.col', 'Web.Atomic.Html.Tag.row', and 'Web.Atomic.Html.Tag.space'+-}+module Web.Atomic.CSS.Layout where++import Web.Atomic.CSS.Box (sides')+import Web.Atomic.Types+++{- | Lay out children in a column. See 'Web.Atomic.Html.Tag.col'++> el ~ flexCol $ do+> el "Top"+> el " - " ~ grow+> el "Bottom"+-}+++flexCol :: (Styleable h) => CSS h -> CSS h+flexCol =+ utility+ "col"+ [ "display" :. "flex"+ , "flex-direction" :. style Column+ ]++{- | Lay out children in a row. See 'Web.Atomic.Html.Tag.row'++> el ~ flexRow $ do+> el "Left"+> el " - " ~ grow+> el "Right"+-}+flexRow :: (Styleable h) => CSS h -> CSS h+flexRow =+ utility+ "row"+ [ "display" :. "flex"+ , "flex-direction" :. style Row+ ]+++++-- | Grow to fill the available space in the parent 'flexRow' or 'flexCol'+grow :: (Styleable h) => CSS h -> CSS h+grow = utility "grow" ["flex-grow" :. "1"]+++-- space :: (IsHtml h, AppliedParent h ~ h, Styleable h) => h+-- space = el ~ grow $ none++{- | Stack children on top of each other as layers. Each layer has the full width. See 'popup'++> el ~ stack $ do+> el "Background"+> el ~ bg Black . opacity 0.5 $ "Overlay"+-}+stack :: (Styleable h) => CSS h -> CSS h+stack =+ container . absChildren+ where+ container =+ utility+ "stack"+ [ "position" :. "relative"+ , "display" :. "grid"+ , "overflow" :. "visible"+ ]++ absChildren =+ css+ "stack-child"+ ".stack-child > *"+ [ "grid-area" :. "1 / 1"+ , "min-height" :. "fit-content"+ ]+++{- | Place an element above others, out of the flow of the page++> el ~ stack $ do+> input @ value "Autocomplete Box"+> el ~ popup (TL 10 10) $ do+> el "Item 1"+> el "Item 2"+> el "Item 3"+> el "This would be covered by the menu"+-}+popup :: (Styleable h) => Sides Length -> CSS h -> CSS h+popup sides =+ position Absolute . inset sides+++-- | Set 'top', 'bottom', 'right', and 'left' all at once+inset :: (Styleable h) => Sides Length -> CSS h -> CSS h+inset = sides' (\n -> top n . right n . bottom n . left n) top right bottom left+++top :: (Styleable h) => Length -> CSS h -> CSS h+top l = utility ("top" -. l) ["top" :. style l]+++bottom :: (Styleable h) => Length -> CSS h -> CSS h+bottom l = utility ("bottom" -. l) ["bottom" :. style l]+++right :: (Styleable h) => Length -> CSS h -> CSS h+right l = utility ("right" -. l) ["right" :. style l]+++left :: (Styleable h) => Length -> CSS h -> CSS h+left l = utility ("left" -. l) ["left" :. style l]+++data FlexDirection+ = Row+ | Column+ deriving (Show, ToStyle)+instance ToClassName FlexDirection where+ toClassName Row = "row"+ toClassName Column = "col"+++flexDirection :: (Styleable h) => FlexDirection -> CSS h -> CSS h+flexDirection dir = utility (toClassName dir) ["flex-direction" :. style dir]+++data FlexWrap+ = WrapReverse+ deriving (Show, ToStyle)+instance PropertyStyle FlexWrap FlexWrap+instance PropertyStyle FlexWrap Wrap+instance ToClassName FlexWrap where+ toClassName WrapReverse = "rev"+++{- | Set the flex-wrap++@+el ~ flexWrap 'WrapReverse' $ do+ el "one"+ el "two"+ el "three"+el ~ flexWrap 'Wrap' $ do+ el "one"+ el "two"+ el "three"+@+-}+flexWrap :: (PropertyStyle FlexWrap w, ToClassName w, Styleable h) => w -> CSS h -> CSS h+flexWrap w =+ utility ("fwrap" -. w) ["flex-wrap" :. propertyStyle @FlexWrap w]+++{- | position:absolute, relative, etc. See 'stack' and 'popup' for a higher-level interface++@+tag "nav" ~ position Fixed . height 100 $ "Navigation bar"+tag "div" ~ flexCol . margin (T 100) $ "Main Content"+@+-}+position :: (Styleable h) => Position -> CSS h -> CSS h+position p = utility ("pos" -. p) ["position" :. style p]+++data Position+ = Absolute+ | Fixed+ | Sticky+ | Relative+ deriving (Show, ToClassName, ToStyle)+++zIndex :: (Styleable h) => Int -> CSS h -> CSS h+zIndex n = utility ("z" -. n) ["z-index" :. style n]+++{- | Set container display++@+el ~ (display 'None') $ "none"+el ~ (display 'Block') $ "block"+@+-}+display :: (PropertyStyle Display d, ToClassName d, Styleable h) => d -> CSS h -> CSS h+display disp =+ utility ("disp" -. disp) ["display" :. propertyStyle @Display disp]+++data Display+ = Block+ | Flex+ deriving (Show, ToClassName, ToStyle)+instance PropertyStyle Display Display+instance PropertyStyle Display None+++data Visibility+ = Visible+ | Hidden+ deriving (Show, ToClassName, ToStyle)+++visibility :: Styleable h => Visibility -> CSS h -> CSS h+visibility v = utility ("vis" -. v) ["visibility" :. style v]++{- | Set to specific width++> el ~ width 100 $ "100px"+> el ~ width (PxRem 100) $ "100px"+> el ~ width (Pct 50) $ "50pct"+-}+width :: (Styleable h) => Length -> CSS h -> CSS h+width n = utility ("w" -. n) [ "width" :. style n ]+++height :: (Styleable h) => Length -> CSS h -> CSS h+height n = utility ("h" -. n) [ "height" :. style n ]+++-- | Allow width to grow to contents but not shrink any smaller than value+minWidth :: (Styleable h) => Length -> CSS h -> CSS h+minWidth n =+ utility ("mw" -. n) ["min-width" :. style n]+++-- | Allow height to grow to contents but not shrink any smaller than value+minHeight :: (Styleable h) => Length -> CSS h -> CSS h+minHeight n =+ utility ("mh" -. n) ["min-height" :. style n]+++data Overflow+ = Scroll+ | Clip+ deriving (Show, ToStyle, ToClassName)+instance PropertyStyle Overflow Overflow+instance PropertyStyle Overflow Auto+instance PropertyStyle Overflow Visibility+++-- | Control how an element clips content that exceeds its bounds +overflow :: (PropertyStyle Overflow o, ToClassName o, Styleable h) => o -> CSS h -> CSS h+overflow o = utility ("over" -. o) ["overflow" :. propertyStyle @Overflow o]
+ src/Web/Atomic/CSS/Reset.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}++module Web.Atomic.CSS.Reset where++import Data.ByteString+import Data.FileEmbed+++{- | Default CSS to remove unintuitive default styles. This is required for utilities to work as expected++> import Data.String.Interpolate (i)+>+> toDocument :: ByteString -> ByteString+> toDocument cnt =+> [i|<html>+> <head>+> <style type="text/css">#{cssResetEmbed}</style>+> </head>+> <body>#{cnt}</body>+> </html>|]+-}+cssResetEmbed :: ByteString+cssResetEmbed = $(embedFile "embed/reset.css")
+ src/Web/Atomic/CSS/Select.hs view
@@ -0,0 +1,66 @@+module Web.Atomic.CSS.Select where++import Web.Atomic.Types+++{- | Apply when hovering over an element++> el ~ bg Primary . hover (bg PrimaryLight) $ "Hover"+-}+hover :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h+hover = pseudo "hover"+++-- | Apply when the mouse is pressed down on an element+active :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h+active = pseudo "active"+++-- | Apply to even-numbered children+even :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h+even = pseudo $ Pseudo "even" ":nth-child(even)"+++-- | Apply to odd-numbered children+odd :: (Styleable h) => (CSS h -> CSS h) -> CSS h -> CSS h+odd = pseudo $ Pseudo "odd" ":nth-child(odd)"+++pseudo :: forall h. (Styleable h) => Pseudo -> (CSS h -> CSS h) -> CSS h -> CSS h+pseudo p f ss =+ mapRules (addPseudo p) (f mempty) <> ss+++{- | Apply when the Media matches the current window. This allows for responsive designs++> el ~ width 100 . media (MinWidth 800) (width 400) $ do+> "Big if window > 800"+-}+media :: (Styleable h) => Media -> (CSS h -> CSS h) -> CSS h -> CSS h+media m f ss =+ mapRules (addMedia m) (f mempty) <> ss+++addPseudo :: Pseudo -> Rule -> Rule+addPseudo p r = r{selector = r.selector <> GeneratedRule (addClassState p) (<> p.suffix)}+++addMedia :: Media -> Rule -> Rule+addMedia m r =+ r+ { media = m : r.media+ , selector = r.selector <> GeneratedRule (addClassState m) id+ }+++{- | Apply when this element is contained somewhere another element with the given class++> el ~ descendentOf "htmx-request" bold $ "Only bold when htmx is making a request"+-}+descendentOf :: (Styleable h) => ClassName -> (CSS h -> CSS h) -> CSS h -> CSS h+descendentOf c f ss =+ mapRules (addAncestor c) (f mempty) <> ss+++addAncestor :: ClassName -> Rule -> Rule+addAncestor cn r = r{selector = r.selector <> GeneratedRule (addClassState cn) (\s -> selector cn <> " " <> s)}
+ src/Web/Atomic/CSS/Text.hs view
@@ -0,0 +1,55 @@+module Web.Atomic.CSS.Text where++import Data.Char (toLower)+import Web.Atomic.Types+++bold :: (Styleable h) => CSS h -> CSS h+bold = utility "bold" ["font-weight" :. "bold"]+++fontSize :: (Styleable h) => Length -> CSS h -> CSS h+fontSize n = utility ("fs" -. n) ["font-size" :. style n]+++color :: (Styleable h) => (ToColor clr) => clr -> CSS h -> CSS h+color c = utility ("clr" -. colorName c) ["color" :. style (colorValue c)]+++italic :: (Styleable h) => CSS h -> CSS h+italic = utility "italic" ["font-style" :. "italic"]+++underline :: (Styleable h) => CSS h -> CSS h+underline = utility "underline" ["text-decoration" :. "underline"]+++data Align+ = AlignCenter+ | AlignLeft+ | AlignRight+ | AlignJustify+ deriving (Show, ToClassName)+instance ToStyle Align where+ style a = Style . fmap toLower $ drop 5 $ show a+++textAlign :: (Styleable h) => Align -> CSS h -> CSS h+textAlign a =+ utility ("ta" -. a) ["text-align" :. style a]+++data WhiteSpace+ = Pre+ | PreWrap+ | PreLine+ | BreakSpaces+ deriving (Show, ToClassName, ToStyle)+instance PropertyStyle WhiteSpace Wrap+instance PropertyStyle WhiteSpace Normal+instance PropertyStyle WhiteSpace WhiteSpace+++whiteSpace :: (PropertyStyle WhiteSpace w, ToClassName w, Styleable h) => w -> CSS h -> CSS h+whiteSpace w =+ utility ("wspace" -. w) ["white-space" :. propertyStyle @WhiteSpace w]
+ src/Web/Atomic/CSS/Transition.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE LambdaCase #-}++module Web.Atomic.CSS.Transition where++import Data.Text (Text)+import Web.Atomic.Types+++{- | Animate changes to the given property++> el ~ transition 100 (Height 400) $ "Tall"+> el ~ transition 100 (Height 100) $ "Small"+-}+transition :: (Styleable h) => Ms -> TransitionProperty -> CSS h -> CSS h+transition ms = \case+ (Height n) -> trans "height" n+ (Width n) -> trans "width" n+ (BgColor c) -> trans "background-color" c+ (Color c) -> trans "color" c+ where+ trans :: (ToClassName val, ToStyle val, Styleable h) => Text -> val -> CSS h -> CSS h+ trans p val =+ utility+ ("t" -. val -. p -. ms)+ [ "transition-duration" :. style ms+ , "transition-property" :. style p+ , Property p :. style val+ ]+++-- You MUST set the height/width manually when you attempt to transition it+data TransitionProperty+ = Width PxRem+ | Height PxRem+ | BgColor HexColor+ | Color HexColor+ deriving (Show)
+ src/Web/Atomic/Html.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}++module Web.Atomic.Html where++import Data.List qualified as L+import Data.Map.Strict (Map)+import Data.String (IsString (..))+import Data.Text (Text, pack)+import GHC.Exts (IsList (..))+import Web.Atomic.Types+++{- | Html monad++@+import Web.Atomic++example = do+ 'el' ~ pad 10 $ do+ 'el' ~ fontSize 24 . bold $ "My Links"+ a '@' href "hoogle.haskell.org" ~ link $ \"Hoogle\"+ a '@' href "hackage.haskell.org" ~ link $ \"Hackage\"++link = underline . color Primary+a = 'tag' "a"+href = 'att' "href"+@+-}+data Html a = Html {value :: a, nodes :: [Node]}+++instance IsList (Html ()) where+ type Item (Html ()) = Node+ fromList = Html () . fromList+ toList (Html _ ns) = ns+++instance IsString (Html ()) where+ fromString s = Html () [fromString s]+++instance Functor Html where+ fmap f (Html a ns) = Html (f a) ns+++instance Applicative Html where+ pure a = Html a []+ (<*>) :: Html (a -> b) -> Html a -> Html b+ Html f nfs <*> Html a nas =+ Html (f a) (nfs <> nas)+++-- ha *> hb = ha <> hb+instance Monad Html where+ (>>=) :: forall a b. Html a -> (a -> Html b) -> Html b+ Html a nas >>= famb =+ let Html b nbs = famb a :: Html b+ in Html b (nas <> nbs)+++el :: Html () -> Html ()+el = tag "div"+++tag :: Text -> Html () -> Html ()+tag nm (Html _ content) = do+ Html () [Elem $ (element nm){content}]+++text :: Text -> Html ()+text t = Html () [Text t]+++none :: Html ()+none = pure ()+++raw :: Text -> Html ()+raw t = Html () [Raw t]+++-- | A single 'Html' element. Note that the class attribute is generated separately from the css rules, rather than the attributes+data Element = Element+ { inline :: Bool+ , name :: Text+ , css :: [Rule]+ , attributes :: Map Name AttValue+ , content :: [Node]+ }+++data Node+ = Elem Element+ | Text Text+ | Raw Text+++instance IsString Node where+ fromString s = Text (pack s)+++mapElement :: (Element -> Element) -> Html a -> Html a+mapElement f (Html a ns) = Html a $ fmap (mapNodeElement f) ns+++mapNodeElement :: (Element -> Element) -> Node -> Node+mapNodeElement f (Elem e) = Elem $ f e+mapNodeElement _ n = n+++element :: Text -> Element+element nm = Element False nm mempty mempty mempty+++instance Attributable (Html a) where+ modAttributes f =+ mapElement (\elm -> elm{attributes = f elm.attributes})+++instance Styleable (Html a) where+ modCSS f =+ mapElement (\elm -> elm{css = f elm.css})+++htmlCSSRules :: Html a -> Map Selector Rule+htmlCSSRules (Html _ ns) = mconcat $ fmap nodeCSSRules ns+++nodeCSSRules :: Node -> Map Selector Rule+nodeCSSRules = \case+ Elem elm -> elementCSSRules elm+ _ -> []+++elementCSSRules :: Element -> Map Selector Rule+elementCSSRules elm =+ ruleMap elm.css <> mconcat (fmap nodeCSSRules elm.content)+++elementClasses :: Element -> [ClassName]+elementClasses elm =+ L.sort $ fmap ruleClassName elm.css
+ src/Web/Atomic/Html/Tag.hs view
@@ -0,0 +1,59 @@+{- |+Module: Web.Atomic.Html.Tag+Copyright: (c) 2023 Sean Hess+License: BSD3+Maintainer: Sean Hess <seanhess@gmail.com>+Stability: experimental+Portability: portable++We can intuitively create layouts by combining of 'row', 'col', 'space', and 'stack'++@+holygrail = do+ col ~ grow $ do+ row do+ el "Top Bar"+ space+ el "Login Button"+ row ~ grow $ do+ col "Left Sidebar"+ col ~ grow $ do+ el "Main Content"+ col "Right Sidebar"+ row "Bottom Bar"+@+-}+module Web.Atomic.Html.Tag where++import Web.Atomic.CSS+import Web.Atomic.Html+++{- |++@+col = 'el' ~ 'flexCol'+@+-}+col :: Html () -> Html ()+col = el ~ flexCol+++{- |++@+col = 'el' ~ 'flexRow'+@+-}+row :: Html () -> Html ()+row = el ~ flexRow+++{- |++@+col = 'el' ~ 'grow'+@+-}+space :: Html ()+space = el ~ grow $ none
+ src/Web/Atomic/Render.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedLists #-}++module Web.Atomic.Render where++import Data.ByteString.Lazy qualified as BL+import Data.List qualified as L+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Maybe (mapMaybe)+import Data.String (IsString (..))+import Data.Text (Text, intercalate, pack)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TLE+import HTMLEntities.Text qualified as HE+import Web.Atomic.Html+import Web.Atomic.Types+++renderLazyText :: Html () -> TL.Text+renderLazyText = TL.fromStrict . renderText+++renderLazyByteString :: Html () -> BL.ByteString+renderLazyByteString = TLE.encodeUtf8 . renderLazyText+++renderText :: Html () -> Text+renderText html =+ let cs = cssRulesLines $ htmlCSSRules html+ in renderLines $ addCss cs $ htmlLines 2 html+ where+ addCss :: [Line] -> [Line] -> [Line]+ addCss [] cnt = cnt+ addCss cs cnt = do+ styleLines cs <> (Line Newline 0 "" : cnt)+++htmlLines :: Int -> Html a -> [Line]+htmlLines ind (Html _ ns) = nodesLines ind ns+++nodesLines :: Int -> [Node] -> [Line]+nodesLines ind ns = mconcat $ fmap (nodeLines ind) ns+++nodeLines :: Int -> Node -> [Line]+nodeLines ind (Elem e) = elementLines ind e+nodeLines _ (Text t) = [Line Inline 0 $ HE.text t]+nodeLines _ (Raw t) = [Line Newline 0 t]+++elementLines :: Int -> Element -> [Line]+elementLines ind elm =+ -- special rendering cases for the children+ case (elm.content :: [Node]) of+ [] ->+ -- auto closing creates a bug in chrome. An auto-closed div+ -- absorbs the next children+ [line $ open <> renderAttributes (elementAttributes elm) <> ">" <> close]+ [Text t] ->+ -- SINGLE text node, just display it indented+ [line $ open <> renderAttributes (elementAttributes elm) <> ">" <> HE.text t <> close]+ children ->+ -- normal indented rendering+ mconcat+ [ [line $ open <> renderAttributes (elementAttributes elm) <> ">"]+ , fmap (addIndent ind) $ nodesLines ind children+ , [line close]+ ]+ where+ open = "<" <> elm.name+ close = "</" <> elm.name <> ">"++ line t =+ if elm.inline+ then Line Inline 0 t+ else Line Newline 0 t+++-- Attributes ---------------------------------------------------++-- | Element's attributes do not include class, which is separated. FlatAttributes generate the class attribute and include it+newtype FlatAttributes = FlatAttributes (Map Name AttValue)+ deriving newtype (Eq)+++-- | The 'FlatAttributes' for an element, inclusive of class.+elementAttributes :: Element -> FlatAttributes+elementAttributes e =+ FlatAttributes $+ addClasses+ (styleClass e)+ e.attributes+ where+ addClasses :: AttValue -> Map Name AttValue -> Map Name AttValue+ addClasses "" as = as+ addClasses av as = M.insertWith (\a b -> a <> " " <> b) "class" av as++ styleClass :: Element -> AttValue+ styleClass elm =+ classesAttValue (elementClasses elm)+++renderAttributes :: FlatAttributes -> Text+renderAttributes (FlatAttributes m) =+ case m of+ [] -> ""+ as -> " " <> T.unwords (map htmlAtt $ M.toList as)+ where+ htmlAtt (k, v) =+ k <> "=" <> "'" <> HE.text v <> "'"+++-- REnder CSS --------------------------------------------++cssRulesLines :: Map Selector Rule -> [Line]+cssRulesLines = mapMaybe cssRuleLine . M.elems+++cssRuleLine :: Rule -> Maybe Line+cssRuleLine r | null r.properties = Nothing+cssRuleLine r =+ let sel = (ruleSelector r).text+ props = intercalate "; " (map renderProp r.properties)+ med = mconcat $ fmap mediaCriteria r.media+ in Just $ Line Newline 0 $ wrapMedia med $ sel <> " { " <> props <> " }"+ where+ renderProp :: Declaration -> Text+ renderProp ((Property p) :. cv) = p <> ":" <> renderStyle cv++ renderStyle :: Style -> Text+ renderStyle (Style v) = pack v+++wrapMedia :: MediaQuery -> Text -> Text+wrapMedia [] cnt = cnt+wrapMedia mqs cnt =+ "@media " <> mediaConditionsText mqs <> " { " <> cnt <> " }"+ where+ mediaConditionsText :: MediaQuery -> Text+ mediaConditionsText (MediaQuery cons) =+ T.intercalate " and " $ fmap (\c -> "(" <> c <> ")") cons+++styleLines :: [Line] -> [Line]+styleLines [] = []+styleLines rulesLines =+ [Line Newline 0 "<style type='text/css'>"]+ <> rulesLines+ <> [Line Newline 0 "</style>"]+++-- Lines ---------------------------------------+-- control inline vs newlines and indent++data Line = Line {end :: LineEnd, indent :: Int, text :: Text}+ deriving (Show, Eq)+++instance IsString Line where+ fromString s = Line Newline 0 (pack s)+++data LineEnd+ = Newline+ | Inline+ deriving (Eq, Show)+++addIndent :: Int -> Line -> Line+addIndent n (Line e ind t) = Line e (ind + n) t+++-- | Render lines to text+renderLines :: [Line] -> Text+renderLines = snd . L.foldl' nextLine (False, "")+ where+ nextLine :: (Bool, Text) -> Line -> (Bool, Text)+ nextLine (newline, t) l = (nextNewline l, t <> currentLine newline l)++ currentLine :: Bool -> Line -> Text+ currentLine newline l+ | newline = "\n" <> spaces l.indent <> l.text+ | otherwise = l.text++ nextNewline l = l.end == Newline++ spaces n = T.replicate n " "
+ src/Web/Atomic/Types.hs view
@@ -0,0 +1,17 @@+module Web.Atomic.Types+ ( module Web.Atomic.Types.ClassName+ , module Web.Atomic.Types.Style+ , module Web.Atomic.Types.Rule+ , module Web.Atomic.Types.Selector+ , module Web.Atomic.Types.Styleable+ , module Web.Atomic.Types.Attributable+ ) where++import Web.Atomic.Types.Attributable+import Web.Atomic.Types.ClassName+import Web.Atomic.Types.Rule+import Web.Atomic.Types.Selector+import Web.Atomic.Types.Style+import Web.Atomic.Types.Styleable++
+ src/Web/Atomic/Types/Attributable.hs view
@@ -0,0 +1,58 @@+module Web.Atomic.Types.Attributable where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Text (Text)+++type Name = Text+type AttValue = Text+++newtype Attributes h = Attributes (Map Name AttValue)+ deriving newtype (Monoid, Semigroup)+++-- | Add Atts+class Attributable h where+ -- | Apply an attribute to some html+ --+ -- > el @ att "id" "main-content" $ do+ -- > tag "img" @ att "src" "logo.png"+ -- > tag "input" @ placeholder "message" ~ border 1+ (@) :: h -> (Attributes h -> Attributes h) -> h+ h @ f =+ flip modAttributes h $ \m ->+ let Attributes atts = f $ Attributes m+ in atts+++ modAttributes :: (Map Name AttValue -> Map Name AttValue) -> h -> h+++infixl 5 @+++instance {-# OVERLAPPABLE #-} (Attributable a, Attributable b) => Attributable (a -> b) where+ (@) :: (a -> b) -> (Attributes (a -> b) -> Attributes (a -> b)) -> (a -> b)+ hh @ f = \content ->+ hh content @ \(Attributes m) ->+ let Attributes m2 = f $ Attributes m+ in Attributes m2+++ modAttributes f hh content =+ modAttributes f $ hh content+++instance Attributable (Map Name AttValue) where+ modAttributes f = f+++instance Attributable (Attributes h) where+ modAttributes f (Attributes m) = Attributes $ f m+++att :: (Attributable h) => Name -> AttValue -> Attributes h -> Attributes h+att n av (Attributes m) =+ Attributes $ M.insert n av m
+ src/Web/Atomic/Types/ClassName.hs view
@@ -0,0 +1,72 @@+module Web.Atomic.Types.ClassName where++import Data.String (IsString (..))+import Data.Text (Text, pack)+import Data.Text qualified as T+++-- | A class name+newtype ClassName = ClassName+ { text :: Text+ }+ deriving newtype (Eq, Ord, Show, Monoid, Semigroup)+++instance IsString ClassName where+ fromString = className . pack+++-- | Create a class name, escaping special characters+className :: Text -> ClassName+className = ClassName . T.toLower . T.map noDot+ where+ noDot '.' = '-'+ noDot c = c+++-- | Convert a type into a className segment to generate unique compound style names based on the value+class ToClassName a where+ toClassName :: a -> ClassName+ default toClassName :: (Show a) => a -> ClassName+ toClassName = className . pack . show+++instance ToClassName Int+instance ToClassName Text where+ toClassName = className+instance ToClassName Float where+ toClassName f = ClassName $ "p" <> pack (show $ round @Float @Int (f * 100))+instance ToClassName ClassName where+ toClassName = id+instance ToClassName [ClassName] where+ toClassName cs = ClassName $ T.intercalate "-" $ fmap (.text) cs+instance ToClassName () where+ toClassName _ = ""+++-- | Hyphenate classnames+(-.) :: (ToClassName a) => ClassName -> a -> ClassName+cn -. a = joinClassSegments "-" cn (toClassName a)+++infixl 7 -.+++joinClassSegments :: Text -> ClassName -> ClassName -> ClassName+joinClassSegments _ "" cn = cn+joinClassSegments _ cn "" = cn+joinClassSegments sep (ClassName cn1) (ClassName cn2) =+ ClassName $ cn1 <> sep <> cn2+++-- modifiers to a class are prepended with ":", like hover\:my-class:hover+addClassState :: (ToClassName a) => a -> ClassName -> ClassName+addClassState a = joinClassSegments ":" (toClassName a)+++-- appendClassSegments :: (ToClassName a) => [a] -> ClassName -> ClassName+-- appendClassSegments as cn = foldl (flip appendClassSegment) cn as++classesAttValue :: [ClassName] -> Text+classesAttValue clss =+ T.unwords $ fmap (.text) clss
+ src/Web/Atomic/Types/Rule.hs view
@@ -0,0 +1,140 @@+module Web.Atomic.Types.Rule where++import Data.List qualified as L+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Maybe (isNothing)+import Data.String (IsString (..))+import Web.Atomic.Types.ClassName+import Web.Atomic.Types.Selector+import Web.Atomic.Types.Style+++-- Rule: CSS Utility Classes ------------------------------------------------++data Rule = Rule+ { className :: ClassName+ , selector :: RuleSelector+ , media :: [Media]+ , properties :: [Declaration]+ }+instance Eq Rule where+ r1 == r2 = ruleSelector r1 == ruleSelector r2+instance Ord Rule where+ r1 <= r2 = ruleSelector r1 <= ruleSelector r2+instance IsString Rule where+ fromString s = fromClass (fromString s)+++data RuleSelector+ = CustomRule Selector+ | GeneratedRule (ClassName -> ClassName) (Selector -> Selector)+instance Semigroup RuleSelector where+ CustomRule s1 <> CustomRule s2 = CustomRule $ s1 <> s2+ GeneratedRule c1 s1 <> GeneratedRule c2 s2 = GeneratedRule (c2 . c1) (s2 . s1)+ -- ignore FromClass if CustomRule is set!+ CustomRule c <> _ = CustomRule c+ _ <> CustomRule c = CustomRule c+instance Monoid RuleSelector where+ mempty = GeneratedRule id id+++-- | An empty rule that only adds the classname+fromClass :: ClassName -> Rule+fromClass cn = Rule cn mempty mempty mempty+++rule :: ClassName -> [Declaration] -> Rule+rule cn = Rule cn mempty mempty+++ruleMap :: [Rule] -> Map Selector Rule+ruleMap = L.foldl' (\m r -> M.insert (ruleSelector r) r m) M.empty+++{- | Add a property to a class+addProp :: (ToStyleValue val) => Property -> val -> Rule -> Rule+addProp p v c =+ c{properties = Declaration p (toStyleValue v) : c.properties}+-}++-- mapSelector :: (Selector -> Selector) -> Rule -> Rule+-- mapSelector f c =+-- c+-- { selector = f c.selector+-- }++mapClassName :: (ClassName -> ClassName) -> Rule -> Rule+mapClassName f c =+ c+ { className = f c.className+ }+++uniqueRules :: [Rule] -> [Rule]+uniqueRules [] = []+uniqueRules (r : rs) =+ r : replaceRules r (uniqueRules rs)+++replaceRules :: Rule -> [Rule] -> [Rule]+replaceRules rnew rs =+ -- OVERRIDE RULES+ -- 1. if ANY property is set again, delete entire previous rule+ -- 2. if "manual" mode is set, pass it through!+ -- 3. if pseudo, media, etc, changes when these rules apply+ let ps = ruleProperties rnew+ in filter (not . matchesRule ps) rs+ where+ matchesRule ps r =+ (hasAnyProperty ps r || rnew.className == r.className)+ && ruleClassNameF rnew.selector "" == ruleClassNameF r.selector ""+ && isNothing (ruleCustomSelector rnew)+ && isNothing (ruleCustomSelector r)+++hasAnyProperty :: [Property] -> Rule -> Bool+hasAnyProperty ps r = any hasProperty ps+ where+ hasProperty :: Property -> Bool+ hasProperty p = p `elem` ruleProperties r+++ruleProperties :: Rule -> [Property]+ruleProperties r =+ fmap (\(p :. _) -> p) r.properties+++lookupRule :: ClassName -> [Rule] -> Maybe Rule+lookupRule c = L.find (\r -> r.className == c)+++ruleClassName :: Rule -> ClassName+ruleClassName r =+ ruleClassNameF r.selector r.className+++ruleClassNameF :: RuleSelector -> ClassName -> ClassName+ruleClassNameF rs =+ case rs of+ CustomRule _ -> id+ GeneratedRule f _ -> f+++ruleSelector :: Rule -> Selector+ruleSelector r =+ ruleSelectorF r.selector $ selector $ ruleClassName r+++ruleSelectorF :: RuleSelector -> Selector -> Selector+ruleSelectorF rs =+ case rs of+ CustomRule s -> const s+ GeneratedRule _ f -> f+++ruleCustomSelector :: Rule -> Maybe Selector+ruleCustomSelector r =+ case r.selector of+ CustomRule s -> Just s+ _ -> Nothing
+ src/Web/Atomic/Types/Selector.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}++module Web.Atomic.Types.Selector where++import Data.String (IsString (..))+import Data.Text (Text, pack)+import Data.Text qualified as T+import GHC.Exts (IsList (..))+import Web.Atomic.Types.ClassName+++-- Selector ---------------------------------------------------------------------++newtype Selector = Selector {text :: Text}+ deriving (Eq, Ord, Show)+ deriving newtype (IsString, Semigroup, Monoid)+++selector :: ClassName -> Selector+selector (ClassName c) =+ Selector $ "." <> clean c+ where+ clean t = T.replace ":" "\\:" t+++-- Pseudo -------------------------------------------------------------------------++{- | Psuedos allow for specifying styles that only apply in certain conditions. See `Web.Atomic.Style.hover` etc++> el (color Primary . hover (color White)) "hello"+-}+data Pseudo = Pseudo {name :: ClassName, suffix :: Selector}+ deriving (Show, Eq, Ord)+++instance IsString Pseudo where+ fromString s =+ let c = fromString s+ in Pseudo c (":" <> Selector (pack s))+++instance ToClassName Pseudo where+ toClassName p = p.name+++-- pseudoText :: Pseudo -> Text+-- pseudoText p = T.toLower $ pack $ show p++-- Media ---------------------------------------------------------------------++newtype MediaQuery = MediaQuery {conditions :: [Text]}+ deriving (Eq, Show)+ deriving newtype (Monoid, Semigroup)+instance IsString MediaQuery where+ fromString s = MediaQuery [pack s]+instance IsList MediaQuery where+ type Item MediaQuery = Text+ fromList = MediaQuery+ toList = (.conditions)+++-- | Media allows for responsive designs that change based on characteristics of the window. See [Layout Example](https://github.com/seanhess/atomic-css/blob/master/example/Example/Layout.hs)+data Media+ = MinWidth Int+ | MaxWidth Int+ deriving (Eq, Ord, Show)+++instance ToClassName Media where+ toClassName = \case+ MinWidth mn ->+ className $ "mmnw" <> (pack $ show mn)+ MaxWidth mx ->+ className $ "mmxw" <> (pack $ show mx)+++mediaCriteria :: Media -> MediaQuery+mediaCriteria (MinWidth n) = MediaQuery ["min-width: " <> (pack $ show n) <> "px"]+mediaCriteria (MaxWidth n) = MediaQuery ["max-width: " <> (pack $ show n) <> "px"]
+ src/Web/Atomic/Types/Style.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Web.Atomic.Types.Style where++import Data.String (IsString (..))+import Data.Text (Text, pack, unpack)+import Data.Text qualified as T+import Numeric (showFFloat)+import Text.Casing (kebab)+import Web.Atomic.Types.ClassName (ToClassName (..), className)+++newtype Property = Property Text+ deriving newtype (Show, Eq, Ord, IsString, Semigroup)+++data Declaration = Property :. Style+ deriving (Show, Ord, Eq)+++newtype Style = Style String+ deriving newtype (IsString, Show, Eq, Monoid, Semigroup, Ord)+++{- | Convert a type to a css style value++@+data Float = Right | Left++instance ToStyle Float where+ style Right = "right"+ style Left = "left"+@+-}+class ToStyle a where+ style :: a -> Style+ default style :: (Show a) => a -> Style+ style = Style . kebab . show+++instance ToStyle String where+ style = Style+instance ToStyle Text where+ style = Style . unpack+instance ToStyle Int+instance ToStyle Float where+ -- this does not convert to a percent, just a ratio+ style n = Style $ showFFloat (Just 2) n ""+instance ToStyle Style where+ style = id+++{- | Reuse types that belong to more than one css property++@+data None = None+ deriving (Show, ToClassName, ToStyle)++data Display+ = Block+ | Flex+ deriving (Show, ToClassName, ToStyle)+instance PropertyStyle Display Display+instance PropertyStyle Display None++display :: (PropertyStyle Display d, ToClassName d, Styleable h) => d -> CSS h -> CSS h+display disp =+ utility ("disp" -. disp) ["display" :. propertyStyle @Display disp]+@+-}+class PropertyStyle property value where+ propertyStyle :: value -> Style+ default propertyStyle :: (ToStyle value) => value -> Style+ propertyStyle = style+++data None = None+ deriving (Show, ToClassName, ToStyle)+++data Normal = Normal+ deriving (Show, ToStyle)+instance ToClassName Normal where+ toClassName Normal = "norm"+++data Auto = Auto+ deriving (Show, ToStyle, ToClassName)+++-- -- | Convert a type to a prop name+-- class ToProp a where+-- toProp :: a -> Text+-- default toProp :: (Show a) => a -> Text+-- toProp = pack . kebab . show++data Length+ = PxRem PxRem+ | Pct Float+ deriving (Show)+++instance ToClassName Length where+ toClassName (PxRem p) = toClassName p+ toClassName (Pct p) = toClassName p+++-- | Px, converted to Rem. Allows for the user to change the document font size and have the app scale accordingly. But allows the programmer to code in pixels to match a design+newtype PxRem = PxRem' Int+ deriving newtype (Show, ToClassName, Num, Eq, Integral, Real, Ord, Enum)+++instance Num Length where+ PxRem p1 + PxRem p2 = PxRem $ p1 + p2+ -- 10 + 10% = 10 + 10% of 10 = 11+ PxRem p1 + Pct pct = PxRem $ round $ fromIntegral p1 * (1 + pct)+ Pct pct + PxRem p1 = PxRem p1 + Pct pct+ Pct p1 + Pct p2 = Pct $ p1 + p2+++ PxRem p1 * PxRem p2 = PxRem $ p1 + p2+ PxRem p1 * Pct pct = PxRem $ round $ fromIntegral p1 * pct+ Pct pct * PxRem p1 = PxRem p1 * Pct pct+ Pct p1 * Pct p2 = Pct $ p1 * p2+++ abs (PxRem a) = PxRem (abs a)+ abs (Pct a) = Pct (abs a)+ signum (PxRem a) = PxRem (signum a)+ signum (Pct a) = Pct (signum a)+ negate (PxRem a) = PxRem (negate a)+ negate (Pct a) = Pct (negate a)+ fromInteger n = PxRem (fromInteger n)+++instance ToStyle PxRem where+ style (PxRem' 0) = "0px"+ style (PxRem' 1) = "1px"+ style (PxRem' n) = Style $ showFFloat (Just 3) ((fromIntegral n :: Float) / 16.0) "" <> "rem"+++instance ToStyle Length where+ style (PxRem p) = style p+ style (Pct n) = Style $ showFFloat (Just 1) (n * 100) "" <> "%"+++-- | Milliseconds, used for transitions+newtype Ms = Ms Int+ deriving (Show)+ deriving newtype (Num, ToClassName)+++instance ToStyle Ms where+ style (Ms n) = Style $ show n <> "ms"+++data Wrap+ = Wrap+ | NoWrap+ deriving (Show, ToClassName)+instance ToStyle Wrap where+ style Wrap = "wrap"+ style NoWrap = "nowrap"+++{- | Options for styles that support specifying various sides++> border 5+> border (X 2)+> border (TRBL 0 5 0 0)+-}+data Sides a+ = All a+ | TRBL a a a a+ | X a+ | Y a+ | XY a a+ | T a+ | R a+ | B a+ | L a+ | TR a a+ | TL a a+ | BR a a+ | BL a a+++-- Num instance is just to support literals+instance (Num a) => Num (Sides a) where+ a + _ = a+ a * _ = a+ abs a = a+ negate a = a+ signum a = a+ fromInteger n = All (fromInteger n)+++-- ** Colors+++{- | ToColor allows you to create a type containing your application's colors:++> data AppColor+> = White+> | Primary+> | Dark+> deriving (Show)+>+> instance ToColor AppColor where+> colorValue White = "#FFF"+> colorValue Dark = "#333"+> colorValue Primary = "#00F"+>+> hello = el ~ bg Primary . color White $ "Hello"+-}+class ToColor a where+ colorValue :: a -> HexColor+ colorName :: a -> Text+ default colorName :: (Show a) => a -> Text+ colorName = T.toLower . pack . show+++-- | Hexidecimal Color. Can be specified with or without the leading '#'. Recommended to use an AppColor type instead of manually using hex colors. See 'ToColor'+newtype HexColor = HexColor Text+ deriving (Show)+++instance ToColor HexColor where+ colorValue c = c+ colorName (HexColor a) = T.dropWhile (== '#') a+++instance ToStyle HexColor where+ style (HexColor s) = Style $ "#" <> unpack (T.dropWhile (== '#') s)+++instance IsString HexColor where+ fromString = HexColor . T.dropWhile (== '#') . T.pack+++instance ToClassName HexColor where+ toClassName = className . colorName
+ src/Web/Atomic/Types/Styleable.hs view
@@ -0,0 +1,115 @@+module Web.Atomic.Types.Styleable where++import Web.Atomic.Types.ClassName+import Web.Atomic.Types.Rule as Rule+import Web.Atomic.Types.Selector+import Web.Atomic.Types.Style+++class Styleable h where+ -- | Apply a CSS utility to some html+ --+ -- > el ~ bold . border 1 $ "styled"+ -- > el "styled" ~ bold . border 1+ -- > el "not styled"+ (~) :: h -> (CSS h -> CSS h) -> h+ h ~ f =+ flip modCSS h $ \rs ->+ let CSS new = f $ CSS rs+ in uniqueRules new+++ modCSS :: ([Rule] -> [Rule]) -> h -> h+++infixl 5 ~+++instance {-# OVERLAPPABLE #-} (Styleable a, Styleable b) => Styleable (a -> b) where+ (~) :: (a -> b) -> (CSS (a -> b) -> CSS (a -> b)) -> (a -> b)+ hh ~ f = \content ->+ hh content ~ \(CSS m) ->+ let CSS m2 = f $ CSS m+ in CSS m2+++ modCSS r hh content =+ modCSS r $ hh content+++instance Styleable [Rule] where+ modCSS f = f+++instance Styleable (CSS h) where+ modCSS f (CSS rs) = CSS $ f rs+++newtype CSS h = CSS {rules :: [Rule]}+ deriving newtype (Monoid, Semigroup)+++mapRules :: (Rule -> Rule) -> CSS a -> CSS a+mapRules f (CSS rs) = CSS $ fmap f rs+++{- | Create an atomic CSS utility. These are classes that set a single property, allowing you to compose styles like functions++@+bold :: 'Styleable' h => 'CSS' h -> 'CSS' h+bold = utility "bold" ["font-weight" :. "bold"]++pad :: 'Styleable' h => 'PxRem' -> 'CSS' h -> 'CSS' h+pad px = utility ("pad" -. px) ["padding" :. 'style' px]++example = el ~ bold . pad 10 $ "Padded and bold"+@+-}+utility :: (Styleable h) => ClassName -> [Declaration] -> CSS h -> CSS h+utility cn ds (CSS rs) =+ CSS $ rule cn ds : rs+++{- | Apply a class name with no styles. Useful for external CSS++> el ~ cls "parent" $ do+> el ~ cls "item" $ "one"+> el ~ cls "item" $ "two"+-}+cls :: (Styleable h) => ClassName -> CSS h -> CSS h+cls cn (CSS rs) =+ CSS $ Rule.fromClass cn : rs+++{- | Embed CSS with a custom selector and apply it to an element. Modifiers like 'hover' will ignore this++> listItems =+> css+> "list"+> ".list > .item"+> [ "display" :. "list-item"+> , "list-style" :. "square"+> ]+>+> example = do+> el ~ listItems $ do+> el ~ cls "item" $ "one"+> el ~ cls "item" $ "two"+> el ~ cls "item" $ "three"+-}+css :: (Styleable h) => ClassName -> Selector -> [Declaration] -> CSS h -> CSS h+css cn sel ds (CSS rs) =+ CSS $ Rule cn (CustomRule sel) mempty ds : rs+++-- | Get all the rules for combined utilities+rules :: (CSS [Rule] -> CSS [Rule]) -> [Rule]+rules f =+ let CSS rs = f mempty+ in rs+++-- | Get all the declarations for a utility or combination of them+declarations :: (CSS [Rule] -> CSS [Rule]) -> [Declaration]+declarations f =+ mconcat $ fmap (.properties) (rules f)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+import Skeletest.Main+
+ test/Test/AttributeSpec.hs view
@@ -0,0 +1,57 @@+module Test.AttributeSpec where++import Data.Map.Strict qualified as M+import Skeletest+import Web.Atomic.Attributes+import Web.Atomic.CSS+import Web.Atomic.Html+import Web.Atomic.Types+++spec :: Spec+spec = do+ describe "Attributable" $ do+ it "applies attributes" $ do+ let Attributes m = mempty @ att "key" "value" . att "one" "one"+ M.keys m `shouldBe` ["key", "one"]++ it "overrides in composition order" $ do+ let Attributes m = mempty @ att "key" "two" . att "key" "one"+ M.toList m `shouldBe` [("key", "two")]++ it "overrides in operator order" $ do+ let Attributes m = mempty @ att "key" "two" @ att "key" "one"+ M.toList m `shouldBe` [("key", "one")]++ it "operator precedence works both ways" $ do+ let _ = tag "div" @ att "one" "value" $ "contents"+ let _ = tag "div" ~ bold @ att "one" "value" $ "contents"+ pure ()++ -- IF statements must have parentheses :/+ it "operator precedence works with if statements" $ do+ let _ =+ tag "div"+ @ att "one" "value"+ . ( if True+ then att "two" "value"+ else id+ )+ $ text "contents"+ pure ()++ describe "class_" $ do+ it "replaces with att" $ do+ let Attributes m = mempty @ att "class" "one" . att "class" "two"+ M.elems m `shouldBe` ["one"]++ let Attributes m2 = mempty @ att "class" "one" @ att "class" "two"+ M.elems m2 `shouldBe` ["two"]++ it "merges when composed" $ do+ let Attributes m = mempty @ class_ "one" . class_ "two"+ M.elems m `shouldBe` ["one two"]++ it "merges when attributed" $ do+ let Attributes m2 = mempty @ class_ "one" @ class_ "two"+ M.elems m2 `shouldBe` ["two one"]
+ test/Test/RenderSpec.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.RenderSpec (spec) where++import Control.Monad (zipWithM_)+import Data.Text (Text, unpack)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Skeletest+import Web.Atomic.CSS+import Web.Atomic.CSS.Select+import Web.Atomic.Html+import Web.Atomic.Render+import Web.Atomic.Types+import Web.Atomic.Types.Rule as Rule+import Prelude hiding (span)+++spec :: Spec+spec = do+ describe "flatAttributes" flatSpec+ describe "lines" linesSpec+ describe "html" htmlSpec+ describe "css" $ do+ describe "media" mediaSpec+ describe "pseudo" pseudoSpec+ describe "rule" ruleSpec+ pure ()+++mediaSpec :: Spec+mediaSpec = do+ it "wraps media" $ do+ wrapMedia (MediaQuery ["awesome", "another"]) "hello" `shouldBe` "@media (awesome) and (another) { hello }"++ it "converts to conditions" $ do+ mediaCriteria (MinWidth 100) `shouldBe` "min-width: 100px"++ it "renders media query" $ do+ cssRuleLine (addMedia (MinWidth 100) $ rule "bold" ["font-weight" :. "bold"]) `shouldBe` Just "@media (min-width: 100px) { .mmnw100\\:bold { font-weight:bold } }"+++pseudoSpec :: Spec+pseudoSpec = do+ it "creates pseudo suffix" $ do+ let CSS rs = hover @(Html ()) bold $ CSS mempty+ fmap ruleSelector rs `shouldBe` [".hover\\:bold:hover"]+++-- pseudoSuffix Hover `shouldBe` ":hover"+-- pseudoSuffix Even `shouldBe` ":nth-child(even)"+-- let r1 = rule "hello" [Declaration "key" "value"]+-- cssRuleLine r1 `shouldBe` Just ".hello { key:value }"++ruleSpec :: Spec+ruleSpec = do+ it "renders rules" $ do+ let r1 = rule "hello" ["key" :. "value"]+ cssRuleLine r1 `shouldBe` Just ".hello { key:value }"++ let r2 = rule "has2" ["k1" :. "val", "k2" :. "val"]+ cssRuleLine r2 `shouldBe` Just ".has2 { k1:val; k2:val }"++ it "no render empty rules" $ do+ cssRuleLine (Rule.fromClass "hello") `shouldBe` Nothing++ it "renders media" $ do+ let r = addMedia (MinWidth 100) $ rule "hello" ["key" :. "value"]+ ruleClassName r `shouldBe` "mmnw100:hello"+ ruleSelector r `shouldBe` ".mmnw100\\:hello"+ cssRuleLine r `shouldBe` Just "@media (min-width: 100px) { .mmnw100\\:hello { key:value } }"++ it "renders pseudo" $ do+ let r = addPseudo "hover" $ rule "hello" ["key" :. "value"]+ cssRuleLine r `shouldBe` Just ".hover\\:hello:hover { key:value }"++ it "renders pseudo + media" $ do+ let r = addMedia (MinWidth 100) $ addPseudo "hover" $ rule "hello" ["key" :. "value"]+ cssRuleLine r `shouldBe` Just "@media (min-width: 100px) { .mmnw100\\:hover\\:hello:hover { key:value } }"+++-- let c = mediaCond (MaxWidth 800) bold+-- wrapMedia+-- Media (CSS [r]) <- pure c+-- r.selector `shouldBe` Selector ".mmxw800-bold"+-- r.className `shouldBe` ClassName "mmxw800-bold"+-- r.media `shouldBe` MediaQuery "(max-width: 800px)"++flatSpec :: Spec+flatSpec = do+ it "flattens empty" $ do+ let elm = element "div"+ elementAttributes elm `shouldBe` FlatAttributes []++ it "includes atts" $ do+ let elm = (element "div"){attributes = [("key", "value")]}+ elementAttributes elm `shouldBe` FlatAttributes [("key", "value")]++ it "includes classes in alphabetical order" $ do+ let elm = (element "div"){css = ["myclass", "another"]}+ elementAttributes elm `shouldBe` FlatAttributes [("class", "another myclass")]++ it "no duplicate attributes" $ do+ let Attributes attributes = att "key" "one" $ att "key" "two" mempty :: Attributes (Html ())+ let elm = (element "div"){attributes}+ elementAttributes elm `shouldBe` FlatAttributes [("key", "one")]++ it "no duplicate classes" $ do+ let elm = (element "div"){css = uniqueRules ["one", "one", "two"]}+ elementAttributes elm `shouldBe` FlatAttributes [("class", "one two")]++ it "classes are merged with css attribute" $ do+ let elm = (element "div"){css = ["mycss"], attributes = [("class", "default")]}+ elementAttributes elm `shouldBe` FlatAttributes [("class", "mycss default")]++ it "includes modified classnames" $ do+ let CSS rs = hover @(Html ()) bold $ CSS mempty+ let elm = (element "div"){css = rs}+ elementAttributes elm `shouldBe` FlatAttributes [("class", "hover:bold")]+++linesSpec :: Spec+linesSpec = do+ it "adds indent" $ do+ addIndent 2 "hello" `shouldBe` Line Newline 2 "hello"++ it "renders basic" $ do+ renderLines ["hello"] `shouldBe` "hello"++ it "renders two" $ do+ renderLines ["<div>one</div>", "<div>two</div>"] `shouldBe` "<div>one</div>\n<div>two</div>"++ it "doesn't indent single line" $ do+ renderLines [Line Newline 2 "<div>one</div>"] `shouldNotBe` " <div>one</div>"++ it "renders indent 2" $ do+ renderLines ["<div>", addIndent 2 "text", "</div>"] `shouldBe` "<div>\n text\n</div>"++ it "renders inline" $ do+ renderLines [Line Inline 0 "one", Line Inline 0 "two"] `shouldBe` "onetwo"+++htmlSpec :: Spec+htmlSpec = do+ describe "lines" $ do+ it "makes one line for single tag" $ do+ htmlLines 0 (tag "div" "hi") `shouldBe` [Line Newline 0 "<div>hi</div>"]++ it "makes two lines for double tags" $ do+ zipWithM_+ shouldBe+ (htmlLines 0 (tag "div" "hello" >> tag "div" "world"))+ [ Line Newline 0 "<div>hello</div>"+ , Line Newline 0 "<div>world</div>"+ ]++ it "indents contents" $ do+ zipWithM_+ shouldBe+ (htmlLines 2 (tag "div" $ tag "div" "one"))+ [ Line Newline 0 "<div>"+ , Line Newline 2 "<div>one</div>"+ , Line Newline 0 "</div>"+ ]++ it "inlines tags and text" $ do+ htmlLines 0 (text "one" >> text "two") `shouldBe` [Line Inline 0 "one", Line Inline 0 "two"]+ htmlLines 0 (inline "span" (text "hi") >> text "two") `shouldBe` [Line Inline 0 "<span>hi</span>", Line Inline 0 "two"]++ it "renders class" $ do+ htmlLines 0 (tag "div" ~ bold $ none) `shouldBe` ["<div class='bold'></div>"]++ it "renders pseudo class" $ do+ htmlLines 0 (tag "div" ~ hover bold $ none) `shouldBe` ["<div class='hover:bold'></div>"]++ describe "renderText" $ do+ it "renders simple output" $ do+ renderText (tag "div" "hi") `shouldBe` "<div>hi</div>"++ it "renders two elements" $ do+ renderText (tag "div" "hello" >> tag "div" "world") `shouldBe` "<div>hello</div>\n<div>world</div>"++ it "single-line with single text node" $ do+ renderText (tag "div" $ text "hello") `shouldBe` "<div>hello</div>"++ it "doesn't auto close tags " $ do+ renderText (tag "div" none) `shouldBe` "<div></div>"++ it "renders inline" $ do+ renderText (inline "span" "hello" >> text "woot" >> inline "span" "world") `shouldBe` "<span>hello</span>woot<span>world</span>"++ it "renders ?" $ do+ renderText (tag "div" $ text "txt" >> tag "div" none >> text "txt") `shouldBe` "<div>\n txt<div></div>\n txt</div>"++ it "matches basic output with styles" $ do+ basic <- T.readFile "test/resources/basic.txt"+ let html = do+ row ~ pad 10 $ do+ el ~ bold $ "hello"+ el "world"+ let out = renderText html+ zipWithM_ shouldBe (T.lines out) (T.lines basic)++ it "intro example" $ do+ let html = el ~ bold . pad 8 $ "Hello World"+ mapM_ (putStrLn . unpack) $ T.lines $ renderText html++ it "renders external classes" $ do+ renderText (el ~ cls "woot" $ none) `shouldBe` "<div class='woot'></div>"++ -- it "matches tooltips big example" $ do+ -- golden <- T.readFile "test/resources/tooltips.txt"+ -- let out = renderText tooltips+ -- putStrLn $ unpack out+ -- zipWithM_ shouldBe (T.lines out) (T.lines golden)++ describe "escape" $ do+ it "should escape bad attributes" $ do+ renderText (tag "div" @ att "title" "bob's" $ none) `shouldBe` "<div title='bob's'></div>"+ renderText (tag "div" @ att "title" "bob\"s" $ none) `shouldBe` "<div title='bob"s'></div>"+ renderText (tag "div" @ att "title" "1<2" $ none) `shouldBe` "<div title='1<2'></div>"++ it "should escape bad text" $ do+ renderText (text "<script>bad</script>") `shouldBe` "<script>bad</script>"++ it "should not escape raw" $ do+ renderText (raw "<script>bad</script>") `shouldBe` "<script>bad</script>"+ renderText (raw "bob's \"buddy\"") `shouldBe` "bob's \"buddy\""++ describe "classes" $ do+ it "should add utility classes" $ do+ htmlLines 0 (tag "div" ~ bold . pad 10 $ none) `shouldBe` ["<div class='bold p-10'></div>"]++ it "should override in composition order" $ do+ htmlLines 0 (tag "div" ~ pad 10 . pad 5 $ none) `shouldBe` ["<div class='p-10'></div>"]++ it "should override in styleable order" $ do+ htmlLines 0 (tag "div" ~ pad 10 ~ pad 5 $ none) `shouldBe` ["<div class='p-5'></div>"]++ it "merges class attribute if set" $ do+ htmlLines 0 (tag "div" @ att "class" "hello" ~ bold . pad 5 $ none) `shouldBe` ["<div class='bold p-5 hello'></div>"]+ where+ inline :: Text -> Html () -> Html ()+ inline nm (Html _ content) = do+ Html () [Elem $ Element True nm mempty mempty content]+++-- tooltips :: Html ()+-- tooltips = do+-- let items :: [Text] = ["One", "Two", "Three", "Four", "Five", "Six"]+-- col ~ pad 10 . gap 10 . width 300 $ do+-- el ~ bold $ "CSS ONLY TOOLTIPS"+-- el "some stuff"+-- text "sometext"+-- mapM_ tooltipItem items+--+-- tooltipItem :: Text -> Html ()+-- tooltipItem item = do+-- el ~ stack . showTooltips . hover (color red) $ do+-- el ~ border 1 . bg white $ text item+-- el ~ cls "tooltip" . popup (TR 10 10) . zIndex 1 . hidden $ do+-- col ~ border 2 . gap 5 . bg white . pad 5 $ do+-- el ~ bold $ "ITEM DETAILS"+-- el $ text item+--+-- showTooltips =+-- css+-- "tooltips"+-- ".tooltips:hover > .tooltip"+-- [Declaration "visibility" "visible"]+--+-- red = HexColor "#F00"+-- white = HexColor "#FFF"++-- col :: Html () -> Html ()+-- col = el ~ flexRow++row :: Html () -> Html ()+row = el ~ flexCol++-- it "psuedo + parent" $ do+-- let sel = (selector "myclass"){ancestor = Just "parent", pseudo = Just Hover}+-- selectorText sel `shouldBe` ".parent .hover\\:parent-myclass:hover"+--+-- it "child" $ do+-- let sel = (selector "myclass"){child = Just "mychild"}+-- attributeClassName sel `shouldBe` "myclass-mychild"+-- selectorText sel `shouldBe` ".myclass-mychild > .mychild"+--+-- let sel2 = (selector "myclass"){child = Just AllChildren}+-- attributeClassName sel2 `shouldBe` "myclass-all"+-- selectorText sel2 `shouldBe` ".myclass-all > *"+--+-- it "parent + pseudo + child" $ do+-- let sel = (selector "myclass"){child = Just "mychild", ancestor = Just "myparent", pseudo = Just Hover}+-- attributeClassName sel `shouldBe` "hover:myparent-myclass-mychild"+-- selectorText sel `shouldBe` ".myparent .hover\\:myparent-myclass-mychild:hover > .mychild"++-- describe "child combinator" $ do+-- it "should include child combinator in definition" $ do
+ test/Test/RuleSpec.hs view
@@ -0,0 +1,101 @@+module Test.RuleSpec where++import Skeletest+import Web.Atomic.CSS.Select (addAncestor, addMedia, addPseudo)+import Web.Atomic.Types+import Web.Atomic.Types.Rule as Rule+++spec :: Spec+spec = do+ describe "Unique Rules" $ do+ it "should only set same class once" $ do+ uniqueRules ["asdf", "asdf"] `shouldBe` ["asdf"]++ fmap (.className) [bold, bold] `shouldBe` ["bold", "bold"]+ fmap (.className) (uniqueRules [bold, bold]) `shouldBe` ["bold"]++ it "should set different properties" $ do+ let rs = [bold, fs12]+ length (uniqueRules rs) `shouldBe` 2++ it "should unset same property" $ do+ let rs = [fs24, bold, fs12]+ fmap (.className) (uniqueRules rs) `shouldBe` ["fs-24", "bold"]++ it "should treat hover states as unique" $ do+ let hoverBold = addPseudo "hover" bold+ hoverNormal = addPseudo "hover" normal+ hoverActiveNormal = addPseudo "hover" $ addPseudo "active" normal++ length (uniqueRules [hoverBold, normal]) `shouldBe` 2+ length (uniqueRules [hoverBold, hoverNormal]) `shouldBe` 1+ length (uniqueRules [hoverActiveNormal, hoverBold]) `shouldBe` 2++ it "should ignore custom selectors" $ do+ length (uniqueRules [bold, custom]) `shouldBe` 2+ length (uniqueRules [custom, bold]) `shouldBe` 2++ describe "className" $ do+ it "basic" $ do+ ruleClassName (Rule.fromClass "hello") `shouldBe` "hello"++ it "includes pseudo" $ do+ ruleClassName (addPseudo "active" $ addPseudo "hover" "hello") `shouldBe` "active:hover:hello"++ it "includes media" $ do+ ruleClassName (addMedia (MinWidth 100) "hello") `shouldBe` "mmnw100:hello"++ it "includes pseudo + media" $ do+ ruleClassName (addMedia (MinWidth 100) $ addPseudo "hover" "hello") `shouldBe` "mmnw100:hover:hello"++ describe "selector" $ do+ it "creates selector from class name" $ do+ ruleSelector (Rule.fromClass "p-10") `shouldBe` ".p-10"++ it "adds pseudo" $ do+ ruleSelector (addPseudo "hover" "p-10") `shouldBe` ".hover\\:p-10:hover"++ it "adds media" $ do+ ruleSelector (addMedia (MinWidth 100) "hello") `shouldBe` ".mmnw100\\:hello"++ it "adds pseudo + media " $ do+ ruleSelector (addMedia (MinWidth 100) $ addPseudo "hover" "hello") `shouldBe` ".mmnw100\\:hover\\:hello:hover"++ describe "ancestor" $ do+ it "prepends selector" $ do+ let r = addAncestor "htmx-request" "hello"+ let cn = ruleClassName r+ cn `shouldBe` "htmx-request:hello"+ ruleSelector r `shouldBe` ".htmx-request " <> selector cn++ it "ancestor + pseudo" $ do+ let r = addAncestor "htmx-request" $ addPseudo "hover" "hello"+ let cn = ruleClassName r+ cn `shouldBe` "htmx-request:hover:hello"+ ruleSelector r `shouldBe` ".htmx-request " <> selector cn <> ":hover"++ -- what dopes this mean? Are they the same?+ -- hover (ancestor "htmx-request" "bold")+ -- ancestor "htmx-request" (hover "bold")+ -- certain things should be outermost....+ it "pseudo + ancestor" $ do+ let r = addPseudo "hover" $ addAncestor "htmx-request" "hello"+ let cn = ruleClassName r+ cn `shouldBe` "hover:htmx-request:hello"+ ruleSelector r `shouldBe` ".htmx-request " <> selector cn <> ":hover"++ it "ignores when custom selector" $ do+ let r = addAncestor "htmx-request" $ addPseudo "hover" $ (rule "hello" []){selector = CustomRule ".woot"}+ let cn = ruleClassName r+ cn `shouldBe` "hello"+ ruleSelector r `shouldBe` ".woot"+ where+ -- it "doesn't change with custom selectors" $ do+ -- ruleSelector (Rule "hello" (Just ".hello") [Hover] [MinWidth 100] []) `shouldBe` ".hello"++ fs12 = Rule "fs-12" mempty mempty ["font-size" :. "12px"]+ fs24 = Rule "fs-24" mempty mempty ["font-size" :. "24px"]+ bold = Rule "bold" mempty mempty ["font-weight" :. "bold"]+ normal = Rule "normal" mempty mempty ["font-weight" :. "normal"]+ custom = Rule "custom" (CustomRule ".custom > *") mempty ["font-weight" :. "bold"]
+ test/Test/StyleSpec.hs view
@@ -0,0 +1,121 @@+module Test.StyleSpec (spec) where++import Skeletest+import Web.Atomic.CSS+import Web.Atomic.Types+import Prelude hiding (span)+++spec :: Spec+spec = do+ mainSpec+ selectorSpec+++mainSpec :: Spec+mainSpec = do+ describe "PropertyStyle" $ do+ it "should compile, and set both the className and styles" $ do+ let rs = rules $ list Decimal+ length rs `shouldBe` 1+ [c] <- pure rs+ ruleClassName c `shouldBe` ClassName "list-decimal"+ ruleSelector c `shouldBe` ".list-decimal"+ c.properties `shouldBe` ["list-style-type" :. "decimal"]++ it "should work with outside member None" $ do+ let rs = rules $ list None+ length rs `shouldBe` 1+ [c] <- pure rs+ ruleClassName c `shouldBe` ClassName "list-none"+ ruleSelector c `shouldBe` ".list-none"+ c.properties `shouldBe` ["list-style-type" :. "none"]++ describe "PxRem" $ do+ it "uses absolutes for 0,1" $ do+ style (PxRem 0) `shouldBe` "0px"+ style (PxRem 16) `shouldBe` "1.000rem"++ it "uses rem for others" $ do+ style (PxRem 2) `shouldBe` "0.125rem"+ style (PxRem 10) `shouldBe` "0.625rem"+ style (PxRem 16) `shouldBe` "1.000rem"++ describe "Length" $ do+ it "styles pct" $ do+ style (Pct (1 / 3)) `shouldBe` "33.3%"++ it "adds values" $ do+ style (PxRem 6 + PxRem 10) `shouldBe` "1.000rem"++ describe "Align" $ do+ it "should produce correct style values" $ do+ style AlignCenter `shouldBe` "center"+ style AlignJustify `shouldBe` "justify"++ describe "ToClassName" $ do+ it "should hyphenate classnames" $ do+ "woot" -. None `shouldBe` "woot-none"++ it "should not hyphenate with empty suffix" $ do+ "woot" -. () `shouldBe` "woot"++ it "should escape classNames" $ do+ className "hello.woot-hi" `shouldBe` ClassName "hello-woot-hi"++ describe "Colors" $ do+ it "correct styleValue independent of leading slash" $ do+ style (HexColor "#FFF") `shouldBe` Style "#FFF"+ style (HexColor "FFF") `shouldBe` Style "#FFF"+ style ("FFF" :: HexColor) `shouldBe` Style "#FFF"+ style ("#FFF" :: HexColor) `shouldBe` Style "#FFF"++ it "correct className independent of leading slash" $ do+ toClassName (HexColor "#FFF") `shouldBe` "fff"+ toClassName (HexColor "FFF") `shouldBe` "fff"+ toClassName ("FFF" :: HexColor) `shouldBe` "fff"+ toClassName ("#FFF" :: HexColor) `shouldBe` "fff"++ it "works with custom colors" $ do+ style (colorValue Danger) `shouldBe` Style "#F00"+ style (colorValue Warning) `shouldBe` Style "#FF0"++ describe "Styleable" $ do+ it "applies styles" $ do+ let rs :: [Rule] = [] ~ bold . fontSize 24+ fmap (.className) rs `shouldBe` ["bold", "fs-24"]++ it "writes in composition order" $ do+ let rs :: [Rule] = [] ~ bold . fontSize 12 . italic+ fmap (.className) rs `shouldBe` ["bold", "fs-12", "italic"]++ it "overrides in operator order" $ do+ let rs :: [Rule] = [] ~ bold . fontSize 12 ~ italic+ fmap (.className) rs `shouldBe` ["italic", "bold", "fs-12"]++ describe "External Classes" $ do+ it "adds external classes" $ do+ let CSS rs = CSS [] ~ cls "external"+ rs `shouldBe` [Rule "external" mempty mempty []]+ fmap (.className) rs `shouldBe` ["external"]+++selectorSpec :: Spec+selectorSpec = do+ describe "Selector" $ do+ it "normal selector" $ do+ selector "myclass" `shouldBe` Selector ".myclass"++ it "escapes colons" $ do+ selector "hover:bold" `shouldBe` Selector ".hover\\:bold"+++data AppColor+ = Danger+ | Warning+ deriving (Show, Eq)+++instance ToColor AppColor where+ colorValue Danger = "#F00"+ colorValue Warning = "FF0"
+ test/Test/UtilitySpec.hs view
@@ -0,0 +1,58 @@+module Test.UtilitySpec where++import Data.List (find)+import Skeletest+import Web.Atomic.CSS+import Web.Atomic.Types as Atomic+++spec :: Spec+spec = do+ describe "display" $ do+ it "sets display:none, display:block" $ do+ let CSS rs = mempty ~ display None+ fmap (.properties) rs `shouldBe` [["display" :. "none"]]++ let CSS rs2 = mempty ~ display Block+ fmap (.properties) rs2 `shouldBe` [["display" :. "block"]]++ describe "TRBL" $ do+ it "sets all" $ do+ let CSS rs = mempty ~ pad 1+ mconcat (fmap (.properties) rs) `shouldBe` ["padding" :. "1px"]++ it "sets XY" $ do+ let CSS rs = mempty ~ pad (XY 1 0)+ let dcls = mconcat (fmap (.properties) rs)+ shouldHaveDeclaration "padding-top" "0px" dcls+ shouldHaveDeclaration "padding-left" "1px" dcls+ shouldHaveDeclaration "padding-bottom" "0px" dcls+ shouldHaveDeclaration "padding-right" "1px" dcls++ it "sets T R B L" $ do+ let CSS rs = mempty ~ pad (T 1) . pad (B 0) . pad (R 16) . pad (L 2)+ let dcls = mconcat (fmap (.properties) rs)+ shouldHaveDeclaration "padding-top" "1px" dcls+ shouldHaveDeclaration "padding-left" "0.125rem" dcls+ shouldHaveDeclaration "padding-bottom" "0px" dcls+ shouldHaveDeclaration "padding-right" "1.000rem" dcls++ it "sets X" $ do+ let CSS rs = mempty ~ pad (X 1)+ let dcls = mconcat (fmap (.properties) rs)+ shouldHaveDeclaration "padding-left" "1px" dcls+ shouldHaveDeclaration "padding-right" "1px" dcls++ it "sets TRBL" $ do+ let CSS rs = mempty ~ pad (TRBL 1 0 0 1)+ let dcls = mconcat (fmap (.properties) rs)+ shouldHaveDeclaration "padding-top" "1px" dcls+ shouldHaveDeclaration "padding-left" "1px" dcls+ shouldHaveDeclaration "padding-bottom" "0px" dcls+ shouldHaveDeclaration "padding-right" "0px" dcls+++shouldHaveDeclaration :: Atomic.Property -> Style -> [Declaration] -> IO ()+shouldHaveDeclaration p v ds = do+ let dcl = p :. v+ find (== dcl) ds `shouldBe` (Just dcl)