diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
--- /dev/null
+++ b/CHANGELOG.md
@@ -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 `
+
+Hello World
+```
+
+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"
+
+
+ Hello
+
+
+### 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)
+
diff --git a/atomic-css.cabal b/atomic-css.cabal
new file mode 100644
--- /dev/null
+++ b/atomic-css.cabal
@@ -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
diff --git a/embed/reset.css b/embed/reset.css
new file mode 100644
--- /dev/null
+++ b/embed/reset.css
@@ -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}
diff --git a/src/Web/Atomic.hs b/src/Web/Atomic.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic.hs
@@ -0,0 +1,99 @@
+{- |
+Module: Web.Atomic
+Copyright: (c) 2023 Sean Hess
+License: BSD3
+Maintainer: Sean Hess
+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:
+
+>
+>
+> Hello World
+
+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)
+-}
diff --git a/src/Web/Atomic/Attributes.hs b/src/Web/Atomic/Attributes.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Attributes.hs
@@ -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
diff --git a/src/Web/Atomic/CSS.hs b/src/Web/Atomic/CSS.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS.hs
@@ -0,0 +1,203 @@
+{- |
+Module: Web.Atomic.CSS
+Copyright: (c) 2023 Sean Hess
+License: BSD3
+Maintainer: Sean Hess
+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"
+@
+-}
diff --git a/src/Web/Atomic/CSS/Box.hs b/src/Web/Atomic/CSS/Box.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Box.hs
@@ -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
diff --git a/src/Web/Atomic/CSS/Layout.hs b/src/Web/Atomic/CSS/Layout.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Layout.hs
@@ -0,0 +1,269 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+{- |
+Module: Web.Atomic.CSS.Layout
+Copyright: (c) 2023 Sean Hess
+License: BSD3
+Maintainer: Sean Hess
+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]
diff --git a/src/Web/Atomic/CSS/Reset.hs b/src/Web/Atomic/CSS/Reset.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Reset.hs
@@ -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|
+>
+>
+>
+> #{cnt}
+> |]
+-}
+cssResetEmbed :: ByteString
+cssResetEmbed = $(embedFile "embed/reset.css")
diff --git a/src/Web/Atomic/CSS/Select.hs b/src/Web/Atomic/CSS/Select.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Select.hs
@@ -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)}
diff --git a/src/Web/Atomic/CSS/Text.hs b/src/Web/Atomic/CSS/Text.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Text.hs
@@ -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]
diff --git a/src/Web/Atomic/CSS/Transition.hs b/src/Web/Atomic/CSS/Transition.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/CSS/Transition.hs
@@ -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)
diff --git a/src/Web/Atomic/Html.hs b/src/Web/Atomic/Html.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Html.hs
@@ -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
diff --git a/src/Web/Atomic/Html/Tag.hs b/src/Web/Atomic/Html/Tag.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Html/Tag.hs
@@ -0,0 +1,59 @@
+{- |
+Module: Web.Atomic.Html.Tag
+Copyright: (c) 2023 Sean Hess
+License: BSD3
+Maintainer: Sean Hess
+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
diff --git a/src/Web/Atomic/Render.hs b/src/Web/Atomic/Render.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Render.hs
@@ -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 ""]
+
+
+-- 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 " "
diff --git a/src/Web/Atomic/Types.hs b/src/Web/Atomic/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types.hs
@@ -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
+
+
diff --git a/src/Web/Atomic/Types/Attributable.hs b/src/Web/Atomic/Types/Attributable.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/Attributable.hs
@@ -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
diff --git a/src/Web/Atomic/Types/ClassName.hs b/src/Web/Atomic/Types/ClassName.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/ClassName.hs
@@ -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
diff --git a/src/Web/Atomic/Types/Rule.hs b/src/Web/Atomic/Types/Rule.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/Rule.hs
@@ -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
diff --git a/src/Web/Atomic/Types/Selector.hs b/src/Web/Atomic/Types/Selector.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/Selector.hs
@@ -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"]
diff --git a/src/Web/Atomic/Types/Style.hs b/src/Web/Atomic/Types/Style.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/Style.hs
@@ -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
diff --git a/src/Web/Atomic/Types/Styleable.hs b/src/Web/Atomic/Types/Styleable.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Atomic/Types/Styleable.hs
@@ -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)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+import Skeletest.Main
+
diff --git a/test/Test/AttributeSpec.hs b/test/Test/AttributeSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/AttributeSpec.hs
@@ -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"]
diff --git a/test/Test/RenderSpec.hs b/test/Test/RenderSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/RenderSpec.hs
@@ -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 ["one
", "two
"] `shouldBe` "one
\ntwo
"
+
+ it "doesn't indent single line" $ do
+ renderLines [Line Newline 2 "one
"] `shouldNotBe` " one
"
+
+ it "renders indent 2" $ do
+ renderLines ["", addIndent 2 "text", "
"] `shouldBe` "\n text\n
"
+
+ 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 "hi
"]
+
+ it "makes two lines for double tags" $ do
+ zipWithM_
+ shouldBe
+ (htmlLines 0 (tag "div" "hello" >> tag "div" "world"))
+ [ Line Newline 0 "hello
"
+ , Line Newline 0 "world
"
+ ]
+
+ it "indents contents" $ do
+ zipWithM_
+ shouldBe
+ (htmlLines 2 (tag "div" $ tag "div" "one"))
+ [ Line Newline 0 ""
+ , Line Newline 2 "
one
"
+ , Line Newline 0 "
hi
"
+
+ it "renders two elements" $ do
+ renderText (tag "div" "hello" >> tag "div" "world") `shouldBe` "hello
\nworld
"
+
+ it "single-line with single text node" $ do
+ renderText (tag "div" $ text "hello") `shouldBe` "hello
"
+
+ it "doesn't auto close tags " $ do
+ renderText (tag "div" none) `shouldBe` ""
+
+ it "renders inline" $ do
+ renderText (inline "span" "hello" >> text "woot" >> inline "span" "world") `shouldBe` "hellowootworld"
+
+ it "renders ?" $ do
+ renderText (tag "div" $ text "txt" >> tag "div" none >> text "txt") `shouldBe` ""
+
+ 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` ""
+
+ -- 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` ""
+ renderText (tag "div" @ att "title" "bob\"s" $ none) `shouldBe` ""
+ renderText (tag "div" @ att "title" "1<2" $ none) `shouldBe` ""
+
+ it "should escape bad text" $ do
+ renderText (text "") `shouldBe` "<script>bad</script>"
+
+ it "should not escape raw" $ do
+ renderText (raw "") `shouldBe` ""
+ 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` [""]
+
+ it "should override in composition order" $ do
+ htmlLines 0 (tag "div" ~ pad 10 . pad 5 $ none) `shouldBe` [""]
+
+ it "should override in styleable order" $ do
+ htmlLines 0 (tag "div" ~ pad 10 ~ pad 5 $ none) `shouldBe` [""]
+
+ it "merges class attribute if set" $ do
+ htmlLines 0 (tag "div" @ att "class" "hello" ~ bold . pad 5 $ none) `shouldBe` [""]
+ 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
diff --git a/test/Test/RuleSpec.hs b/test/Test/RuleSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/RuleSpec.hs
@@ -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"]
diff --git a/test/Test/StyleSpec.hs b/test/Test/StyleSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/StyleSpec.hs
@@ -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"
diff --git a/test/Test/UtilitySpec.hs b/test/Test/UtilitySpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/UtilitySpec.hs
@@ -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)