diff --git a/.gitignore b/.gitignore
index 7088d63..7b32d78 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,6 @@
dist-newstyle
node_modules
+Session.vim
dist
.DS_Store
tags
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 4bd4c1a..3a13ba2 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,13 +1,21 @@
-# Revision history for web-view
+# Revision history for atomic-css
-## 0.7.0
+## atomic-css 0.1.0
+
+Renamed library 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 selectors 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
-## 0.6.0
+## web-view 0.6.0
* stack - layout children on top of each other
* ChildCombinator: apply styles to direct children
@@ -15,22 +23,21 @@
* fixed: escaping in auto-generated `
+
+
Hello World
```
-Leverage the full power of Haskell functions for reuse, instead of relying on CSS.
+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 = gap 10
+page = flexCol . gap 10 . pad 10
-myPage = col page $ do
- el h1 "My Page"
- ...
+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/utility-first)
+This approach is inspired by Tailwindcss' [Utility Classes](https://tailwindcss.com/docs/styling-with-utility-classes)
+
-### Intuitive Layouts
+### Intuitive Flexbox Layouts
-Easily create layouts with `row`, `col`, `grow`, and `space`
+Create complex layouts with `row`, `col`, `grow`, and `space`
```haskell
-holygrail :: View c ()
-holygrail = layout id $ do
- row section "Top Bar"
- row grow $ do
- col section "Left Sidebar"
- col (section . grow) "Main Content"
- col section "Right Sidebar"
- row section "Bottom Bar"
- where section = 'border' 1
+holygrail = do
+ col ~ grow $ do
+ row "Top Bar"
+ row ~ grow $ do
+ col "Left Sidebar"
+ col ~ grow $ "Main Content"
+ col "Right Sidebar"
+ row "Bottom Bar"
```
-### Embedded CSS
-
-Views track which styles are used in any child node, and automatically embed all CSS when rendered.
-
- >>> renderText $ el bold "Hello"
-
-
-
Hello
-
-
### Stateful Styles
-We can apply styles when certain states apply. For example, to change the background on hover:
+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"
+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))
+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 web-view without cloning the project run `nix run github:seanhess/web-view` to run the example webserver locally
+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 `web-view` to `overriddenHaskellPackages` and which provides a ghc966 and ghc982 package set that satisfy `web-view`'s dependencies.
+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";
- web-view.url = "github:seanhess/web-view"; # or "path:/path/to/cloned/web-view";
+ atomic-css.url = "github:seanhess/atomic-css"; # or "path:/path/to/cloned/atomic-css";
flake-utils.url = "github:numtide/flake-utils";
};
- outputs = { self, nixpkgs, web-view, flake-utils, ... }:
+ outputs = { self, nixpkgs, atomic-css, flake-utils, ... }:
flake-utils.lib.eachDefaultSystem (
system:
let
pkgs = import nixpkgs {
inherit system;
- overlays = [ web-view.overlays.default ];
+ overlays = [ atomic-css.overlays.default ];
};
haskellPackagesOverride = pkgs.overriddenHaskellPackages.ghc966.override (old: {
overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: { })) (hfinal: hprev: {
@@ -104,7 +116,7 @@ You can import this flake's overlay to add `web-view` to `overriddenHaskellPacka
in
{
devShells.default = haskellPackagesOverride.shellFor {
- packages = p: [ p.web-view ];
+ packages = p: [ p.atomic-css ];
};
}
);
@@ -116,16 +128,16 @@ Local Development
### Recommended ghcid command
-If you want to work on both the web-view library and example code, this `ghcid` command will run and reload the examples server as you change any non-testing code.
+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:web-view" --run=Main.main --warnings --reload=./embed/preflight.css
+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:web-view" --run=Main.main --warnings --reload=./embed/preflight.css
+ghcid --command="cabal repl test lib:atomic-css" --run=Main.main --warnings --reload=./embed/preflight.css
```
### Nix
@@ -136,7 +148,7 @@ ghcid --command="cabal repl test lib:web-view" --run=Main.main --warnings --relo
- `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-web-view` and `nix build .#ghc966-web-view` builds the library with the `overriddenHaskellPackages`
+- `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
@@ -165,15 +177,15 @@ Learn More
----------
View Documentation on [Hackage][hackage]
-* https://hackage.haskell.org/package/web-view
+* https://hackage.haskell.org/package/atomic-css
View on Github
-* https://github.com/seanhess/web-view
+* https://github.com/seanhess/atomic-css
-View [Examples](https://github.com/seanhess/web-view/blob/latest/example/app/Main.hs)
+View [Examples](https://github.com/seanhess/atomic-css/blob/latest/example/app/Main.hs)
-[hackage]: https://hackage.haskell.org/package/web-view
+[hackage]: https://hackage.haskell.org/package/atomic-css
Contributors
diff --git a/Session.vim b/Session.vim
deleted file mode 100644
index 5d16909..0000000
--- a/Session.vim
+++ /dev/null
@@ -1,191 +0,0 @@
-let SessionLoad = 1
-let s:so_save = &g:so | let s:siso_save = &g:siso | setg so=0 siso=0 | setl so=-1 siso=-1
-let v:this_session=expand(":p")
-silent only
-silent tabonly
-cd ~/Projects/Work/GasWork/RelatedWork/web-view
-if expand('%') == '' && !&modified && line('$') <= 1 && getline(1) == ''
- let s:wipebuf = bufnr('%')
-endif
-let s:shortmess_save = &shortmess
-if &shortmess =~ 'A'
- set shortmess=aoOA
-else
- set shortmess=aoO
-endif
-badd +500 src/Web/View/Types.hs
-badd +277 src/Web/View/Style.hs
-badd +68 ~/.local/share/nvim/parrot/chats/2025-01-23.22-56-48.041.md
-badd +66 web-view.cabal
-badd +251 ~/.local/share/nvim/parrot/chats/2025-01-25.06-42-05.937.md
-badd +1 src/Web/View/Types
-argglobal
-%argdel
-$argadd src/Web/View/Types
-edit src/Web/View/Style.hs
-let s:save_splitbelow = &splitbelow
-let s:save_splitright = &splitright
-set splitbelow splitright
-wincmd _ | wincmd |
-vsplit
-1wincmd h
-wincmd _ | wincmd |
-split
-1wincmd k
-wincmd w
-wincmd w
-wincmd _ | wincmd |
-split
-1wincmd k
-wincmd w
-let &splitbelow = s:save_splitbelow
-let &splitright = s:save_splitright
-wincmd t
-let s:save_winminheight = &winminheight
-let s:save_winminwidth = &winminwidth
-set winminheight=0
-set winheight=1
-set winminwidth=0
-set winwidth=1
-exe '1resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 1resize ' . ((&columns * 91 + 91) / 182)
-exe '2resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 2resize ' . ((&columns * 91 + 91) / 182)
-exe '3resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 3resize ' . ((&columns * 90 + 91) / 182)
-exe '4resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 4resize ' . ((&columns * 90 + 91) / 182)
-argglobal
-balt src/Web/View/Types.hs
-setlocal fdm=manual
-setlocal fde=0
-setlocal fmr={{{,}}}
-setlocal fdi=#
-setlocal fdl=0
-setlocal fml=1
-setlocal fdn=20
-setlocal fen
-silent! normal! zE
-let &fdl = &fdl
-let s:l = 277 - ((18 * winheight(0) + 19) / 38)
-if s:l < 1 | let s:l = 1 | endif
-keepjumps exe s:l
-normal! zt
-keepjumps 277
-normal! 0
-lcd ~/Projects/Work/GasWork/RelatedWork/web-view
-wincmd w
-argglobal
-if bufexists(fnamemodify("~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs", ":p")) | buffer ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs | else | edit ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs | endif
-if &buftype ==# 'terminal'
- silent file ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs
-endif
-balt ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs
-setlocal fdm=manual
-setlocal fde=0
-setlocal fmr={{{,}}}
-setlocal fdi=#
-setlocal fdl=0
-setlocal fml=1
-setlocal fdn=20
-setlocal fen
-silent! normal! zE
-let &fdl = &fdl
-let s:l = 499 - ((30 * winheight(0) + 19) / 38)
-if s:l < 1 | let s:l = 1 | endif
-keepjumps exe s:l
-normal! zt
-keepjumps 499
-normal! 02|
-lcd ~/Projects/Work/GasWork/RelatedWork/web-view
-wincmd w
-argglobal
-if bufexists(fnamemodify("~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs", ":p")) | buffer ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs | else | edit ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs | endif
-if &buftype ==# 'terminal'
- silent file ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs
-endif
-balt ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs
-setlocal fdm=manual
-setlocal fde=0
-setlocal fmr={{{,}}}
-setlocal fdi=#
-setlocal fdl=0
-setlocal fml=1
-setlocal fdn=20
-setlocal nofen
-silent! normal! zE
-31,63fold
-87,112fold
-150,168fold
-276,279fold
-392,413fold
-442,470fold
-510,519fold
-let &fdl = &fdl
-let s:l = 125 - ((24 * winheight(0) + 19) / 38)
-if s:l < 1 | let s:l = 1 | endif
-keepjumps exe s:l
-normal! zt
-keepjumps 125
-normal! 0
-lcd ~/Projects/Work/GasWork/RelatedWork/web-view
-wincmd w
-argglobal
-if bufexists(fnamemodify("~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs", ":p")) | buffer ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs | else | edit ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs | endif
-if &buftype ==# 'terminal'
- silent file ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Types.hs
-endif
-balt ~/Projects/Work/GasWork/RelatedWork/web-view/src/Web/View/Style.hs
-setlocal fdm=manual
-setlocal fde=0
-setlocal fmr={{{,}}}
-setlocal fdi=#
-setlocal fdl=0
-setlocal fml=1
-setlocal fdn=20
-setlocal nofen
-silent! normal! zE
-31,63fold
-87,112fold
-150,168fold
-276,279fold
-392,413fold
-442,470fold
-510,519fold
-let &fdl = &fdl
-let s:l = 268 - ((19 * winheight(0) + 19) / 38)
-if s:l < 1 | let s:l = 1 | endif
-keepjumps exe s:l
-normal! zt
-keepjumps 268
-normal! 0
-lcd ~/Projects/Work/GasWork/RelatedWork/web-view
-wincmd w
-exe '1resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 1resize ' . ((&columns * 91 + 91) / 182)
-exe '2resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 2resize ' . ((&columns * 91 + 91) / 182)
-exe '3resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 3resize ' . ((&columns * 90 + 91) / 182)
-exe '4resize ' . ((&lines * 38 + 39) / 79)
-exe 'vert 4resize ' . ((&columns * 90 + 91) / 182)
-tabnext 1
-if exists('s:wipebuf') && len(win_findbuf(s:wipebuf)) == 0 && getbufvar(s:wipebuf, '&buftype') isnot# 'terminal'
- silent exe 'bwipe ' . s:wipebuf
-endif
-unlet! s:wipebuf
-set winheight=1 winwidth=20
-let &shortmess = s:shortmess_save
-let &winminheight = s:save_winminheight
-let &winminwidth = s:save_winminwidth
-let s:sx = expand(":p:r")."x.vim"
-if filereadable(s:sx)
- exe "source " . fnameescape(s:sx)
-endif
-let &g:so = s:so_save | let &g:siso = s:siso_save
-set hlsearch
-let g:this_session = v:this_session
-let g:this_obsession = v:this_session
-doautoall SessionLoadPost
-unlet SessionLoad
-" vim: set ft=vim :
diff --git a/web-view.cabal b/atomic-css.cabal
similarity index 55%
rename from web-view.cabal
rename to atomic-css.cabal
index 4127f47..90b337a 100644
--- a/web-view.cabal
+++ b/atomic-css.cabal
@@ -4,13 +4,13 @@ cabal-version: 2.2
--
-- see: https://github.com/sol/hpack
-name: web-view
-version: 0.7.0
-synopsis: Type-safe HTML and CSS with intuitive layouts and composable styles.
-description: Type-safe HTML and CSS with intuitive layouts and composable styles. Inspired by Tailwindcss and Elm-UI . See documentation for the @Web.View@ module below
+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/web-view
-bug-reports: https://github.com/seanhess/web-view/issues
+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
@@ -20,30 +20,40 @@ tested-with:
GHC == 9.8.2
, GHC == 9.6.6
extra-source-files:
- embed/preflight.css
+ embed/reset.css
extra-doc-files:
README.md
CHANGELOG.md
source-repository head
type: git
- location: https://github.com/seanhess/web-view
+ location: https://github.com/seanhess/atomic-css
library
exposed-modules:
- Web.View
- Web.View.Element
- Web.View.Layout
- Web.View.Render
- Web.View.Reset
- Web.View.Style
- Web.View.Types
- Web.View.Types.Url
- Web.View.View
+ 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_web_view
+ Paths_atomic_css
autogen-modules:
- Paths_web_view
+ Paths_atomic_css
hs-source-dirs:
src
default-extensions:
@@ -51,6 +61,10 @@ library
OverloadedRecordDot
DuplicateRecordFields
NoFieldSelectors
+ TypeFamilies
+ DerivingStrategies
+ DefaultSignatures
+ DeriveAnyClass
ghc-options: -Wall -fdefer-typed-holes
build-depends:
base >=4.16 && <5
@@ -61,7 +75,6 @@ library
, file-embed >=0.0.10 && <0.1
, html-entities >=1.1.4.7 && <1.2
, http-types ==0.12.*
- , string-interpolate >=0.3.2 && <0.4
, text >=1.2 && <3
default-language: GHC2021
@@ -69,13 +82,14 @@ test-suite test
type: exitcode-stdio-1.0
main-is: Spec.hs
other-modules:
+ Test.AttributeSpec
Test.RenderSpec
+ Test.RuleSpec
Test.StyleSpec
- Test.UrlSpec
- Test.ViewSpec
- Paths_web_view
+ Test.UtilitySpec
+ Paths_atomic_css
autogen-modules:
- Paths_web_view
+ Paths_atomic_css
hs-source-dirs:
test/
default-extensions:
@@ -83,9 +97,14 @@ test-suite test
OverloadedRecordDot
DuplicateRecordFields
NoFieldSelectors
+ TypeFamilies
+ DerivingStrategies
+ DefaultSignatures
+ DeriveAnyClass
ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor
build-depends:
- base >=4.16 && <5
+ atomic-css
+ , base >=4.16 && <5
, bytestring >=0.11 && <0.13
, casing >0.1.3.0 && <0.2
, containers >=0.6 && <1
@@ -94,7 +113,5 @@ test-suite test
, html-entities >=1.1.4.7 && <1.2
, http-types ==0.12.*
, skeletest
- , string-interpolate >=0.3.2 && <0.4
, text >=1.2 && <3
- , web-view
default-language: GHC2021
diff --git a/bin/dev b/bin/dev
index f73f220..9dce84f 100755
--- a/bin/dev
+++ b/bin/dev
@@ -22,4 +22,4 @@ watchexec -e hs,yaml cabal test &
# Autoreload on save. Show errors and warnings
# run even if warnings
-ghcid --command="cabal repl exe:example lib:web-view" --run=Main.main --warnings --reload=./embed/preflight.css
+ghcid --command="cabal repl exe:example lib:atomic-css" --run=Main.main --warnings --reload=./embed/preflight.css
diff --git a/embed/preflight.css b/embed/preflight.css
deleted file mode 100644
index ce4b2f1..0000000
--- a/embed/preflight.css
+++ /dev/null
@@ -1 +0,0 @@
-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{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}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/embed/reset.css b/embed/reset.css
new file mode 100644
index 0000000..e24e67e
--- /dev/null
+++ b/embed/reset.css
@@ -0,0 +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/example/app/Example/Blaze.hs b/example/app/Example/Blaze.hs
new file mode 100644
index 0000000..b4aa3e4
--- /dev/null
+++ b/example/app/Example/Blaze.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Example.Blaze where
+
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.List qualified as L
+import Data.Map (Map)
+import Data.Map.Strict qualified as M
+import Data.Maybe (mapMaybe)
+import Data.Text (Text, unpack)
+import Data.Text qualified as T
+import Effectful
+import Effectful.State.Static.Local
+import Text.Blaze.Html (Html)
+import Text.Blaze.Html4.Strict qualified as H
+import Text.Blaze.Html4.Strict.Attributes as HA hiding (title)
+import Text.Blaze.Internal (Attributable (..), ChoiceString (..), MarkupM (..), StaticString (..))
+import Text.Blaze.Renderer.Utf8
+import Web.Atomic.CSS
+import Web.Atomic.Render
+import Web.Atomic.Types hiding (Attributable)
+import Prelude hiding (div, head, id)
+
+
+test :: IO ()
+test = do
+ let (_, h2) = execHtml simple
+ putStrLn $ BLC.unpack $ renderMarkup h2
+ putStrLn "------------------------------"
+
+ let (rs, h) = execHtml page1
+
+ putStrLn $ unpack $ renderLines $ cssRulesLines $ ruleMap rs
+ putStrLn ""
+ putStrLn $ BLC.unpack $ renderMarkup h
+
+
+newtype Fusion a = Fusion {eff :: Eff '[State Html, State [Rule]] a}
+ deriving newtype (Functor, Applicative, Monad)
+
+
+simple :: Fusion ()
+simple = do
+ head ~ pad 10 ~ pad 5 $ pure ()
+
+
+page1 :: Fusion ()
+page1 = do
+ html $ do
+ head ~ pad 6 . pad 8 ~ pad 10 . pad 4 $ do
+ title (text "Introduction page.")
+ link ! rel "stylesheet" ! type_ "text/css" ! href "screen.css"
+ body ~ display Block ~ pad 8 $ do
+ div ! id "header" ~ bold . pad 5 ~ pad 10 ~ display Flex $ text "Syntax"
+ p $ text "This is an example of BlazeMarkup syntax."
+ ul $ mapM_ (li . showHtml @Int) [1, 2, 3]
+
+
+html :: Fusion () -> Fusion ()
+html = tag H.html
+head :: Fusion () -> Fusion ()
+head = tag H.head
+body :: Fusion () -> Fusion ()
+body = tag H.body
+title :: Fusion () -> Fusion ()
+title = tag H.title
+link :: Fusion ()
+link = tag (const H.link) (pure ())
+div :: Fusion () -> Fusion ()
+div = tag H.div
+p :: Fusion () -> Fusion ()
+p = tag H.p
+ul :: Fusion () -> Fusion ()
+ul = tag H.ul
+li :: Fusion () -> Fusion ()
+li = tag H.li
+
+
+instance Attributable (Fusion ()) where
+ Fusion eff ! at = Fusion $ do
+ eff
+ modify @Html $ \h -> h ! at
+
+
+instance Attributable (Fusion () -> Fusion ()) where
+ parent ! at = \child -> do
+ parent child
+ Fusion $ modify @Html $ \h -> h ! at
+
+
+instance Styleable (Fusion ()) where
+ modCSS f (Fusion eff) = Fusion $ do
+ eff
+
+ h <- get @Html
+ rsold <- get @[Rule]
+
+ let rsnew = f $ lookupRules (getClass h) (classMap rsold)
+
+ put $ L.nub $ rsnew <> rsold
+ put $ insertClass (fmap (.className) rsnew) h
+
+
+getClass :: MarkupM () -> [ClassName]
+getClass = \case
+ -- merge
+ AddAttribute (StaticString _ _ "class") _ (Text v) _ ->
+ classesFromValue v
+ -- forward
+ AddAttribute _ _ _ h -> getClass h
+ AddCustomAttribute _ _ h -> getClass h
+ Append _ ma -> getClass ma
+ -- ignore
+ Comment _ _ -> []
+ Empty _ -> []
+ -- insert
+ _ -> []
+
+
+insertClass :: [ClassName] -> MarkupM () -> MarkupM ()
+insertClass cs = \case
+ -- replace any existing class attribute
+ AddAttribute (StaticString _ _ "class") _ (Text _) h ->
+ addClassAttribute h
+ -- forward
+ AddAttribute raw key val h -> AddAttribute raw key val (insertClass cs h)
+ AddCustomAttribute c1 c2 h -> AddCustomAttribute c1 c2 (insertClass cs h)
+ Append mb ma -> Append mb (insertClass cs ma)
+ -- ignore
+ Comment s a -> Comment s a
+ Empty a -> Empty a
+ -- insert
+ h -> addClassAttribute h
+ where
+ addClassAttribute h =
+ AddAttribute "class" " class=\"" (Text $ classAttValue cs) h
+
+
+-- classRules :: Map ClassName Rule -> Text -> [Rule]
+-- classRules m val =
+-- lookupRules (classesFromValue val) m
+
+classMap :: [Rule] -> Map ClassName Rule
+classMap rs = M.fromList $ fmap (\r -> (r.className, r)) rs
+
+
+classAttValue :: [ClassName] -> Text
+classAttValue cns =
+ mconcat $ L.intersperse " " $ fmap (.text) cns
+
+
+classesFromValue :: Text -> [ClassName]
+classesFromValue = fmap ClassName . T.splitOn " "
+
+
+lookupRules :: [ClassName] -> Map ClassName Rule -> [Rule]
+lookupRules cn m =
+ mapMaybe (\c -> M.lookup c m) cn
+
+
+tag :: (Html -> Html) -> Fusion () -> Fusion ()
+tag tg cnt = do
+ let (rs, inner) = execHtml cnt
+ addHtml $ tg inner
+ addRules rs
+ pure ()
+
+
+addHtml :: Html -> Fusion ()
+addHtml h = Fusion $ do
+ modify (>> h)
+
+
+addRules :: [Rule] -> Fusion ()
+addRules rs = Fusion $ do
+ modify (rs <>)
+
+
+-- el :: [Rule] -> Eff es Html -> Eff es Html
+-- el rs = tag Html.div
+
+text :: Text -> Fusion ()
+text t = addHtml $ H.toMarkup t
+
+
+execHtml :: Fusion () -> ([Rule], Html)
+execHtml a = do
+ let ewrite = execState @Html (pure ()) $ a.eff :: Eff '[State [Rule]] Html
+ let (h, rs) = runPureEff $ runState @[Rule] [] ewrite
+ -- collapse the class tag into one
+ (rs, h)
+
+
+-- in -- h' = h ! class_ (rulesToClass rs) :: Html
+
+showHtml :: (Show a) => a -> Fusion ()
+showHtml a =
+ addHtml $ H.toMarkup $ show a
+
+-- this is kind of bullshit!
+-- collapseClasses :: [Rule] -> MarkupM a -> MarkupM a
+-- collapseClasses allRules mrk = do
+-- let (h', cs) = runPureEff $ runWriter @[String] $ collapseClasses' mrk
+-- traceM $ "CC " <> show cs
+-- let rs = uniqueRules $ mapMaybe (flip lookupRule allRules) (classNames cs)
+-- let classes = classesAttValue $ fmap (.className) rs
+-- case classes of
+-- Nothing -> h'
+-- Just av -> h' ! class_ (fromString $ unpack $ av)
+-- where
+-- classNames :: [String] -> [ClassName]
+-- classNames ss = mconcat $ fmap (fmap (ClassName . pack) . words) ss
+--
+-- collapseClasses' :: MarkupM a -> Eff '[Writer [String]] (MarkupM a)
+-- collapseClasses' = \case
+-- AddAttribute (StaticString _ _ "class") _ (String val) inner -> do
+-- traceM $ "@class " <> val
+-- tell [val]
+-- -- strip the attribute for now, keep collecting classes
+-- collapseClasses' inner
+-- AddAttribute (StaticString _ _ "class") _ val inner -> do
+-- -- traceM $ "@class " <> show val
+-- collapseClasses' inner
+-- AddCustomAttribute a b inner -> do
+-- traceM "@a"
+-- h <- collapseClasses' inner
+-- -- keep collecting classes
+-- pure $ AddCustomAttribute a b h
+-- Append a b -> do
+-- traceM " >> "
+-- -- collect classes separately
+-- let ha = collapseClasses allRules a
+-- let hb = collapseClasses allRules b
+-- pure $ Append ha hb
+-- -- Leaf, CustomLeaf, Content, Comment, Empty, Parent, CustomParent
+-- -- we don't need to walk children, because we execHtml in `tag`
+-- h -> pure h
diff --git a/example/app/Main.hs b/example/app/Main.hs
index 70bed93..671d46f 100644
--- a/example/app/Main.hs
+++ b/example/app/Main.hs
@@ -3,20 +3,13 @@
module Main where
-import Data.Bifunctor (first)
-import Data.Function ((&))
-import Data.Map (Map)
-import Data.Map.Strict qualified as M
+import Data.ByteString.Lazy (fromStrict)
import Data.String.Interpolate (i)
import Data.Text (Text)
-import Debug.Trace
import Network.HTTP.Types (status200, status404)
import Network.Wai
import Network.Wai.Handler.Warp as Warp
-import Web.View
-import Web.View.Render
-import Web.View.Style
-import Web.View.Types
+import Web.Atomic
main :: IO ()
@@ -25,16 +18,36 @@ main = do
Warp.run 3010 app
-buttons :: View c ()
-buttons = col (gap 10 . pad 20) $ do
- el (bold . fontSize 32) "My page"
+nav :: Html () -> Html ()
+nav = tag "nav"
- row (gap 10) $ do
- button (btn Primary) "Do Something"
- button (btn Secondary) "Cancel"
- --
- button' Secondary "Another Example"
+button :: Html () -> Html ()
+button = tag "button"
+
+
+input :: Html ()
+input = tag "button" none
+
+
+placeholder :: (Attributable h) => AttValue -> Attributes h -> Attributes h
+placeholder = att "placeholder"
+
+
+autofocus :: (Attributable h) => Attributes h -> Attributes h
+autofocus = att "autofocus" ""
+
+
+buttons :: Html ()
+buttons = col ~ gap 10 . pad 20 $ do
+ el ~ bold . fontSize 32 $ "My page"
+ el ~ hover bold $ "hover"
+
+ row ~ gap 10 $ do
+ button ~ btn Primary $ "Do Something"
+ button ~ btn Secondary $ "Cancel"
+
+ button' Secondary ~ width 100 $ "Another Example"
where
-- Make style functions to encourage reuse
btn c = bg c . hover (bg (light c)) . color White . rounded 3 . pad 15
@@ -43,216 +56,197 @@ buttons = col (gap 10 . pad 20) $ do
light _ = Gray
-- alternatively, we can make View functions
- button' c = button (btn c)
+ button' c = button ~ btn c
-inputs :: View c ()
+inputs :: Html ()
inputs = do
- layout (pad 20 . gap 10) $ do
- el bold "INPUT"
- input (border 1 . pad 10 . bg White . placeholder "Not Focused")
- input (border 1 . pad 10 . bg White . placeholder "Should Focus" . autofocus)
+ col ~ grow . pad 20 . gap 10 $ do
+ el ~ bold $ "INPUT"
+ input @ placeholder "Not Focused" ~ border 1 . pad 10 . bg White
+ input @ placeholder "Should Focus" @ autofocus ~ border 1 . pad 10 . bg White
-responsive :: View c ()
+responsive :: Html ()
responsive = do
- layout (big flexRow) $ do
- nav (gap 10 . pad 20 . bg Primary . color White . small topbar . big sidebar) $ do
- el bold "SIDEBAR"
- el_ "One"
- el_ "Two"
- el_ "Three"
-
- col (scroll . grow . pad 20 . gap 20 . bg White) $ do
- el (bold . fontSize 24) "Make the window smaller"
- el_ "This demonstrates how to create a responsive design. Resize the window under 800px wide and the nav bar will switch to a top bar"
-
- col (color Gray . gap 20) $ do
- el_ $ text lorem
- el_ $ text lorem
- el_ $ text lorem
- el_ $ text lorem
- el_ $ text lorem
- el_ $ text lorem
- el_ $ text lorem
+ nav ~ pad 20 . gap 10 . bg Primary . color White . menu $ do
+ el ~ bold $ "MENU"
+ el "One"
+ el "Two"
+ el "Three"
+
+ col ~ content . grow . pad 20 . gap 20 . bg White $ do
+ el ~ bold . fontSize 24 $ "Make the window smaller"
+ el "This demonstrates how to create a responsive design. Resize the window under 800px wide and the nav bar will switch to a top bar"
+
+ col ~ color Gray . gap 20 $ do
+ el $ text lorem
+ el $ text lorem
+ el $ text lorem
+ el $ text lorem
+ el $ text lorem
+ el $ text lorem
+ el $ text lorem
where
- sidebar = width 250 . flexCol
- topbar = height 100 . flexRow
+ menuWidth = 250
+ menuHeight = 70
+
+ menu = big sidebar . small topbar
+ sidebar = width menuWidth . position Fixed . flexCol . top 0 . bottom 0 . left 0
+ topbar = height menuHeight . position Fixed . flexRow . top 0 . left 0 . right 0
+
+ content = big (margin (L menuWidth)) . small (margin (T menuHeight))
+
+ big :: (Styleable c) => (CSS c -> CSS c) -> (CSS c -> CSS c)
big = media (MinWidth 800)
+
+ small :: (Styleable c) => (CSS c -> CSS c) -> (CSS c -> CSS c)
small = media (MaxWidth 800)
-holygrail :: View c ()
-holygrail = layout id $ do
- row (bg Primary) "Top Bar"
- row grow $ do
- col (bg Secondary) "Left Sidebar"
- col grow $ do
+holygrail :: Html ()
+holygrail = col ~ grow $ do
+ row ~ bg Primary $ "Top Bar"
+ row ~ grow $ do
+ col ~ bg Secondary $ "Left Sidebar"
+ col ~ grow $ do
text "Content Upper Left"
space
- row id $ do
+ row $ do
space
text "Content Bottom Right"
- col (bg Secondary) "Right Sidebar"
- row (bg Primary) "Bottom Bar"
+ col ~ bg Secondary $ "Right Sidebar"
+ row ~ bg Primary $ "Bottom Bar"
-tooltips :: View c ()
+tooltips :: Html ()
tooltips = do
- col (pad 10 . gap 10 . width 300) $ do
- el bold "CSS ONLY TOOLTIPS"
+ col ~ pad 10 . gap 10 . width 300 $ do
+ el ~ bold $ "CSS ONLY TOOLTIPS"
mapM_ viewItemRow ["One", "Two", "Three", "Four", "Five", "Six"]
where
viewItemRow item = do
- -- you must have a name?
- stack (hover (children "tooltip" visible)) $ do
- layer id $ el (border 1 . bg White) $ text item
- layer (popup (TR 10 10) . tooltip . zIndex 1 . hidden) $ do
- viewTooltipDetails item
-
- viewTooltipDetails item =
- col (border 2 . gap 5 . bg White . pad 5) $ do
- el bold "ITEM DETAILS"
- el_ $ text item
- el_ "details lorem blah blah blah"
-
- tooltip = addClass $ cls "tooltip"
-
-
--- TODO: run the mod, any classes added should be modified
--- this will ignore any attributes you add!
-children :: Text -> Mod id -> Mod id
-children child f atts =
- let Attributes cs _ = f mempty
- final =
- Attributes
- { classes = atts.classes <> retargetCSS cs
- , other = atts.other
- }
- in trace (show $ final) final
- where
- retargetCSS :: Map Selector Class -> Map Selector Class
- retargetCSS classes =
- M.fromList $ fmap (\(s, c) -> (targetChildren s, c{selector = targetChildren s})) $ M.toList classes
-
- targetChildren :: Selector -> Selector
- targetChildren sel =
- let res = sel{className = sel.className, child = Just $ ChildWithName child}
- in trace (show (selectorText sel, selectorText res)) res
-
-
-visible :: Mod id
-visible = addClass $ cls "visible" & prop @Text "visibility" "visible"
-
-
-hidden :: Mod id
-hidden = addClass $ cls "hidden" & prop @Text "visibility" "hidden"
-
-
-stacks :: View c ()
-stacks = layout id $ do
- row (bg Primary . bold . pad 10 . color White) "Stacks"
- col (pad 10 . gap 10) $ do
- el_ "Stacks put contents on top of each other"
- stack (border 1) $ do
- layer (bg Light . pad 10) "In the background"
- layer (pad 10) $ do
- row id $ do
+ col ~ stack . showTooltips . hover (color red) . pointer $ do
+ el ~ border 1 . bg White $ text item
+ el ~ cls "tooltip" . popup (TR 10 10) . zIndex 1 . visibility Hidden $ do
+ col ~ border 2 . gap 5 . bg White . pad 5 $ do
+ el ~ bold $ "ITEM DETAILS"
+ el $ text item
+ el "details lorem blah blah blah"
+
+ showTooltips =
+ css
+ "tooltips"
+ ".tooltips:hover > .tooltip"
+ (declarations $ visibility Visible)
+
+ red = HexColor "#F00"
+
+
+stacks :: Html ()
+stacks = col ~ grow $ do
+ row ~ bg Primary . bold . pad 10 . color White $ "Stacks"
+ col ~ pad 10 . gap 10 $ do
+ el "Stacks put contents on top of each other"
+ col ~ stack . border 1 $ do
+ el ~ bg Light . pad 10 $ "In the background"
+ col ~ pad 10 $ do
+ row $ do
space
- el (bg SecondaryLight . grow . pad 5) "Above"
- layer (pad (XY 15 5)) $ do
- row id $ do
+ el ~ bg SecondaryLight . grow . pad 5 $ "Above"
+ el ~ pad (XY 15 5) $ do
+ row $ do
space
- el (bg Primary . pad 10 . color White) "Max Above!"
-
- el_ "We can collapse items in a stack so they don't affect the width"
- stack (bg Light . pad 10) $ do
- layer id $ do
- row (gap 5) $ do
- el_ "Some"
- el_ "Stuff"
- el_ "Here"
- layer (popup (BR 0 0)) $ col (pad 10 . bg SecondaryLight) $ do
- el_ "One"
- el_ "Two"
- el_ "Three"
- el_ "Four"
-
- stack (border 1) $ do
- layer (bg Light) "Background"
- layer (bg SecondaryLight . opacity 0.8 . popup (X 50)) $ do
- el_ "HMM"
- el_ "OK"
- layer (flexRow . bg Warning . opacity 0.8) $ do
+ el ~ bg Primary . pad 10 . color White $ "Max Above@"
+
+ el "We can collapse items in a stack so they don't affect the width"
+ col ~ stack . bg Light . pad 10 $ do
+ col $ do
+ row ~ gap 5 $ do
+ el "Some"
+ el "Stuff"
+ el "Here"
+ col ~ popup (BR 0 0) . pad 10 . bg SecondaryLight $ do
+ el "One"
+ el "Two"
+ el "Three"
+ el "Four"
+
+ col ~ stack . border 1 $ do
+ col ~ bg Light $ "Background"
+ col ~ bg SecondaryLight . opacity 0.8 . popup (X 50) $ do
+ el "HMM"
+ el "OK"
+ row ~ bg Warning . opacity 0.8 $ do
space
- el_ "Overlay"
-
- el_ "Example Popup Search"
- stack (border 1) $ do
- layer id $ row (bg Light . pad 10) "This is a search bar"
- layer (popup (TRBL 43 5 5 5) . border 1) $ do
- col (bg SecondaryLight . pad (L 50) . pad (R 50)) $ do
- el (hover (bg White) . pointer) "I am a popup"
- el_ "I am a popup"
- el_ "I am a popup"
- el_ "I am a popup"
-
- col (gap 10) $ do
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
- el_ "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
-
- col (border 1 . popup (TR 5 5)) "I AM AN ELEMENT"
-
-
-texts :: View c ()
-texts = col (gap 10 . pad 20) $ do
- el (bg Warning . bg Error) "Error"
- el (bg Error . bg Warning) "Warning"
-
- el (pad 10) $ do
- el (parent "htmx-request" flexRow . hide) "Loading..."
- el (parent "htmx-request" hide . flexRow) "Normal Content"
-
- el italic "Italic Text"
- el underline "Underline Text"
- el bold "Bold Text"
-
- ol id $ do
- let nums = list Decimal
- li nums "first"
- li nums "second"
- li nums "third"
-
- ul id $ do
- li (list Disc) "first"
- li (list Disc) "second"
- li (list None) "third"
-
- el bold "flexWrap"
- row (gap 5 . width 200 . flexWrap WrapReverse) $ do
- el (border 1 . pad 5) "one"
- el (border 1 . pad 5) "two"
- el (border 1 . pad 5) "three"
- el (border 1 . pad 5) "four"
- el (border 1 . pad 5) "five"
- el (border 1 . pad 5) "six"
- el (border 1 . pad 5) "seven"
- el (border 1 . pad 5) "eight"
- el (border 1 . pad 5) "nine"
-
- el bold "textWrap"
- el (border 1 . width 200 . textWrap NoWrap) (text lorem)
- el (border 1 . width 200 . textWrap Wrap) (text lorem)
-
- el bold "css order"
- el (flexCol . flexRow) $ do
+ el "Overlay"
+
+ el ~ bold $ "Example Popup Search"
+ el ~ stack . border 1 $ do
+ row ~ bg Light . pad 10 $ "This is a search bar"
+ col ~ popup (TRBL 43 5 5 5) . border 1 $ do
+ col ~ bg SecondaryLight . pad (L 50) . pad (R 50) $ do
+ el ~ hover (bg White) . pointer $ "I am a popup"
+ el "I am a popup"
+ el "I am a popup"
+ el "I am a popup"
+
+ col ~ gap 10 $ do
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+ el "Content asldkjfalsdk jjklasd flkajsd flkjasd lfkjalskdfj alsdkjf "
+
+ col ~ border 1 . popup (TR 5 5) $ "I AM AN ELEMENT"
+
+
+texts :: Html ()
+texts = col ~ gap 10 . pad 20 $ do
+ el ~ bg Warning . bg Error $ "Error"
+ -- el ~ bg Error . bg Warning ~ if True then bold else id $ "Warning"
+
+ el ~ pad 10 $ do
+ el ~ descendentOf "htmx-request" flexRow . display None $ "Loading..."
+ el ~ descendentOf "htmx-request" (display None) . flexRow $ "Normal Content"
+
+ el ~ italic $ "Italic Text"
+ el ~ underline $ "Underline Text"
+ el ~ bold $ "Bold Text"
+
+ -- ol [] $ do
+ -- let nums = list Decimal
+ -- li nums "first"
+ -- li nums "second"
+ -- li nums "third"
+ --
+ -- ul [] $ do
+ -- li (list Disc) "first"
+ -- li (list Disc) "second"
+ -- li (list None) "third"
+
+ el ~ bold $ "flexWrap"
+ row ~ gap 5 . width 200 . flexWrap WrapReverse $ do
+ el ~ border 1 . pad 5 $ "one"
+ el ~ border 1 . pad 5 $ "two"
+ el ~ border 1 . pad 5 $ "three"
+ el ~ border 1 . pad 5 $ "four"
+ el ~ border 1 . pad 5 $ "five"
+ el ~ border 1 . pad 5 $ "six"
+ el ~ border 1 . pad 5 $ "seven"
+ el ~ border 1 . pad 5 $ "eight"
+ el ~ border 1 . pad 5 $ "nine"
+
+ el ~ bold $ "White Space: text wrap"
+ el ~ border 1 . width 200 . whiteSpace NoWrap . overflow Hidden $ text lorem
+ el ~ border 1 . width 200 . whiteSpace Wrap $ text lorem
+
+ el ~ bold $ "css order"
+ el ~ flexCol . flexRow $ do
text "WOOT"
text "BOOT"
@@ -261,18 +255,41 @@ lorem :: Text
lorem = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
-examples :: View c ()
-examples = col (pad 20 . gap 15) $ do
- el (bold . fontSize 24) "Layout"
- link "buttons" lnk "Buttons"
- link "responsive" lnk "Responsive"
- link "holygrail" lnk "Holy Grail"
- link "stacks" lnk "Stacks"
- link "text" lnk "Text"
- link "inputs" lnk "Inputs"
- link "tooltips" lnk "Tooltips"
+longContent :: Html ()
+longContent = do
+ col ~ gap 10 . pad 10 $ do
+ resultsTable $ replicate 100 "asdf"
+ where
+ resultsTable langs = do
+ col ~ gap 15 $ do
+ mapM_ languageRow langs
+ where
+ languageRow lang = do
+ col ~ gap 5 $ do
+ button ~ pad (XY 10 2) . border 1 . hover (bg Light) $ "Select"
+ row $ do
+ row $ do
+ row $ do
+ row $ do
+ row $ do
+ tag "div" ~ bg Light . pad (XY 10 2) . fontSize 16 . textAlign AlignCenter $ text lang
+
+
+-- rows = textAlign AlignCenter . border 1 . borderColor GrayLight
+
+examples :: Html ()
+examples = col ~ pad 20 . gap 15 $ do
+ el ~ bold . fontSize 24 $ "Layout"
+ link "buttons" "Buttons"
+ link "responsive" "Responsive"
+ link "holygrail" "Holy Grail"
+ link "stacks" "Stacks"
+ link "text" "Text"
+ link "inputs" "Inputs"
+ link "tooltips" "Tooltips"
+ link "long-content" "Long Content"
where
- lnk = color Primary
+ link href = tag "a" @ att "href" href ~ color Primary
app :: Application
@@ -286,6 +303,8 @@ app req respond = do
["text"] -> view texts
["inputs"] -> view inputs
["tooltips"] -> view tooltips
+ ["long-content"] -> view longContent
+ ["static", "reset.css"] -> reset
_ -> notFound
where
html h =
@@ -299,10 +318,13 @@ app req respond = do
document cnt =
[i|
-
+
#{cnt}
|]
+ reset =
+ respond $ responseLBS status200 [("Content-Type", "text/css; charset=utf-8")] (fromStrict cssResetEmbed)
+
data AppColor
= White
diff --git a/example/example.cabal b/example/example.cabal
index 77e95e7..7c02a2f 100644
--- a/example/example.cabal
+++ b/example/example.cabal
@@ -67,6 +67,9 @@ executable example
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
+ other-modules:
+ Example.Blaze
+
default-extensions:
OverloadedStrings
OverloadedRecordDot
@@ -76,13 +79,18 @@ executable example
-- Other library packages from which modules are imported.
build-depends:
base >=4.16,
- web-view,
+ atomic-css,
containers,
http-types,
string-interpolate,
text,
wai,
- warp
+ warp,
+ blaze-html,
+ blaze-markup,
+ bytestring,
+ effectful
+
-- Directories containing source files.
hs-source-dirs: app
diff --git a/flake.nix b/flake.nix
index e47a25f..d3ecb8d 100644
--- a/flake.nix
+++ b/flake.nix
@@ -1,5 +1,5 @@
{
- description = "web-view overlay, development and examples";
+ description = "atomic-css overlay, development and examples";
nixConfig = {
extra-substituters = [
@@ -29,7 +29,7 @@
pre-commit-hooks,
}:
let
- packageName = "web-view";
+ packageName = "atomic-css";
examplesName = "example";
src = nix-filter.lib {
root = ./.;
diff --git a/package.yaml b/package.yaml
index 917b1ca..37069e1 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,24 +1,25 @@
-name: web-view
-version: 0.7.0
-synopsis: Type-safe HTML and CSS with intuitive layouts and composable styles.
-homepage: https://github.com/seanhess/web-view
-github: seanhess/web-view
+name: atomic-css
+version: 0.1.0
+synopsis: Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI
+
+homepage: https://github.com/seanhess/atomic-css
+github: seanhess/atomic-css
license: BSD-3-Clause
license-file: LICENSE
author: Sean Hess
maintainer: seanhess@gmail.com
category: Web
description:
- Type-safe HTML and CSS with intuitive layouts and composable styles. Inspired by Tailwindcss and Elm-UI
+ Type-safe, composable CSS utility functions. Inspired by Tailwindcss and Elm-UI
.
- See documentation for the @Web.View@ module below
+ See documentation for the @Web.Atomic@ module below
extra-doc-files:
- README.md
- CHANGELOG.md
extra-source-files:
- - embed/preflight.css
+ - embed/reset.css
language: GHC2021
@@ -35,6 +36,10 @@ default-extensions:
- OverloadedRecordDot
- DuplicateRecordFields
- NoFieldSelectors
+ - TypeFamilies
+ - DerivingStrategies
+ - DefaultSignatures
+ - DeriveAnyClass
dependencies:
- base >=4.16 && <5
@@ -43,7 +48,6 @@ dependencies:
- casing > 0.1.3.0 && <0.2
- effectful-core >= 2.3 && <3
- text >= 1.2 && <3
- - string-interpolate >= 0.3.2 && <0.4
- file-embed >= 0.0.10 && <0.1
- http-types >= 0.12 && <0.13
- html-entities >= 1.1.4.7 && <1.2
@@ -61,5 +65,5 @@ tests:
- -with-rtsopts=-N
- -F -pgmF=skeletest-preprocessor
dependencies:
- - web-view
+ - atomic-css
- skeletest
diff --git a/src/Web/Atomic.hs b/src/Web/Atomic.hs
new file mode 100644
index 0000000..b6da12a
--- /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
index 0000000..c794d56
--- /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
index 0000000..b541837
--- /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 '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
index 0000000..83683a1
--- /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
index 0000000..6a7d9dc
--- /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 '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
index 0000000..5650456
--- /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
index 0000000..df20c69
--- /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
index 0000000..d7f0490
--- /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
index 0000000..4a22e34
--- /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
index 0000000..56837df
--- /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
index 0000000..ffab452
--- /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 '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
index 0000000..3dff781
--- /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
index 0000000..ffdc3da
--- /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
index 0000000..c1630e0
--- /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
index 0000000..a28ceb1
--- /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
index 0000000..8035d1c
--- /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
index 0000000..0d11197
--- /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
index 0000000..cef897c
--- /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
index 0000000..41ae778
--- /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/src/Web/View.hs b/src/Web/View.hs
deleted file mode 100644
index 735a7d6..0000000
--- a/src/Web/View.hs
+++ /dev/null
@@ -1,227 +0,0 @@
-{- |
-Module: Web.View
-Copyright: (c) 2023 Sean Hess
-License: BSD3
-Maintainer: Sean Hess
-Stability: experimental
-Portability: portable
-
-Type-safe HTML and CSS with intuitive layout and composable styles. Inspired by Tailwindcss and Elm-UI
--}
-module Web.View
- ( -- * How to use this library
- -- $use
-
- -- ** Rendering 'View's
- renderText
- , renderLazyText
- , renderLazyByteString
-
- -- ** Full HTML Documents
- -- $documents
- , module Web.View.Reset
-
- -- * Views
- , View
-
- -- ** Mods
- , Mod
-
- -- * Elements
- , el
- , el_
-
- -- ** Layout
- , layout
- , root
- , col
- , row
- , space
- , nav
- , stack
- , Layer
- , layer
- , popup
- , scroll
- , grow
- , flexRow
- , flexCol
- , hide
- , truncate
-
- -- ** Content
- , text
- , raw
- , none
- , pre
- , code
-
- -- ** Inputs
- , form
- , input
- , name
- , value
- , placeholder
- , autofocus
- , label
- , link
- , button
-
- -- ** Lists
- , ol
- , ul
- , li
-
- -- ** Tables
- , table
- , tcol
- , th
- , td
- , TableHead
- , TableColumn
-
- -- ** Document Metadata
- , script
- , style
- , stylesheet
-
- -- * CSS Modifiers
- , width
- , height
- , minWidth
- , minHeight
- , pad
- , gap
- , opacity
- , shadow
- , Shadow
- , Inner (..)
- , rounded
- , fontSize
- , color
- , bg
- , bold
- , italic
- , underline
- , border
- , borderColor
- , pointer
- , position
- , Position (..)
- , zIndex
- , offset
- , textAlign
- , Align (..)
- , list
- , ListType (..)
- , display
- , Display (..)
- , transition
- , TransitionProperty (..)
- , Ms
- , flexWrap
- , textWrap
- , FlexWrap (..)
- , TextWrap
- , Wrap (..)
-
- -- ** Selector States
- , hover
- , active
- , even
- , odd
- , media
- , Media (..)
- , parent
-
- -- * View Context
- , context
- , addContext
-
- -- * Creating New Elements and Modifiers
- , tag
- , att
-
- -- * Types
- , Sides (..)
- , PxRem
- , Length (..)
- , ToColor (..)
- , HexColor (..)
- , None (..)
- , Attributes
-
- -- * Url
- , module Web.View.Types.Url
- , Query
- ) where
-
-import Network.HTTP.Types (Query)
-import Web.View.Element
-import Web.View.Layout
-import Web.View.Render
-import Web.View.Reset
-import Web.View.Style
-import Web.View.Types
-import Web.View.Types.Url
-import Web.View.View
-import Prelude hiding (even, head, odd, truncate)
-
-
-{- $use
-
-Create styled `View's using composable Haskell functions
-
-> myView :: View ctx ()
-> myView = col (gap 10) $ do
-> el (bold . fontSize 32) "My page"
-> button (border 1) "Click Me"
-
-This represents an HTML fragment with embedded CSS definitions
-
->
->
->
->
My page
->
->
-
-Leverage the full power of Haskell functions for reuse, instead of relying on CSS.
-
-> header = bold
-> h1 = header . fontSize 32
-> h2 = header . fontSize 24
-> page = gap 10
->
-> myView = col page $ do
-> el h1 "My Page"
-> ...
-
-This approach is inspired by Tailwindcss' [Utility Classes](https://tailwindcss.com/docs/utility-first)
--}
-
-
-{- $documents
-
-Create a full HTML document by embedding the view and 'cssResetEmbed'
-
-> import Data.String.Interpolate (i)
-> import Web.View
->
-> toDocument :: Text -> Text
-> toDocument content =
-> [i|
-> My Website
->
-> #{content}
-> |]
->
-> myDocument :: Text
-> myDocument = toDocument $ renderText myView
--}
diff --git a/src/Web/View/Element.hs b/src/Web/View/Element.hs
deleted file mode 100644
index 63898a7..0000000
--- a/src/Web/View/Element.hs
+++ /dev/null
@@ -1,209 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module Web.View.Element where
-
-import Control.Monad (forM_)
-import Data.Function ((&))
-import Data.Text (Text)
-import Effectful
-import Effectful.Writer.Static.Local
-import Web.View.Style
-import Web.View.Types
-import Web.View.Types.Url
-import Web.View.View
-
-
-{- | A basic element
-
-> el (bold . pad 10) "Hello"
--}
-el :: Mod c -> View c () -> View c ()
-el = tag "div"
-
-
-{- | A basic element, with no modifiers
-
-> el_ "Hello"
--}
-el_ :: View c () -> View c ()
-el_ = tag "div" id
-
-
-{- | Add text to a view. Not required for string literals
-
-> el_ $ do
-> "Hello: "
-> text user.name
--}
-text :: Text -> View c ()
-text t = viewAddContent $ Text t
-
-
-{- | Embed static, unescaped HTML or SVG. Take care not to use 'raw' with user-generated content.
-
-> spinner = raw ""
--}
-raw :: Text -> View c ()
-raw t = viewAddContent $ Raw t
-
-
-{- | Do not show any content
-
-> if isVisible
-> then content
-> else none
--}
-none :: View c ()
-none = pure ()
-
-
-pre :: Mod c -> Text -> View c ()
-pre f t = tag "pre" f (text t)
-
-
-code :: Mod c -> Text -> View c ()
-code f t = tag "code" f (text t)
-
-
--- | A hyperlink to the given url
-link :: Url -> Mod c -> View c () -> View c ()
-link u f = tag "a" (att "href" (renderUrl u) . f)
-
-
--- * Inputs
-
-
-form :: Mod c -> View c () -> View c ()
-form = tag "form"
-
-
-input :: Mod c -> View c ()
-input m = tag "input" (m . att "type" "text") none
-
-
-name :: Text -> Mod c
-name = att "name"
-
-
-value :: Text -> Mod c
-value = att "value"
-
-
-label :: Mod c -> View c () -> View c ()
-label = tag "label"
-
-
-button :: Mod c -> View c () -> View c ()
-button = tag "button"
-
-
-placeholder :: Text -> Mod id
-placeholder = att "placeholder"
-
-
-autofocus :: Mod c
-autofocus = att "autofocus" ""
-
-
--- * Document Metadata
-
-
-script :: Text -> View c ()
-script src = tag "script" (att "type" "text/javascript" . att "src" src) none
-
-
-style :: Text -> View c ()
-style cnt = tag "style" (att "type" "text/css") (text $ "\n" <> cnt <> "\n")
-
-
-stylesheet :: Text -> View c ()
-stylesheet href = tag "link" (att "rel" "stylesheet" . att "href" href) none
-
-
--- * Tables
-
-
-{- | Create a type safe data table by specifying columns
-
-> usersTable :: [User] -> View c ()
-> usersTable us = do
-> table id us $ do
-> tcol (th hd "Name") $ \u -> td cell $ text u.name
-> tcol (th hd "Email") $ \u -> td cell $ text u.email
-> where
-> hd = cell . bold
-> cell = pad 4 . border 1
--}
-table :: Mod c -> [dt] -> Eff '[Writer [TableColumn c dt]] () -> View c ()
-table f dts wcs = do
- c <- context
- let cols = runPureEff . execWriter $ wcs
- tag "table" borderCollapse $ do
- tag "thead" id $ do
- tag "tr" f $ do
- forM_ cols $ \tc -> do
- addContext (TableHead c) tc.headCell
- tag "tbody" id $ do
- forM_ dts $ \dt -> do
- tag "tr" f $ do
- forM_ cols $ \tc -> do
- addContext dt $ tc.dataCell dt
- where
- borderCollapse :: Mod c
- borderCollapse = addClass $ cls "brd-cl" & prop @Text "border-collapse" "collapse"
-
-
-tcol :: forall dt c. View (TableHead c) () -> (dt -> View dt ()) -> Eff '[Writer [TableColumn c dt]] ()
-tcol hd view = do
- tell ([TableColumn hd view] :: [TableColumn c dt])
-
-
-th :: Mod c -> View c () -> View (TableHead c) ()
-th f cnt = do
- TableHead c <- context
- addContext c $ tag "th" f cnt
-
-
-td :: Mod () -> View () () -> View dt ()
-td f c = addContext () $ tag "td" f c
-
-
-newtype TableHead a = TableHead a
-
-
-data TableColumn c dt = TableColumn
- { headCell :: View (TableHead c) ()
- , dataCell :: dt -> View dt ()
- }
-
-
--- * Lists
-
-
-newtype ListItem c a = ListItem (View c a)
- deriving newtype (Functor, Applicative, Monad)
-
-
-{- | List elements do not include any inherent styling but are useful for accessibility. See 'Web.View.Style.list'.
-
-> ol id $ do
-> let nums = list Decimal
-> li nums "one"
-> li nums "two"
-> li nums "three"
--}
-ol :: Mod c -> ListItem c () -> View c ()
-ol f (ListItem cnt) = do
- tag "ol" f cnt
-
-
-ul :: Mod c -> ListItem c () -> View c ()
-ul f (ListItem cnt) = do
- tag "ul" f cnt
-
-
-li :: Mod c -> View c () -> ListItem c ()
-li f cnt = ListItem $ do
- tag "li" f cnt
diff --git a/src/Web/View/Layout.hs b/src/Web/View/Layout.hs
deleted file mode 100644
index 79b0d6e..0000000
--- a/src/Web/View/Layout.hs
+++ /dev/null
@@ -1,196 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase #-}
-
-module Web.View.Layout where
-
-import Data.Function
-import Data.Text
-import Web.View.Element
-import Web.View.Style
-import Web.View.Types
-import Web.View.View (View, tag)
-
-
-{- | We can intuitively create layouts with combinations of 'row', 'col', 'stack', 'grow', and 'space'
-
-Wrap main content in 'layout' to allow the view to consume vertical screen space
-
-@
-holygrail :: 'View' c ()
-holygrail = 'layout' id $ do
- 'row' section "Top Bar"
- 'row' 'grow' $ do
- 'col' section "Left Sidebar"
- 'col' (section . 'grow') "Main Content"
- 'col' section "Right Sidebar"
- 'row' section "Bottom Bar"
- where section = 'border' 1
-@
--}
-layout :: Mod c -> View c () -> View c ()
-layout f = el (root . f)
-
-
-{- | As `layout` but as a 'Mod'
-
-> holygrail = col root $ do
-> ...
--}
-root :: Mod c
-root = flexCol . fillViewport
- where
- fillViewport =
- addClass $
- cls "layout"
- -- [ ("white-space", "pre")
- & prop @Text "width" "100vw"
- & prop @Text "height" "100vh"
- -- not sure if this property is necessary, copied from older code
- & prop @Text "min-height" "100vh"
- & prop @Text "z-index" "0"
-
-
-{- | Lay out children in a column.
-
-> col grow $ do
-> el_ "Top"
-> space
-> el_ "Bottom"
--}
-col :: Mod c -> View c () -> View c ()
-col f = el (flexCol . f)
-
-
-{- | Lay out children in a row
-
-> row id $ do
-> el_ "Left"
-> space
-> el_ "Right"
--}
-row :: Mod c -> View c () -> View c ()
-row f = el (flexRow . f)
-
-
-{- | Grow to fill the available space in the parent 'Web.View.Layout.row' or 'Web.View.Layout.col'
-
-> row id $ do
-> el grow none
-> el_ "Right"
--}
-grow :: Mod c
-grow = addClass $ cls "grow" & prop @Int "flex-grow" 1
-
-
-{- | Space that fills the available space in the parent 'Web.View.Layout.row' or 'Web.View.Layout.col'.
-
-
-> row id $ do
-> space
-> el_ "Right"
-
-This is equivalent to an empty element with 'grow'
-
-> space = el grow none
--}
-space :: View c ()
-space = el grow none
-
-
-{- | Make a fixed 'layout' by putting 'scroll' on a child-element
-
-> document = row root $ do
-> nav (width 300) "Sidebar"
-> col (grow . scroll) "Main Content"
--}
-scroll :: Mod c
-scroll = addClass $ cls "scroll" & prop @Text "overflow" "auto"
-
-
--- | A Nav element
-nav :: Mod c -> View c () -> View c ()
-nav f = tag "nav" (f . flexCol)
-
-
-{- | Stack children on top of each other. Each child has the full width. See 'popup'
-
-> stack id $ do
-> layer id "Background"
-> layer (bg Black . opacity 0.5) "Overlay"
--}
-stack :: Mod c -> Layer c () -> View c ()
-stack f (Layer children) = do
- tag "div" (f . container . absChildren) children
- where
- container =
- addClass $
- cls "stack"
- & prop @Text "position" "relative"
- & prop @Text "display" "grid"
- & prop @Text "overflow" "visible"
- absChildren =
- addClass $
- Class absSelector mempty
- & prop @Text "grid-area" "1 / 1"
- & prop @Text "min-height" "fit-content"
- absSelector = (selector "abs-childs"){child = Just AllChildren}
-
-
-newtype Layer c a = Layer (View c a)
- deriving newtype (Functor, Applicative, Monad)
-
-
--- | A normal layer contributes to the size of the parent. See 'stack'
-layer :: Mod c -> View c () -> Layer c ()
-layer f cnt = Layer $ do
- el (flexCol . f) cnt
-
-
-{- | This 'layer' is not included in the 'stack' size, and covers content outside of it. If used outside of stack, the popup is offset from the entire page.
-
-> stack id $ do
-> layer id $ input (value "Autocomplete Box")
-> layer (popup (TRBL 50 0 0 0)) $ do
-> el_ "Item 1"
-> el_ "Item 2"
-> el_ "Item 3"
-> el_ "This is covered by the menu"
--}
-popup :: Sides Length -> Mod c
-popup sides =
- position Absolute . offset sides
-
-
--- | Hide an element. See 'display'
-hide :: Mod c
-hide = display None
-
-
--- | Set container to be a row. Favor 'Web.View.Layout.row' when possible
-flexRow :: Mod c
-flexRow =
- addClass $
- cls "row"
- & prop @Text "display" "flex"
- & prop @Text "flex-direction" "row"
-
-
--- | Set container to be a column. Favor 'Web.View.Layout.col' when possible
-flexCol :: Mod c
-flexCol =
- addClass $
- cls "col"
- & prop @Text "display" "flex"
- & prop @Text "flex-direction" "column"
-
-
--- | Cut off the contents of the element
-truncate :: Mod c
-truncate =
- addClass $
- cls "truncate"
- & prop @Text "white-space" "nowrap"
- & prop @Text "overflow" "hidden"
- & prop @Text "text-overflow" "ellipsis"
diff --git a/src/Web/View/Render.hs b/src/Web/View/Render.hs
deleted file mode 100644
index 2d116e8..0000000
--- a/src/Web/View/Render.hs
+++ /dev/null
@@ -1,258 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
-
-module Web.View.Render where
-
-import Data.ByteString.Lazy qualified as BL
-import Data.Function ((&))
-import Data.Map.Strict qualified as M
-import Data.Maybe (mapMaybe)
-import Data.String (fromString)
-import Data.String.Interpolate (i)
-import Data.Text (Text, intercalate, pack, toLower)
-import Data.Text qualified as T
-import Data.Text.Lazy qualified as L
-import Data.Text.Lazy.Encoding qualified as LE
-import HTMLEntities.Text qualified as HE
-import Web.View.Types
-import Web.View.View (View, ViewState (..), runView)
-
-
-{- | Renders a 'View' as HTML with embedded CSS class definitions
-
->>> renderText $ el bold "Hello"
-
-
Hello
--}
-renderText :: View () () -> Text
-renderText = renderText' ()
-
-
-renderLazyText :: View () () -> L.Text
-renderLazyText = L.fromStrict . renderText
-
-
-renderLazyByteString :: View () () -> BL.ByteString
-renderLazyByteString = LE.encodeUtf8 . renderLazyText
-
-
-data Line = Line {end :: LineEnd, indent :: Int, text :: Text}
- deriving (Show, Eq)
-
-
-data LineEnd
- = Newline
- | Inline
- deriving (Eq, Show)
-
-
--- | Render lines to text
-renderLines :: [Line] -> Text
-renderLines = snd . 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 " "
-
-
-{- | Render with the specified view context
-
-> renderText' () $ el bold "Hello"
--}
-renderText' :: c -> View c () -> Text
-renderText' c vw =
- let vst = runView c vw
- css = renderCSS vst.css
- in renderLines $ addCss css $ mconcat $ fmap (renderContent 2) vst.contents
- where
- addCss :: [Line] -> [Line] -> [Line]
- addCss [] cnt = cnt
- addCss css cnt = do
- styleLines css <> (Line Newline 0 "" : cnt)
-
- styleLines :: [Line] -> [Line]
- styleLines css =
- [Line Newline 0 ""]
-
-
-renderContent :: Int -> Content -> [Line]
-renderContent ind (Node t) = renderTag ind t
-renderContent _ (Text t) = [Line Inline 0 $ HE.text t]
-renderContent _ (Raw t) = [Line Newline 0 t]
-
-
-renderTag :: Int -> Element -> [Line]
-renderTag ind tag =
- case tag.children of
- [] ->
- -- auto closing creates a bug in chrome. An auto-closed div
- -- absorbs the next children
- [line $ open <> htmlAtts (flatAttributes tag) <> ">" <> close]
- -- single text node
- [Text t] ->
- -- SINGLE text node, just display it indented
- [line $ open <> htmlAtts (flatAttributes tag) <> ">" <> HE.text t <> close]
- _ ->
- mconcat
- [ [line $ open <> htmlAtts (flatAttributes tag) <> ">"]
- , fmap (addIndent ind) $ htmlChildren tag.children
- , [line close]
- ]
- where
- open = "<" <> tag.name
- close = " tag.name <> ">"
-
- line t =
- if tag.inline
- then Line Inline 0 t
- else Line Newline 0 t
-
- htmlChildren :: [Content] -> [Line]
- htmlChildren cts =
- mconcat $
- fmap (renderContent ind) cts
-
- htmlAtts :: FlatAttributes -> Text
- htmlAtts (FlatAttributes []) = ""
- htmlAtts (FlatAttributes as) =
- " "
- <> T.unwords (map htmlAtt $ M.toList as)
- where
- htmlAtt (k, v) =
- k <> "=" <> "'" <> HE.text v <> "'"
-
-
-addIndent :: Int -> Line -> Line
-addIndent n (Line e ind t) = Line e (ind + n) t
-
-
-renderCSS :: CSS -> [Line]
-renderCSS = mapMaybe renderClass . M.elems
- where
- renderClass :: Class -> Maybe Line
- renderClass c | M.null c.properties = Nothing
- renderClass c =
- let sel = selectorText c.selector
- props = intercalate "; " (map renderProp $ M.toList c.properties)
- in Just $ Line Newline 0 $ [i|#{sel} { #{props} }|] & addMedia c.selector.media
-
- addMedia Nothing css = css
- addMedia (Just m) css =
- let mc = mediaCriteria m
- in [i|@media #{mc} { #{css} }|]
-
- mediaCriteria :: Media -> Text
- mediaCriteria (MinWidth n) = [i|(min-width: #{n}px)|]
- mediaCriteria (MaxWidth n) = [i|(max-width: #{n}px)|]
-
- renderProp :: (Text, StyleValue) -> Text
- renderProp (p, cv) = p <> ":" <> renderStyle cv
-
- renderStyle :: StyleValue -> Text
- renderStyle (StyleValue v) = pack v
-
-
-indent :: Text -> Text
-indent t = " " <> t
-
-
--- | The css selector for this style
-selectorText :: Selector -> Text
-selectorText s =
- let classAttributeName = HE.text (attributeClassName s).text
- in ancestor s.ancestor <> "." <> addPseudo s.pseudo classAttributeName <> child s.child
- where
- ancestor Nothing = ""
- ancestor (Just p) = "." <> HE.text p <> " "
-
- -- ":" is treated as a pseudo selector. We want to use prefixed pseudos in the name as part of the name
- -- so we must escape the colon
- addPseudo Nothing c = c
- addPseudo (Just p) c =
- T.replace ":" "\\:" c <> ":" <> pseudoSuffix p
-
- child Nothing = ""
- child (Just (ChildWithName c)) =
- " > ." <> HE.text c
- child (Just AllChildren) =
- " > *"
-
- pseudoSuffix :: Pseudo -> Text
- pseudoSuffix Even = "nth-child(even)"
- pseudoSuffix Odd = "nth-child(odd)"
- pseudoSuffix p = pseudoText p
-
-
--- | Unique name for the class, as seen in the element's class attribute
-attributeClassName :: Selector -> ClassName
-attributeClassName sel =
- addMedia sel.media . addPseudo sel.pseudo . addAncestor sel.ancestor . addChild sel.child $ sel.className
- where
- addAncestor :: Maybe Ancestor -> ClassName -> ClassName
- addAncestor Nothing cn = cn
- addAncestor (Just a) cn = className a <> "-" <> cn
-
- addChild :: Maybe ChildCombinator -> ClassName -> ClassName
- addChild Nothing cn = cn
- addChild (Just (ChildWithName child)) cn = cn <> "-" <> className child
- addChild (Just AllChildren) cn = cn <> "-all"
-
- addPseudo :: Maybe Pseudo -> ClassName -> ClassName
- addPseudo Nothing cn = cn
- addPseudo (Just p) cn =
- className (pseudoText p) <> ":" <> cn
-
- addMedia :: Maybe Media -> ClassName -> ClassName
- addMedia Nothing cn = cn
- addMedia (Just (MinWidth n)) cn =
- "mmnw" <> fromString (show n) <> "-" <> cn
- addMedia (Just (MaxWidth n)) cn =
- "mmxw" <> fromString (show n) <> "-" <> cn
-
-
--- classNameAddAncestor :: Ancestor -> ClassName -> ClassName
--- classNameAddAncestor a cn =
--- ClassName a <> "-" <> cn
---
---
--- classNameAddChild :: ChildCombinator -> ClassName -> ClassName
--- classNameAddChild cc cn =
--- case cc of
--- ChildWithName child -> cn <> "-" <> ClassName child
--- AllChildren -> cn <> "-all"
---
--- classNameAddPseudo :: Pseudo -> ClassName -> ClassName
--- classNameAddPseudo p cn =
--- className (pseudoText p) <> ":" <> cn
---
-
-pseudoText :: Pseudo -> Text
-pseudoText p = toLower $ pack $ show p
-
-
--- | The 'Web.View.Types.Attributes' for an element, inclusive of class.
-flatAttributes :: Element -> FlatAttributes
-flatAttributes t =
- FlatAttributes $
- addClass t.attributes.classes t.attributes.other
- where
- addClass css atts
- | M.null css = atts
- | otherwise = M.insert "class" (classAttValue $ M.elems css) atts
-
- classAttValue :: [Class] -> Text
- classAttValue cx =
- T.unwords $ fmap ((.text) . attributeClassName . (.selector)) cx
diff --git a/src/Web/View/Reset.hs b/src/Web/View/Reset.hs
deleted file mode 100644
index 89df2d0..0000000
--- a/src/Web/View/Reset.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module Web.View.Reset where
-
-import Data.ByteString
-import Data.FileEmbed
-import Data.Text
-
-
-{- | Default CSS to remove unintuitive default styles. This or 'cssResetLink' is required.
-
-> import Data.String.Interpolate (i)
->
-> toDocument :: ByteString -> ByteString
-> toDocument cnt =
-> [i|
->
->
->
-> #{cnt}
-> |]
--}
-cssResetEmbed :: ByteString
-cssResetEmbed = $(embedFile "embed/preflight.css")
-
-
-{- | Alternatively, the reset is available on a CDN
-
-> import Data.String.Interpolate (i)
->
-> toDocument :: ByteString -> ByteString
-> toDocument cnt =
-> [i|
->
->
->
-> #{cnt}
-> |]
--}
-cssResetLink :: Text
-cssResetLink = ""
diff --git a/src/Web/View/Style.hs b/src/Web/View/Style.hs
deleted file mode 100644
index cbeab13..0000000
--- a/src/Web/View/Style.hs
+++ /dev/null
@@ -1,546 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -Wno-name-shadowing #-}
-
-module Web.View.Style where
-
-import Data.Function ((&))
-import Data.Map.Strict qualified as M
-import Data.Text (Text)
-import Web.View.Types
-
-
-{- HLINT "HLint: shadows the existing binding" -}
-
--- * Styles
-
-
--- | Set to a specific width
-width :: Length -> Mod c
-width n =
- addClass $
- cls ("w" -. n)
- & prop "width" n
- & prop @Int "flex-shrink" 0
-
-
--- | Set to a specific height
-height :: Length -> Mod c
-height n =
- addClass $
- cls ("h" -. n)
- & prop "height" n
- & prop @Int "flex-shrink" 0
-
-
--- | Allow width to grow to contents but not shrink any smaller than value
-minWidth :: Length -> Mod c
-minWidth n =
- addClass $
- cls ("mw" -. n)
- & prop "min-width" n
-
-
--- | Allow height to grow to contents but not shrink any smaller than value
-minHeight :: Length -> Mod c
-minHeight n =
- addClass $
- cls ("mh" -. n)
- & prop "min-height" n
-
-
-{- | Space surrounding the children of the element
-
-To create even spacing around and between all elements:
-
-> col (pad 10 . gap 10) $ do
-> el_ "one"
-> el_ "two"
-> el_ "three"
--}
-pad :: Sides Length -> Mod c
-pad (All n) =
- addClass $
- cls ("pad" -. n)
- & prop "padding" n
-pad (Y n) =
- addClass $
- cls ("pady" -. n)
- & prop "padding-top" n
- & prop "padding-bottom" n
-pad (X n) =
- addClass $
- cls ("padx" -. n)
- & prop "padding-left" n
- & prop "padding-right" n
-pad (XY x y) = pad (TRBL y x y x)
-pad (TRBL t r b l) =
- addClass $
- cls ("pad" -. t -. r -. b -. l)
- & prop "padding-top" t
- & prop "padding-right" r
- & prop "padding-bottom" b
- & prop "padding-left" l
-pad (T x) = addClass $ cls ("padt" -. x) & prop "padding-top" x
-pad (R x) = addClass $ cls ("padr" -. x) & prop "padding-right" x
-pad (B x) = addClass $ cls ("padb" -. x) & prop "padding-bottom" x
-pad (L x) = addClass $ cls ("padl" -. x) & prop "padding-left" x
-pad (TR t r) = pad (TRBL t r 0 0)
-pad (TL t l) = pad (TRBL t 0 0 l)
-pad (BR b r) = pad (TRBL 0 r b 0)
-pad (BL b l) = pad (TRBL 0 0 b l)
-
-
--- | The space between child elements. See 'pad'
-gap :: Length -> Mod c
-gap n = addClass $ cls ("gap" -. n) & prop "gap" n
-
-
-fontSize :: Length -> Mod c
-fontSize n = addClass $ cls ("fs" -. n) & prop "font-size" n
-
-
--- fontFamily :: Text -> Mod c
--- fontFamily t = cls1 $ Class ("font" -. n) [("font-family", pxRem n)]
-
-{- | Add a drop shadow to an element
-
-> input (shadow Inner) "Inset Shadow"
-> button (shadow ()) "Click Me"
--}
-shadow :: (Style Shadow a, ToClassName a) => a -> Mod c
-shadow a =
- addClass $
- cls ("shadow" -. a)
- & prop "box-shadow" (styleValue @Shadow a)
-
-
--- "0 1px 3px 0 rgb(0 0 0 / 0.1), 0 1px 2px -1px rgb(0 0 0 / 0.1)"
-
-data Shadow
-data Inner = Inner
- deriving (Show, ToClassName)
-
-
-instance Style Shadow () where
- styleValue _ = "0 1px 3px 0 rgb(0 0 0 / 0.1), 0 1px 2px -1px rgb(0 0 0 / 0.1);"
-instance Style Shadow None where
- styleValue _ = "0 0 #0000;"
-instance Style Shadow Inner where
- styleValue _ = "inset 0 2px 4px 0 rgb(0 0 0 / 0.05);"
-
-
--- | Round the corners of the element
-rounded :: Length -> Mod c
-rounded n = addClass $ cls ("rnd" -. n) & prop "border-radius" n
-
-
--- | Set the background color. See 'Web.View.Types.ToColor'
-bg :: (ToColor clr) => clr -> Mod ctx
-bg c =
- addClass $
- cls ("bg" -. colorName c)
- & prop "background-color" (colorValue c)
-
-
--- | Set the text color. See 'Web.View.Types.ToColor'
-color :: (ToColor clr) => clr -> Mod ctx
-color c = addClass $ cls ("clr" -. colorName c) & prop "color" (colorValue c)
-
-
-bold :: Mod c
-bold = addClass $ cls "bold" & prop @Text "font-weight" "bold"
-
-
-italic :: Mod c
-italic = addClass $ cls "italic" & prop @Text "font-style" "italic"
-
-
-underline :: Mod c
-underline = addClass $ cls "underline" & prop @Text "text-decoration" "underline"
-
-
-{- | Set the list style of an item
-
-> ol id $ do
-> li (list Decimal) "First"
-> li (list Decimal) "Second"
-> li (list Decimal) "Third"
--}
-list :: (ToClassName a, Style ListType a) => a -> Mod c
-list a =
- addClass $
- cls ("list" -. a)
- & prop "list-style-type" (styleValue @ListType a)
-
-
-data ListType
- = Decimal
- | Disc
- deriving (Show, ToClassName, ToStyleValue)
-instance Style ListType ListType
-instance Style ListType None
-
-
-opacity :: Float -> Mod c
-opacity n =
- addClass $
- cls ("opacity" -. n)
- & prop "opacity" n
-
-
-{- | Set a border around the element
-
-> el (border 1) "all sides"
-> el (border (X 1)) "only left and right"
--}
-border :: Sides PxRem -> Mod c
-border (All p) =
- addClass $
- cls ("brd" -. p)
- & prop "border-width" p
- & prop @Text "border-style" "solid"
-border (Y p) =
- addClass $
- cls ("brdy" -. p)
- & prop "border-top-width" p
- & prop "border-bottom-width" p
-border (X p) =
- addClass $
- cls ("brdx" -. p)
- & prop "border-left-width" p
- & prop "border-right-width" p
-border (XY x y) = border (TRBL y x y x)
-border (TRBL t r b l) =
- addClass $
- cls ("brd" -. t -. r -. b -. l)
- & prop "border-top-width" t
- & prop "border-right-width" r
- & prop "border-bottom-width" b
- & prop "border-left-width" l
-border (T x) = addClass $ cls ("brdt" -. x) & prop "border-top-width" x
-border (R x) = addClass $ cls ("brdr" -. x) & prop "border-right-width" x
-border (B x) = addClass $ cls ("brdb" -. x) & prop "border-bottom-width" x
-border (L x) = addClass $ cls ("brdl" -. x) & prop "border-left-width" x
-border (TR t r) = border (TRBL t r 0 0)
-border (TL t l) = border (TRBL t 0 0 l)
-border (BR b r) = border (TRBL 0 r b 0)
-border (BL b l) = border (TRBL 0 0 b l)
-
-
--- | Set a border color. See 'Web.View.Types.ToColor'
-borderColor :: (ToColor clr) => clr -> Mod ctx
-borderColor c =
- addClass $
- cls ("brdc" -. colorName c)
- & prop "border-color" (colorValue c)
-
-
-{- | Use a button-like cursor when hovering over the element
-
-Button-like elements:
-
-> btn = pointer . bg Primary . hover (bg PrimaryLight)
->
-> options = row id $ do
-> el btn "Login"
-> el btn "Sign Up"
--}
-pointer :: Mod c
-pointer = addClass $ cls "pointer" & prop @Text "cursor" "pointer"
-
-
-{- | Animate changes to the given property
-
-> el (transition 100 (Height 400)) "Tall"
-> el (transition 100 (Height 100)) "Small"
--}
-transition :: Ms -> TransitionProperty -> Mod c
-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 p val =
- addClass $
- cls ("t" -. val -. p -. ms)
- & prop "transition-duration" ms
- & prop "transition-property" p
- & prop p 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)
-
-
-textAlign :: Align -> Mod c
-textAlign a =
- addClass $
- cls ("ta" -. a)
- & prop "text-align" a
-
-
--- | position:absolute, relative, etc. See 'Web.View.Layout.stack' and 'Web.View.Layout.popup'
-position :: Position -> Mod c
-position p = addClass $ cls (toClassName p) & prop "position" p
-
-
-data Position
- = Absolute
- | Fixed
- | Sticky
- | Relative
- deriving (Show, ToClassName, ToStyleValue)
-
-
-zIndex :: Int -> Mod c
-zIndex n = addClass $ cls ("z" -. n) & prop "z-index" n
-
-
--- | Set top, bottom, right, and left. See 'Web.View.Layout.stack' and 'Web.View.Layout.popup'
-offset :: Sides Length -> Mod c
-offset sides = addClass (off sides)
- where
- off :: Sides Length -> Class
- off = \case
- All n -> off (TRBL n n n n)
- Y n -> off (XY 0 n)
- X n -> off (XY n 0)
- XY x y -> off (TRBL y x y x)
- TRBL t r b l ->
- cls ("pop" -. t -. r -. b -. l)
- & prop "top" t
- & prop "right" r
- & prop "bottom" b
- & prop "left" l
- T x -> cls ("popt" -. x) & prop "top" x
- R x -> cls ("popr" -. x) & prop "right" x
- B x -> cls ("popb" -. x) & prop "bottom" x
- L x -> cls ("popl" -. x) & prop "left" x
- TR t r ->
- cls ("poptr" -. t -. r)
- & prop "top" t
- & prop "right" r
- TL t l ->
- cls ("poptl" -. t -. l)
- & prop "top" t
- & prop "left" l
- BR b r ->
- cls ("popbr" -. b -. r)
- & prop "right" r
- & prop "bottom" b
- BL b l ->
- cls ("popbl" -. b -. l)
- & prop "bottom" b
- & prop "left" l
-
-
-{- | Set container display
-
-el (display None) "HIDDEN"
--}
-display :: (Style Display a, ToClassName a) => a -> Mod c
-display disp =
- addClass $
- cls ("disp" -. disp)
- & prop "display" (styleValue @Display disp)
-
-
-data Display
- = Block
- deriving (Show, ToClassName, ToStyleValue)
-instance Style Display Display
-instance Style Display None
-
-
-data Wrap
- = Wrap
- | NoWrap
- deriving (Show, ToClassName)
-instance ToStyleValue Wrap where
- toStyleValue Wrap = "wrap"
- toStyleValue NoWrap = "nowrap"
-
-
-data FlexWrap
- = WrapReverse
- deriving (Show, ToStyleValue)
-instance Style FlexWrap FlexWrap
-instance Style FlexWrap Wrap
-instance ToClassName FlexWrap where
- toClassName WrapReverse = "rev"
-
-
-flexWrap :: (Style FlexWrap a, ToClassName a, ToStyleValue a) => a -> Mod c
-flexWrap w =
- addClass $
- cls ("fwrap" -. w)
- & prop "flex-wrap" w
-
-
-data TextWrap
-
-
--- = Balance
--- | Pretty
--- | Stable
--- deriving (Show, ToStyleValue, ToClassName)
--- instance Style TextWrap TextWrap
-instance Style TextWrap Wrap
-
-
-textWrap :: (Style TextWrap a, ToClassName a, ToStyleValue a) => a -> Mod c
-textWrap w =
- addClass $
- cls ("twrap" -. w)
- & prop "text-wrap" w
-
-
--- * Selector Modifiers
-
-
-{- | Apply when hovering over an element
-
-> el (bg Primary . hover (bg PrimaryLight)) "Hover"
--}
-hover :: Mod c -> Mod c
-hover = applyPseudo Hover
-
-
--- | Apply when the mouse is pressed down on an element
-active :: Mod c -> Mod c
-active = applyPseudo Active
-
-
--- | Apply to even-numbered children
-even :: Mod c -> Mod c
-even = applyPseudo Even
-
-
--- | Apply to odd-numbered children
-odd :: Mod c -> Mod c
-odd = applyPseudo Odd
-
-
-{- | Apply when the Media matches the current window. This allows for responsive designs
-
-> el (width 100 . media (MinWidth 800) (width 400))
-> "Big if window > 800"
--}
-media :: Media -> Mod c -> Mod c
-media m = mapModClass $ \c ->
- c
- { selector = addMedia c.selector
- }
- where
- addMedia :: Selector -> Selector
- addMedia Selector{..} = Selector{media = Just m, ..}
-
-
-{- | Apply when the element is somewhere inside an anscestor.
-
-For example, the HTMX library applies an "htmx-request" class to the body when a request is pending. We can use this to create a loading indicator
-
-> el (pad 10) $ do
-> el (parent "htmx-request" flexRow . hide) "Loading..."
-> el (parent "htmx-request" hide . flexRow) "Normal Content"
--}
-parent :: Text -> Mod c -> Mod c
-parent p = mapModClass $ \c ->
- c
- { selector = addAncestor c.selector
- }
- where
- addAncestor :: Selector -> Selector
- addAncestor Selector{..} = Selector{ancestor = Just p, ..}
-
-
--- Add a pseudo-class like Hover to your style
-applyPseudo :: Pseudo -> Mod c -> Mod c
-applyPseudo ps = mapModClass $ \c ->
- c
- { selector = addToSelector c.selector
- }
- where
- addToSelector :: Selector -> Selector
- addToSelector Selector{..} = Selector{pseudo = Just ps, ..}
-
-
-mapModClass :: (Class -> Class) -> Mod c -> Mod c
-mapModClass fc fm as =
- -- apply the function to all classes added by the mod
- -- ignore
- let as' = fm $ Attributes [] []
- in as'
- { classes = as.classes <> fmap fc as'.classes
- , other = as.other <> as'.other
- }
-
-
-{- | Setting the same property twice will result in only one of the classes being applied. It is not intuitive, as CSS rules dictate that the order of the class definitions determine precedence. You can mark a `Mod` as important to force it to apply
-important :: Mod c -> Mod c
-important =
- mapModClass $ \c ->
- c
- { important = True
- }
--}
-
--- * Creating New Styles
-
-
-{- | Add a single class
-
-> width :: PxRem -> Mod
-> width n =
-> addClass
-> $ cls ("w" -. n)
-> & prop "width" n
-> & prop @Int "flex-shrink" 0
--}
-addClass :: Class -> Mod c
-addClass c attributes =
- Attributes
- { classes = M.insert c.selector c attributes.classes
- , other = attributes.other
- }
-
-
--- | Construct a class from a ClassName
-cls :: ClassName -> Class
-cls n = Class (selector n) []
-
-
-{- | Construct a mod from a ClassName with no CSS properties. Convenience for situations where external CSS classes need to be referenced.
-
-> el (extClass "btn" . extClass "btn-primary") "Click me!"
--}
-extClass :: ClassName -> Mod c
-extClass = addClass . cls
-
-
--- | Add a property to a class
-prop :: (ToStyleValue val) => Name -> val -> Class -> Class
-prop n v c =
- c{properties = M.insert n (toStyleValue v) c.properties}
-
-
--- | Hyphenate classnames
-(-.) :: (ToClassName a) => ClassName -> a -> ClassName
-(ClassName n) -. a =
- case toClassName a of
- "" -> ClassName n
- suffix -> (ClassName $ n <> "-") <> suffix
-
-
-infixl 6 -.
diff --git a/src/Web/View/Types.hs b/src/Web/View/Types.hs
deleted file mode 100644
index 6dfd1c3..0000000
--- a/src/Web/View/Types.hs
+++ /dev/null
@@ -1,395 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
-
-module Web.View.Types where
-
-import Data.Char (toLower)
-import Data.Kind (Type)
-import Data.Map.Strict (Map)
-import Data.String (IsString (..))
-import Data.Text (Text, pack, unpack)
-import Data.Text qualified as T
-import GHC.Generics (Generic)
-import Numeric (showFFloat)
-import Text.Casing (kebab)
-
-
-data Content
- = Node Element
- | Text Text
- | -- | Raw embedded HTML or SVG. See 'Web.View.Element.raw'
- Raw Text
- deriving (Show, Eq)
-
-
--- | A single HTML tag. Note that the class attribute is stored separately from the rest of the attributes to make adding styles easier
-data Element = Element
- { inline :: Bool
- , name :: Name
- , attributes :: Attributes ()
- , children :: [Content]
- }
- deriving (Show, Eq)
-
-
--- | Construct an Element
-element :: Name -> Attributes c -> [Content] -> Element
-element n atts =
- Element False n (stripContext atts)
-
-
--- | Internal. Convert an Attributes to any context
-stripContext :: Attributes a -> Attributes b
-stripContext (Attributes cls other) = Attributes cls other
-
-
--- | The Attributes for an 'Element'. Classes are merged and managed separately from the other attributes.
-data Attributes c = Attributes
- { classes :: CSS
- , other :: Map Name AttValue
- }
- deriving (Show, Eq)
-
-
-instance Semigroup (Attributes c) where
- a1 <> a2 = Attributes (a1.classes <> a2.classes) (a1.other <> a2.other)
-instance Monoid (Attributes c) where
- mempty = Attributes mempty mempty
-type Attribute = (Name, AttValue)
-type Name = Text
-type AttValue = Text
-
-
--- * Attribute Modifiers
-
-
-{- | Element functions expect a modifier function as their first argument. These can add attributes and classes. Combine multiple `Mod`s with (`.`)
-
-> userEmail :: User -> View c ()
-> userEmail user = input (fontSize 16 . active) (text user.email)
-> where
-> active = isActive user then bold else id
-
-If you don't want to specify any attributes, you can use `id`
-
-> plainView :: View c ()
-> plainView = el id "No styles"
--}
-type Mod (context :: Type) = Attributes context -> Attributes context
-
-
--- * Atomic CSS
-
-
--- TODO: document atomic CSS here?
-
--- | All the atomic classes used in a 'Web.View.View'
-type CSS = Map Selector Class
-
-
--- | Atomic classes include a selector and the corresponding styles
-data Class = Class
- { selector :: Selector
- , properties :: Styles
- }
- deriving (Show, Eq)
-
-
--- | The styles to apply for a given atomic 'Class'
-type Styles = Map Name StyleValue
-
-
--- | A parent selector limits the selector to only apply when a descendent of the parent in question
-type Ancestor = Text
-
-
--- | A child selector limits
-data ChildCombinator
- = AllChildren
- | ChildWithName Text
- deriving (Show, Eq, Ord)
-
-
-instance IsString ChildCombinator where
- fromString s = ChildWithName (fromString s)
-
-
--- | The selector to use for the given atomic 'Class'
-data Selector = Selector
- { media :: Maybe Media
- , ancestor :: Maybe Ancestor
- , child :: Maybe ChildCombinator
- , pseudo :: Maybe Pseudo
- , className :: ClassName
- }
- deriving (Eq, Ord, Show)
-
-
-instance IsString Selector where
- fromString s = selector (fromString s)
-
-
--- | Create a 'Selector' given only a 'ClassName'
-selector :: ClassName -> Selector
-selector c =
- Selector
- { pseudo = Nothing
- , ancestor = Nothing
- , child = Nothing
- , media = Nothing
- , className = c
- }
-
-
--- | A class name
-newtype ClassName = ClassName
- { text :: Text
- }
- deriving newtype (Eq, Ord, Show, Monoid, Semigroup)
-
-
-instance IsString ClassName where
- fromString s = ClassName $ pack s
-
-
--- | 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 . T.pack . show
-
-
-instance ToClassName Int
-instance ToClassName Text where
- toClassName = className
-instance ToClassName Float where
- toClassName f = className $ pack $ showFFloat (Just 3) f ""
-instance ToClassName () where
- toClassName _ = ""
-
-
-{- | Psuedos allow for specifying styles that only apply in certain conditions. See `Web.View.Style.hover` etc
-
-> el (color Primary . hover (color White)) "hello"
--}
-data Pseudo
- = Hover
- | Active
- | Even
- | Odd
- deriving (Show, Eq, Ord)
-
-
--- | The value of a css style property
-newtype StyleValue = StyleValue String
- deriving newtype (IsString, Show, Eq, Monoid, Semigroup)
-
-
--- | Use a type as a css style property value
-class ToStyleValue a where
- toStyleValue :: a -> StyleValue
- default toStyleValue :: (Show a) => a -> StyleValue
- toStyleValue = StyleValue . kebab . show
-
-
-instance ToStyleValue String where
- toStyleValue = StyleValue
-
-
-instance ToStyleValue Text where
- toStyleValue = StyleValue . unpack
-
-
-instance ToStyleValue Int
-
-
-instance ToStyleValue Float where
- -- this does not convert to a percent, just a ratio
- toStyleValue n = StyleValue $ showFFloat (Just 2) n ""
-
-
-instance ToStyleValue StyleValue where
- toStyleValue = id
-
-
--- | Convert a type to a prop name
-class ToProp a where
- toProp :: a -> Name
- default toProp :: (Show a) => a -> Name
- 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
- -- only support numeric literals
- a + _ = a
- a * _ = a
- 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 ToStyleValue PxRem where
- toStyleValue (PxRem' 0) = "0px"
- toStyleValue (PxRem' 1) = "1px"
- toStyleValue (PxRem' n) = StyleValue $ show ((fromIntegral n :: Float) / 16.0) <> "rem"
-
-
-instance ToStyleValue Length where
- toStyleValue (PxRem p) = toStyleValue p
- toStyleValue (Pct n) = StyleValue $ showFFloat (Just 1) (n * 100) "" <> "%"
-
-
--- | Milliseconds, used for transitions
-newtype Ms = Ms Int
- deriving (Show)
- deriving newtype (Num, ToClassName)
-
-
-instance ToStyleValue Ms where
- toStyleValue (Ms n) = StyleValue $ show n <> "ms"
-
-
--- | Media allows for responsive designs that change based on characteristics of the window. See [Layout Example](https://github.com/seanhess/web-view/blob/master/example/Example/Layout.hs)
-data Media
- = MinWidth Int
- | MaxWidth Int
- deriving (Eq, Ord, Show)
-
-
-{- | Options for styles that support specifying various sides. This has a "fake" Num instance to support literals
-
-> 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)
-
-
--- | Element's attributes do not include class, which is separated. FlatAttributes generate the class attribute and include it
-newtype FlatAttributes = FlatAttributes {attributes :: Map Name AttValue}
- deriving (Generic)
-
-
--- ** Colors
-
-
-{- | ToColor allows you to create a type containing your application's colors:
-
-> data AppColor
-> = White
-> | Primary
-> | Dark
->
-> instance ToColor AppColor where
-> colorValue White = "#FFF"
-> colorValue Dark = "#333"
-> colorValue Primary = "#00F"
->
-> hello :: View c ()
-> 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 'Web.View.Types.ToColor'
-newtype HexColor = HexColor Text
- deriving (Show)
-
-
-instance ToColor HexColor where
- colorValue c = c
- colorName (HexColor a) = T.dropWhile (== '#') a
-
-
-instance ToStyleValue HexColor where
- toStyleValue (HexColor s) = StyleValue $ "#" <> unpack (T.dropWhile (== '#') s)
-
-
-instance IsString HexColor where
- fromString = HexColor . T.dropWhile (== '#') . T.pack
-
-
-instance ToClassName HexColor where
- toClassName = className . colorName
-
-
-data Align
- = AlignCenter
- | AlignLeft
- | AlignRight
- | AlignJustify
- deriving (Show, ToClassName)
-instance ToStyleValue Align where
- toStyleValue a = StyleValue $ map toLower $ drop 5 $ show a
-
-
-data None = None
- deriving (Show, ToClassName, ToStyleValue)
-
-
--- uniquely set the style value based on the style
-class Style cls value where
- styleValue :: value -> StyleValue
- default styleValue :: (ToStyleValue value) => value -> StyleValue
- styleValue = toStyleValue
-
-
-class ToClass cls value where
- toClass :: value -> Class
diff --git a/src/Web/View/Types/Url.hs b/src/Web/View/Types/Url.hs
deleted file mode 100644
index 33511ef..0000000
--- a/src/Web/View/Types/Url.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-module Web.View.Types.Url where
-
-import Control.Applicative ((<|>))
-import Data.Bifunctor (first)
-import Data.Maybe (fromMaybe)
-import Data.String (IsString (..))
-import Data.Text (Text, pack)
-import Data.Text qualified as T
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import Effectful
-import Effectful.State.Static.Local
-import Network.HTTP.Types (Query, parseQuery, renderQuery)
-
-
-type Segment = Text
-
-
-pathUrl :: [Segment] -> Url
-pathUrl p = Url "" "" p []
-
-
-cleanSegment :: Segment -> Segment
-cleanSegment = T.dropWhileEnd (== '/') . T.dropWhile (== '/')
-
-
-pathSegments :: Text -> [Segment]
-pathSegments p = filter (not . T.null) $ T.splitOn "/" $ T.dropWhile (== '/') p
-
-
--- Problem: if scheme and domain exist, it MUST be an absolute url
-data Url = Url
- { scheme :: Text
- , domain :: Text
- , path :: [Segment]
- , query :: Query
- }
- deriving (Eq)
-instance IsString Url where
- fromString = url . pack
-instance Show Url where
- show = show . renderUrl
-instance Read Url where
- readsPrec _ s =
- first url <$> reads @Text s
-instance Semigroup Url where
- Url s d p q <> Url _ _ p2 q2 = Url s d (p <> p2) (q <> q2)
-instance Monoid Url where
- mempty = Url "" "" [] []
-
-
-url :: Text -> Url
-url t = runPureEff $ evalState t $ do
- s <- scheme
- d <- domain s
- ps <- paths
- q <- query
- pure $ Url{scheme = s, domain = d, path = ps, query = q}
- where
- parse :: (State Text :> es) => (Char -> Bool) -> Eff es Text
- parse b = do
- inp <- get
- let match = T.takeWhile b inp
- rest = T.dropWhile b inp
- put rest
- pure match
-
- string :: (State Text :> es) => Text -> Eff es (Maybe Text)
- string pre = do
- inp <- get
- case T.stripPrefix pre inp of
- Nothing -> pure Nothing
- Just rest -> do
- put rest
- pure (Just pre)
-
- -- it's either scheme AND domain, or relative path
- scheme = do
- http <- string "http://"
- https <- string "https://"
- pure $ fromMaybe "" $ http <|> https
-
- domain "" = pure ""
- domain _ = parse (not . isDomainSep)
-
- pathText :: (State Text :> es) => Eff es Text
- pathText = parse (not . isQuerySep)
-
- paths :: (State Text :> es) => Eff es [Segment]
- paths = do
- p <- pathText
- pure $ pathSegments p
-
- query :: (State Text :> es) => Eff es Query
- query = do
- q <- parse (/= '\n')
- pure $ parseQuery $ encodeUtf8 q
-
- isDomainSep '/' = True
- isDomainSep _ = False
-
- isQuerySep '?' = True
- isQuerySep _ = False
-
-
-renderUrl :: Url -> Text
-renderUrl u = u.scheme <> u.domain <> renderPath u.path <> decodeUtf8 (renderQuery True u.query)
-
-
-renderPath :: [Segment] -> Text
-renderPath ss = "/" <> T.intercalate "/" (map cleanSegment ss)
diff --git a/src/Web/View/View.hs b/src/Web/View/View.hs
deleted file mode 100644
index 332bd27..0000000
--- a/src/Web/View/View.hs
+++ /dev/null
@@ -1,153 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE OverloadedLists #-}
-
-module Web.View.View where
-
-import Data.Map.Strict qualified as M
-import Data.String (IsString (..))
-import Data.Text (Text, pack)
-import Effectful
-import Effectful.Reader.Static
-import Effectful.State.Static.Local as ES
-import Web.View.Types
-
-
--- * Views
-
-
-{- | Views are HTML fragments that carry all 'CSS' used by any child element.
-
-> view :: View c ()
-> view = col (pad 10 . gap 10) $ do
-> el bold "Hello"
-> el_ "World"
-
-They can also have a context which can be used to create type-safe or context-aware elements. See 'context' or 'Web.View.Element.table' for an example
--}
-newtype View context a = View {viewState :: Eff [Reader context, State ViewState] a}
- deriving newtype (Functor, Applicative, Monad)
-
-
-instance IsString (View context ()) where
- fromString s = viewAddContent $ Text (pack s)
-
-
-data ViewState = ViewState
- { contents :: [Content]
- , css :: CSS
- }
-
-
-instance Semigroup ViewState where
- va <> vb = ViewState (va.contents <> vb.contents) (va.css <> vb.css)
-
-
--- | Extract the 'ViewState' from a 'View'
-runView :: context -> View context () -> ViewState
-runView ctx (View ef) =
- runPureEff . execState (ViewState [] []) . runReader ctx $ ef
-
-
-{- | Views have a `Reader` built-in for convienient access to static data, and to add type-safety to view functions. See 'Web.View.Element.ListItem and https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html
-
-> numberView :: View Int ()
-> numberView = do
-> num <- context
-> el_ $ do
-> "Number: "
-> text (pack $ show num)
--}
-context :: View context context
-context = View ask
-
-
-{- | Run a view with a specific `context` in a parent 'View' with a different context.
-
->
-> parentView :: View c ()
-> parentView = do
-> addContext 1 numberView
-> addContext 2 numberView
-> addContext 3 numberView
--}
-addContext :: context -> View context () -> View c ()
-addContext ctx vw = do
- -- runs the sub-view in a different context, saving its state
- -- we need to MERGE it
- let st = runView ctx vw
- View $ do
- s <- get
- put $ s <> st
-
-
-viewModContents :: ([Content] -> [Content]) -> View context ()
-viewModContents f = View $ do
- ES.modify $ \s -> s{contents = f s.contents}
-
-
-viewModCss :: (CSS -> CSS) -> View context ()
-viewModCss f = View $ do
- ES.modify $ \s -> s{css = f s.css}
-
-
-viewAddClasses :: CSS -> View c ()
-viewAddClasses clss = do
- viewModCss $ \cm -> foldr addClsDef cm clss
- where
- addClsDef :: Class -> CSS -> CSS
- addClsDef c = M.insert c.selector c
-
-
-viewAddContent :: Content -> View c ()
-viewAddContent ct =
- viewModContents (<> [ct])
-
-
--- | Inserts contents into the first child element
-viewInsertContents :: [Content] -> View c ()
-viewInsertContents cs = viewModContents insert
- where
- insert [Node e] = [Node $ insertEl e]
- insert cnt = cnt <> cs
- insertEl e = e{children = e.children <> cs}
-
-
--- * Creating new Elements
-
-
-{- | Create a new element constructor with the given tag name
-
-> aside :: Mod c -> View c () -> View c ()
-> aside = tag "aside"
--}
-tag :: Text -> Mod c -> View c () -> View c ()
-tag n = tag' (element n)
-
-
-{- | Create a new element constructor with a custom element
- -
-> span :: Mod c -> View c () -> View c ()
-> span = tag' (Element True) "span"
--}
-tag' :: (Attributes c -> [Content] -> Element) -> Mod c -> View c () -> View c ()
-tag' mkElem f ct = do
- -- Applies the modifier and merges children into parent
- ctx <- context
- let st = runView ctx ct
- let ats = f mempty
- let elm = mkElem ats st.contents
- viewAddContent $ Node elm
- viewAddClasses st.css
- viewAddClasses elm.attributes.classes
-
-
-{- | Set an attribute, replacing existing value
-
-> hlink :: Text -> View c () -> View c ()
-> hlink url content = tag "a" (att "href" url) content
--}
-att :: Name -> AttValue -> Mod c
-att n v attributes =
- let atts = M.insert n v attributes.other
- in attributes{other = atts}
diff --git a/test/Test/AttributeSpec.hs b/test/Test/AttributeSpec.hs
new file mode 100644
index 0000000..f0c7c11
--- /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
index 14d6ade..616442c 100644
--- a/test/Test/RenderSpec.hs
+++ b/test/Test/RenderSpec.hs
@@ -1,148 +1,301 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Test.RenderSpec (spec) where
-import Data.Text (Text)
+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.View
-import Web.View.Render
-import Web.View.Style
-import Web.View.Types
-import Web.View.View (ViewState (..), runView, tag')
+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 "render" renderSpec
- describe "selector" selectorSpec
+ describe "flatAttributes" flatSpec
+ describe "lines" linesSpec
+ describe "html" htmlSpec
+ describe "css" $ do
+ describe "media" mediaSpec
+ describe "pseudo" pseudoSpec
+ describe "rule" ruleSpec
+ pure ()
-renderSpec :: Spec
-renderSpec = do
- describe "output" $ do
- it "should render simple output" $ do
- renderText (el_ "hi") `shouldBe` "
hi
"
+mediaSpec :: Spec
+mediaSpec = do
+ it "wraps media" $ do
+ wrapMedia (MediaQuery ["awesome", "another"]) "hello" `shouldBe` "@media (awesome) and (another) { hello }"
- it "should render two elements" $ do
- renderText (el_ "hello" >> el_ "world") `shouldBe` "
hello
\n
world
"
+ it "converts to conditions" $ do
+ mediaCriteria (MinWidth 100) `shouldBe` "min-width: 100px"
- it "should match basic output with styles" $ do
- golden <- goldenFile "test/resources/basic.txt"
- let out = renderText $ col (pad 10) $ el bold "hello" >> el_ "world"
- out `shouldBe` golden
+ 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 } }"
- describe "escape" $ do
- it "should escape properly" $ do
- golden <- goldenFile "test/resources/escaping.txt"
- let out = renderText $ do
- el (att "title" "I have some apos' and quotes \" and I'm a <> attribute!!!") "I am 'user"
- el (att "title" "I have some apos' and quotes \" and I'm a <> attribute!!!") $ do
- el_ "I am 'user"
- el_ "I am another 'user"
- out `shouldBe` golden
-
- it "should escape properly" $ do
- golden <- goldenFile "test/resources/raw.txt"
- let out = renderText $ el bold $ raw ""
- out `shouldBe` golden
-
- describe "empty rules" $ do
- it "should skip css class when no css attributes" $ do
- let view = do
- el (addClass $ cls "empty") "i have no css"
- el bold "i have some css"
- renderLines (renderCSS (runCSS view)) `shouldBe` ".bold { font-weight:bold }"
-
- it "should skip css element when no css rules" $ do
- let res = renderText $ el empty "i have no css"
- res `shouldBe` "
i have no css
"
-
- it "should render classes only once" $ do
- let single = el bold "test"
- let double = el (bold . bold) "test"
- renderText double `shouldBe` renderText single
-
- describe "inline" $ do
- it "renderLines should respect inline text " $ do
- renderLines [Line Inline 0 "one ", Line Inline 0 "two"] `shouldBe` "one two"
-
- it "renderLines should respect inline tags " $ do
- renderLines [Line Inline 0 "one ", Line Inline 0 "two ", Line Inline 0 "/", Line Inline 0 " three"] `shouldBe` "one two / three"
-
- it "should render text and inline elements inline" $ do
- let span = tag' (Element True "span") :: Mod () -> View () () -> View () ()
- let res =
- renderText $ do
- text "one "
- text "two "
- span id "/"
- text " three"
- res `shouldBe` "one two / three"
-
- describe "indentation" $ do
- it "should nested indent" $ do
- golden <- goldenFile "test/resources/nested.txt"
- let out = renderText $ do
- el_ $ do
- el_ $ do
- el_ "HI"
- out `shouldBe` golden
- where
- empty = addClass $ cls "empty"
+pseudoSpec :: Spec
+pseudoSpec = do
+ it "creates pseudo suffix" $ do
+ let CSS rs = hover @(Html ()) bold $ CSS mempty
+ fmap ruleSelector rs `shouldBe` [".hover\\:bold:hover"]
-selectorSpec :: Spec
-selectorSpec = do
- it "should escape classNames" $ do
- className "hello.woot-hi" `shouldBe` "hello-woot-hi"
- it "normal selector" $ do
- let sel = selector "myclass"
- selectorText sel `shouldBe` ".myclass"
+-- pseudoSuffix Hover `shouldBe` ":hover"
+-- pseudoSuffix Even `shouldBe` ":nth-child(even)"
+-- let r1 = rule "hello" [Declaration "key" "value"]
+-- cssRuleLine r1 `shouldBe` Just ".hello { key:value }"
- it "pseudo selector" $ do
- let sel = (selector "myclass"){pseudo = Just Hover}
- attributeClassName sel `shouldBe` "hover:myclass"
- selectorText sel `shouldBe` ".hover\\:myclass:hover"
+ruleSpec :: Spec
+ruleSpec = do
+ it "renders rules" $ do
+ let r1 = rule "hello" ["key" :. "value"]
+ cssRuleLine r1 `shouldBe` Just ".hello { key:value }"
- it "it should include ancestor in selector" $ do
- let sel = (selector "myclass"){ancestor = Just "parent"}
- attributeClassName sel `shouldBe` "parent-myclass"
- selectorText sel `shouldBe` ".parent .parent-myclass"
+ let r2 = rule "has2" ["k1" :. "val", "k2" :. "val"]
+ cssRuleLine r2 `shouldBe` Just ".has2 { k1:val; k2:val }"
- it "should not media query in selectorText" $ do
- let sel = (selector "myclass"){media = Just (MinWidth 100)}
- attributeClassName sel `shouldBe` "mmnw100-myclass"
- selectorText sel `shouldBe` ".mmnw100-myclass"
+ it "no render empty rules" $ do
+ cssRuleLine (Rule.fromClass "hello") `shouldBe` Nothing
- it "psuedo + parent" $ do
- let sel = (selector "myclass"){ancestor = Just "parent", pseudo = Just Hover}
- selectorText sel `shouldBe` ".parent .hover\\:parent-myclass:hover"
+ 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 "child" $ do
- let sel = (selector "myclass"){child = Just "mychild"}
- attributeClassName sel `shouldBe` "myclass-mychild"
- selectorText sel `shouldBe` ".myclass-mychild > .mychild"
+ it "renders pseudo" $ do
+ let r = addPseudo "hover" $ rule "hello" ["key" :. "value"]
+ cssRuleLine r `shouldBe` Just ".hover\\:hello:hover { key:value }"
- let sel2 = (selector "myclass"){child = Just AllChildren}
- attributeClassName sel2 `shouldBe` "myclass-all"
- selectorText sel2 `shouldBe` ".myclass-all > *"
+ 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 } }"
- 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"
+-- 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)"
--- describe "child combinator" $ do
--- it "should include child combinator in definition" $ do
+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
\n
two
"
+
+ 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 "
"
+ ]
+
+ 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 "hi", Line Inline 0 "two"]
+
+ it "renders class" $ do
+ htmlLines 0 (tag "div" ~ bold $ none) `shouldBe` [""]
+
+ it "renders pseudo class" $ do
+ htmlLines 0 (tag "div" ~ hover bold $ none) `shouldBe` [""]
-goldenFile :: FilePath -> IO Text
-goldenFile fp = do
- inp <- T.readFile fp
- pure $ T.dropWhileEnd (== '\n') inp
+ describe "renderText" $ do
+ it "renders simple output" $ do
+ renderText (tag "div" "hi") `shouldBe` "
hi
"
+ it "renders two elements" $ do
+ renderText (tag "div" "hello" >> tag "div" "world") `shouldBe` "
hello
\n
world
"
-runCSS :: View () () -> CSS
-runCSS view = (runView () view).css
+ 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` "
\n txt\n txt
"
+
+ 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
index 0000000..0e3f5bf
--- /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
index 4a7ffed..ea8bf71 100644
--- a/test/Test/StyleSpec.hs
+++ b/test/Test/StyleSpec.hs
@@ -1,32 +1,121 @@
module Test.StyleSpec (spec) where
-import Data.Map.Strict qualified as M
import Skeletest
-import Web.View
-import Web.View.Style ((-.))
-import Web.View.Types (Attributes (..), Class (..), selector)
+import Web.Atomic.CSS
+import Web.Atomic.Types
import Prelude hiding (span)
spec :: Spec
spec = do
- describe "Style Class" $ do
+ mainSpec
+ selectorSpec
+
+
+mainSpec :: Spec
+mainSpec = do
+ describe "PropertyStyle" $ do
it "should compile, and set both the className and styles" $ do
- let as = list Decimal mempty
- length (M.elems as.classes) `shouldBe` 1
- [c] <- pure $ M.elems as.classes
- c.selector `shouldBe` selector "list-decimal"
- c.properties `shouldBe` M.fromList [("list-style-type", "decimal")]
+ 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 as = list None mempty
- length (M.elems as.classes) `shouldBe` 1
- [c] <- pure $ M.elems as.classes
- c.selector `shouldBe` selector "list-none"
- c.properties `shouldBe` M.fromList [("list-style-type", "none")]
+ 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/UrlSpec.hs b/test/Test/UrlSpec.hs
deleted file mode 100644
index a033e9d..0000000
--- a/test/Test/UrlSpec.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module Test.UrlSpec (spec) where
-
-import Skeletest
-import Text.Read (readMaybe)
-import Web.View.Types.Url
-
-
-data Something = Something Url
- deriving (Show, Read, Eq)
-
-
-spec :: Spec
-spec = do
- describe "Url" $ do
- describe "parsing" $ do
- it "scheme and domain" $ do
- url "https://www.google.com" `shouldBe` Url "https://" "www.google.com" [] []
-
- it "path urls" $ do
- url "/my/path" `shouldBe` Url "" "" ["my", "path"] []
-
- it "scheme, domain, and path" $ do
- url "http://woot.com/my/path" `shouldBe` Url "http://" "woot.com" ["my", "path"] []
-
- it "no slash prefix" $ do
- url "hello/world" `shouldBe` Url "" "" ["hello", "world"] []
-
- it "query" $ do
- url "/path?key=value" `shouldBe` Url "" "" ["path"] [("key", Just "value")]
-
- describe "render" $ do
- it "paths" $ do
- renderUrl (url "/hello/world") `shouldBe` "/hello/world"
-
- it "query" $ do
- renderUrl (url "/path?key=value") `shouldBe` "/path?key=value"
-
- it "full" $ do
- renderUrl (url "https://example.com/hello/world?hello&name=bob") `shouldBe` "https://example.com/hello/world?hello&name=bob"
-
- it "empty" $ do
- renderUrl (Url "" "" [] []) `shouldBe` "/"
- renderUrl (url "https://example.com/") `shouldBe` "https://example.com/"
- renderUrl (url "https://example.com") `shouldBe` "https://example.com/"
-
- describe "show/read" $ do
- let u = Url "" "" ["proposals"] []
- it "show" $
- show u `shouldBe` "\"/proposals\""
-
- it "read" $
- readMaybe "\"/proposals\"" `shouldBe` Just u
-
- it "show nested" $ do
- show (Something u) `shouldBe` "Something \"/proposals\""
-
- it "read nested" $ do
- readMaybe @Something (show (Something u)) `shouldBe` Just (Something u)
diff --git a/test/Test/UtilitySpec.hs b/test/Test/UtilitySpec.hs
new file mode 100644
index 0000000..c68eb50
--- /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)
diff --git a/test/Test/ViewSpec.hs b/test/Test/ViewSpec.hs
deleted file mode 100644
index 82d9647..0000000
--- a/test/Test/ViewSpec.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Test.ViewSpec where
-
-import Skeletest
-import Web.View
-import Web.View.Types
-import Web.View.View (ViewState (..), runView)
-import Prelude hiding (span)
-
-
-spec :: Spec
-spec = do
- describe "view" $ do
- describe "string literals" $ do
- it "should include lits at text" $ do
- let view = ("hello: " :: View c ()) >> text "world"
- (runView () view).contents `shouldBe` [Text "hello: ", Text "world"]
-
- it "should include text and text" $ do
- let view = text "stuff" >> text "hello"
- (runView () view).contents `shouldBe` [Text "stuff", Text "hello"]
-
- it "should include text and trailing lits" $ do
- let view = text "stuff" >> "hello"
- (runView () view).contents `shouldBe` [Text "stuff", Text "hello"]
diff --git a/test/resources/basic.txt b/test/resources/basic.txt
index 47cb324..c9e4585 100644
--- a/test/resources/basic.txt
+++ b/test/resources/basic.txt
@@ -1,10 +1,10 @@
-