packages feed

web-view 0.5.0 → 0.6.0

raw patch · 13 files changed

+451/−214 lines, 13 filesdep +Diffdep +skeletestdep −sydtest

Dependencies added: Diff, skeletest

Dependencies removed: sydtest

Files

CHANGELOG.md view
@@ -1,5 +1,13 @@ # Revision history for web-view +## 0.6.0++* stack - layout children on top of each other+* ChildCombinator: apply styles to direct children+* `Mod` is now `Mod context`, allowing for type-safe `Mod`s+* fixed: escaping in auto-generated `<style>`+* Refactored: selectors and rendering+ ## 0.5.0  * Rendering improvements
src/Web/View.hs view
@@ -36,6 +36,7 @@   , root   , col   , row+  , stack   , grow   , space   , collapse@@ -142,7 +143,7 @@  Create styled `View's using composable Haskell functions -> myView :: View c ()+> myView :: View ctx () > myView = col (gap 10) $ do >  el (bold . fontSize 32) "My page" >  button (border 1) "Click Me"
src/Web/View/Element.hs view
@@ -17,7 +17,7 @@  > el (bold . pad 10) "Hello" -}-el :: Mod -> View c () -> View c ()+el :: Mod c -> View c () -> View c () el = tag "div"  @@ -57,39 +57,39 @@ none = pure ()  -pre :: Mod -> Text -> View c ()+pre :: Mod c -> Text -> View c () pre f t = tag "pre" f (text t)   -- | A hyperlink to the given url-link :: Url -> Mod -> View c () -> View c ()+link :: Url -> Mod c -> View c () -> View c () link u f = tag "a" (att "href" (renderUrl u) . f)   -- * Inputs  -form :: Mod -> View c () -> View c ()+form :: Mod c -> View c () -> View c () form f = tag "form" (f . flexCol)  -input :: Mod -> View c ()+input :: Mod c -> View c () input m = tag "input" (m . att "type" "text") none  -name :: Text -> Mod+name :: Text -> Mod c name = att "name"  -value :: Text -> Mod+value :: Text -> Mod c value = att "value"  -label :: Mod -> View c () -> View c ()+label :: Mod c -> View c () -> View c () label = tag "label"  -button :: Mod -> View c () -> View c ()+button :: Mod c -> View c () -> View c () button = tag "button"  @@ -122,7 +122,7 @@ >   hd = cell . bold >   cell = pad 4 . border 1 -}-table :: Mod -> [dt] -> Eff '[Writer [TableColumn c dt]] () -> View c ()+table :: Mod c -> [dt] -> Eff '[Writer [TableColumn c dt]] () -> View c () table f dts wcs = do   c <- context   let cols = runPureEff . execWriter $ wcs@@ -137,7 +137,7 @@           forM_ cols $ \tc -> do             addContext dt $ tc.dataCell dt  where-  borderCollapse :: Mod+  borderCollapse :: Mod c   borderCollapse = addClass $ cls "brd-cl" & prop @Text "border-collapse" "collapse"  @@ -146,13 +146,13 @@   tell ([TableColumn hd view] :: [TableColumn c dt])  -th :: Mod -> View c () -> View (TableHead c) ()+th :: Mod c -> View c () -> View (TableHead c) () th f cnt = do   TableHead c <- context   addContext c $ tag "th" f cnt  -td :: Mod -> View () () -> View dt ()+td :: Mod () -> View () () -> View dt () td f c = addContext () $ tag "td" f c
src/Web/View/Layout.hs view
@@ -8,7 +8,7 @@ import Web.View.View (View, tag)  -{- | We can intuitively create layouts with combindations of 'row', 'col', 'grow', and 'space'+{- | We can intuitively create layouts with combinations of 'row', 'col', 'stack', 'grow', and 'space'  Wrap main content in 'layout' to allow the view to consume vertical screen space @@ -24,7 +24,7 @@   where section = 'border' 1 @ -}-layout :: Mod -> View c () -> View c ()+layout :: Mod c -> View c () -> View c () layout f = el (root . f)  @@ -33,18 +33,18 @@ > holygrail = col root $ do >   ... -}-root :: Mod-root =-  flexCol-    . addClass-      ( cls "layout"-          -- [ ("white-space", "pre")-          & prop @Text "width" "100vw"-          & prop @Text "height" "100vh"-          -- not sure if this property is necessary, copied from older code-          & prop @Text "min-height" "100vh"-          & prop @Text "z-index" "0"-      )+root :: Mod c+root = flexCol . fillViewport+ where+  fillViewport =+    addClass $+      cls "layout"+        -- [ ("white-space", "pre")+        & prop @Text "width" "100vw"+        & prop @Text "height" "100vh"+        -- not sure if this property is necessary, copied from older code+        & prop @Text "min-height" "100vh"+        & prop @Text "z-index" "0"   {- | Lay out children in a column.@@ -54,7 +54,7 @@ >    space >    el_ "Bottom" -}-col :: Mod -> View c () -> View c ()+col :: Mod c -> View c () -> View c () col f = el (flexCol . f)  @@ -65,7 +65,7 @@ >    space >    el_ "Right" -}-row :: Mod -> View c () -> View c ()+row :: Mod c -> View c () -> View c () row f = el (flexRow . f)  @@ -75,7 +75,7 @@ >  el grow none >  el_ "Right" -}-grow :: Mod+grow :: Mod c grow = addClass $ cls "grow" & prop @Int "flex-grow" 1  @@ -94,8 +94,8 @@ space = el grow none  --- | Allow items to become smaller than their contents. This is not the opposite of grow!-collapse :: Mod+-- | Allow items to become smaller than their contents. This is not the opposite of `grow`!+collapse :: Mod c collapse = addClass $ cls "collapse" & prop @Int "min-width" 0  @@ -105,10 +105,33 @@ >   nav (width 300) "Sidebar" >   col (grow . scroll) "Main Content" -}-scroll :: Mod+scroll :: Mod c scroll = addClass $ cls "scroll" & prop @Text "overflow" "auto"   -- | A Nav element-nav :: Mod -> View c () -> View c ()+nav :: Mod c -> View c () -> View c () nav f = tag "nav" (f . flexCol)+++{- | Stack children on top of each other. Each child has the full width++> stack id $ do+>   row id "Background"+>   row (bg Black . opacity 0.5) "Overlay"+-}+stack :: Mod c -> View c () -> View c ()+stack f =+  tag "div" (f . container . absChildren)+ where+  container =+    addClass $+      cls "stack"+        & prop @Text "position" "relative"+        & prop @Text "display" "grid"+  absChildren =+    addClass $+      Class absSelector mempty+        & prop @Text "position" "relative"+        & prop @Text "grid-area" "1 / 1"+  absSelector = (selector "abs-childs"){child = Just AllChildren}
src/Web/View/Render.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -7,9 +8,10 @@  import Data.ByteString.Lazy qualified as BL import Data.Function ((&))-import Data.List (foldl')+import Data.List (foldl', sortOn) import Data.Map qualified as M import Data.Maybe (mapMaybe)+import Data.String (fromString) import Data.String.Interpolate (i) import Data.Text (Text, intercalate, pack, toLower) import Data.Text qualified as T@@ -40,7 +42,7 @@  data Line   = Line {end :: LineEnd, indent :: Int, text :: Text}-  deriving (Show)+  deriving (Show, Eq)   data LineEnd@@ -74,17 +76,18 @@ renderText' c vw =   let vst = runView c vw       css = renderCSS vst.css-   in addCss css $ renderLines $ mconcat $ fmap (renderContent 2) vst.contents+   in renderLines $ addCss css $ mconcat $ fmap (renderContent 2) vst.contents  where-  addCss :: [Text] -> Text -> Text+  addCss :: [Line] -> [Line] -> [Line]   addCss [] cnt = cnt   addCss css cnt = do-    renderLines (renderContent 2 $ styleElement css) <> "\n\n" <> cnt+    styleLines css <> (Line Newline 0 "" : cnt) -  styleElement :: [Text] -> Content-  styleElement css =-    Node $ element "style" (Attributes [] [("type", "text/css")]) $ do-      pure $ Text $ "\n" <> intercalate "\n" css <> "\n"+  styleLines :: [Line] -> [Line]+  styleLines css =+    [Line Newline 0 "<style type='text/css'>"]+      <> css+      <> [Line Newline 0 "</style>"]   renderContent :: Int -> Content -> [Line]@@ -138,15 +141,15 @@ addIndent n (Line e ind t) = Line e (ind + n) t  -renderCSS :: CSS -> [Text]-renderCSS = mapMaybe renderClass . M.elems+renderCSS :: CSS -> [Line]+renderCSS = mapMaybe renderClass . sortOn (.selector)  where-  renderClass :: Class -> Maybe Text+  renderClass :: Class -> Maybe Line   renderClass c | M.null c.properties = Nothing   renderClass c =     let sel = selectorText c.selector         props = intercalate "; " (map renderProp $ M.toList c.properties)-     in Just $ [i|#{sel} { #{props} }|] & addMedia c.selector.media+     in Just $ Line Newline 0 $ [i|#{sel} { #{props} }|] & addMedia c.selector.media    addMedia Nothing css = css   addMedia (Just m) css =@@ -171,42 +174,73 @@ -- | The css selector for this style selectorText :: Selector -> Text selectorText s =-  parent s.parent <> "." <> addPseudo s.pseudo (classNameElementText s.media s.parent Nothing s.className)+  let classAttributeName = HE.text (attributeClassName s).text+   in ancestor s.ancestor <> "." <> addPseudo s.pseudo classAttributeName <> child s.child  where-  parent Nothing = ""-  parent (Just p) = "." <> p <> " "+  ancestor Nothing = ""+  ancestor (Just p) = "." <> HE.text p <> " " +  -- ":" is treated as a pseudo selector. We want to use prefixed pseudos in the name as part of the name+  -- so we must escape the colon   addPseudo Nothing c = c   addPseudo (Just p) c =-    pseudoText p <> "\\:" <> c <> ":" <> pseudoSuffix p+    T.replace ":" "\\:" c <> ":" <> pseudoSuffix p +  child Nothing = ""+  child (Just (ChildWithName c)) =+    " > ." <> HE.text c+  child (Just AllChildren) =+    " > *"+   pseudoSuffix :: Pseudo -> Text   pseudoSuffix Even = "nth-child(even)"   pseudoSuffix Odd = "nth-child(odd)"   pseudoSuffix p = pseudoText p  --- | The class name as it appears in the element-classNameElementText :: Maybe Media -> Maybe Text -> Maybe Pseudo -> ClassName -> Text-classNameElementText mm mp mps c =-  addMedia mm . addPseudo mps . addParent mp $ c.text+-- | Unique name for the class, as seen in the element's class attribute+attributeClassName :: Selector -> ClassName+attributeClassName sel =+  addMedia sel.media . addPseudo sel.pseudo . addAncestor sel.ancestor . addChild sel.child $ sel.className  where-  addParent Nothing cn = cn-  addParent (Just p) cn = p <> "-" <> cn+  addAncestor :: Maybe Ancestor -> ClassName -> ClassName+  addAncestor Nothing cn = cn+  addAncestor (Just a) cn = className a <> "-" <> cn -  addPseudo :: Maybe Pseudo -> Text -> Text+  addChild :: Maybe ChildCombinator -> ClassName -> ClassName+  addChild Nothing cn = cn+  addChild (Just (ChildWithName child)) cn = cn <> "-" <> className child+  addChild (Just AllChildren) cn = cn <> "-all"++  addPseudo :: Maybe Pseudo -> ClassName -> ClassName   addPseudo Nothing cn = cn   addPseudo (Just p) cn =-    pseudoText p <> ":" <> cn+    className (pseudoText p) <> ":" <> cn -  addMedia :: Maybe Media -> Text -> Text+  addMedia :: Maybe Media -> ClassName -> ClassName   addMedia Nothing cn = cn   addMedia (Just (MinWidth n)) cn =-    [i|mmnw#{n}-#{cn}|]+    "mmnw" <> fromString (show n) <> "-" <> cn   addMedia (Just (MaxWidth n)) cn =-    [i|mmxw#{n}-#{cn}|]+    "mmxw" <> fromString (show n) <> "-" <> cn  +-- classNameAddAncestor :: Ancestor -> ClassName -> ClassName+-- classNameAddAncestor a cn =+--   ClassName a <> "-" <> cn+--+--+-- classNameAddChild :: ChildCombinator -> ClassName -> ClassName+-- classNameAddChild cc cn =+--   case cc of+--     ChildWithName child -> cn <> "-" <> ClassName child+--     AllChildren -> cn <> "-all"+--+-- classNameAddPseudo :: Pseudo -> ClassName -> ClassName+-- classNameAddPseudo p cn =+--     className (pseudoText p) <> ":" <> cn+--+ pseudoText :: Pseudo -> Text pseudoText p = toLower $ pack $ show p @@ -222,4 +256,4 @@    classAttValue :: [Class] -> Text   classAttValue cx =-    T.unwords $ fmap (\c -> classNameElementText c.selector.media c.selector.parent c.selector.pseudo c.selector.className) cx+    T.unwords $ fmap ((.text) . attributeClassName . (.selector)) cx
src/Web/View/Style.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}  module Web.View.Style where @@ -11,11 +11,13 @@ import Web.View.Types  +{- HLINT "HLint: shadows the existing binding" -}+ -- * Styles   -- | Set to a specific width-width :: Length -> Mod+width :: Length -> Mod c width n =   addClass $     cls ("w" -. n)@@ -24,7 +26,7 @@   -- | Set to a specific height-height :: Length -> Mod+height :: Length -> Mod c height n =   addClass $     cls ("h" -. n)@@ -33,7 +35,7 @@   -- | Allow width to grow to contents but not shrink any smaller than value-minWidth :: Length -> Mod+minWidth :: Length -> Mod c minWidth n =   addClass $     cls ("mw" -. n)@@ -41,7 +43,7 @@   -- | Allow height to grow to contents but not shrink any smaller than value-minHeight :: Length -> Mod+minHeight :: Length -> Mod c minHeight n =   addClass $     cls ("mh" -. n)@@ -57,7 +59,7 @@ >   el_ "two" >   el_ "three" -}-pad :: Sides Length -> Mod+pad :: Sides Length -> Mod c pad (All n) =   addClass $     cls ("pad" -. n)@@ -89,19 +91,19 @@   -- | The space between child elements. See 'pad'-gap :: Length -> Mod+gap :: Length -> Mod c gap n = addClass $ cls ("gap" -. n) & prop "gap" n  -fontSize :: Length -> Mod+fontSize :: Length -> Mod c fontSize n = addClass $ cls ("fs" -. n) & prop "font-size" n  --- fontFamily :: Text -> Mod+-- fontFamily :: Text -> Mod c -- fontFamily t = cls1 $ Class ("font" -. n) [("font-family", pxRem n)]  -- | Set container to be a row. Favor 'Web.View.Layout.row' when possible-flexRow :: Mod+flexRow :: Mod c flexRow =   addClass $     cls "row"@@ -110,7 +112,7 @@   -- | Set container to be a column. Favor 'Web.View.Layout.col' when possible-flexCol :: Mod+flexCol :: Mod c flexCol =   addClass $     cls "col"@@ -119,7 +121,7 @@   -- | Adds a basic drop shadow to an element-shadow :: Mod+shadow :: Mod c shadow =   addClass $     cls "shadow"@@ -127,12 +129,12 @@   -- | Round the corners of the element-rounded :: Length -> Mod+rounded :: Length -> Mod c 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 :: (ToColor clr) => clr -> Mod ctx bg c =   addClass $     cls ("bg" -. colorName c)@@ -140,23 +142,23 @@   -- | Set the text color. See 'Web.View.Types.ToColor'-color :: (ToColor c) => c -> Mod+color :: (ToColor clr) => clr -> Mod ctx color c = addClass $ cls ("clr" -. colorName c) & prop "color" (colorValue c)  -bold :: Mod+bold :: Mod c bold = addClass $ cls "bold" & prop @Text "font-weight" "bold"   -- | Hide an element. See 'parent' and 'media'-hide :: Mod+hide :: Mod c hide =   addClass $     cls "hide"       & prop @Text "display" "none"  -opacity :: Float -> Mod+opacity :: Float -> Mod c opacity n =   addClass $     cls ("opacity" -. n)@@ -168,7 +170,7 @@ > el (border 1) "all sides" > el (border (X 1)) "only left and right" -}-border :: Sides PxRem -> Mod+border :: Sides PxRem -> Mod c border (All p) =   addClass $     cls ("brd" -. p)@@ -201,7 +203,7 @@   -- | Set a border color. See 'Web.View.Types.ToColor'-borderColor :: (ToColor c) => c -> Mod+borderColor :: (ToColor clr) => clr -> Mod ctx borderColor c =   addClass $     cls ("brdc" -. colorName c)@@ -218,12 +220,12 @@ >   el btn "Login" >   el btn "Sign Up" -}-pointer :: Mod+pointer :: Mod c pointer = addClass $ cls "pointer" & prop @Text "cursor" "pointer"   -- | Cut off the contents of the element-truncate :: Mod+truncate :: Mod c truncate =   addClass $     cls "truncate"@@ -237,27 +239,31 @@ > el (transition 100 (Height 400)) "Tall" > el (transition 100 (Height 100)) "Small" -}-transition :: Ms -> TransitionProperty -> Mod+transition :: Ms -> TransitionProperty -> Mod c transition ms = \case   (Height n) -> trans "height" n   (Width n) -> trans "width" n+  (BgColor c) -> trans "background-color" c+  (Color c) -> trans "color" c  where-  trans p px =+  trans p val =     addClass $-      cls ("t" -. px -. p -. ms)+      cls ("t" -. val -. p -. ms)         & prop "transition-duration" ms         & prop "transition-property" p-        & prop p px+        & prop p val   -- You MUST set the height/width manually when you attempt to transition it data TransitionProperty   = Width PxRem   | Height PxRem+  | BgColor HexColor+  | Color HexColor   deriving (Show)  -textAlign :: Align -> Mod+textAlign :: Align -> Mod c textAlign a =   addClass $     cls ("ta" -. a)@@ -271,22 +277,22 @@  > el (bg Primary . hover (bg PrimaryLight)) "Hover" -}-hover :: Mod -> Mod+hover :: Mod c -> Mod c hover = applyPseudo Hover   -- | Apply when the mouse is pressed down on an element-active :: Mod -> Mod+active :: Mod c -> Mod c active = applyPseudo Active   -- | Apply to even-numbered children-even :: Mod -> Mod+even :: Mod c -> Mod c even = applyPseudo Even   -- | Apply to odd-numbered children-odd :: Mod -> Mod+odd :: Mod c -> Mod c odd = applyPseudo Odd  @@ -295,14 +301,14 @@ > el (width 100 . media (MinWidth 800) (width 400)) >   "Big if window > 800" -}-media :: Media -> Mod -> Mod+media :: Media -> Mod c -> Mod c media m = mapModClass $ \c ->   c     { selector = addMedia c.selector     }  where   addMedia :: Selector -> Selector-  addMedia (Selector pr ps _ cn) = Selector pr ps (Just m) cn+  addMedia Selector{..} = Selector{media = Just m, ..}   {- | Apply when the element is somewhere inside an anscestor.@@ -313,28 +319,28 @@ >   el (parent "htmx-request" flexRow . hide) "Loading..." >   el (parent "htmx-request" hide . flexRow) "Normal Content" -}-parent :: Text -> Mod -> Mod+parent :: Text -> Mod c -> Mod c parent p = mapModClass $ \c ->   c-    { selector = addParent c.selector+    { selector = addAncestor c.selector     }  where-  addParent :: Selector -> Selector-  addParent (Selector _ ps m c) = Selector (Just p) ps m c+  addAncestor :: Selector -> Selector+  addAncestor Selector{..} = Selector{ancestor = Just p, ..}   -- Add a pseudo-class like Hover to your style-applyPseudo :: Pseudo -> Mod -> Mod+applyPseudo :: Pseudo -> Mod c -> Mod c applyPseudo ps = mapModClass $ \c ->   c     { selector = addToSelector c.selector     }  where   addToSelector :: Selector -> Selector-  addToSelector (Selector pr _ m cn) = Selector pr (Just ps) m cn+  addToSelector Selector{..} = Selector{pseudo = Just ps, ..}  -mapModClass :: (Class -> Class) -> Mod -> Mod+mapModClass :: (Class -> Class) -> Mod c -> Mod c mapModClass fc fm as =   -- apply the function to all classes added by the mod   -- ignore@@ -345,6 +351,15 @@         }  +{- | Setting the same property twice will result in only one of the classes being applied. It is not intuitive, as CSS rules dictate that the order of the class definitions determine precedence. You can mark a `Mod` as important to force it to apply+important :: Mod c -> Mod c+important =+  mapModClass $ \c ->+    c+      { important = True+      }+-}+ -- * Creating New Styles  @@ -357,33 +372,36 @@ >     & prop "width" n >     & prop @Int "flex-shrink" 0 -}-addClass :: Class -> Mod+addClass :: Class -> Mod c addClass c attributes =   Attributes     { classes = c : attributes.classes     , 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 :: ClassName -> Mod c extClass = addClass . cls + -- | Add a property to a class prop :: (ToStyleValue val) => Name -> val -> Class -> Class prop n v c =   c{properties = M.insert n (toStyleValue v) c.properties}  --- | Hyphneate classnames+-- | Hyphenate classnames (-.) :: (ToClassName a) => ClassName -> a -> ClassName-(ClassName n) -. a = ClassName $ n <> "-" <> toClassName a+(ClassName n) -. a = (ClassName $ n <> "-") <> toClassName a   infixl 6 -.
src/Web/View/Types.hs view
@@ -4,6 +4,7 @@  module Web.View.Types where +import Data.Kind (Type) import Data.Map (Map) import Data.String (IsString (..)) import Data.Text (Text, pack, unpack)@@ -18,32 +19,39 @@   | Text Text   | -- | Raw embedded HTML or SVG. See 'Web.View.Element.raw'     Raw Text-  deriving (Show)+  deriving (Show, Eq)   -- | 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   { inline :: Bool   , name :: Name-  , attributes :: Attributes+  , attributes :: Attributes ()   , children :: [Content]   }-  deriving (Show)+  deriving (Show, Eq)   -- | Construct an Element-element :: Name -> Attributes -> [Content] -> Element-element = Element False+element :: Name -> Attributes c -> [Content] -> Element+element n atts =+  Element False n (stripContext atts)+ where+  stripContext :: Attributes c -> Attributes ()+  stripContext (Attributes cls other) = Attributes cls other  -data Attributes = Attributes+-- | The Attributes for an 'Element'. Classes are merged and managed separately from the other attributes.+data Attributes c = Attributes   { classes :: [Class]   , other :: Map Name AttValue   }-  deriving (Show)-instance Semigroup Attributes where+  deriving (Show, Eq)+++instance Semigroup (Attributes c) where   a1 <> a2 = Attributes (a1.classes <> a2.classes) (a1.other <> a2.other)-instance Monoid Attributes where+instance Monoid (Attributes c) where   mempty = Attributes [] mempty type Attribute = (Name, AttValue) type Name = Text@@ -53,14 +61,19 @@ -- * Attribute Modifiers  -{- | Element functions expect a Mod function as their first argument that adds attributes and classes.+{- | Element functions expect a modifier function as their first argument. These can add attributes and classes. Combine multiple `Mod`s with (`.`)  > userEmail :: User -> View c () > userEmail user = input (fontSize 16 . active) (text user.email) >   where >     active = isActive user then bold else id++If you don't want to specify any attributes, you can use `id`++> plainView :: View c ()+> plainView = el id "No styles" -}-type Mod = Attributes -> Attributes+type Mod (context :: Type) = Attributes context -> Attributes context   -- * Atomic CSS@@ -69,7 +82,7 @@ -- TODO: document atomic CSS here?  -- | All the atomic classes used in a 'Web.View.View'-type CSS = Map Selector Class+type CSS = [Class]   -- | Atomic classes include a selector and the corresponding styles@@ -77,54 +90,86 @@   { selector :: Selector   , properties :: Styles   }-  deriving (Show)+  deriving (Show, Eq)   -- | The styles to apply for a given atomic 'Class' type Styles = Map Name StyleValue  +-- | A parent selector limits the selector to only apply when a descendent of the parent in question+type Ancestor = Text+++-- | A child selector limits+data ChildCombinator+  = AllChildren+  | ChildWithName Text+  deriving (Show, Eq, Ord)+++instance IsString ChildCombinator where+  fromString s = ChildWithName (fromString s)++ -- | The selector to use for the given atomic 'Class' data Selector = Selector-  { parent :: Maybe Text+  { media :: Maybe Media+  , ancestor :: Maybe Ancestor+  , child :: Maybe ChildCombinator   , pseudo :: Maybe Pseudo-  , media :: Maybe Media   , className :: ClassName   }   deriving (Eq, Ord, Show)   instance IsString Selector where-  fromString s = Selector Nothing Nothing Nothing (fromString s)+  fromString s = selector (fromString s)   -- | Create a 'Selector' given only a 'ClassName' selector :: ClassName -> Selector-selector = Selector Nothing Nothing Nothing+selector c =+  Selector+    { pseudo = Nothing+    , ancestor = Nothing+    , child = Nothing+    , media = Nothing+    , className = c+    }   -- | A class name newtype ClassName = ClassName   { text :: Text   }-  deriving newtype (Eq, Ord, IsString, Show)+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup)  +instance IsString ClassName where+  fromString s = ClassName $ pack s+++-- | Create a class name, escaping special characters+className :: Text -> ClassName+className = ClassName . T.toLower . T.map noDot+ where+  noDot '.' = '-'+  noDot c = c++ -- | Convert a type into a className segment to generate unique compound style names based on the value class ToClassName a where-  toClassName :: a -> Text-  default toClassName :: (Show a) => a -> Text-  toClassName = T.toLower . T.pack . show+  toClassName :: a -> ClassName+  default toClassName :: (Show a) => a -> ClassName+  toClassName = className . T.pack . show   instance ToClassName Int instance ToClassName Text where-  toClassName = id+  toClassName = className instance ToClassName Float where-  toClassName f = pack $ map noDot $ showFFloat (Just 3) f ""-   where-    noDot '.' = '-'-    noDot c = c+  toClassName f = className $ pack $ showFFloat (Just 3) f ""   {- | Psuedos allow for specifying styles that only apply in certain conditions. See `Web.View.Style.hover` etc@@ -141,7 +186,7 @@  -- | The value of a css style property newtype StyleValue = StyleValue String-  deriving newtype (IsString, Show)+  deriving newtype (IsString, Show, Eq)   -- | Use a type as a css style property value@@ -168,8 +213,7 @@   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+  = PxRem PxRem   | Pct Float   deriving (Show) @@ -179,6 +223,7 @@   toClassName (Pct p) = toClassName p  +-- | 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, Eq, Integral, Real, Ord, Enum) @@ -278,21 +323,26 @@   colorName = T.toLower . pack . show  +-- | Hexidecimal Color. Can be specified with or without the leading '#'. Recommended to use an AppColor type instead of manually using hex colors. See 'Web.View.Types.ToColor'+newtype HexColor = HexColor Text+  deriving (Show)++ instance ToColor HexColor where   colorValue c = c   colorName (HexColor a) = T.dropWhile (== '#') a  --- | Hexidecimal Color. Can be specified with or without the leading '#'. Recommended to use an AppColor type instead of manually using hex colors. See 'Web.View.Types.ToColor'-newtype HexColor = HexColor Text-- instance ToStyleValue HexColor where   toStyleValue (HexColor s) = StyleValue $ "#" <> unpack (T.dropWhile (== '#') s)   instance IsString HexColor where   fromString = HexColor . T.dropWhile (== '#') . T.pack+++instance ToClassName HexColor where+  toClassName = className . colorName   data Align
src/Web/View/View.hs view
@@ -23,14 +23,14 @@ >   el bold "Hello" >   el_ "World" -They can also have a context which can be used to create type-safe or context-aware elements. See 'Web.View.Element.table' for an example+They can also have a context which can be used to create type-safe or context-aware elements. See 'context' or 'Web.View.Element.table' for an example -} newtype View context a = View {viewState :: Eff [Reader context, State ViewState] a}   deriving newtype (Functor, Applicative, Monad)   instance IsString (View context ()) where-  fromString s = viewModContents (const [Text (pack s)])+  fromString s = viewAddContent $ Text (pack s)   data ViewState = ViewState@@ -49,18 +49,36 @@   runPureEff . execState (ViewState [] []) . runReader ctx $ ef  --- | Get the current context+{- | 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++> numberView :: View Int ()+> numberView = do+>   num <- context+>   el_ $ do+>     "Number: "+>     text (pack $ show num)+-} context :: View context context context = View ask  --- | Run a view with a specific `context` in a parent 'View' with a different context. This can be used to create type safe view functions, like 'Web.View.Element.table'+{- | Run a view with a specific `context` in a parent 'View' with a different context.++>+> parentView :: View c ()+> parentView = do+>   addContext 1 numberView+>   addContext 2 numberView+>   addContext 3 numberView+-} addContext :: context -> View context () -> View c () addContext ctx vw = do   -- runs the sub-view in a different context, saving its state   -- we need to MERGE it   let st = runView ctx vw-  View $ ES.modify $ \s -> s <> st+  View $ do+    s <- get+    put $ s <> st   viewModContents :: ([Content] -> [Content]) -> View context ()@@ -78,7 +96,7 @@   viewModCss $ \cm -> foldr addClsDef cm clss  where   addClsDef :: Class -> CSS -> CSS-  addClsDef c = M.insert c.selector c+  addClsDef c = (c :)   viewAddContent :: Content -> View c ()@@ -100,19 +118,19 @@  {- | Create a new element constructor with the given tag name -> aside :: Mod -> View c () -> View c ()+> aside :: Mod c -> View c () -> View c () > aside = tag "aside" -}-tag :: Text -> Mod -> View c () -> View c ()+tag :: Text -> Mod c -> View c () -> View c () tag n = tag' (element n)   {- | Create a new element constructor with a custom element  --> span :: Mod -> View c () -> View c ()+> span :: Mod c -> View c () -> View c () > span = tag' (Element True) "span" -}-tag' :: (Attributes -> [Content] -> Element) -> Mod -> View c () -> View c ()+tag' :: (Attributes c -> [Content] -> Element) -> Mod c -> View c () -> View c () tag' mkElem f ct = do   -- Applies the modifier and merges children into parent   ctx <- context@@ -120,7 +138,7 @@   let ats = f mempty   let elm = mkElem ats st.contents   viewAddContent $ Node elm-  viewAddClasses $ M.elems st.css+  viewAddClasses st.css   viewAddClasses elm.attributes.classes  @@ -129,7 +147,7 @@ > hlink :: Text -> View c () -> View c () > hlink url content = tag "a" (att "href" url) content -}-att :: Name -> AttValue -> Mod+att :: Name -> AttValue -> Mod c att n v attributes =   let atts = M.insert n v attributes.other    in attributes{other = atts}
test/Spec.hs view
@@ -1,3 +1,2 @@-{-# OPTIONS_GHC -F -pgmF sydtest-discover #-}-+import Skeletest.Main
test/Test/RenderSpec.hs view
@@ -1,81 +1,141 @@ module Test.RenderSpec (spec) where  import Data.Text (Text)-import Test.Syd+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Skeletest import Web.View-import Web.View.Render (Line (..), LineEnd (..), renderLines)+import Web.View.Render import Web.View.Style-import Web.View.Types (Element (..))-import Web.View.View (tag')+import Web.View.Types+import Web.View.View (ViewState (..), runView, tag') import Prelude hiding (span)   spec :: Spec spec = do-  describe "render" $ do-    describe "output" $ do-      it "should render simple output" $ do-        renderText (el_ "hi") `shouldBe` "<div>hi</div>"+  describe "render" renderSpec+  describe "selector" selectorSpec -      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"+renderSpec :: Spec+renderSpec = do+  describe "output" $ do+    it "should render simple output" $ do+      renderText (el_ "hi") `shouldBe` "<div>hi</div>" -    describe "escape" $ do-      it "should escape properly" $ do-        goldenFile "test/resources/escaping.txt" $ do-          pure $ renderText $ do+    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+      golden <- goldenFile "test/resources/basic.txt"+      let out = renderText $ col (pad 10) $ el bold "hello" >> el_ "world"+      out `shouldBe` golden++  describe "escape" $ do+    it "should escape properly" $ do+      golden <- goldenFile "test/resources/escaping.txt"+      let out = 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"+      out `shouldBe` golden -      it "should escape properly" $ do-        goldenFile "test/resources/raw.txt" $ do-          pure $ renderText $ el bold $ raw "<svg>&\"'</svg>"+    it "should escape properly" $ do+      golden <- goldenFile "test/resources/raw.txt"+      let out = renderText $ el bold $ raw "<svg>&\"'</svg>"+      out `shouldBe` golden -    describe "empty rules" $ do-      it "should skip css class when no css attributes" $ do-        goldenFile "test/resources/nocssattrs.txt" $ do-          pure $ renderText $ do+  describe "empty rules" $ do+    it "should skip css class when no css attributes" $ do+      let view = do             el (addClass $ cls "empty") "i have no css"             el bold "i have some css"+      renderLines (renderCSS (runCSS view)) `shouldBe` ".bold { font-weight:bold }" -      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>"+    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"+  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 "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"+    it "should render text and inline elements inline" $ do+      let span = tag' (Element True "span") :: Mod () -> View () () -> View () ()+      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+  describe "indentation" $ do+    it "should nested indent" $ do+      golden <- goldenFile "test/resources/nested.txt"+      let out = renderText $ do             el_ $ do               el_ $ do                 el_ "HI"+      out `shouldBe` golden  -goldenFile :: FilePath -> IO Text -> GoldenTest Text-goldenFile fp txt = do-  goldenTextFile fp $ do-    t <- txt-    pure $ t <> "\n"+selectorSpec :: Spec+selectorSpec = do+  it "should escape classNames" $ do+    className "hello.woot-hi" `shouldBe` "hello-woot-hi"++  it "normal selector" $ do+    let sel = selector "myclass"+    selectorText sel `shouldBe` ".myclass"++  it "pseudo selector" $ do+    let sel = (selector "myclass"){pseudo = Just Hover}+    attributeClassName sel `shouldBe` "hover:myclass"+    selectorText sel `shouldBe` ".hover\\:myclass:hover"++  it "it should include ancestor in selector" $ do+    let sel = (selector "myclass"){ancestor = Just "parent"}+    attributeClassName sel `shouldBe` "parent-myclass"+    selectorText sel `shouldBe` ".parent .parent-myclass"++  it "should not media query in selectorText" $ do+    let sel = (selector "myclass"){media = Just (MinWidth 100)}+    attributeClassName sel `shouldBe` "mmnw100-myclass"+    selectorText sel `shouldBe` ".mmnw100-myclass"++  it "psuedo + parent" $ do+    let sel = (selector "myclass"){ancestor = Just "parent", pseudo = Just Hover}+    selectorText sel `shouldBe` ".parent .hover\\:parent-myclass:hover"++  it "child" $ do+    let sel = (selector "myclass"){child = Just "mychild"}+    attributeClassName sel `shouldBe` "myclass-mychild"+    selectorText sel `shouldBe` ".myclass-mychild > .mychild"++    let sel2 = (selector "myclass"){child = Just AllChildren}+    attributeClassName sel2 `shouldBe` "myclass-all"+    selectorText sel2 `shouldBe` ".myclass-all > *"++  it "parent + pseudo + child" $ do+    let sel = (selector "myclass"){child = Just "mychild", ancestor = Just "myparent", pseudo = Just Hover}+    attributeClassName sel `shouldBe` "hover:myparent-myclass-mychild"+    selectorText sel `shouldBe` ".myparent .hover\\:myparent-myclass-mychild:hover > .mychild"+++-- describe "child combinator" $ do+--   it "should include child combinator in definition"  $ do++goldenFile :: FilePath -> IO Text+goldenFile fp = do+  inp <- T.readFile fp+  pure $ T.dropWhileEnd (== '\n') inp+++runCSS :: View () () -> CSS+runCSS view = (runView () view).css
test/Test/UrlSpec.hs view
@@ -1,6 +1,6 @@ module Test.UrlSpec (spec) where -import Test.Syd+import Skeletest import Text.Read (readMaybe) import Web.View.Types.Url
+ test/Test/ViewSpec.hs view
@@ -0,0 +1,24 @@+module Test.ViewSpec where++import Skeletest+import Web.View+import Web.View.Types+import Web.View.View (ViewState (..), runView)+import Prelude hiding (span)+++spec :: Spec+spec = do+  describe "view" $ do+    describe "string literals" $ do+      it "should include lits at text" $ do+        let view = ("hello: " :: View c ()) >> text "world"+        (runView () view).contents `shouldBe` [Text "hello: ", Text "world"]++      it "should include text and text" $ do+        let view = text "stuff" >> text "hello"+        (runView () view).contents `shouldBe` [Text "stuff", Text "hello"]++      it "should include text and trailing lits" $ do+        let view = text "stuff" >> "hello"+        (runView () view).contents `shouldBe` [Text "stuff", Text "hello"]
web-view.cabal view
@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           web-view-version:        0.5.0+version:        0.6.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@@ -62,12 +62,13 @@     , text >=1.2 && <3   default-language: GHC2021 -test-suite tests+test-suite test   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:       Test.RenderSpec       Test.UrlSpec+      Test.ViewSpec       Paths_web_view   autogen-modules:       Paths_web_view@@ -78,11 +79,12 @@       OverloadedRecordDot       DuplicateRecordFields       NoFieldSelectors-  ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor   build-tool-depends:-      sydtest-discover:sydtest-discover+      skeletest:skeletest-preprocessor   build-depends:-      base >=4.16 && <5+      Diff >=0.5 && <1.0+    , base >=4.16 && <5     , bytestring >=0.11 && <0.13     , casing >0.1.3.0 && <0.2     , containers >=0.6 && <1@@ -90,8 +92,8 @@     , file-embed >=0.0.10 && <0.1     , html-entities >=1.1.4.7 && <1.2     , http-types ==0.12.*+    , skeletest     , string-interpolate >=0.3.2 && <0.4-    , sydtest ==0.15.*     , text >=1.2 && <3     , web-view   default-language: GHC2021