diff --git a/src/Web/View.hs b/src/Web/View.hs index d312a35..3c5f967 100644 --- a/src/Web/View.hs +++ b/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 diff --git a/src/Web/View/Element.hs b/src/Web/View/Element.hs index cb5cc1d..31b1dc7 100644 --- a/src/Web/View/Element.hs +++ b/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" diff --git a/src/Web/View/Style.hs b/src/Web/View/Style.hs index 26f69cf..4f63763 100644 --- a/src/Web/View/Style.hs +++ b/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 diff --git a/src/Web/View/Types.hs b/src/Web/View/Types.hs index 1ada41b..4cac832 100644 --- a/src/Web/View/Types.hs +++ b/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) diff --git a/src/Web/View/View.hs b/src/Web/View/View.hs index a0a522d..d6094cb 100644 --- a/src/Web/View/View.hs +++ b/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 diff --git a/test/Test/StyleSpec.hs b/test/Test/StyleSpec.hs new file mode 100644 index 0000000..6aa32c8 --- /dev/null +++ b/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" diff --git a/web-view.cabal b/web-view.cabal index 0e179d5..36de158 100644 --- a/web-view.cabal +++ b/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