packages feed

web-view 0.4.0 → 0.5.0

raw patch · 10 files changed

+232/−65 lines, 10 filesdep +html-entities

Dependencies added: html-entities

Files

CHANGELOG.md view
@@ -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
README.md view
@@ -85,3 +85,11 @@   [hackage]: https://hackage.haskell.org/package/web-view+++Contributors+------------++* [Sean Hess](seanhess)+* [Kamil Figiela](https://github.com/kfigiela)+
src/Web/View/Render.hs view
@@ -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
src/Web/View/Style.hs view
@@ -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
src/Web/View/Types.hs view
@@ -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
src/Web/View/Types/Url.hs view
@@ -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)
src/Web/View/View.hs view
@@ -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
test/Test/RenderSpec.hs view
@@ -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` "<div>hi</div>"++      it "should render two elements" $ do+        renderText (el_ "hello" >> el_ "world") `shouldBe` "<div>hello</div>\n<div>world</div>"++      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 <<great>> attribute!!!") "I am <malicious> &apos;user"+            el (att "title" "I have some apos' and quotes \" and I'm a <<great>> attribute!!!") $ do+              el_ "I am <malicious> &apos;user"+              el_ "I am another <malicious> &apos;user"++      it "should escape properly" $ do+        goldenFile "test/resources/raw.txt" $ do+          pure $ renderText $ el bold $ raw "<svg>&\"'</svg>"++    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` "<div class='empty'>i have no css</div>"++    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 "<span>/</span>", Line Inline 0 " three"] `shouldBe` "one two <span>/</span> 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 <span>/</span> 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"
test/Test/UrlSpec.hs view
@@ -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)
web-view.cabal view
@@ -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.*