diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/benchmarks/HtmlBenchmarks.hs b/benchmarks/HtmlBenchmarks.hs
--- a/benchmarks/HtmlBenchmarks.hs
+++ b/benchmarks/HtmlBenchmarks.hs
@@ -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)
diff --git a/lucid.cabal b/lucid.cabal
--- a/lucid.cabal
+++ b/lucid.cabal
@@ -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
diff --git a/src/Lucid/Base.hs b/src/Lucid/Base.hs
--- a/src/Lucid/Base.hs
+++ b/src/Lucid/Base.hs
@@ -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
diff --git a/src/Lucid/Html5.hs b/src/Lucid/Html5.hs
--- a/src/Lucid/Html5.hs
+++ b/src/Lucid/Html5.hs
@@ -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@ 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
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -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_ "")) ==
"")
- it "mixed"
- (renderText
+ it "mixed" $
+ renderText
(p_ [class_ "foo",style_ "attrib"]
(do style_ ""
- style_ "")) ==
- "")
+ style_ "")) ==?*
+ [ ""
+ , ""
+ ]
it "no closing"
(renderText (p_ [class_ "foo"] (input_ [])) ==
"")
- it "multiple"
- (renderText (p_ [class_ "foo",id_ "zot"] "foo") ==
- "
")
-- | Test that one can use elements with extensible attributes.
testExtension :: Spec
@@ -177,9 +192,11 @@
do it "bootstrap"
(renderText (container_ "Foo!") ==
"