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..6f9f603 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,4 @@ -# Revision history for web-view +# Revision history for atomic-css ## 0.7.0 diff --git a/DELETEME.md b/DELETEME.md new file mode 100644 index 0000000..1108d02 --- /dev/null +++ b/DELETEME.md @@ -0,0 +1,24 @@ + +OK, so.... + +hover needs to work with multiple classes: + => hover (bg Green <> color Red) + +but overriding selectors needs to work in a sane way + -- use a monadic bind? + -- this sure looks like one! + setSelector $ \this $ a |> b >> this + +-- they don't have to be directly serializable +-- they could be functions! + +bg Green => {bg-green} +hover (bg Green) => \sel -> sel ': "hover" + + +-- I like the new stuff. Now you can't do setSelector (placeholder "woot") + + +Ok ok ok ... so... selector... + + diff --git a/README.md b/README.md index 31a1092..b7fd554 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ -Web View +Atomic CSS ============ -[![Hackage](https://img.shields.io/hackage/v/web-view.svg)][hackage] +[![Hackage](https://img.shields.io/hackage/v/atomic-css.svg)][hackage] Type-safe HTML and CSS with intuitive layout and composable styles. Inspired by Tailwindcss and Elm-UI @@ -73,28 +73,28 @@ el (width 100 . media (MinWidth 800) (width 400)) ### 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 +104,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 +116,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 +136,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 +165,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 64% rename from web-view.cabal rename to atomic-css.cabal index 4127f47..695a95c 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 +name: atomic-css +version: 0.8.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 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 @@ -27,23 +27,32 @@ extra-doc-files: 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.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 +60,10 @@ library OverloadedRecordDot DuplicateRecordFields NoFieldSelectors + TypeFamilies + DerivingStrategies + DefaultSignatures + DeriveAnyClass ghc-options: -Wall -fdefer-typed-holes build-depends: base >=4.16 && <5 @@ -61,7 +74,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 +81,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 +96,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 +112,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/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..edfba0f 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,52 @@ main = do Warp.run 3010 app -buttons :: View c () -buttons = col (gap 10 . pad 20) $ do - el (bold . fontSize 32) "My page" +col :: Html () -> Html () +col = tag "div" ~ flexCol - row (gap 10) $ do - button (btn Primary) "Do Something" - button (btn Secondary) "Cancel" - -- - button' Secondary "Another Example" +row :: Html () -> Html () +row = tag "div" ~ flexRow + + +el :: Html () -> Html () +el = tag "div" + + +space :: Html () +space = tag "div" ~ grow $ none + + +nav :: Html () -> Html () +nav = tag "nav" + + +button :: Html () -> Html () +button = tag "button" + + +input :: Html () +input = tag "button" none + + +placeholder :: (Attributable h) => AttValue -> Attributes h -> Attributes h +placeholder t = att "placeholder" t + + +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 +72,194 @@ 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 ~ fillViewport . 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 + col ~ fillViewport . 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 where - sidebar = width 250 . flexCol - topbar = height 100 . flexRow + -- oh no@ the @ operator converts everythign to attributes@ + -- and I need them to be CSS only@ + sidebar = width 250 <> flexCol + topbar = height 100 <> flexRow + + 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 ~ fillViewport $ 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) $ 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 + el "details lorem blah blah blah" + + showTooltips = + css + "tooltips" + ".tooltips:hover > .tooltip" + (declarations hidden) + + red = HexColor "#F00" + + +stacks :: Html () +stacks = col ~ fillViewport $ 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 $ "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 text "WOOT" text "BOOT" @@ -261,18 +268,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 - lnk = color Primary + 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 + link href cnt = tag "a" @ att "href" href ~ color Primary $ cnt app :: Application @@ -286,6 +316,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 +331,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..fb0aa29 100644 --- a/package.yaml +++ b/package.yaml @@ -1,8 +1,8 @@ -name: web-view -version: 0.7.0 +name: atomic-css +version: 0.8.0 synopsis: Type-safe HTML and CSS with intuitive layouts and composable styles. -homepage: https://github.com/seanhess/web-view -github: seanhess/web-view +homepage: https://github.com/seanhess/atomic-css +github: seanhess/atomic-css license: BSD-3-Clause license-file: LICENSE author: Sean Hess @@ -35,6 +35,10 @@ default-extensions: - OverloadedRecordDot - DuplicateRecordFields - NoFieldSelectors + - TypeFamilies + - DerivingStrategies + - DefaultSignatures + - DeriveAnyClass dependencies: - base >=4.16 && <5 @@ -43,7 +47,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 +64,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..8f57526 --- /dev/null +++ b/src/Web/Atomic.hs @@ -0,0 +1,12 @@ +module Web.Atomic + ( module Web.Atomic.CSS + , module Web.Atomic.Types + , module Web.Atomic.Html + , module Web.Atomic.Render + ) where + +import Web.Atomic.CSS +import Web.Atomic.Html +import Web.Atomic.Render +import Web.Atomic.Types + diff --git a/src/Web/Atomic/Attributes.hs b/src/Web/Atomic/Attributes.hs new file mode 100644 index 0000000..3be3f4b --- /dev/null +++ b/src/Web/Atomic/Attributes.hs @@ -0,0 +1,19 @@ +module Web.Atomic.Attributes + ( Attributable (..) + , class_ + , att + , Name + , AttValue + , Attributes + ) where + +import Data.Map.Strict qualified as M +import Web.Atomic.Types + + +-- merge class names instead of replacing them, separating by spaces +-- this is no good! +-- the merging won't preserve this logic +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..ce3a0f3 --- /dev/null +++ b/src/Web/Atomic/CSS.hs @@ -0,0 +1,59 @@ +module Web.Atomic.CSS + ( module Web.Atomic.CSS.Select + , module Web.Atomic.CSS.Box + , module Web.Atomic.CSS.Text + , module Web.Atomic.CSS.Transition + , module Web.Atomic.CSS.Layout + , module Web.Atomic.Types.Styleable + , module Web.Atomic.Types.Style + , Media (..) + , module Web.Atomic.CSS.Reset + -- not sure where to put these + , list + , ListType (..) + , pointer + ) where + +import Web.Atomic.CSS.Box +import Web.Atomic.CSS.Layout +import Web.Atomic.CSS.Reset +import Web.Atomic.CSS.Select (active, descendentOf, even, hover, media, odd) +import Web.Atomic.CSS.Text +import Web.Atomic.CSS.Transition +import Web.Atomic.Types +import Web.Atomic.Types.Style +import Web.Atomic.Types.Styleable (CSS, Styleable, cls, css, utility, (~)) + + +{- | Set the list style of an item + +> ol id $ do +> li (list Decimal) "First" +> li (list Decimal) "Second" +> li (list Decimal) "Third" +-} +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 = row id $ do +> el btn "Login" +> el btn "Sign Up" +-} +pointer :: (Styleable h) => CSS h -> CSS h +pointer = utility "pointer" ["cursor" :. "pointer"] diff --git a/src/Web/Atomic/CSS/Box.hs b/src/Web/Atomic/CSS/Box.hs new file mode 100644 index 0000000..5e014b0 --- /dev/null +++ b/src/Web/Atomic/CSS/Box.hs @@ -0,0 +1,145 @@ +module Web.Atomic.CSS.Box where + +import Web.Atomic.Types + + +-- | Cut off the contents of the element +truncate :: (Styleable h) => CSS h -> CSS h +truncate = + utility + "truncate" + [ "white-space" :. "nowrap" + , "overflow" :. "hidden" + , "text-overflow" :. "ellipsis" + ] + + +{- | 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 :: (Styleable h) => Sides Length -> CSS h -> CSS h +pad (All n) = + utility ("p" -. n) ["padding" :. style n] +pad (Y n) = pad (T n) . pad (B n) +pad (X n) = pad (L n) . pad (R n) +pad (XY x y) = pad (X x) . pad (Y y) +pad (TRBL t r b l) = + pad (T t) . pad (R r) . pad (B b) . pad (L l) +pad (T x) = utility ("pt" -. x) ["padding-top" :. style x] +pad (R x) = utility ("pr" -. x) ["padding-right" :. style x] +pad (B x) = utility ("pb" -. x) ["padding-bottom" :. style x] +pad (L x) = utility ("pl" -. x) ["padding-left" :. style 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 :: (Styleable h) => Length -> CSS h -> CSS h +gap n = utility ("gap" -. n) ["gap" :. style n] + + +margin :: (Styleable h) => Sides Length -> CSS h -> CSS h +margin (All n) = + utility ("m" -. n) ["margin" :. style n] +margin (Y n) = margin (T n) . margin (B n) +margin (X n) = margin (L n) . margin (R n) +margin (XY x y) = margin (X x) . margin (Y y) +margin (TRBL t r b l) = + margin (T t) . margin (R r) . margin (B b) . margin (L l) +margin (T x) = utility ("mt" -. x) ["margin-top" :. style x] +margin (R x) = utility ("mr" -. x) ["margin-right" :. style x] +margin (B x) = utility ("mb" -. x) ["margin-bottom" :. style x] +margin (L x) = utility ("ml" -. x) ["margin-left" :. style x] +margin (TR t r) = margin (TRBL t r 0 0) +margin (TL t l) = margin (TRBL t 0 0 l) +margin (BR b r) = margin (TRBL 0 r b 0) +margin (BL b l) = margin (TRBL 0 0 b l) + + +{- | 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 'Web.View.Types.ToColor' +bg :: (ToColor clr, Styleable h) => clr -> CSS h -> CSS h +bg c = utility ("bg" -. colorName c) ["background-color" :. style (colorValue c)] + + +data BorderStyle + = Solid + | Dashed + deriving (Show, ToStyle, ToClassName) + + +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] + + +-- | 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" +-} +borderWidth :: (Styleable h) => Sides PxRem -> CSS h -> CSS h +borderWidth (All n) = + utility ("brd" -. n) ["border-width" :. style n] +borderWidth (Y n) = borderWidth (T n) . borderWidth (B n) +borderWidth (X n) = borderWidth (L n) . borderWidth (R n) +borderWidth (XY x y) = borderWidth (X x) . borderWidth (Y y) +borderWidth (TRBL t r b l) = + borderWidth (T t) . borderWidth (R r) . borderWidth (B b) . borderWidth (L l) +borderWidth (T x) = utility ("brdt" -. x) ["border-top-width" :. style x] +borderWidth (R x) = utility ("brdt" -. x) ["border-right-width" :. style x] +borderWidth (B x) = utility ("brdt" -. x) ["border-bottom-width" :. style x] +borderWidth (L x) = utility ("brdt" -. x) ["border-left-width" :. style x] +borderWidth (TR t r) = borderWidth (TRBL t r 0 0) +borderWidth (TL t l) = borderWidth (TRBL t 0 0 l) +borderWidth (BR b r) = borderWidth (TRBL 0 r b 0) +borderWidth (BL b l) = borderWidth (TRBL 0 0 b l) + + +-- | Set a border color. See 'Web.View.Types.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] diff --git a/src/Web/Atomic/CSS/Layout.hs b/src/Web/Atomic/CSS/Layout.hs new file mode 100644 index 0000000..0090c67 --- /dev/null +++ b/src/Web/Atomic/CSS/Layout.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module Web.Atomic.CSS.Layout where + +import Web.Atomic.Types + + +{- | 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 :: Html () -> Html () +-- layout = col @ fillViewport + +{- | As `layout` but as a 'Attributes + +> holygrail = col root $ do +> ... +-} +fillViewport :: (Styleable h) => CSS h -> CSS h +fillViewport = + utility + "fill-viewport" + -- [ ("white-space", "pre") + [ "width" :. "100vw" + , "height" :. "100vh" + , -- not sure if this property is necessary, copied from older code + "min-height" :. "100vh" + , "z-index" :. "0" + ] + + +{- | Lay out children in a row + +> row id $ do +> el_ "Left" +> space +> el_ "Right" +-} +flexRow :: (Styleable h) => CSS h -> CSS h +flexRow = + utility + "row" + [ "display" :. "flex" + , "flex-direction" :. style Row + ] + + +{- | Lay out children in a column. + +> col grow $ do +> el_ "Top" +> space +> el_ "Bottom" +-} +flexCol :: (Styleable h) => CSS h -> CSS h +flexCol = + utility + "col" + [ "display" :. "flex" + , "flex-direction" :. style Column + ] + + +{- | 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 :: (Styleable h) => CSS h -> CSS h +grow = utility "grow" ["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 :: (IsHtml h, AppliedParent h ~ h, Styleable h) => h +-- 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 :: (Styleable h) => CSS h -> CSS h +scroll = utility "scroll" ["overflow" :. "auto"] + + +{- | A Nav element +nav :: (IsHtml h) => h -> h +nav = tag "nav" +-} + +{- | 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 :: (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" + ] + + +{- | 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 :: (Styleable h) => Sides Length -> CSS h -> CSS h +popup sides = + position Absolute . inset sides + + +-- | Set top, bottom, right, and left. See 'Web.View.Layout.stack' and 'Web.View.Layout.popup' +inset :: (Styleable h) => Sides Length -> CSS h -> CSS h +inset sides = off sides + where + 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 -> 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 + + +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" + + +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 'Web.View.Layout.stack' and 'Web.View.Layout.popup' +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) "HIDDEN" +-} +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 + + +hidden :: (Styleable h) => CSS h -> CSS h +hidden = utility "hidden" ["visibility" :. "hidden"] + + +visible :: (Styleable h) => CSS h -> CSS h +visible = utility "hidden" ["visibility" :. "visible"] + + +-- | Set to a specific width +width :: (Styleable h) => Length -> CSS h -> CSS h +width n = + utility + ("w" -. n) + [ "width" :. style n + , "flex-shrink" :. "0" + ] + + +-- | Set to a specific height +height :: (Styleable h) => Length -> CSS h -> CSS h +height n = + utility + ("h" -. n) + [ "height" :. style n + , "flex-shrink" :. "0" + ] + + +-- | 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] diff --git a/src/Web/View/Reset.hs b/src/Web/Atomic/CSS/Reset.hs similarity index 96% rename from src/Web/View/Reset.hs rename to src/Web/Atomic/CSS/Reset.hs index 89df2d0..3a55aea 100644 --- a/src/Web/View/Reset.hs +++ b/src/Web/Atomic/CSS/Reset.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Web.View.Reset where +module Web.Atomic.CSS.Reset where import Data.ByteString import Data.FileEmbed diff --git a/src/Web/Atomic/CSS/Select.hs b/src/Web/Atomic/CSS/Select.hs new file mode 100644 index 0000000..a63608f --- /dev/null +++ b/src/Web/Atomic/CSS/Select.hs @@ -0,0 +1,62 @@ +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)) +> "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 + } + + +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..3917117 --- /dev/null +++ b/src/Web/Atomic/CSS/Text.hs @@ -0,0 +1,54 @@ +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] + + +-- | Set the text color. See 'Web.View.Types.ToColor' +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 TextWrap +instance PropertyStyle TextWrap Wrap + + +-- = Balance +-- | Pretty +-- | Stable +-- deriving (Show, ToStyleValue, ToClassName) + +textWrap :: (PropertyStyle TextWrap w, ToClassName w, Styleable h) => w -> CSS h -> CSS h +textWrap w = + utility ("twrap" -. w) ["text-wrap" :. propertyStyle @TextWrap w] diff --git a/src/Web/Atomic/CSS/Transition.hs b/src/Web/Atomic/CSS/Transition.hs new file mode 100644 index 0000000..c3e8598 --- /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..0ac9e31 --- /dev/null +++ b/src/Web/Atomic/Html.hs @@ -0,0 +1,137 @@ +{-# 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 + + +-- | A single HTML tag. Note that the class attribute is generated separately from the css, rather than the attributes +data Element = Element + { inline :: Bool + , name :: Text + , css :: [Rule] + , attributes :: Map Name AttValue + , content :: [Node] + } + + +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) + + +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 h = + mapElement (\elm -> elm{attributes = f elm.attributes}) h + + +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] + + +instance Styleable (Html a) where + modCSS f h = + mapElement (\elm -> elm{css = f elm.css}) h + + +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 = + -- fmap (.className) $ elm.css <> M.elems elm.styles + L.sort $ fmap ruleClassName $ elm.css + +-- -- TEST -------------------------- +-- +-- asdf :: (Attributable h) => Attributes h -> Attributes h +-- asdf = att "asdf" "hello" +-- +-- +-- asdf2 :: Attributes (Html a -> Html a) -> Attributes (Html a -> Html a) +-- asdf2 = att "asdf" "hello" +-- +-- +-- test :: Html () +-- test = tag "div" @ asdf2 $ none diff --git a/src/Web/Atomic/Render.hs b/src/Web/Atomic/Render.hs new file mode 100644 index 0000000..19a228b --- /dev/null +++ b/src/Web/Atomic/Render.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE OverloadedLists #-} + +module Web.Atomic.Render where + +import Data.ByteString.Lazy qualified as BL +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 L +import Data.Text.Lazy.Encoding qualified as LE +import HTMLEntities.Text qualified as HE +import Web.Atomic.Html +import Web.Atomic.Types + + +renderLazyText :: Html () -> L.Text +renderLazyText = L.fromStrict . renderText + + +renderLazyByteString :: Html () -> BL.ByteString +renderLazyByteString = LE.encodeUtf8 . renderLazyText + + +{- | Renders a 'View' as HTML with embedded CSS class definitions + +>>> renderText $ el bold "Hello" + +
Hello
+-} +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 'Web.View.Types.Attributes' 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 . 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..ce6ac26 --- /dev/null +++ b/src/Web/Atomic/Types/Attributable.hs @@ -0,0 +1,53 @@ +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 + (@) :: 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 m = f m + + +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..de73011 --- /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 +import Numeric (showFFloat) + + +-- | 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 $ pack $ showFFloat (Just 3) f "" +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 6 -. + + +joinClassSegments :: Text -> ClassName -> ClassName -> ClassName +joinClassSegments _ "" cn = cn +joinClassSegments _ cn "" = cn +joinClassSegments sep (ClassName cn1) (ClassName cn2) = + ClassName $ cn1 <> sep <> cn2 + + +addClassState :: (ToClassName a) => a -> ClassName -> ClassName +addClassState a cn = joinClassSegments ":" (toClassName a) cn + + +-- 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..2a34a1d --- /dev/null +++ b/src/Web/Atomic/Types/Rule.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE LambdaCase #-} + +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 + + +-- rule :: ClassName -> [Declaration] -> Rule +-- rule cn ds = +-- (Rule cn (selector cn) mempty ds) + +-- | An empty rule that only adds the classname +fromClass :: ClassName -> Rule +fromClass cn = Rule cn mempty mempty mempty + + +rule :: ClassName -> [Declaration] -> Rule +rule cn ds = Rule cn mempty mempty ds + + +ruleMap :: [Rule] -> Map Selector Rule +ruleMap rs = foldl' (\m r -> M.insert (ruleSelector r) r m) M.empty rs + + +{- | 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..5e0f124 --- /dev/null +++ b/src/Web/Atomic/Types/Style.hs @@ -0,0 +1,210 @@ +{-# 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) + + +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 property value +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 + + +-- uniquely set the style value based on the property in question +class PropertyStyle property value where + propertyStyle :: value -> Style + default propertyStyle :: (ToStyle value) => value -> Style + propertyStyle = style + + +data None = None + deriving (Show, ToClassName, ToStyle) + + +-- -- | 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. 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) + + +-- ** 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.Atomic.Types.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 + +-- (.:) :: (ToStyle a) => Property -> Style -> Declaration +-- cn .: v = +-- Declaration cn (toStyleValue v) diff --git a/src/Web/Atomic/Types/Styleable.hs b/src/Web/Atomic/Types/Styleable.hs new file mode 100644 index 0000000..b3a9e0b --- /dev/null +++ b/src/Web/Atomic/Types/Styleable.hs @@ -0,0 +1,77 @@ +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 + (~) :: 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 rs = f rs + + +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 + + +cls :: (Styleable h) => ClassName -> CSS h -> CSS h +cls cn (CSS rs) = + CSS $ Rule.fromClass cn : rs + + +-- Custom CSS +css :: (Styleable h) => ClassName -> Selector -> [Declaration] -> CSS h -> CSS h +css cn sel ds (CSS rs) = + CSS $ Rule cn (CustomRule sel) mempty ds : rs + + +utility :: (Styleable h) => ClassName -> [Declaration] -> CSS h -> CSS h +utility cn ds (CSS rs) = + CSS $ rule cn 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/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..ebc6cc8 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 Control.Monad (zipWithM_) import Data.Text (Text) 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 "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 + + +el :: Html () -> Html () +el = tag "div" + +-- 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..b52ffb6 --- /dev/null +++ b/test/Test/RuleSpec.hs @@ -0,0 +1,109 @@ +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 unset same property using (~)" $ do + -- let rs = [] ~ fontSize 12 . bold ~ fontSize 24 + -- length rs `shouldBe` 3 + -- 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" + + -- it "doesn't change with custom selectors" $ do + -- ruleClassName (Rule "hello" (Just ".hello") [Hover] [MinWidth 100] []) `shouldBe` "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..40f875a 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 rs :: [Rule] = [] ~ 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 @@ -
+
hello
world
diff --git a/test/resources/escaping.txt b/test/resources/escaping.txt deleted file mode 100644 index a06a7f7..0000000 --- a/test/resources/escaping.txt +++ /dev/null @@ -1,5 +0,0 @@ -
I am <malicious> &apos;user
-
-
I am <malicious> &apos;user
-
I am another <malicious> &apos;user
-
diff --git a/test/resources/nested.txt b/test/resources/nested.txt deleted file mode 100644 index 7e4e2c1..0000000 --- a/test/resources/nested.txt +++ /dev/null @@ -1,5 +0,0 @@ -
-
-
HI
-
-
diff --git a/test/resources/nocss.txt b/test/resources/nocss.txt deleted file mode 100644 index 12c3035..0000000 --- a/test/resources/nocss.txt +++ /dev/null @@ -1 +0,0 @@ -
i have no css
diff --git a/test/resources/nocssattrs.txt b/test/resources/nocssattrs.txt deleted file mode 100644 index 4168a6e..0000000 --- a/test/resources/nocssattrs.txt +++ /dev/null @@ -1,6 +0,0 @@ - - -
i have no css
-
i have some css
diff --git a/test/resources/raw.txt b/test/resources/raw.txt deleted file mode 100644 index bc72e65..0000000 --- a/test/resources/raw.txt +++ /dev/null @@ -1,7 +0,0 @@ - - -
- &"' -
diff --git a/test/resources/tooltips.txt b/test/resources/tooltips.txt new file mode 100644 index 0000000..f51f662 --- /dev/null +++ b/test/resources/tooltips.txt @@ -0,0 +1,81 @@ + + +
+
CSS ONLY TOOLTIPS
+
some stuff
+ sometext
+
One
+ +
+
+
Two
+ +
+
+
Three
+ +
+
+
Four
+ +
+
+
Five
+ +
+
+
Six
+ +
+