web-view 0.6.0 → 0.6.1
raw patch · 10 files changed
+244/−28 lines, 10 files
Files
- README.md +56/−0
- src/Web/View.hs +12/−0
- src/Web/View/Element.hs +22/−0
- src/Web/View/Render.hs +6/−6
- src/Web/View/Style.hs +78/−11
- src/Web/View/Types.hs +22/−4
- src/Web/View/View.hs +3/−3
- test/Test/RenderSpec.hs +8/−1
- test/Test/StyleSpec.hs +32/−0
- web-view.cabal +5/−3
README.md view
@@ -71,6 +71,62 @@ "Big if window > 800" ``` +### 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++Local Development+-----------------++### Nix++Prepend targets with ghc982 or ghc966 to use GHC 9.8.2 or GHC 9.6.6++- `nix run` starts the example project with GHC 9.8.2+- `nix develop` to get a shell with all dependencies installed for GHC 9.8.2. +- `nix develop .#ghc966-web-view` for GHC 9.6.6++You can also get a development shell for the example project with:++```+cd example+nix develop ../#ghc982-example+cabal run+```++You can import this flake's overlay to add `web-view` to all package sets and override ghc966 and ghc982 with the packages to satisfy `web-view`'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";+ flake-utils.url = "github:numtide/flake-utils";+ };++ outputs = { self, nixpkgs, web-view, flake-utils, ... }:+ flake-utils.lib.eachDefaultSystem (+ system:+ let+ pkgs = import nixpkgs {+ inherit system;+ overlays = [ web-view.overlays.default ];+ };+ haskellPackagesOverride = pkgs.haskell.packages.ghc966.override (old: {+ overrides = pkgs.lib.composeExtensions (old.overrides or (_: _: { })) (hfinal: hprev: {+ # your overrides here+ });+ });+ in+ {+ devShells.default = haskellPackagesOverride.shellFor {+ packages = p: [ p.web-view ];+ };+ }+ );+}+```+ Learn More ----------
src/Web/View.hs view
@@ -48,6 +48,7 @@ , raw , none , pre+ , code -- ** Inputs , form@@ -58,6 +59,11 @@ , link , button + -- ** Lists+ , ol+ , ul+ , li+ -- ** Tables , table , tcol@@ -78,6 +84,7 @@ , minHeight , flexRow , flexCol+ , display , pad , gap , hide@@ -89,11 +96,14 @@ , color , bg , bold+ , italic+ , underline , border , borderColor , pointer , transition , textAlign+ , list -- ** Selector States , hover@@ -121,6 +131,8 @@ , ToColor (..) , HexColor (..) , Align (..)+ , ListType (..)+ , None (..) -- * Url , module Web.View.Types.Url
src/Web/View/Element.hs view
@@ -61,6 +61,10 @@ 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)@@ -163,3 +167,21 @@ { headCell :: View (TableHead c) () , dataCell :: dt -> View dt () }+++-- * Lists+++data ListItem = ListItem+++ul :: Mod c -> View ListItem () -> View c ()+ul f cnt = tag "ul" f $ addContext ListItem cnt+++ol :: Mod c -> View ListItem () -> View c ()+ol f cnt = tag "ol" f $ addContext ListItem cnt+++li :: Mod ListItem -> View ListItem () -> View ListItem ()+li = tag "li"
src/Web/View/Render.hs view
@@ -8,7 +8,7 @@ import Data.ByteString.Lazy qualified as BL import Data.Function ((&))-import Data.List (foldl', sortOn)+import Data.List (foldl') import Data.Map qualified as M import Data.Maybe (mapMaybe) import Data.String (fromString)@@ -40,8 +40,7 @@ renderLazyByteString = LE.encodeUtf8 . renderLazyText -data Line- = Line {end :: LineEnd, indent :: Int, text :: Text}+data Line = Line {end :: LineEnd, indent :: Int, text :: Text} deriving (Show, Eq) @@ -142,7 +141,7 @@ renderCSS :: CSS -> [Line]-renderCSS = mapMaybe renderClass . sortOn (.selector)+renderCSS = mapMaybe renderClass . M.elems where renderClass :: Class -> Maybe Line renderClass c | M.null c.properties = Nothing@@ -251,8 +250,9 @@ FlatAttributes $ addClass t.attributes.classes t.attributes.other where- addClass [] atts = atts- addClass cx atts = M.insert "class" (classAttValue cx) atts+ addClass css atts+ | M.null css = atts+ | otherwise = M.insert "class" (classAttValue $ M.elems css) atts classAttValue :: [Class] -> Text classAttValue cx =
src/Web/View/Style.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-}@@ -120,14 +123,53 @@ & prop @Text "flex-direction" "column" +-- | Set container display to Block or none+display :: (Style Display a, ToClassName a) => a -> Mod c+display display =+ addClass $+ cls ("disp" -. display)+ & prop "display" (styleValue @Display display)+++data Display+ = Block+ deriving (Show, ToClassName, ToStyleValue)+instance Style Display Display+instance Style Display None+++-- | Hide an element. See 'display'+hide :: Mod c+hide = display None++ -- | Adds a basic drop shadow to an element shadow :: Mod c-shadow =+shadow = shadow' ()+++shadow' :: (Style Shadow a, ToClassName a) => a -> Mod c+shadow' a = addClass $- cls "shadow"- & prop @Text "box-shadow" "0 1px 3px 0 rgb(0 0 0 / 0.1), 0 1px 2px -1px rgb(0 0 0 / 0.1)"+ 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@@ -150,14 +192,29 @@ bold = addClass $ cls "bold" & prop @Text "font-weight" "bold" --- | Hide an element. See 'parent' and 'media'-hide :: Mod c-hide =+italic :: Mod c+italic = addClass $ cls "italic" & prop @Text "font-style" "italic"+++underline :: Mod c+underline = addClass $ cls "underline" & prop @Text "text-decoration" "underline"+++list :: (ToClassName a, Style ListType a) => a -> Mod c+list a = addClass $- cls "hide"- & prop @Text "display" "none"+ 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 $@@ -346,7 +403,7 @@ -- ignore let as' = fm $ Attributes [] [] in as'- { classes = as.classes <> map fc as'.classes+ { classes = as.classes <> fmap fc as'.classes , other = as.other <> as'.other } @@ -375,7 +432,7 @@ addClass :: Class -> Mod c addClass c attributes = Attributes- { classes = c : attributes.classes+ { classes = M.insert c.selector c attributes.classes , other = attributes.other } @@ -401,7 +458,17 @@ -- | Hyphenate classnames (-.) :: (ToClassName a) => ClassName -> a -> ClassName-(ClassName n) -. a = (ClassName $ n <> "-") <> toClassName a+(ClassName n) -. a =+ case toClassName a of+ "" -> ClassName n+ suffix -> (ClassName $ n <> "-") <> suffix infixl 6 -.+++-- uniquely set the style value based on this+class Style style value where+ styleValue :: value -> StyleValue+ default styleValue :: (ToStyleValue value) => value -> StyleValue+ styleValue = toStyleValue
src/Web/View/Types.hs view
@@ -43,7 +43,7 @@ -- | The Attributes for an 'Element'. Classes are merged and managed separately from the other attributes. data Attributes c = Attributes- { classes :: [Class]+ { classes :: CSS , other :: Map Name AttValue } deriving (Show, Eq)@@ -52,7 +52,7 @@ 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 = Attributes mempty mempty type Attribute = (Name, AttValue) type Name = Text type AttValue = Text@@ -82,7 +82,7 @@ -- TODO: document atomic CSS here? -- | All the atomic classes used in a 'Web.View.View'-type CSS = [Class]+type CSS = Map Selector Class -- | Atomic classes include a selector and the corresponding styles@@ -170,6 +170,8 @@ 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@@ -186,7 +188,7 @@ -- | The value of a css style property newtype StyleValue = StyleValue String- deriving newtype (IsString, Show, Eq)+ deriving newtype (IsString, Show, Eq, Monoid, Semigroup) -- | Use a type as a css style property value@@ -212,6 +214,10 @@ toStyleValue n = StyleValue $ showFFloat (Just 2) n "" +instance ToStyleValue StyleValue where+ toStyleValue = id++ data Length = PxRem PxRem | Pct Float@@ -348,3 +354,15 @@ data Align = Center deriving (Show, ToClassName, ToStyleValue)+++data None = None+ deriving (Show, ToClassName, ToStyleValue)++-- data Size+-- = Sm+-- | Md+-- | Lg+-- | Xl+-- | Xl2+-- deriving (Show, ToClassName)
src/Web/View/View.hs view
@@ -49,7 +49,7 @@ 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.table' and https://hackage.haskell.org/package/hyperbole/docs/Web-Hyperbole.html+{- | 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@@ -91,12 +91,12 @@ ES.modify $ \s -> s{css = f s.css} -viewAddClasses :: [Class] -> View c ()+viewAddClasses :: CSS -> View c () viewAddClasses clss = do viewModCss $ \cm -> foldr addClsDef cm clss where addClsDef :: Class -> CSS -> CSS- addClsDef c = (c :)+ addClsDef c = M.insert c.selector c viewAddContent :: Content -> View c ()
test/Test/RenderSpec.hs view
@@ -55,9 +55,14 @@ renderLines (renderCSS (runCSS view)) `shouldBe` ".bold { font-weight:bold }" it "should skip css element when no css rules" $ do- let res = renderText $ el (addClass $ cls "empty") "i have no css"+ let res = renderText $ el empty "i have no css" res `shouldBe` "<div class='empty'>i have no css</div>" + 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"@@ -83,6 +88,8 @@ el_ $ do el_ "HI" out `shouldBe` golden+ where+ empty = addClass $ cls "empty" selectorSpec :: Spec
+ test/Test/StyleSpec.hs view
@@ -0,0 +1,32 @@+module Test.StyleSpec (spec) where++import Data.Map qualified as M+import Skeletest+import Web.View+import Web.View.Style ((-.))+import Web.View.Types (Attributes (..), Class (..), selector)+import Prelude hiding (span)+++spec :: Spec+spec = do+ describe "Style Class" $ 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")]++ 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")]++ describe "ToClassName" $ do+ it "should hyphenate classnames" $ do+ "woot" -. None `shouldBe` "woot-none"+ it "should not hyphenate with empty suffix" $ do+ "woot" -. () `shouldBe` "woot"
web-view.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: web-view-version: 0.6.0+version: 0.6.1 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@@ -16,6 +16,9 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple+tested-with:+ GHC == 9.8.2+ , GHC == 9.6.6 extra-source-files: embed/preflight.css extra-doc-files:@@ -67,6 +70,7 @@ main-is: Spec.hs other-modules: Test.RenderSpec+ Test.StyleSpec Test.UrlSpec Test.ViewSpec Paths_web_view@@ -80,8 +84,6 @@ DuplicateRecordFields NoFieldSelectors ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor- build-tool-depends:- skeletest:skeletest-preprocessor build-depends: Diff >=0.5 && <1.0 , base >=4.16 && <5