Style class. display, li, code

src/Web/View.hs

@@ -48,6 +48,7 @@ module Web.View
   , raw
   , none
   , pre
+  , code
 
     -- ** Inputs
   , form
@@ -58,6 +59,11 @@ module Web.View
   , link
   , button
 
+    -- ** Lists
+  , ol
+  , ul
+  , li
+
     -- ** Tables
   , table
   , tcol
@@ -78,6 +84,7 @@ module Web.View
   , minHeight
   , flexRow
   , flexCol
+  , display
   , pad
   , gap
   , hide
@@ -89,11 +96,14 @@ module Web.View
   , color
   , bg
   , bold
+  , italic
+  , underline
   , border
   , borderColor
   , pointer
   , transition
   , textAlign
+  , list
 
     -- ** Selector States
   , hover
@@ -121,6 +131,8 @@ module Web.View
   , ToColor (..)
   , HexColor (..)
   , Align (..)
+  , ListType (..)
+  , None (..)
 
     -- * Url
   , module Web.View.Types.Url

src/Web/View/Element.hs

@@ -61,6 +61,10 @@ 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)
@@ -163,3 +167,21 @@ data TableColumn c dt = TableColumn
   { 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/Style.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -120,12 +123,51 @@ flexCol =
       & 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
@@ -150,12 +192,27 @@ bold :: Mod c
 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
@@ -401,7 +458,17 @@ prop n v c =
 
 -- | 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

@@ -170,6 +170,8 @@ 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
@@ -186,7 +188,7 @@ data Pseudo
 
 -- | 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 @@ instance ToStyleValue Float where
   toStyleValue n = StyleValue $ showFFloat (Just 2) n ""
 
 
+instance ToStyleValue StyleValue where
+  toStyleValue = id
+
+
 data Length
   = PxRem PxRem
   | Pct Float
@@ -348,3 +354,15 @@ instance ToClassName HexColor where
 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

@@ -49,7 +49,7 @@ 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.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

test/Test/StyleSpec.hs

@@ -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

@@ -1,6 +1,6 @@
 cabal-version: 2.2
 
--- This file has been generated from package.yaml by hpack version 0.36.1.
+-- This file has been generated from package.yaml by hpack version 0.37.0.
 --
 -- see: https://github.com/sol/hpack
 
@@ -70,6 +70,7 @@ test-suite test
   main-is: Spec.hs
   other-modules:
       Test.RenderSpec
+      Test.StyleSpec
       Test.UrlSpec
       Test.ViewSpec
       Paths_web_view