web-view 0.3.1 → 0.4.0
raw patch · 11 files changed
+343/−316 lines, 11 filesdep +effectful-coredep −effectfuldep −waidep −warpdep ~http-types
Dependencies added: effectful-core
Dependencies removed: effectful, wai, warp
Dependency ranges changed: http-types
Files
- CHANGELOG.md +8/−0
- README.md +3/−3
- example/Main.hs +0/−155
- src/Web/View.hs +13/−2
- src/Web/View/Element.hs +2/−1
- src/Web/View/Reset.hs +4/−4
- src/Web/View/Style.hs +109/−107
- src/Web/View/Types.hs +56/−11
- src/Web/View/Types/Url.hs +101/−0
- test/Test/UrlSpec.hs +39/−0
- web-view.cabal +8/−33
CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for web-view +## 0.4.0++* Added new Mods. Length type. Improved Url type++## 0.3.1++* Cleanup. Refactored Mods+ ## 0.2.3 -- 2023-11-27 * First version. Released on an unsuspecting world.
README.md view
@@ -1,10 +1,10 @@ Web View ============ -Type-safe HTML and CSS with intuitive layout and composable styles. Inspired by Tailwindcss and Elm-UI- [][hackage] +Type-safe HTML and CSS with intuitive layout and composable styles. Inspired by Tailwindcss and Elm-UI+ ### Write Haskell instead of CSS Type-safe utility functions to generate styled HTML.@@ -81,7 +81,7 @@ View on Github * https://github.com/seanhess/web-view -View [Examples](https://github.com/seanhess/web-view/blob/main/example/Main.hs)+View [Examples](https://github.com/seanhess/web-view/blob/main/example/app/Main.hs) [hackage]: https://hackage.haskell.org/package/web-view
− example/Main.hs
@@ -1,155 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}--module Main where--import Data.String.Interpolate (i)-import Data.Text as T (Text, filter, toLower)-import Network.HTTP.Types (status200, status404)-import Network.Wai-import Network.Wai.Handler.Warp as Warp-import Web.View---main :: IO ()-main = do- putStrLn "Starting on http://localhost:3010/"- Warp.run 3010 app---clash :: View c ()-clash = col (gap 10 . pad 20) $ do- el (bold . fontSize 24) "Clash"- el_ "What happens if we set the same style twice?"-- el (bg Primary . bg Warning) "Hello"---buttons :: View c ()-buttons = col (gap 10 . pad 20) $ do- el (bold . fontSize 32) "My page"-- row (gap 10) $ do- button (btn Primary) "Do Something"- button (btn Secondary) "Cancel"-- --- button' Secondary "Another Example"- where- -- Make style functions to encourage reuse- btn c = bg c . hover (bg (light c)) . color White . rounded 3 . pad 15- light Primary = PrimaryLight- light Secondary = SecondaryLight- light _ = Gray-- -- alternatively, we can make View functions- button' c = button (btn c)---responsive :: View c ()-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_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- el_ "Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?"- where- sidebar = width 250 . flexCol- topbar = height 100 . flexRow- big = media (MinWidth 800)- 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- text "Content Upper Left"- space- row id $ do- space- text "Content Bottom Right"- col (bg Secondary) "Right Sidebar"- row (bg Primary) "Bottom Bar"---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 "clash" lnk "Clash"- where- lnk = color Primary- url = toLower . T.filter (/= ' ')---app :: Application-app req respond = do- case pathInfo req of- [] -> view examples- ["buttons"] -> view buttons- ["responsive"] -> view responsive- ["holygrail"] -> view holygrail- ["clash"] -> view clash- _ -> notFound- where- html h =- respond $ responseLBS status200 [("Content-Type", "text/html; charset=utf-8")] h-- notFound =- respond $ responseLBS status404 [("Content-Type", "text/plain; charset=utf-8")] "Not Found"-- view v =- html $ document $ renderLazyByteString v-- document cnt =- [i|<html>- <head><style type="text/css">#{cssResetEmbed}</style></head>- <body>#{cnt}</body>- </html>|]---data AppColor- = White- | Light- | Gray- | Dark- | Success- | Error- | Warning- | Primary- | PrimaryLight- | Secondary- | SecondaryLight- deriving (Show)---instance ToColor AppColor where- colorValue White = "#FFF"- colorValue Light = "#F2F2F3"- colorValue Gray = "#888"- colorValue Dark = "#2E3842" -- "#232C41"- colorValue Primary = "#2C74BB"- colorValue PrimaryLight = "#3281cf"- colorValue Success = "#D5E6DE"- colorValue Error = "#F3D8DA"- colorValue Warning = "#FDF3D1"- colorValue Secondary = "#5CADDB"- colorValue SecondaryLight = "#6CBDEB"
src/Web/View.hs view
@@ -62,6 +62,8 @@ , tcol , th , td+ , TableHead+ , TableColumn -- ** Document Metadata , script@@ -78,6 +80,8 @@ , pad , gap , hide+ , opacity+ , truncate , shadow , rounded , fontSize@@ -110,21 +114,28 @@ , Sides (..) , Media (..) , PxRem- , Url (..)+ , Length (..) , TransitionProperty (..) , Ms , ToColor (..) , HexColor (..)+ , Align (..)++ -- * 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)+import Prelude hiding (even, head, odd, truncate) {- $use
src/Web/View/Element.hs view
@@ -9,6 +9,7 @@ import Effectful.Writer.Static.Local import Web.View.Style import Web.View.Types+import Web.View.Types.Url import Web.View.View @@ -62,7 +63,7 @@ -- | A hyperlink to the given url link :: Url -> Mod -> View c () -> View c ()-link (Url u) f = tag "a" (att "href" u . f)+link u f = tag "a" (att "href" (renderUrl u) . f) -- * Inputs
src/Web/View/Reset.hs view
@@ -11,7 +11,7 @@ > import Data.String.Interpolate (i) >-> toDocument :: Text -> Text+> toDocument :: ByteString -> ByteString > toDocument cnt = > [i|<html> > <head>@@ -24,15 +24,15 @@ cssResetEmbed = $(embedFile "embed/preflight.css") -{- | Alternatively, the reset is available as on a CDN+{- | Alternatively, the reset is available on a CDN > import Data.String.Interpolate (i) >-> toDocument :: Text -> Text+> toDocument :: ByteString -> ByteString > toDocument cnt = > [i|<html> > <head>-> <link rel="stylesheet" href="#{cssResetEmbed}">+> <link rel="stylesheet" href="#{cssResetLink}"> > </head> > <body>#{cnt}</body> > </html>|]
src/Web/View/Style.hs view
@@ -15,37 +15,37 @@ -- | Set to a specific width-width :: PxRem -> Mod+width :: Length -> Mod width n =- addClass- $ cls ("w" -. n)- & prop "width" n- & prop @Int "flex-shrink" 0+ addClass $+ cls ("w" -. n)+ & prop "width" n+ & prop @Int "flex-shrink" 0 -- | Set to a specific height-height :: PxRem -> Mod+height :: Length -> Mod height n =- addClass- $ cls ("h" -. n)- & prop "height" n- & prop @Int "flex-shrink" 0+ 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 :: PxRem -> Mod+minWidth :: Length -> Mod minWidth n =- addClass- $ cls ("mw" -. n)- & prop "min-width" n+ addClass $+ cls ("mw" -. n)+ & prop "min-width" n -- | Allow height to grow to contents but not shrink any smaller than value-minHeight :: PxRem -> Mod+minHeight :: Length -> Mod minHeight n =- addClass- $ cls ("mh" -. n)- & prop "min-height" n+ addClass $+ cls ("mh" -. n)+ & prop "min-height" n {- | Space surrounding the children of the element@@ -57,43 +57,43 @@ > el_ "two" > el_ "three" -}-pad :: Sides PxRem -> Mod+pad :: Sides Length -> Mod pad (All n) =- addClass- $ cls ("pad" -. n)- & prop "padding" n+ addClass $+ cls ("pad" -. n)+ & prop "padding" n pad (Y n) =- addClass- $ cls ("pady" -. n)- & prop "padding-top" n- & prop "padding-bottom" 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+ addClass $+ cls ("padx" -. n)+ & prop "padding-left" n+ & prop "padding-right" n pad (XY x y) =- addClass- $ cls ("pad" -. x -. y)- & prop "padding-left" x- & prop "padding-right" x- & prop "padding-top" y- & prop "padding-bottom" y+ addClass $+ cls ("pad" -. x -. y)+ & prop "padding-left" x+ & prop "padding-right" x+ & prop "padding-top" y+ & prop "padding-bottom" y 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+ addClass $+ cls ("pad" -. t -. r -. b -. l)+ & prop "padding-top" t+ & prop "padding-right" r+ & prop "padding-bottom" b+ & prop "padding-left" l -- | The space between child elements. See 'pad'-gap :: PxRem -> Mod+gap :: Length -> Mod gap n = addClass $ cls ("gap" -. n) & prop "gap" n -fontSize :: PxRem -> Mod+fontSize :: Length -> Mod fontSize n = addClass $ cls ("fs" -. n) & prop "font-size" n @@ -103,40 +103,40 @@ -- | Set container to be a row. Favor 'Web.View.Layout.row' when possible flexRow :: Mod flexRow =- addClass- $ cls "row"- & prop @Text "display" "flex"- & prop @Text "flex-direction" "row"+ 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 flexCol =- addClass- $ cls "col"- & prop @Text "display" "flex"- & prop @Text "flex-direction" "column"+ addClass $+ cls "col"+ & prop @Text "display" "flex"+ & prop @Text "flex-direction" "column" -- | Adds a basic drop shadow to an element shadow :: Mod shadow =- 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)"+ 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)" -- | Round the corners of the element-rounded :: PxRem -> Mod+rounded :: Length -> Mod rounded n = addClass $ cls ("rnd" -. n) & prop "border-radius" n -- | Set the background color. See 'Web.View.Types.ToColor' bg :: (ToColor c) => c -> Mod bg c =- addClass- $ cls ("bg" -. colorName c)- & prop "background-color" (colorValue c)+ addClass $+ cls ("bg" -. colorName c)+ & prop "background-color" (colorValue c) -- | Set the text color. See 'Web.View.Types.ToColor'@@ -151,11 +151,18 @@ -- | Hide an element. See 'parent' and 'media' hide :: Mod hide =- addClass- $ cls "hide"- & prop @Text "display" "none"+ addClass $+ cls "hide"+ & prop @Text "display" "none" +opacity :: Float -> Mod+opacity n =+ addClass $+ cls ("opacity" -. n)+ & prop "opacity" n++ {- | Set a border around the element > el (border 1) "all sides"@@ -163,42 +170,42 @@ -} border :: Sides PxRem -> Mod border (All p) =- addClass- $ cls ("brd" -. p)- & prop "border" p- & prop @Text "border-style" "solid"+ 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+ 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+ addClass $+ cls ("brdx" -. p)+ & prop "border-left-width" p+ & prop "border-right-width" p border (XY x y) =- addClass- $ cls ("brd" -. x -. y)- & prop "border-right-width" x- & prop "border-left-width" x- & prop "border-top-width" y- & prop "border-bottom-width" y+ addClass $+ cls ("brd" -. x -. y)+ & prop "border-right-width" x+ & prop "border-left-width" x+ & prop "border-top-width" y+ & prop "border-bottom-width" y 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+ 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 -- | Set a border color. See 'Web.View.Types.ToColor' borderColor :: (ToColor c) => c -> Mod borderColor c =- addClass- $ cls ("brdc" -. colorName c)- & prop "border-color" (colorValue c)+ addClass $+ cls ("brdc" -. colorName c)+ & prop "border-color" (colorValue c) {- | Use a button-like cursor when hovering over the element@@ -218,11 +225,11 @@ -- | Cut off the contents of the element truncate :: Mod truncate =- addClass- $ cls "truncate"- & prop @Text "white-space" "nowrap"- & prop @Text "overflow" "hidden"- & prop @Text "text-overflow" "ellipsis"+ addClass $+ cls "truncate"+ & prop @Text "white-space" "nowrap"+ & prop @Text "overflow" "hidden"+ & prop @Text "text-overflow" "ellipsis" {- | Animate changes to the given property@@ -236,11 +243,11 @@ (Width n) -> trans "width" n where trans p px =- addClass- $ cls ("t" -. px -. p -. ms)- & prop "transition-duration" ms- & prop "transition-property" p- & prop p px+ addClass $+ cls ("t" -. px -. p -. ms)+ & prop "transition-duration" ms+ & prop "transition-property" p+ & prop p px -- You MUST set the height/width manually when you attempt to transition it@@ -252,14 +259,9 @@ textAlign :: Align -> Mod textAlign a =- addClass- $ cls ("ta" -. a)- & prop "text-align" a---data Align- = Center- deriving (Show, ToClassName, ToStyleValue)+ addClass $+ cls ("ta" -. a)+ & prop "text-align" a -- * Selector Modifiers
src/Web/View/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} module Web.View.Types where@@ -8,6 +9,7 @@ import Data.Text (Text, pack, unpack) import Data.Text qualified as T import GHC.Generics (Generic)+import Numeric (showFFloat) import Text.Casing (kebab) @@ -30,6 +32,10 @@ { classes :: [Class] , other :: Map Name AttValue }+instance Semigroup Attributes where+ a1 <> a2 = Attributes (a1.classes <> a2.classes) (a1.other <> a2.other)+instance Monoid Attributes where+ mempty = Attributes [] mempty type Attribute = (Name, AttValue) type Name = Text type AttValue = Text@@ -102,9 +108,13 @@ instance ToClassName Int-instance ToClassName Float instance ToClassName Text where toClassName = id+instance ToClassName Float where+ toClassName f = pack $ map noDot $ showFFloat (Just 3) f ""+ where+ noDot '.' = '-'+ noDot c = c {- | Psuedos allow for specifying styles that only apply in certain conditions. See `Web.View.Style.hover` etc@@ -142,17 +152,51 @@ instance ToStyleValue Int --- | 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)+instance ToStyleValue Float where+ -- this does not convert to a percent, just a ratio+ toStyleValue n = StyleValue $ showFFloat (Just 2) n "" +data Length+ = -- | 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+ PxRem PxRem+ | Pct Float+ deriving (Show)+++instance ToClassName Length where+ toClassName (PxRem p) = toClassName p+ toClassName (Pct p) = toClassName p+++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"+ 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)@@ -199,10 +243,6 @@ deriving (Generic) -newtype Url = Url Text- deriving newtype (IsString)-- -- ** Colors @@ -243,3 +283,8 @@ instance IsString HexColor where fromString = HexColor . T.dropWhile (== '#') . T.pack+++data Align+ = Center+ deriving (Show, ToClassName, ToStyleValue)
+ src/Web/View/Types/Url.hs view
@@ -0,0 +1,101 @@+module Web.View.Types.Url where++import Control.Applicative ((<|>))+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 Debug.Trace+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 (Show, Eq)+instance IsString Url where+ fromString = url . pack+++url :: Text -> Url+url t = runPureEff $ evalState (T.toLower 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+ traceM $ show ("Prefix" :: String, rest, pre, inp)+ 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 <> paths u.path <> decodeUtf8 (renderQuery True u.query)+ where+ paths :: [Segment] -> Text+ paths ss = "/" <> T.intercalate "/" (map cleanSegment ss)
+ test/Test/UrlSpec.hs view
@@ -0,0 +1,39 @@+module Test.UrlSpec (spec) where++import Test.Syd+import Web.View.Types.Url+++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/"
web-view.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.3.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: web-view-version: 0.3.1+version: 0.4.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@@ -35,6 +35,7 @@ Web.View.Reset Web.View.Style Web.View.Types+ Web.View.Types.Url Web.View.View other-modules: Paths_web_view@@ -53,46 +54,19 @@ , bytestring >=0.11 && <0.13 , casing >0.1.3.0 && <0.2 , containers >=0.6 && <1- , effectful ==2.3.*+ , effectful-core >=2.3 && <3 , file-embed >=0.0.10 && <0.1+ , http-types ==0.12.* , string-interpolate >=0.3.2 && <0.4 , text >=1.2 && <3 default-language: GHC2021 -executable example- main-is: Main.hs- other-modules:- Paths_web_view- autogen-modules:- Paths_web_view- hs-source-dirs:- example- default-extensions:- OverloadedStrings- OverloadedRecordDot- DuplicateRecordFields- NoFieldSelectors- ghc-options: -Wall -fdefer-typed-holes- build-depends:- base >=4.16 && <5- , bytestring >=0.11 && <0.13- , casing >0.1.3.0 && <0.2- , containers >=0.6 && <1- , effectful ==2.3.*- , file-embed >=0.0.10 && <0.1- , http-types >=0.12.3 && <0.13- , string-interpolate >=0.3.2 && <0.4- , text >=1.2 && <3- , wai >=3.2.3 && <3.3- , warp >=3.3.30 && <3.4- , web-view- default-language: GHC2021- test-suite tests type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Test.RenderSpec+ Test.UrlSpec Paths_web_view autogen-modules: Paths_web_view@@ -111,8 +85,9 @@ , bytestring >=0.11 && <0.13 , casing >0.1.3.0 && <0.2 , containers >=0.6 && <1- , effectful ==2.3.*+ , effectful-core >=2.3 && <3 , file-embed >=0.0.10 && <0.1+ , http-types ==0.12.* , string-interpolate >=0.3.2 && <0.4 , sydtest ==0.15.* , text >=1.2 && <3