lucid 2.9.12 → 2.11.20260427
raw patch · 7 files changed
Files
- CHANGELOG.md +38/−0
- README.md +10/−2
- benchmarks/HtmlBenchmarks.hs +34/−21
- lucid.cabal +14/−7
- src/Lucid/Base.hs +46/−36
- src/Lucid/Html5.hs +17/−1
- test/Main.hs +38/−21
CHANGELOG.md view
@@ -1,3 +1,41 @@+## Upcoming++## 2.11.20260427++* Support GHC 9.14++## 2.11.20250303++* Support GHC 9.12++## 2.11.20230408++* Don't expect Control.Monad to be re-exported from mtl anymore++## 2.11.1++* Use explicit imports for mtl, avoids the mtl-2.3 issue+* Added `minlength` attribute.+* Added `loading` attribute.++## 2.11.0++* Change internal attributes to `Seq Attribute`. This preserves+ ordering. Attributes are merged in a left-biased way, preserving the+ key order as first encountered.++## 2.10.0++* Change internal attributes representation from HashMap to Map. This+ introduces stable ordering, at a negligible performance cost for+ realistic element sizes. This may affect some test suites.+* doctype no longer accepts attributes. You can use `with` with+ `doctypeHtml` now, if needed.++## 2.9.12.1++* Allow different orderings of attributes in test-suite+ ## 2.9.12 * Add MonadFix instance
README.md view
@@ -3,9 +3,12 @@ Clear to write, read and edit DSL for writing HTML -[Documentation](http://chrisdone.github.io/lucid/)+**Table of Contents** -[lucid-from-html](https://github.com/dbaynard/lucid-from-html) will convert html to the `lucid` DSL, though it is experimental.+- [Introduction](#introduction)+- [Rendering](#rendering)+- [Good to know](#good-to-know)+- [Transforming](#transforming) ## Introduction @@ -119,6 +122,11 @@ See the documentation for the `Lucid` module for information about using it as a monad transformer.++## Good to know++* Attributes are escaped, so you cannot write arbitrary JavaScript in attributes. Instead, do something like `onclick_ "foo()"`.+* Attributes are rendered in the order that they are written in your Haskell code. ## Transforming
benchmarks/HtmlBenchmarks.hs view
@@ -7,12 +7,12 @@ module HtmlBenchmarks where import Data.Monoid (Monoid,mappend,mempty)+import Data.Text (Text) import qualified Data.Text as T -- import qualified Data.Text.Lazy.Builder as B import qualified Prelude as P import Prelude hiding (div, id)-import Data.String -- import BenchmarkUtils import Lucid@@ -22,10 +22,10 @@ -- | Description of an HTML benchmark -- data HtmlBenchmark = forall a. HtmlBenchmark- String -- ^ Name.+ String -- ^ Name. (a -> Html ()) -- ^ Rendering function.- a -- ^ Data.- (Html ()) -- ^ Longer description.+ a -- ^ Data.+ (Html ()) -- ^ Longer description. -- | List containing all benchmarks. --@@ -40,15 +40,19 @@ , HtmlBenchmark "wideTree" wideTree wideTreeData $ "A very wide tree (" >> toHtml (show (length wideTreeData)) >> " elements)" , HtmlBenchmark "wideTreeEscaping" wideTree wideTreeEscapingData $ do- "A very wide tree (" >> toHtml (show (length wideTreeData)) >> " elements)"+ "A very wide tree (" >> toHtml (show (length wideTreeEscapingData)) >> " elements)" " with lots of escaping" , HtmlBenchmark "deepTree" deepTree deepTreeData $ do "A really deep tree (" >> toHtml (show deepTreeData) >> " nested templates)" , HtmlBenchmark "manyAttributes" manyAttributes manyAttributesData $ do "A single element with " >> toHtml (show (length manyAttributesData))- " attributes."+ " distinct attributes."+ , HtmlBenchmark "duplicateAttributes" duplicateAttributes duplicateAttributesData $ do+ "A single element with a single attribute and " >> toHtml (show (length duplicateAttributesData))+ " values." , HtmlBenchmark "customAttribute" customAttributes customAttributesData $- "Creating custom attributes"+ "Creating custom attributes (middle ground between manyAttributes and duplicateAttributes)"+ ] rows :: Int@@ -58,20 +62,20 @@ bigTableData = replicate rows [1..10] {-# NOINLINE bigTableData #-} -basicData :: (String, String, [String])+basicData :: (Text, Text, [Text]) basicData = ("Just a test", "joe", items) {-# NOINLINE basicData #-} -items :: [String]-items = map (("Number " `mappend`) . show) [1 :: Int .. 14]+items :: [Text]+items = map (("Number " `mappend`) . T.pack . show) [1 :: Int .. 14] {-# NOINLINE items #-} -wideTreeData :: [String]+wideTreeData :: [Text] wideTreeData = take 5000 $ cycle ["λf.(λx.fxx)(λx.fxx)", "These old days", "Foobar", "lol", "x ∈ A"] {-# NOINLINE wideTreeData #-} -wideTreeEscapingData :: [String]+wideTreeEscapingData :: [Text] wideTreeEscapingData = take 1000 $ cycle ["<><>", "\"lol\"", "<&>", "'>>'"] {-# NOINLINE wideTreeEscapingData #-}@@ -80,10 +84,15 @@ deepTreeData = 1000 {-# NOINLINE deepTreeData #-} -manyAttributesData :: [String]-manyAttributesData = wideTreeData+manyAttributesData :: [(T.Text, T.Text)]+manyAttributesData = zipWith mk [0 ..] wideTreeData where+ mk :: Int -> T.Text -> (T.Text, T.Text)+ mk i val = (T.pack ("attr" ++ show i), val) -customAttributesData :: [(String, String)]+duplicateAttributesData :: [Text]+duplicateAttributesData = wideTreeData++customAttributesData :: [(Text, Text)] customAttributesData = zip wideTreeData wideTreeData -- | Render the argument matrix as an HTML table.@@ -97,7 +106,7 @@ -- | Render a simple HTML page with some data. ---basic :: (String, String, [String]) -- ^ (Title, User, Items)+basic :: (Text, Text, [Text]) -- ^ (Title, User, Items) -> Html () -- ^ Result. basic (title', user, items') = html_ $ do head_ $ title_ $ toHtml title'@@ -112,7 +121,7 @@ -- | A benchmark producing a very wide but very shallow tree. ---wideTree :: [String] -- ^ Text to create a tree from.+wideTree :: [Text] -- ^ Text to create a tree from. -> Html () -- ^ Result. wideTree = div_ . mapM_ ((with p_ [id_ "foo"]) . toHtml) @@ -125,11 +134,15 @@ -- | Create an element with many attributes. ---manyAttributes :: [String] -- ^ List of attribute values.+manyAttributes :: [(T.Text, T.Text)] -- ^ List of attribute values. -> Html () -- ^ Result.-manyAttributes as = img_ (map (id_ . T.pack) as)+manyAttributes as = img_ (map (\(key, val) -> makeAttribute key val) as) -customAttributes :: [(String, String)] -- ^ List of attribute name, value pairs+duplicateAttributes :: [Text] -- ^ List of attribute values.+ -> Html () -- ^ Result.+duplicateAttributes as = img_ (map id_ as)++customAttributes :: [(Text, Text)] -- ^ List of attribute name, value pairs -> Html () -- ^ Result customAttributes xs =- img_ (map (\(key,val) -> makeAttribute (fromString key) (T.pack val)) xs)+ img_ (map (\(key,val) -> makeAttribute key val) xs)
lucid.cabal view
@@ -1,5 +1,5 @@ name: lucid-version: 2.9.12+version: 2.11.20260427 synopsis: Clear to write, read and edit DSL for HTML description: Clear to write, read and edit DSL for HTML.@@ -15,15 +15,16 @@ license: BSD3 license-file: LICENSE author: Chris Done-maintainer: chrisdone@gmail.com, oleg.grenrus@iki.fi-copyright: 2014-2017 Chris Done+maintainer: chrisdone@gmail.com+copyright: 2014-2021 Chris Done category: Web build-type: Simple-cabal-version: >=1.8+cabal-version: >=1.10 extra-source-files: README.md, CHANGELOG.md-tested-with: GHC==7.10.3,GHC==8.0.2,GHC==8.2.2,GHC==8.4.4,GHC==8.6.5, GHC==8.8.1+tested-with: GHC==7.10.3,GHC==8.0.2,GHC==8.2.2,GHC==8.4.4,GHC==8.6.5,GHC==8.8.4,GHC==8.10.7,GHC==9.0.1,GHC==9.2.1, GHC==9.4.1 library+ default-language: Haskell2010 hs-source-dirs: src/ ghc-options: -Wall -O2 exposed-modules: Lucid@@ -32,7 +33,7 @@ Lucid.Bootstrap -- GHC boot libraries- build-depends: base >=4.8 && <4.14+ build-depends: base >=4.8 && <5 , bytestring >=0.10.6.0 , containers >=0.5.6.2 , transformers >=0.4.2.0@@ -49,9 +50,13 @@ build-depends: blaze-builder >=0.4.0.0 , hashable >=1.2.3.2 , mmorph >=1.0.3- , unordered-containers >=0.2.5.1 +source-repository head+ type: git+ location: https://github.com/chrisdone/lucid.git+ test-suite test+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test@@ -66,6 +71,7 @@ mtl benchmark bench+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Main.hs@@ -80,6 +86,7 @@ ghc-options: -O2 benchmark bench-io+ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: IO.hs
src/Lucid/Base.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeOperators #-} -- Search for UndecidableInstances to see why this is needed {-# LANGUAGE UndecidableInstances #-}@@ -44,8 +45,11 @@ import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze import Control.Applicative import Control.Monad-import Control.Monad.Morph-import Control.Monad.Reader+import Control.Monad.Morph (MFunctor(..))+import Control.Monad.Reader (MonadReader(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Fix (MonadFix(..))+import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Writer.Class (MonadWriter(..))@@ -53,8 +57,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import Data.Functor.Identity-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M+import qualified Data.Map.Strict as M import Data.Hashable (Hashable(..)) import Data.Semigroup (Semigroup (..)) import Data.Monoid (Monoid (..))@@ -63,15 +66,21 @@ import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Encoding as T-import Data.Typeable (Typeable) import Prelude+import Data.Maybe+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Foldable (toList)+import qualified Data.Set as Set -------------------------------------------------------------------------------- -- Types --- | A simple attribute. Don't use the constructor, use 'makeAttribute'.+-- | A simple attribute. Don't use the constructor, use+-- 'makeAttribute'. Attributes are case sensitive, so if you want+-- attributes to be merged properly, use a single case representation. data Attribute = Attribute !Text !Text- deriving (Show,Eq,Typeable)+ deriving (Show,Eq) instance Hashable Attribute where hashWithSalt salt (Attribute a b) = salt `hashWithSalt` a `hashWithSalt` b@@ -85,21 +94,16 @@ -- | A monad transformer that generates HTML. Use the simpler 'Html' -- type if you don't want to transform over some other monad.+--+-- Don't rely on the internal representation of this type. Use the+-- monad and functor classes. newtype HtmlT m a =- HtmlT {runHtmlT :: m (HashMap Text Text -> Builder,a)+ HtmlT {runHtmlT :: m (Seq Attribute -> Builder,a) -- ^ This is the low-level way to run the HTML transformer, -- finally returning an element builder and a value. You can -- pass 'mempty' for this argument for a top-level call. See -- 'evalHtmlT' and 'execHtmlT' for easier to use functions. }--- GHC 7.4 errors with--- Can't make a derived instance of `Typeable (HtmlT m a)':--- `HtmlT' must only have arguments of kind `*'--- GHC 7.6 errors with--- `HtmlT' must only have arguments of kind `*'-#if __GLASGOW_HASKELL__ >= 707- deriving (Typeable)-#endif -- | @since 2.9.5 instance MFunctor HtmlT where@@ -112,7 +116,9 @@ -- | Monoid is right-associative, a la the 'Builder' in it. instance (a ~ (),Applicative m) => Monoid (HtmlT m a) where mempty = pure mempty+#if !MIN_VERSION_base(4,11,0) mappend = liftA2 mappend+#endif -- | Based on the monad instance. instance Applicative m => Applicative (HtmlT m) where@@ -140,21 +146,12 @@ -- | Basically acts like Writer. instance Monad m => Monad (HtmlT m) where- return a = HtmlT (return (mempty,a))- {-# INLINE return #-}- m >>= f = HtmlT $ do ~(g,a) <- runHtmlT m ~(h,b) <- runHtmlT (f a) return (g <> h,b) {-# INLINE (>>=) #-} - m >> n = HtmlT $ do- ~(g, _) <- runHtmlT m- ~(h, b) <- runHtmlT n- return (g <> h, b)- {-# INLINE (>>) #-}- -- | Used for 'lift'. instance MonadTrans HtmlT where lift m =@@ -342,22 +339,16 @@ instance (Functor m) => With (HtmlT m a) where with f = \attr -> HtmlT (mk attr <$> runHtmlT f) where- mk attr ~(f',a) = (\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr')+ mk attr ~(f',a) = (\attr' -> f' (attr' <> Seq.fromList attr) ,a)- toPair (Attribute x y) = (x,y) -- | For the contentful elements: 'Lucid.Html5.div_' instance (Functor m) => With (HtmlT m a -> HtmlT m a) where with f = \attr inner -> HtmlT (mk attr <$> runHtmlT (f inner)) where- mk attr ~(f',a) = (\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr')+ mk attr ~(f',a) = (\attr' -> f' (attr' <> Seq.fromList attr) ,a)- toPair (Attribute x y) = (x,y) --- | Union two sets of arguments and append duplicate keys.-unionArgs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text-unionArgs = M.unionWith (<>)- -------------------------------------------------------------------------------- -- Running @@ -529,8 +520,27 @@ else s "=\"" <> Blaze.fromHtmlEscapedText val <> s "\"" -- | Folding and monoidally appending attributes.-foldlMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m-foldlMapWithKey f = M.foldlWithKey' (\m k v -> m `mappend` f k v) mempty+foldlMapWithKey :: (Text -> Text -> Builder) -> Seq Attribute -> Builder+foldlMapWithKey f attributes =+ case nubOrdMaybe (map fst pairs) of+ Just keyList ->+ foldMap (\k -> fromMaybe mempty (fmap (f k) (M.lookup k values))) keyList+ where values = M.fromListWith (<>) pairs+ Nothing -> foldMap (\(Attribute k v) -> f k v) attributes+ where+ pairs = map (\(Attribute k v) -> (k,v)) (toList attributes)++-- | Do a nubOrd, but only return Maybe if it actually removes anything.+nubOrdMaybe :: Ord a => [a] -> Maybe [a]+nubOrdMaybe = go False Set.empty []+ where+ go (!removed) set acc (x:xs)+ | x `Set.member` set = go True set acc xs+ | otherwise = go removed (Set.insert x set) (x : acc) xs+ go removed _set acc [] =+ if removed+ then pure (reverse acc)+ else Nothing -- | Convenience function for constructing builders. s :: String -> Builder
src/Lucid/Html5.hs view
@@ -15,8 +15,12 @@ -- Elements -- | @DOCTYPE@ element+--+-- This is implemented as "raw output", because the doctype doesn't+-- accept attributes, such as those inserted via 'with'.+-- doctype_ :: Applicative m => HtmlT m ()-doctype_ = makeElementNoEnd "!DOCTYPE HTML"+doctype_ = HtmlT (pure (const "<!DOCTYPE HTML>", ())) -- | @DOCTYPE@ element + @html@ element doctypehtml_ :: Applicative m => HtmlT m a -> HtmlT m a@@ -675,6 +679,10 @@ list_ :: Text -> Attribute list_ = makeAttribute "list" +-- | The @loading@ attribute.+loading_ :: Text -> Attribute+loading_ = makeAttribute "loading"+ -- | The @loop@ attribute. loop_ :: Text -> Attribute loop_ = makeAttribute "loop"@@ -707,6 +715,10 @@ min_ :: Text -> Attribute min_ = makeAttribute "min" +-- | The @minlength@ attribute.+minlength_ :: Text -> Attribute+minlength_ = makeAttribute "minlength"+ -- | The @multiple@ attribute. multiple_ :: Text -> Attribute multiple_ = makeAttribute "multiple"@@ -994,6 +1006,10 @@ -- | The @placeholder@ attribute. placeholder_ :: Text -> Attribute placeholder_ = makeAttribute "placeholder"++-- | The @poster@ attribute.+poster_ :: Text -> Attribute+poster_ = makeAttribute "poster" -- | The @preload@ attribute. preload_ :: Text -> Attribute
test/Main.hs view
@@ -11,6 +11,7 @@ import Lucid.Base import Lucid.Bootstrap +import Control.Monad import Control.Applicative import Control.Monad.State.Strict @@ -38,6 +39,10 @@ describe "commuteHtmlT" testCommuteHtmlT describe "monadFix" testMonadFix +(==?*) :: (Eq a, Show a) => a -> [a] -> Assertion+x ==?* xs | x `elem` xs = return ()+ | otherwise = assertFailure $ show x ++ " is not equal to any of " ++ show xs+ -- | Test text/unicode. testText :: Spec testText =@@ -103,18 +108,22 @@ (p_ [class_ "foo"] (p_ "")) == "<p class=\"foo\"><p></p></p>")- it "mixed"- (renderText+ it "mixed" $+ renderText (p_ [class_ "foo",style_ "attrib"] (do style_ ""- style_ "")) ==- "<p style=\"attrib\" class=\"foo\"><style></style><style></style></p>")+ style_ "")) ==?*+ [ "<p style=\"attrib\" class=\"foo\"><style></style><style></style></p>"+ , "<p class=\"foo\" style=\"attrib\"><style></style><style></style></p>"+ ] it "no closing" (renderText (p_ [class_ "foo"] (input_ [])) == "<p class=\"foo\"><input></p>")- it "multiple"- (renderText (p_ [class_ "foo",id_ "zot"] "foo") ==- "<p id=\"zot\" class=\"foo\">foo</p>")+ it "multiple" $+ renderText (p_ [class_ "foo",id_ "zot"] "foo") ==?*+ [ "<p id=\"zot\" class=\"foo\">foo</p>"+ , "<p class=\"foo\" id=\"zot\">foo</p>"+ ] it "encoded" (renderText (p_ [class_ "foo<>"] "foo") == "<p class=\"foo<>\">foo</p>")@@ -152,24 +161,30 @@ [class_ "foo"] (p_ "")) == "<p class=\"foo\"><p></p></p>")- it "mixed"- (renderText+ it "mixed" $+ renderText (with p_ [class_ "foo",style_ "attrib"]- (style_ "")) ==- "<p style=\"attrib\" class=\"foo\"><style></style></p>")- it "no closing"- (renderText (with p_ [class_ "foo"] (with (input_ [type_ "text"]) [class_ "zot"])) ==- "<p class=\"foo\"><input type=\"text\" class=\"zot\"></p>")- it "multiple"- (renderText (with p_ [class_ "foo",id_ "zot"] "foo") ==- "<p id=\"zot\" class=\"foo\">foo</p>")+ (style_ "")) ==?*+ [ "<p style=\"attrib\" class=\"foo\"><style></style></p>"+ , "<p class=\"foo\" style=\"attrib\"><style></style></p>"+ ]+ it "no closing" $+ renderText (with p_ [class_ "foo"] (with (input_ [type_ "text"]) [class_ "zot"])) ==?*+ [ "<p class=\"foo\"><input type=\"text\" class=\"zot\"></p>"+ , "<p class=\"foo\"><input class=\"zot\" type=\"text\"></p>"+ ]+ it "multiple" $+ renderText (with p_ [class_ "foo",id_ "zot"] "foo") ==?*+ [ "<p id=\"zot\" class=\"foo\">foo</p>"+ , "<p class=\"foo\" id=\"zot\">foo</p>"+ ] it "encoded" (renderText (with p_ [class_ "foo<>"] "foo") == "<p class=\"foo<>\">foo</p>") it "nesting attributes" (renderText (with (with p_ [class_ "foo"]) [class_ "bar"] "foo") ==- "<p class=\"foobar\">foo</p>")+ "<p class=\"foobar\">foo</p>") -- | Test that one can use elements with extensible attributes. testExtension :: Spec@@ -177,9 +192,11 @@ do it "bootstrap" (renderText (container_ "Foo!") == "<div class=\" container \">Foo!</div>")- it "bootstrap-attributes-extended"- (renderText (container_ [class_ "bar",id_ "zot"] "Foo!") ==- "<div id=\"zot\" class=\" container bar\">Foo!</div>")+ it "bootstrap-attributes-extended" $+ renderText (container_ [class_ "bar",id_ "zot"] "Foo!") ==?*+ [ "<div class=\" container bar\" id=\"zot\">Foo!</div>"+ , "<div class=\" container bar\" id=\"zot\">Foo!</div>"+ ] -- | Test special elements that do something different to normal -- elements.