diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for web-view +## 0.5.0 + +* Rendering improvements +* extClass to add external css class +* inline elements +* Url: no longer lowercases automatically. Show/Read instance +* + ## 0.4.0 * Added new Mods. Length type. Improved Url type diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -85,3 +85,11 @@ [hackage]: https://hackage.haskell.org/package/web-view + + +Contributors +------------ + +* [Sean Hess](seanhess) +* [Kamil Figiela](https://github.com/kfigiela) + diff --git a/src/Web/View/Render.hs b/src/Web/View/Render.hs --- a/src/Web/View/Render.hs +++ b/src/Web/View/Render.hs @@ -1,21 +1,23 @@ {-# 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.List (foldl') import Data.Map qualified as M +import Data.Maybe (mapMaybe) import Data.String.Interpolate (i) -import Data.Text (Text, intercalate, pack, toLower, unlines, unwords) +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 Web.View.View (View, ViewState (..), runView, viewInsertContents) -import Prelude hiding (unlines, unwords) - --- import Debug.Trace +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 @@ -36,83 +38,115 @@ renderLazyByteString = LE.encodeUtf8 . renderLazyText +data Line + = Line {end :: LineEnd, indent :: Int, text :: Text} + deriving (Show) + + +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 u = intercalate "\n" content +renderText' c vw = + let vst = runView c vw + css = renderCSS vst.css + in addCss css $ renderLines $ mconcat $ fmap (renderContent 2) vst.contents where - -- T.intercalate "\n" (content <> style css) - content :: [Text] - content = map (unlines . renderContent) . (.contents) $ runView c addCss + addCss :: [Text] -> Text -> Text + addCss [] cnt = cnt + addCss css cnt = do + renderLines (renderContent 2 $ styleElement css) <> "\n\n" <> cnt - addCss = do - viewInsertContents [styleElement] - u + styleElement :: [Text] -> Content + styleElement css = + Node $ element "style" (Attributes [] [("type", "text/css")]) $ do + pure $ Text $ "\n" <> intercalate "\n" css <> "\n" - css :: [Text] - css = renderCSS $ (.css) $ runView c u - styleElement :: Content - styleElement = - Node $ Element "style" (Attributes [] [("type", "text/css")]) [Text $ intercalate "\n" css] - - renderContent :: Content -> [Text] - renderContent (Node t) = renderTag indent t - renderContent (Text t) = [t] - renderContent (Raw t) = [t] +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 :: (Text -> Text) -> Element -> [Text] +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 - [open <> htmlAtts (flatAttributes tag) <> ">" <> close] + [line $ open <> htmlAtts (flatAttributes tag) <> ">" <> close] -- single text node [Text t] -> -- SINGLE text node, just display it indented - [open <> htmlAtts (flatAttributes tag) <> ">" <> t <> close] + [line $ open <> htmlAtts (flatAttributes tag) <> ">" <> HE.text t <> close] _ -> mconcat - [ [open <> htmlAtts (flatAttributes tag) <> ">"] - , ind <$> htmlChildren tag.children - , [close] + [ [line $ open <> htmlAtts (flatAttributes tag) <> ">"] + , fmap (addIndent ind) $ htmlChildren tag.children + , [line close] ] where open = "<" <> tag.name close = " tag.name <> ">" - htmlContent :: Content -> [Text] - htmlContent (Node t) = renderTag ind t - htmlContent (Text t) = [t] - htmlContent (Raw t) = [t] + line t = + if tag.inline + then Line Inline 0 t + else Line Newline 0 t - htmlChildren :: [Content] -> [Text] + htmlChildren :: [Content] -> [Line] htmlChildren cts = - mconcat - $ fmap htmlContent cts + mconcat $ + fmap (renderContent ind) cts htmlAtts :: FlatAttributes -> Text htmlAtts (FlatAttributes []) = "" htmlAtts (FlatAttributes as) = " " - <> unwords (map htmlAtt $ M.toList as) + <> T.unwords (map htmlAtt $ M.toList as) where htmlAtt (k, v) = - k <> "=" <> "'" <> v <> "'" + k <> "=" <> "'" <> HE.text v <> "'" +addIndent :: Int -> Line -> Line +addIndent n (Line e ind t) = Line e (ind + n) t + + renderCSS :: CSS -> [Text] -renderCSS = map renderClass . M.elems +renderCSS = mapMaybe renderClass . M.elems where - renderClass :: Class -> Text + renderClass :: Class -> Maybe Text + renderClass c | M.null c.properties = Nothing renderClass c = let sel = selectorText c.selector props = intercalate "; " (map renderProp $ M.toList c.properties) - in [i|#{sel} { #{props} }|] & addMedia c.selector.media + in Just $ [i|#{sel} { #{props} }|] & addMedia c.selector.media addMedia Nothing css = css addMedia (Just m) css = @@ -180,17 +214,12 @@ -- | The 'Web.View.Types.Attributes' for an element, inclusive of class. flatAttributes :: Element -> FlatAttributes flatAttributes t = - FlatAttributes - $ addClass t.attributes.classes t.attributes.other + FlatAttributes $ + addClass t.attributes.classes t.attributes.other where addClass [] atts = atts addClass cx atts = M.insert "class" (classAttValue cx) atts classAttValue :: [Class] -> Text classAttValue cx = - unwords $ fmap (\c -> classNameElementText c.selector.media c.selector.parent c.selector.pseudo c.selector.className) cx - --- showView :: c -> View c () -> Text --- showView c v = --- let st = runView c v --- in unlines $ mconcat $ map renderContent st.contents + T.unwords $ fmap (\c -> classNameElementText c.selector.media c.selector.parent c.selector.pseudo c.selector.className) cx diff --git a/src/Web/View/Style.hs b/src/Web/View/Style.hs --- a/src/Web/View/Style.hs +++ b/src/Web/View/Style.hs @@ -364,11 +364,16 @@ , 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 +extClass = addClass . cls -- | Add a property to a class prop :: (ToStyleValue val) => Name -> val -> Class -> Class diff --git a/src/Web/View/Types.hs b/src/Web/View/Types.hs --- a/src/Web/View/Types.hs +++ b/src/Web/View/Types.hs @@ -18,20 +18,29 @@ | Text Text | -- | Raw embedded HTML or SVG. See 'Web.View.Element.raw' Raw Text + deriving (Show) -- | 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 - { name :: Name + { inline :: Bool + , name :: Name , attributes :: Attributes , children :: [Content] } + deriving (Show) +-- | Construct an Element +element :: Name -> Attributes -> [Content] -> Element +element = Element False + + data Attributes = Attributes { classes :: [Class] , other :: Map Name AttValue } + deriving (Show) instance Semigroup Attributes where a1 <> a2 = Attributes (a1.classes <> a2.classes) (a1.other <> a2.other) instance Monoid Attributes where @@ -68,6 +77,7 @@ { selector :: Selector , properties :: Styles } + deriving (Show) -- | The styles to apply for a given atomic 'Class' @@ -81,7 +91,7 @@ , media :: Maybe Media , className :: ClassName } - deriving (Eq, Ord) + deriving (Eq, Ord, Show) instance IsString Selector where @@ -97,7 +107,7 @@ newtype ClassName = ClassName { text :: Text } - deriving newtype (Eq, Ord, IsString) + deriving newtype (Eq, Ord, IsString, Show) -- | Convert a type into a className segment to generate unique compound style names based on the value @@ -211,7 +221,7 @@ data Media = MinWidth Int | MaxWidth Int - deriving (Eq, Ord) + deriving (Eq, Ord, Show) {- | Options for styles that support specifying various sides. This has a "fake" Num instance to support literals diff --git a/src/Web/View/Types/Url.hs b/src/Web/View/Types/Url.hs --- a/src/Web/View/Types/Url.hs +++ b/src/Web/View/Types/Url.hs @@ -1,12 +1,12 @@ 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 Debug.Trace import Effectful import Effectful.State.Static.Local import Network.HTTP.Types (Query, parseQuery, renderQuery) @@ -34,13 +34,22 @@ , path :: [Segment] , query :: Query } - deriving (Show, Eq) + 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.toLower t) $ do +url t = runPureEff $ evalState t $ do s <- scheme d <- domain s ps <- paths @@ -61,7 +70,6 @@ case T.stripPrefix pre inp of Nothing -> pure Nothing Just rest -> do - traceM $ show ("Prefix" :: String, rest, pre, inp) put rest pure (Just pre) diff --git a/src/Web/View/View.hs b/src/Web/View/View.hs --- a/src/Web/View/View.hs +++ b/src/Web/View/View.hs @@ -98,18 +98,27 @@ -- * Creating new Elements -{- | Create a new element constructor +{- | Create a new element constructor with the given tag name > aside :: Mod -> View c () -> View c () > aside = tag "aside" -} tag :: Text -> Mod -> View c () -> View c () -tag nm f ct = do +tag n = tag' (element n) + + +{- | Create a new element constructor with a custom element + - +> span :: Mod -> View c () -> View c () +> span = tag' (Element True) "span" +-} +tag' :: (Attributes -> [Content] -> Element) -> Mod -> 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 $ Attributes [] [] - let elm = Element nm ats st.contents + let ats = f mempty + let elm = mkElem ats st.contents viewAddContent $ Node elm viewAddClasses $ M.elems st.css viewAddClasses elm.attributes.classes diff --git a/test/Test/RenderSpec.hs b/test/Test/RenderSpec.hs --- a/test/Test/RenderSpec.hs +++ b/test/Test/RenderSpec.hs @@ -1,12 +1,81 @@ module Test.RenderSpec (spec) where +import Data.Text (Text) import Test.Syd import Web.View +import Web.View.Render (Line (..), LineEnd (..), renderLines) +import Web.View.Style +import Web.View.Types (Element (..)) +import Web.View.View (tag') +import Prelude hiding (span) spec :: Spec spec = do describe "render" $ do - it "should match expected output" $ do - let res = renderText $ el bold "hi" - pureGoldenTextFile "test/resources/basic.txt" res + describe "output" $ do + it "should render simple output" $ do + renderText (el_ "hi") `shouldBe` "
hi
" + + it "should render two elements" $ do + renderText (el_ "hello" >> el_ "world") `shouldBe` "
hello
\n
world
" + + it "should match basic output with styles" $ do + goldenFile "test/resources/basic.txt" $ do + pure $ renderText $ col (pad 10) $ el bold "hello" >> el_ "world" + + describe "escape" $ do + it "should escape properly" $ do + goldenFile "test/resources/escaping.txt" $ do + pure $ 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" + + it "should escape properly" $ do + goldenFile "test/resources/raw.txt" $ do + pure $ renderText $ el bold $ raw "&\"'" + + describe "empty rules" $ do + it "should skip css class when no css attributes" $ do + goldenFile "test/resources/nocssattrs.txt" $ do + pure $ renderText $ do + el (addClass $ cls "empty") "i have no css" + el bold "i have some css" + + it "should skip css element when no css rules" $ do + let res = renderText $ el (addClass $ cls "empty") "i have no css" + res `shouldBe` "
i have no css
" + + 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 c () -> View c () + 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 + goldenFile "test/resources/nested.txt" $ do + pure $ renderText $ do + el_ $ do + el_ $ do + el_ "HI" + + +goldenFile :: FilePath -> IO Text -> GoldenTest Text +goldenFile fp txt = do + goldenTextFile fp $ do + t <- txt + pure $ t <> "\n" diff --git a/test/Test/UrlSpec.hs b/test/Test/UrlSpec.hs --- a/test/Test/UrlSpec.hs +++ b/test/Test/UrlSpec.hs @@ -1,9 +1,14 @@ module Test.UrlSpec (spec) where import Test.Syd +import Text.Read (readMaybe) import Web.View.Types.Url +data Something = Something Url + deriving (Show, Read, Eq) + + spec :: Spec spec = do describe "Url" $ do @@ -37,3 +42,17 @@ 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/web-view.cabal b/web-view.cabal --- a/web-view.cabal +++ b/web-view.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: web-view -version: 0.4.0 +version: 0.5.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 @@ -56,6 +56,7 @@ , containers >=0.6 && <1 , effectful-core >=2.3 && <3 , 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 @@ -87,6 +88,7 @@ , containers >=0.6 && <1 , effectful-core >=2.3 && <3 , 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 , sydtest ==0.15.*