packages feed

lucid2 (empty) → 0.0.20220508

raw patch · 9 files changed

+2163/−0 lines, 9 filesdep +HUnitdep +basedep +bifunctorssetup-changed

Dependencies added: HUnit, base, bifunctors, blaze-builder, bytestring, containers, hspec, lucid2, mtl, parsec, text, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,34 @@+## 0.0.x++TBA++## New in lucid2++Changed:++* All on* attributes and style_ do not escape their values anymore. Be+  careful. Though you were probably being careful with these anyway,+  as they are inherently dangerous for XXS.++Renamed:++* makeAttribute is renamed to makeAttributes.+* Added makeAttributesRaw.++Dropped:++* Eq/Ord/Show instances for Attribute.+* Drop the `Lucid.Bootstrap` module entirely.+* Dropped the mmorph dependency (breaking changes often, not+  reliable), instead we provide a simple `hoist` function of the right+  type.+* Drop MonadError.+* Drop MonadWriter.+* Drop hashable.+* Drop XML elements.++Dependencies:++* We now only depend on blaze-builder, and the rest are libraries that+  come with GHC, which are held to a slightly higher standard of not+  breaking changes.
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2014, Chris Done+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of Chris Done nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,151 @@+lucid2+=====++**Note**: For a list of changes from lucid1 to lucid2, see [CHANGELOG.md](https://github.com/chrisdone/lucid/blob/master/lucid2/CHANGELOG.md)++Clear to write, read and edit DSL for writing HTML++**Table of Contents**++- [Introduction](#introduction)+- [Rendering](#rendering)+- [Good to know](#good-to-know)+- [Transforming](#transforming)++## Version++This is version 2 of the lucid package, according to the+[Immutable Publishing Policy](https://chrisdone.com/posts/ipp/).++There never be any breaking changes made to this package.++## Introduction++HTML terms in Lucid are written with a postfix ‘`_`’ to indicate data+rather than code. Some examples:++`p_`, `class_`, `table_`, `style_`++See `Lucid.Html5` for a complete list of Html5 combinators.++Plain text is written using the `OverloadedStrings` and+`ExtendedDefaultRules` extensions, and is automatically escaped:++``` haskell+λ> "123 < 456" :: Html ()+```++``` html+123 &lt; 456+```++Elements nest by function application:++``` haskell+λ> table_ (tr_ (td_ (p_ "Hello, World!"))) :: Html ()+```++``` html+<table><tr><td><p>Hello, World!</p></td></tr></table>+```++Elements are juxtaposed via monoidal append:++``` haskell+λ> p_ "hello" <> p_ "sup" :: Html ()+```++``` html+<p>hello</p><p>sup</p>+```++Or monadic sequencing:++``` haskell+λ> div_ (do p_ "hello"; p_ "sup") :: Html ()+```++``` html+<div><p>hello</p><p>sup</p></div>+```++Attributes are set by providing an argument list:++``` haskell+λ> p_ [class_ "brand"] "Lucid Inc" :: Html ()+```++``` html+<p class="brand">Lucid Inc</p>+```++Here is a fuller example of Lucid:++``` haskell+table_ [rows_ "2"]+       (tr_ (do td_ [class_ "top",colspan_ "2",style_ "color:red"]+                    (p_ "Hello, attributes!")+                td_ "yay!"))+```++``` html+<table rows="2">+  <tr>+    <td style="color:red" colspan="2" class="top">+      <p>Hello, attributes!</p>+    </td>+    <td>yay!</td>+  </tr>+</table>+```++## Rendering++For proper rendering you can easily run some HTML immediately with:++``` haskell+λ> renderText (p_ "Hello!")+```++``` html+"<p>Hello!</p>"+```++Or to bytes:++``` haskell+λ> renderBS (p_ [style_ "color:red"] "Hello!")+```++``` html+"<p style=\"color:red\">Hello!</p>"+```++For ease of use in GHCi, there is a `Show` instance, as+demonstrated above.++If the above rendering functions aren't suited for your purpose, you+can run the monad directly via `execHtml` and use the more low-level+blaze `Builder`, which has a plethora of output modes in+Blaze.ByteString.Builder.++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++You can use `lift` to call parent monads.++``` haskell+λ> runReader (renderTextT (html_ (body_ (do name <- lift ask+                                            p_ [class_ "name"] (toHtml name)))))+             ("Chris" :: String)+```+``` html+"<html><body><p class=\"name\">Chris</p></body></html>"+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lucid2.cabal view
@@ -0,0 +1,62 @@+name:                lucid2+version:             0.0.20220508+synopsis:            Clear to write, read and edit DSL for HTML+description:+  Clear to write, read and edit DSL for HTML.+  .+  * Names are consistent, and do not conflict with base or are keywords (all have suffix @_@)+  .+  * Same combinator can be used for attributes and elements (e.g. 'style_')+  .+  * For more, read <https://chrisdone.com/posts/lucid the blog post>+  .+  See the "Lucid" module for more documentation.+  .+  This package is the newer version of lucid.+homepage:            https://github.com/chrisdone/lucid+license:             BSD3+license-file:        LICENSE+author:              Chris Done+maintainer:          lucid2@chrisdone.com+copyright:           2014-2022 Chris Done+category:            Web+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md, CHANGELOG.md++library+  default-language:  Haskell2010+  hs-source-dirs:    src/+  ghc-options:       -Wall -O2+  exposed-modules:   Lucid+                     Lucid.Base+                     Lucid.Html5++  -- GHC boot libraries+  build-depends:     base          >= 4.8 && < 4.17+                   , bytestring    >= 0.10.12.0+                   , containers    >= 0.6.5.1+                   , transformers  >= 0.5.6.2+                   , mtl           >= 2.2.2+                   , text          >= 1.2.4.1++  -- other dependencies+  build-depends:     blaze-builder++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+    build-depends: base,+                   lucid2,+                   HUnit,+                   hspec,+                   parsec,+                   bifunctors,+                   text,+                   mtl
+ src/Lucid.hs view
@@ -0,0 +1,158 @@+-- | Clear to write, read and edit DSL for writing HTML+--+-- See "Lucid.Html5" for a complete list of Html5 combinators. That+-- module is re-exported from this module for your convenience.+--+-- See "Lucid.Base" for lower level functions like+-- `makeElement`, `makeAttributes`, 'termRaw', etc.+--+-- To convert html to the lucid DSL, use the (experimental) program+-- <https://github.com/dbaynard/lucid-from-html lucid-from-html>+-- which may eventually be integrated into lucid itself.++module Lucid+  (-- * Intro+   -- $intro+   renderText+  ,renderBS+  ,renderTextT+  ,renderBST+  ,renderToFile+   -- * Running+   -- $running+  ,execHtmlT+  ,evalHtmlT+  ,runHtmlT+   -- * Types+  ,Html+  ,HtmlT+  ,Attributes+   -- * Classes+   -- $overloaded+  ,Term(..)+  ,ToHtml(..)+  -- * Re-exports+  ,module Lucid.Html5)+ where++import Lucid.Base+import Lucid.Html5++-- $intro+--+-- HTML terms in Lucid are written with a postfix ‘@_@’ to indicate data+-- rather than code. Some examples:+--+-- 'p_', 'class_', 'table_', 'style_'+--+-- Note: If you're testing in the REPL you need to add a type annotation to+-- indicate that you want HTML. In normal code your top-level+-- declaration signatures handle that.+--+-- For GHCi:+--+-- @+-- :set -XOverloadedStrings -XExtendedDefaultRules@+-- import Lucid+-- @+--+-- In a module: @{-\# LANGUAGE OverloadedStrings, ExtendedDefaultRules \#-}@+--+-- Plain text is written like this, and is automatically escaped:+--+-- >>> "123 < 456" :: Html ()+-- 123 &lt; 456+--+-- Except some elements, like 'script_':+--+-- >>> script_ "alert('Hello!' > 12)" :: Html ()+-- <script>alert('Hello!' > 12)</script>+--+-- Elements nest by function application:+--+-- >>> table_ (tr_ (td_ (p_ "Hello, World!"))) :: Html ()+-- <table><tr><td><p>Hello, World!</p></td></tr></table>+--+-- Elements are juxtaposed via monoidal append (remember to import "Data.Monoid"):+--+-- >>> p_ "hello" <> p_ "sup" :: Html ()+-- <p>hello</p><p>sup</p>+--+-- Or monadic sequencing:+--+-- >>> div_ (do p_ "hello"; p_ "sup") :: Html ()+-- <div><p>hello</p><p>sup</p></div>+--+-- Attributes are set by providing an argument list:+--+-- >>> p_ [class_ "brand"] "Lucid Inc" :: Html ()+-- <p class="brand">Lucid Inc</p>+--+-- >>> p_ [data_ "zot" "foo",checked_] "Go!" :: Html ()+-- <p data-zot="foo" checked>go</p>+--+-- Attribute and element terms are not conflicting:+--+-- >>> style_ [style_ "inception"] "Go deeper." :: Html ()+-- <style style="inception">Go deeper.</style>+--+-- Here is a fuller example of Lucid:+--+-- @+-- table_ [rows_ "2"]+--        (tr_ (do td_ [class_ "top",colspan_ "2",style_ "color:red"]+--                     (p_ "Hello, attributes!")+--                 td_ "yay!"))+-- @+--+-- Elements (and some attributes) are variadic and overloaded, see the+-- 'Term' class for more explanation about that.+--+-- For proper rendering you can easily run some HTML immediately with:+--+-- >>> renderText (p_ "Hello!")+-- > "<p>Hello!</p>"+--+-- >>> renderBS (p_ [style_ "color:red"] "Hello!")+-- "<p style=\"color:red\">Hello!</p>"+--+-- For ease of use in GHCi, there is a 'Show' instance, as+-- demonstrated above.++-- $overloaded+--+-- To support convenient use of HTML terms, HTML terms are+-- overloaded. Here are the following types possible for an element+-- term accepting attributes and/or children:+--+-- @+-- p_ :: Term arg result => arg -> result+-- p_ :: Monad m => [Attributes] -> HtmlT m () -> HtmlT m ()+-- p_ :: Monad m => HtmlT m () -> HtmlT m ()+-- @+--+-- The first is the generic form. The latter two are the possible+-- types for an element.+--+-- Elements that accept no content are always concrete:+--+-- @+-- input_ :: Monad m => [Attributes] -> HtmlT m ()+-- @+--+-- And some elements share the same name as attributes, so you can+-- also overload them as attributes:+--+-- @+-- style_ :: TermRaw arg result => arg -> result+-- style_ :: Monad m => [Attributes] -> Text -> HtmlT m ()+-- style_ :: Monad m => Text -> HtmlT m ()+-- style_ :: Text -> Attributes+-- @++-- $running+--+-- If the above rendering functions aren't suited for your purpose,+-- you can run the monad directly and use the more low-level blaze+-- `Builder`, which has a plethora of output modes in+-- "Blaze.ByteString.Builder".
+ src/Lucid/Base.hs view
@@ -0,0 +1,442 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE BangPatterns, RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++-- Search for UndecidableInstances to see why this is needed+{-# LANGUAGE UndecidableInstances #-}++-- | Base types and combinators.++module Lucid.Base+  (-- * Rendering+   renderText+  ,renderBS+  ,renderTextT+  ,renderBST+  ,renderToFile+   -- * Running+  ,execHtmlT+  ,evalHtmlT+  ,runHtmlT+  ,relaxHtmlT+  -- ,commuteHtmlT+  -- ,hoistHtmlT+  -- * Combinators+  ,makeElement+  ,makeElementNoEnd+  ,makeAttributes+  ,makeAttributesRaw+  ,Attributes+   -- * Types+  ,Html+  ,HtmlT+   -- * Classes+  ,Term(..)+  ,TermRaw(..)+  ,ToHtml(..))+  where++import           Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Html.Utf8 as Blaze+import           Control.Applicative+import           Control.Monad+import           Control.Monad.Error.Class (MonadError(..))+import           Control.Monad.Reader+import           Control.Monad.State.Class (MonadState(..))+import           Control.Monad.Trans.State.Strict (StateT(..), modify')+import qualified Data.ByteString as S+import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as L+import           Data.Foldable (toList)+import           Data.Functor.Identity+import qualified Data.Map.Strict as M+import           Data.Maybe+import           Data.Sequence (Seq)+import qualified Data.Set as Set+import           Data.String+import           Data.Text (Text)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import           Data.Tuple (swap)+import           Prelude++--------------------------------------------------------------------------------+-- Types++-- | A simple attribute. Don't use the constructor, use+-- 'makeAttributes'.  Attributes are case sensitive, so if you want+-- attributes to be merged properly, use a single case representation.+data Attribute = Attribute !Text !Builder++-- | A list of attributes.+newtype Attributes = Attributes { unAttributes :: Seq Attribute }+  deriving (Monoid, Semigroup)++-- | Simple HTML builder type. Defined in terms of 'HtmlT'. Check out+-- that type for instance information.+--+-- Simple use-cases will just use this type. But if you want to+-- transformer over Reader or something, you can go and use 'HtmlT'.+type Html = HtmlT Identity++-- | A monad transformer that generates HTML. Use the simpler 'Html'+-- type if you don't want to transform over some other monad.+newtype HtmlT m a = HtmlT { unHtmlT :: StateT Builder m a }+  deriving (Monad, Functor, Applicative, MonadTrans, MonadFix)++-- | @since 2.9.7+instance MonadReader r m => MonadReader r (HtmlT m) where+  ask = lift ask+  local f (HtmlT a) = HtmlT (local f a)++-- | @since 2.9.7+instance MonadState s m => MonadState s (HtmlT m) where+  get = lift get+  put = lift . put+  state = lift . state++-- | Run the HtmlT transformer.+runHtmlT :: Monad m => HtmlT m a -> m (Builder, a)+runHtmlT = fmap swap . flip runStateT mempty . unHtmlT++-- -- | Switch the underlying monad.+-- hoistHtmlT :: (Monad m, Monad n) => (forall a. m a -> n a) -> HtmlT m b -> HtmlT n b+-- hoistHtmlT f (HtmlT xs) = HtmlT (f xs)++-- | @since 2.9.7+instance (a ~ (),Monad m) => Semigroup (HtmlT m a) where+  (<>) = liftA2 (<>)++-- | Monoid is right-associative, a la the 'Builder' in it.+instance (a ~ (),Monad m) => Monoid (HtmlT m a) where+  mempty  = pure mempty+  mappend = liftA2 mappend++-- | If you want to use IO in your HTML generation.+instance MonadIO m => MonadIO (HtmlT m) where+  liftIO = lift . liftIO++-- | We pack it via string. Could possibly encode straight into a+-- builder. That might be faster.+instance (Monad m,a ~ ()) => IsString (HtmlT m a) where+  fromString = toHtml++-- | Just calls 'renderText'.+instance (m ~ Identity) => Show (HtmlT m a) where+  show = LT.unpack . renderText++-- | Can be converted to HTML.+class ToHtml a where+  -- | Convert to HTML, doing HTML escaping.+  toHtml :: Monad m => a -> HtmlT m ()+  -- | Convert to HTML without any escaping.+  toHtmlRaw :: Monad m => a -> HtmlT m ()++-- | @since 2.9.8+instance (a ~ (), m ~ Identity) => ToHtml (HtmlT m a) where+  toHtml = relaxHtmlT+  toHtmlRaw = relaxHtmlT++instance ToHtml String where+  toHtml    = write . Blaze.fromHtmlEscapedString+  toHtmlRaw = write . Blaze.fromString++instance ToHtml Text where+  toHtml    = write . Blaze.fromHtmlEscapedText+  toHtmlRaw = write . Blaze.fromText++instance ToHtml LT.Text where+  toHtml    = write . Blaze.fromHtmlEscapedLazyText+  toHtmlRaw = write . Blaze.fromLazyText++-- | This instance requires the ByteString to contain UTF-8 encoded+-- text, for the 'toHtml' method. The 'toHtmlRaw' method doesn't care,+-- but the overall HTML rendering methods in this module assume UTF-8.+--+-- @since 2.9.5+instance ToHtml S.ByteString where+  toHtml    = write . Blaze.fromHtmlEscapedText . T.decodeUtf8+  toHtmlRaw = write . Blaze.fromByteString++-- | This instance requires the ByteString to contain UTF-8 encoded+-- text, for the 'toHtml' method. The 'toHtmlRaw' method doesn't care,+-- but the overall HTML rendering methods in this module assume UTF-8.+--+-- @since 2.9.5+instance ToHtml L.ByteString where+  toHtml    = write . Blaze.fromHtmlEscapedLazyText . LT.decodeUtf8+  toHtmlRaw = write . Blaze.fromLazyByteString++-- | Used to construct HTML terms.+--+-- Simplest use: p_ = term "p" yields 'Lucid.Html5.p_'.+--+-- Very overloaded for three cases:+--+-- * The first case is the basic @arg@ of @[(Text,Text)]@ which will+--   return a function that wants children.+-- * The second is an @arg@ which is @HtmlT m ()@, in which case the+--   term accepts no attributes and just the children are used for the+--   element.+-- * Finally, this is also used for overloaded attributes, like+--   `Lucid.Html5.style_` or `Lucid.Html5.title_`. If a return type of @(Text,Text)@ is inferred+--   then an attribute will be made.+--+-- The instances look intimidating but actually the constraints make+-- it very general so that type inference works well even in the+-- presence of things like @OverloadedLists@ and such.+class Term arg result | result -> arg where+  -- | Used for constructing elements e.g. @term "p"@ yields 'Lucid.Html5.p_'.+  term :: Text   -- ^ Name of the element or attribute.+       -> arg    -- ^ Either an attribute list or children.+       -> result -- ^ Result: either an element or an attribute.++-- | Given attributes, expect more child input.+instance (Monad m,f ~ HtmlT m a) => Term [Attributes] (f -> HtmlT m a) where+  term name = makeElement name++-- | Given children immediately, just use that and expect no+-- attributes.+instance (Monad m) => Term (HtmlT m a) (HtmlT m a) where+  term name = makeElement name mempty+  {-# INLINE term #-}++-- | Some terms (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for+-- attributes as well as elements.+instance Term Text Attributes where+  term key value = makeAttributes key value++-- | Same as the 'Term' class, but will not HTML escape its+-- children. Useful for elements like 'Lucid.Html5.style_' or+-- 'Lucid.Html5.script_'.+class TermRaw arg result | result -> arg where+  -- | Used for constructing elements e.g. @termRaw "p"@ yields 'Lucid.Html5.p_'.+  termRaw :: Text   -- ^ Name of the element or attribute.+       -> arg    -- ^ Either an attribute list or children.+       -> result -- ^ Result: either an element or an attribute.++-- | Given attributes, expect more child input.+instance (Monad m,ToHtml f, a ~ ()) => TermRaw [Attributes] (f -> HtmlT m a) where+  termRaw name attrs = makeElement name attrs . toHtmlRaw++-- | Given children immediately, just use that and expect no+-- attributes.+instance (Monad m,a ~ ()) => TermRaw Text (HtmlT m a) where+  termRaw name = makeElement name mempty . toHtmlRaw++-- | Some termRaws (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for+-- attributes as well as elements.+instance TermRaw Text Attributes where+  termRaw key value = makeAttributesRaw key value++--------------------------------------------------------------------------------+-- Running++-- | Render the HTML to a lazy 'ByteString'.+--+-- This is a convenience function defined in terms of 'execHtmlT',+-- 'runIdentity' and 'Blaze.toLazyByteString'. Check the source if+-- you're interested in the lower-level behaviour.+--+renderToFile :: FilePath -> Html a -> IO ()+renderToFile fp = L.writeFile fp . Blaze.toLazyByteString . runIdentity . execHtmlT++-- | Render the HTML to a lazy 'ByteString'.+--+-- This is a convenience function defined in terms of 'execHtmlT',+-- 'runIdentity' and 'Blaze.toLazyByteString'. Check the source if+-- you're interested in the lower-level behaviour.+--+renderBS :: Html a -> ByteString+renderBS = Blaze.toLazyByteString . runIdentity . execHtmlT++-- | Render the HTML to a lazy 'Text'.+--+-- This is a convenience function defined in terms of 'execHtmlT',+-- 'runIdentity' and 'Blaze.toLazyByteString', and+-- 'LT.decodeUtf8'. Check the source if you're interested in the+-- lower-level behaviour.+--+renderText :: Html a -> LT.Text+renderText = LT.decodeUtf8 . Blaze.toLazyByteString . runIdentity . execHtmlT++-- | Render the HTML to a lazy 'ByteString', but in a monad.+--+-- This is a convenience function defined in terms of 'execHtmlT' and+-- 'Blaze.toLazyByteString'. Check the source if you're interested in+-- the lower-level behaviour.+--+renderBST :: Monad m => HtmlT m a -> m ByteString+renderBST = fmap Blaze.toLazyByteString . execHtmlT++-- | Render the HTML to a lazy 'Text', but in a monad.+--+-- This is a convenience function defined in terms of 'execHtmlT' and+-- 'Blaze.toLazyByteString', and 'LT.decodeUtf8'. Check the source if+-- you're interested in the lower-level behaviour.+--+renderTextT :: Monad m => HtmlT m a -> m LT.Text+renderTextT = fmap (LT.decodeUtf8 . Blaze.toLazyByteString) . execHtmlT++--------------------------------------------------------------------------------+-- Running, transformer versions++-- | Build the HTML. Analogous to @execState@.+--+-- You might want to use this is if you want to do something with the+-- raw 'Builder'. Otherwise for simple cases you can just use+-- 'renderText' or 'renderBS'.+execHtmlT :: Monad m+          => HtmlT m a  -- ^ The HTML to generate.+          -> m Builder  -- ^ The @a@ is discarded.+execHtmlT m =+  do (builder,_) <- runHtmlT m+     return builder+{-# inline execHtmlT #-}++-- | Generalize the underlying monad.+--+-- Some builders are happy to deliver results in a pure underlying+-- monad, here 'Identity', but have trouble maintaining the polymorphic+-- type. This utility generalizes from 'Identity'.+--+-- @since 2.9.6+relaxHtmlT :: Monad m+           => HtmlT Identity a  -- ^ The HTML generated purely.+           -> HtmlT m a         -- ^ Same HTML accessible in a polymorphic context.+relaxHtmlT = undefined+-- relaxHtmlT = hoistHtmlT go+--   where+--     go :: Monad m => Identity a -> m a+--     go = return . runIdentity++-- | Commute inner @m@ to the front.+--+-- This is useful when you have impure HTML generation, e.g. using `StateT`.+-- Recall, there is `MonadState s HtmlT` instance.+--+-- @+-- exampleHtml :: MonadState Int m => HtmlT m ()+-- exampleHtml = ul_ $ replicateM_ 5 $ do+--   x <- get+--   put (x + 1)+--   li_ $ toHtml $ show x+--+-- exampleHtml' :: Monad m => HtmlT m ()+-- exampleHtml' = evalState (commuteHtmlT exampleHtml) 1+-- @+--+-- @since 2.9.9+-- commuteHtmlT :: (Functor m, Monad n)+--              => HtmlT m a      -- ^ unpurely generated HTML+--              -> m (HtmlT n a)  -- ^ Commuted monads. /Note:/ @n@ can be 'Identity'+-- commuteHtmlT (HtmlT xs) = fmap (HtmlT . return) xs++-- | Evaluate the HTML to its return value. Analogous to @evalState@.+--+-- Use this if you want to ignore the HTML output of an action+-- completely and just get the result.+--+-- For using with the 'Html' type, you'll need 'runIdentity' e.g.+--+-- >>> runIdentity (evalHtmlT (p_ "Hello!"))+-- ()+--+evalHtmlT :: Monad m+          => HtmlT m a -- ^ HTML monad to evaluate.+          -> m a       -- ^ Ignore the HTML output and just return the value.+evalHtmlT m =+  do (_,a) <- runHtmlT m+     return a++--------------------------------------------------------------------------------+-- Combinators++-- | Make a set of attributes.+makeAttributes :: Text -- ^ Attribute name.+               -> Text -- ^ Attribute value.+               -> Attributes+makeAttributes x y = Attributes (pure (Attribute x (Blaze.fromHtmlEscapedText y)))++-- | Make a set of unescaped attributes.+makeAttributesRaw ::+     Text -- ^ Attribute name.+  -> Text -- ^ Attribute value.+  -> Attributes+makeAttributesRaw x y = Attributes (pure (Attribute x (Blaze.fromText y)))++-- | Make an HTML builder.+makeElement :: Monad m+            => Text       -- ^ Name.+            -> [Attributes]+            -> HtmlT m a  -- ^ Children HTML.+            -> HtmlT m a -- ^ A parent element.+{-# INLINE[1] makeElement #-}+makeElement name attr children = do+  write+    (s "<" <> Blaze.fromText name <> foldlMapWithKey buildAttr (attributeList attr) <> s ">")+  v <- children+  write (s "</" <> Blaze.fromText name <> s ">")+  pure v++-- | Make an HTML builder for elements which have no ending tag.+makeElementNoEnd :: Monad m+                 => Text       -- ^ Name.+                 -> [Attributes]+                 -> HtmlT m () -- ^ A parent element.+makeElementNoEnd name attr =+  write+    (s "<" <> Blaze.fromText name <> foldlMapWithKey buildAttr (attributeList attr) <> s ">")++-- | Build and encode an attribute.+buildAttr :: Text -> Builder -> Builder+buildAttr key val = s " " <> Blaze.fromText key <> s "=\"" <> val <> s "\""++-- | Folding and monoidally appending attributes.+foldlMapWithKey :: (Text -> Builder -> 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.fromListWithKey combineAttributes pairs+    Nothing -> foldMap (\(Attribute k v) -> f k v) attributes+  where+    pairs = map (\(Attribute k v) -> (k,v)) (toList attributes)++-- | Special handling for class and style, which are common things+-- people want to combine.+combineAttributes :: Text -> Builder -> Builder -> Builder+combineAttributes "class" v2 v1 = v1 <> " " <> v2+combineAttributes "style" v2 v1 = v1 <> ";" <> v2+combineAttributes _       v2 v1 = v1 <> v2++-- | 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+s = Blaze.fromString+{-# INLINE s #-}++-- | Write some HTML output.+write :: Monad m => Builder -> HtmlT m ()+write b = HtmlT (modify' (<> b))+{-# inline write #-}++attributeList :: [Attributes] -> Seq Attribute+attributeList = foldMap unAttributes
+ src/Lucid/Html5.hs view
@@ -0,0 +1,1134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS -fno-warn-type-defaults #-}++-- | Html5 terms.++module Lucid.Html5 where++import Lucid.Base++import Data.ByteString+import Data.Text (Text)++-------------------------------------------------------------------------------+-- Elements++-- | @DOCTYPE@ element+--+-- This is implemented as "raw output", because the doctype doesn't+-- accept attributes.+--+doctype_ :: Monad m => HtmlT m ()+doctype_ = toHtmlRaw ("<!DOCTYPE HTML>" :: ByteString)++-- | @DOCTYPE@ element + @html@ element+doctypehtml_ :: Monad m => HtmlT m a -> HtmlT m a+doctypehtml_ m = doctype_ *> html_ m++-- | @a@ element+a_ :: Term arg result => arg -> result+a_ = term "a"++-- | @abbr@ element+abbr_ :: Term arg result => arg -> result+abbr_ = term "abbr"++-- | @address@ element+address_ :: Term arg result => arg -> result+address_ = term "address"++-- | @area@ element+area_ :: Monad m => [Attributes] -> HtmlT m ()+area_ = makeElementNoEnd "area"++-- | @article@ element+article_ :: Term arg result => arg -> result+article_ = term "article"++-- | @aside@ element+aside_ :: Term arg result => arg -> result+aside_ = term "aside"++-- | @audio@ element+audio_ :: Term arg result => arg -> result+audio_ = term "audio"++-- | @b@ element+b_ :: Term arg result => arg -> result+b_ = term "b"++-- | @base@ element+base_ :: Monad m => [Attributes] -> HtmlT m ()+base_ = makeElementNoEnd "base"++-- | @bdo@ element+bdo_ :: Term arg result => arg -> result+bdo_ = term "bdo"++-- | @blockquote@ element+blockquote_ :: Term arg result => arg -> result+blockquote_ = term "blockquote"++-- | @body@ element+body_ :: Term arg result => arg -> result+body_ = term "body"++-- | @br@ element+br_ :: Monad m => [Attributes] -> HtmlT m ()+br_ = makeElementNoEnd "br"++-- | @button@ element+button_ :: Term arg result => arg -> result+button_ = term "button"++-- | @canvas@ element+canvas_ :: Term arg result => arg -> result+canvas_ = term "canvas"++-- | @caption@ element+caption_ :: Term arg result => arg -> result+caption_ = term "caption"++-- | @cite@ element or @cite@ attribute.+cite_ :: Term arg result => arg -> result+cite_ = term "cite"++-- | @code@ element+code_ :: Term arg result => arg -> result+code_ = term "code"++-- | @col@ element+col_ :: Monad m => [Attributes] -> HtmlT m ()+col_ = makeElementNoEnd "col"++-- | @colgroup@ element+colgroup_ :: Term arg result => arg -> result+colgroup_ = term "colgroup"++-- | @command@ element+command_ :: Term arg result => arg -> result+command_ = term "command"++-- | @datalist@ element+datalist_ :: Term arg result => arg -> result+datalist_ = term "datalist"++-- | @dd@ element+dd_ :: Term arg result => arg -> result+dd_ = term "dd"++-- | @del@ element+del_ :: Term arg result => arg -> result+del_ = term "del"++-- | @details@ element+details_ :: Term arg result => arg -> result+details_ = term "details"++-- | @dfn@ element+dfn_ :: Term arg result => arg -> result+dfn_ = term "dfn"++-- | @div@ element+div_ :: Term arg result => arg -> result+div_ = term "div"++-- | @dl@ element+dl_ :: Term arg result => arg -> result+dl_ = term "dl"++-- | @dt@ element+dt_ :: Term arg result => arg -> result+dt_ = term "dt"++-- | @em@ element+em_ :: Term arg result => arg -> result+em_ = term "em"++-- | @embed@ element+embed_ :: Monad m => [Attributes] -> HtmlT m ()+embed_ = makeElementNoEnd "embed"++-- | @fieldset@ element+fieldset_ :: Term arg result => arg -> result+fieldset_ = term "fieldset"++-- | @figcaption@ element+figcaption_ :: Term arg result => arg -> result+figcaption_ = term "figcaption"++-- | @figure@ element+figure_ :: Term arg result => arg -> result+figure_ = term "figure"++-- | @footer@ element+footer_ :: Term arg result => arg -> result+footer_ = term "footer"++-- | @form@ element or @form@ attribute+form_ :: Term arg result => arg -> result+form_ = term "form"++-- | @h1@ element+h1_ :: Term arg result => arg -> result+h1_ = term "h1"++-- | @h2@ element+h2_ :: Term arg result => arg -> result+h2_ = term "h2"++-- | @h3@ element+h3_ :: Term arg result => arg -> result+h3_ = term "h3"++-- | @h4@ element+h4_ :: Term arg result => arg -> result+h4_ = term "h4"++-- | @h5@ element+h5_ :: Term arg result => arg -> result+h5_ = term "h5"++-- | @h6@ element+h6_ :: Term arg result => arg -> result+h6_ = term "h6"++-- | @head@ element+head_ :: Term arg result => arg -> result+head_ = term "head"++-- | @header@ element+header_ :: Term arg result => arg -> result+header_ = term "header"++-- | @hgroup@ element+hgroup_ :: Term arg result => arg -> result+hgroup_ = term "hgroup"++-- | @hr@ element+hr_ :: Monad m => [Attributes] -> HtmlT m ()+hr_ = makeElementNoEnd "hr"++-- | @html@ element+html_ :: Term arg result => arg -> result+html_ = term "html"++-- | @i@ element+i_ :: Term arg result => arg -> result+i_ = term "i"++-- | @iframe@ element+iframe_ :: Term arg result => arg -> result+iframe_ = term "iframe"++-- | @img@ element+img_ :: Monad m => [Attributes] -> HtmlT m ()+img_ = makeElementNoEnd "img"++-- | @input@ element+input_ :: Monad m => [Attributes] -> HtmlT m ()+input_ = makeElementNoEnd "input"++-- | @ins@ element+ins_ :: Term arg result => arg -> result+ins_ = term "ins"++-- | @kbd@ element+kbd_ :: Term arg result => arg -> result+kbd_ = term "kbd"++-- | @keygen@ element+keygen_ :: Monad m => [Attributes] -> HtmlT m ()+keygen_ = makeElementNoEnd "keygen"++-- | @label@ element or @label@ attribute+label_ :: Term arg result => arg -> result+label_ = term "label"++-- | @legend@ element+legend_ :: Term arg result => arg -> result+legend_ = term "legend"++-- | @li@ element+li_ :: Term arg result => arg -> result+li_ = term "li"++-- | @link@ element+link_ :: Monad m => [Attributes] -> HtmlT m ()+link_ = makeElementNoEnd "link"++-- | @map@ element+map_ :: Term arg result => arg -> result+map_ = term "map"++-- | @main@ element+main_ :: Term arg result => arg -> result+main_ = term "main"++-- | @mark@ element+mark_ :: Term arg result => arg -> result+mark_ = term "mark"++-- | @menu@ element+menu_ :: Term arg result => arg -> result+menu_ = term "menu"++-- | @menuitem@ element+menuitem_ :: Monad m => [Attributes] -> HtmlT m ()+menuitem_ = makeElementNoEnd "menuitem"++-- | @meta@ element+meta_ :: Monad m => [Attributes] -> HtmlT m ()+meta_ = makeElementNoEnd "meta"++-- | @meter@ element+meter_ :: Term arg result => arg -> result+meter_ = term "meter"++-- | @nav@ element+nav_ :: Term arg result => arg -> result+nav_ = term "nav"++-- | @noscript@ element+noscript_ :: Term arg result => arg -> result+noscript_ = term "noscript"++-- | @object@ element+object_ :: Term arg result => arg -> result+object_ = term "object"++-- | @ol@ element+ol_ :: Term arg result => arg -> result+ol_ = term "ol"++-- | @optgroup@ element+optgroup_ :: Term arg result => arg -> result+optgroup_ = term "optgroup"++-- | @option@ element+option_ :: Term arg result => arg -> result+option_ = term "option"++-- | @output@ element+output_ :: Term arg result => arg -> result+output_ = term "output"++-- | @p@ element+p_ :: Term arg result => arg -> result+p_ = term "p"++-- | @param@ element+param_ :: Monad m => [Attributes] -> HtmlT m ()+param_ = makeElementNoEnd "param"++-- | The @svg@ attribute.+svg_ :: Term arg result => arg -> result+svg_ = term "svg"++-- | @pre@ element+pre_ :: Term arg result => arg -> result+pre_ = term "pre"++-- | @progress@ element+progress_ :: Term arg result => arg -> result+progress_ = term "progress"++-- | @q@ element+q_ :: Term arg result => arg -> result+q_ = term "q"++-- | @rp@ element+rp_ :: Term arg result => arg -> result+rp_ = term "rp"++-- | @rt@ element+rt_ :: Term arg result => arg -> result+rt_ = term "rt"++-- | @ruby@ element+ruby_ :: Term arg result => arg -> result+ruby_ = term "ruby"++-- | @samp@ element+samp_ :: Term arg result => arg -> result+samp_ = term "samp"++-- | @script@ element+script_ :: TermRaw arg result => arg -> result+script_ = termRaw "script"++-- | @section@ element+section_ :: Term arg result => arg -> result+section_ = term "section"++-- | @select@ element+select_ :: Term arg result => arg -> result+select_ = term "select"++-- | @small@ element+small_ :: Term arg result => arg -> result+small_ = term "small"++-- | @source@ element+source_ :: Monad m => [Attributes] -> HtmlT m ()+source_ = makeElementNoEnd "source"++-- | @span@ element or @span@ attribute+span_ :: Term arg result => arg -> result+span_ = term "span"++-- | @strong@ element+strong_ :: Term arg result => arg -> result+strong_ = term "strong"++-- | @style@ element or @style@ attribute+style_ :: TermRaw arg result => arg -> result+style_ = termRaw "style"++-- | @sub@ element+sub_ :: Term arg result => arg -> result+sub_ = term "sub"++-- | @summary@ element or @summary@ attribute+summary_ :: Term arg result => arg -> result+summary_ = term "summary"++-- | @sup@ element+sup_ :: Term arg result => arg -> result+sup_ = term "sup"++-- | @table@ element+table_ :: Term arg result => arg -> result+table_ = term "table"++-- | @tbody@ element+tbody_ :: Term arg result => arg -> result+tbody_ = term "tbody"++-- | @td@ element+td_ :: Term arg result => arg -> result+td_ = term "td"++-- | @textarea@ element+textarea_ :: Term arg result => arg -> result+textarea_ = term "textarea"++-- | @tfoot@ element+tfoot_ :: Term arg result => arg -> result+tfoot_ = term "tfoot"++-- | @th@ element+th_ :: Term arg result => arg -> result+th_ = term "th"++-- | @template@ element+template_ :: Term arg result => arg -> result+template_ = term "template"++-- | @thead@ element+thead_ :: Term arg result => arg -> result+thead_ = term "thead"++-- | @time@ element+time_ :: Term arg result => arg -> result+time_ = term "time"++-- | @title@ element or @title@ attribute+title_ :: Term arg result => arg -> result+title_ = term "title"++-- | @tr@ element+tr_ :: Term arg result => arg -> result+tr_ = term "tr"++-- | @track@ element+track_ :: Monad m => [Attributes] -> HtmlT m ()+track_ = makeElementNoEnd "track"++-- | @ul@ element+ul_ :: Term arg result => arg -> result+ul_ = term "ul"++-- | @var@ element+var_ :: Term arg result => arg -> result+var_ = term "var"++-- | @video@ element+video_ :: Term arg result => arg -> result+video_ = term "video"++-- | @wbr@ element+wbr_ :: Monad m => [Attributes] -> HtmlT m ()+wbr_ = makeElementNoEnd "wbr"++-------------------------------------------------------------------------------+-- Attributes++-- | The @accept@ attribute.+accept_ :: Text -> Attributes+accept_ = makeAttributes "accept"++-- | The @acceptCharset@ attribute.+acceptCharset_ :: Text -> Attributes+acceptCharset_ = makeAttributes "accept-charset"++-- | The @accesskey@ attribute.+accesskey_ :: Text -> Attributes+accesskey_ = makeAttributes "accesskey"++-- | The @action@ attribute.+action_ :: Text -> Attributes+action_ = makeAttributes "action"++-- | The @alt@ attribute.+alt_ :: Text -> Attributes+alt_ = makeAttributes "alt"++-- | The @async@ attribute.+async_ :: Text -> Attributes+async_ = makeAttributes "async"++-- | The @autocomplete@ attribute.+autocomplete_ :: Text -> Attributes+autocomplete_ = makeAttributes "autocomplete"++-- | The @autofocus@ attribute.+autofocus_ :: Attributes+autofocus_ = makeAttributes "autofocus" mempty++-- | The @autoplay@ attribute.+autoplay_ :: Text -> Attributes+autoplay_ = makeAttributes "autoplay"++-- | The @challenge@ attribute.+challenge_ :: Text -> Attributes+challenge_ = makeAttributes "challenge"++-- | The @charset@ attribute.+charset_ :: Text -> Attributes+charset_ = makeAttributes "charset"++-- | The @checked@ attribute.+checked_ :: Attributes+checked_ = makeAttributes "checked" mempty++-- | The @class@ attribute.+class_ :: Text -> Attributes+class_ = makeAttributes "class"++-- | The @cols@ attribute.+cols_ :: Text -> Attributes+cols_ = makeAttributes "cols"++-- | The @colspan@ attribute.+colspan_ :: Text -> Attributes+colspan_ = makeAttributes "colspan"++-- | The @content@ attribute.+content_ :: Text -> Attributes+content_ = makeAttributes "content"++-- | The @contenteditable@ attribute.+contenteditable_ :: Text -> Attributes+contenteditable_ = makeAttributes "contenteditable"++-- | The @contextmenu@ attribute.+contextmenu_ :: Text -> Attributes+contextmenu_ = makeAttributes "contextmenu"++-- | The @controls@ attribute.+controls_ :: Text -> Attributes+controls_ = makeAttributes "controls"++-- | The @coords@ attribute.+coords_ :: Text -> Attributes+coords_ = makeAttributes "coords"++-- | The @crossorigin@ attribute.+--+-- @since 2.9.8+crossorigin_ :: Text -> Attributes+crossorigin_ = makeAttributes "crossorigin"++-- | The @data@ attribute.+data_ :: Text -> Text -> Attributes+data_ name = makeAttributes ("data-" <> name)++-- | The @datetime@ attribute.+datetime_ :: Text -> Attributes+datetime_ = makeAttributes "datetime"++-- | The @defer@ attribute.+defer_ :: Text -> Attributes+defer_ = makeAttributes "defer"++-- | The @dir@ attribute.+dir_ :: Text -> Attributes+dir_ = makeAttributes "dir"++-- | The @disabled@ attribute.+disabled_ :: Text -> Attributes+disabled_ = makeAttributes "disabled"++-- | The @download@ attribute.+download_ :: Text -> Attributes+download_ = makeAttributes "download"++-- | The @draggable@ attribute.+draggable_ :: Text -> Attributes+draggable_ = makeAttributes "draggable"++-- | The @enctype@ attribute.+enctype_ :: Text -> Attributes+enctype_ = makeAttributes "enctype"++-- | The @for@ attribute.+for_ :: Text -> Attributes+for_ = makeAttributes "for"++-- | The @formaction@ attribute.+formaction_ :: Text -> Attributes+formaction_ = makeAttributes "formaction"++-- | The @formenctype@ attribute.+formenctype_ :: Text -> Attributes+formenctype_ = makeAttributes "formenctype"++-- | The @formmethod@ attribute.+formmethod_ :: Text -> Attributes+formmethod_ = makeAttributes "formmethod"++-- | The @formnovalidate@ attribute.+formnovalidate_ :: Text -> Attributes+formnovalidate_ = makeAttributes "formnovalidate"++-- | The @formtarget@ attribute.+formtarget_ :: Text -> Attributes+formtarget_ = makeAttributes "formtarget"++-- | The @headers@ attribute.+headers_ :: Text -> Attributes+headers_ = makeAttributes "headers"++-- | The @height@ attribute.+height_ :: Text -> Attributes+height_ = makeAttributes "height"++-- | The @hidden@ attribute.+hidden_ :: Text -> Attributes+hidden_ = makeAttributes "hidden"++-- | The @high@ attribute.+high_ :: Text -> Attributes+high_ = makeAttributes "high"++-- | The @href@ attribute.+href_ :: Text -> Attributes+href_ = makeAttributes "href"++-- | The @hreflang@ attribute.+hreflang_ :: Text -> Attributes+hreflang_ = makeAttributes "hreflang"++-- | The @httpEquiv@ attribute.+httpEquiv_ :: Text -> Attributes+httpEquiv_ = makeAttributes "http-equiv"++-- | The @icon@ attribute.+icon_ :: Text -> Attributes+icon_ = makeAttributes "icon"++-- | The @id@ attribute.+id_ :: Text -> Attributes+id_ = makeAttributes "id"++-- | The @integrity@ attribute.+--+-- @since 2.9.8+integrity_ :: Text -> Attributes+integrity_ = makeAttributes "integrity"++-- | The @ismap@ attribute.+ismap_ :: Text -> Attributes+ismap_ = makeAttributes "ismap"++-- | The @item@ attribute.+item_ :: Text -> Attributes+item_ = makeAttributes "item"++-- | The @itemprop@ attribute.+itemprop_ :: Text -> Attributes+itemprop_ = makeAttributes "itemprop"++-- | The @keytype@ attribute.+keytype_ :: Text -> Attributes+keytype_ = makeAttributes "keytype"++-- | The @lang@ attribute.+lang_ :: Text -> Attributes+lang_ = makeAttributes "lang"++-- | The @list@ attribute.+list_ :: Text -> Attributes+list_ = makeAttributes "list"++-- | The @loading@ attribute.+loading_ :: Text -> Attributes+loading_ = makeAttributes "loading"++-- | The @loop@ attribute.+loop_ :: Text -> Attributes+loop_ = makeAttributes "loop"++-- | The @low@ attribute.+low_ :: Text -> Attributes+low_ = makeAttributes "low"++-- | The @manifest@ attribute.+manifest_ :: Text -> Attributes+manifest_ = makeAttributes "manifest"++-- | The @max@ attribute.+max_ :: Text -> Attributes+max_ = makeAttributes "max"++-- | The @maxlength@ attribute.+maxlength_ :: Text -> Attributes+maxlength_ = makeAttributes "maxlength"++-- | The @media@ attribute.+media_ :: Text -> Attributes+media_ = makeAttributes "media"++-- | The @method@ attribute.+method_ :: Text -> Attributes+method_ = makeAttributes "method"++-- | The @min@ attribute.+min_ :: Text -> Attributes+min_ = makeAttributes "min"++-- | The @minlength@ attribute.+minlength_ :: Text -> Attributes+minlength_ = makeAttributes "minlength"++-- | The @multiple@ attribute.+multiple_ :: Text -> Attributes+multiple_ = makeAttributes "multiple"++-- | The @name@ attribute.+name_ :: Text -> Attributes+name_ = makeAttributes "name"++-- | The @novalidate@ attribute.+novalidate_ :: Text -> Attributes+novalidate_ = makeAttributes "novalidate"++-- | The @onbeforeonload@ attribute.+onbeforeonload_ :: Text -> Attributes+onbeforeonload_ = makeAttributesRaw "onbeforeonload"++-- | The @onbeforeprint@ attribute.+onbeforeprint_ :: Text -> Attributes+onbeforeprint_ = makeAttributesRaw "onbeforeprint"++-- | The @onblur@ attribute.+onblur_ :: Text -> Attributes+onblur_ = makeAttributesRaw "onblur"++-- | The @oncanplay@ attribute.+oncanplay_ :: Text -> Attributes+oncanplay_ = makeAttributesRaw "oncanplay"++-- | The @oncanplaythrough@ attribute.+oncanplaythrough_ :: Text -> Attributes+oncanplaythrough_ = makeAttributesRaw "oncanplaythrough"++-- | The @onchange@ attribute.+onchange_ :: Text -> Attributes+onchange_ = makeAttributesRaw "onchange"++-- | The @onclick@ attribute.+onclick_ :: Text -> Attributes+onclick_ = makeAttributesRaw "onclick"++-- | The @oncontextmenu@ attribute.+oncontextmenu_ :: Text -> Attributes+oncontextmenu_ = makeAttributesRaw "oncontextmenu"++-- | The @ondblclick@ attribute.+ondblclick_ :: Text -> Attributes+ondblclick_ = makeAttributesRaw "ondblclick"++-- | The @ondrag@ attribute.+ondrag_ :: Text -> Attributes+ondrag_ = makeAttributesRaw "ondrag"++-- | The @ondragend@ attribute.+ondragend_ :: Text -> Attributes+ondragend_ = makeAttributesRaw "ondragend"++-- | The @ondragenter@ attribute.+ondragenter_ :: Text -> Attributes+ondragenter_ = makeAttributesRaw "ondragenter"++-- | The @ondragleave@ attribute.+ondragleave_ :: Text -> Attributes+ondragleave_ = makeAttributesRaw "ondragleave"++-- | The @ondragover@ attribute.+ondragover_ :: Text -> Attributes+ondragover_ = makeAttributesRaw "ondragover"++-- | The @ondragstart@ attribute.+ondragstart_ :: Text -> Attributes+ondragstart_ = makeAttributesRaw "ondragstart"++-- | The @ondrop@ attribute.+ondrop_ :: Text -> Attributes+ondrop_ = makeAttributesRaw "ondrop"++-- | The @ondurationchange@ attribute.+ondurationchange_ :: Text -> Attributes+ondurationchange_ = makeAttributesRaw "ondurationchange"++-- | The @onemptied@ attribute.+onemptied_ :: Text -> Attributes+onemptied_ = makeAttributesRaw "onemptied"++-- | The @onended@ attribute.+onended_ :: Text -> Attributes+onended_ = makeAttributesRaw "onended"++-- | The @onerror@ attribute.+onerror_ :: Text -> Attributes+onerror_ = makeAttributesRaw "onerror"++-- | The @onfocus@ attribute.+onfocus_ :: Text -> Attributes+onfocus_ = makeAttributesRaw "onfocus"++-- | The @onformchange@ attribute.+onformchange_ :: Text -> Attributes+onformchange_ = makeAttributesRaw "onformchange"++-- | The @onforminput@ attribute.+onforminput_ :: Text -> Attributes+onforminput_ = makeAttributesRaw "onforminput"++-- | The @onhaschange@ attribute.+onhaschange_ :: Text -> Attributes+onhaschange_ = makeAttributesRaw "onhaschange"++-- | The @oninput@ attribute.+oninput_ :: Text -> Attributes+oninput_ = makeAttributesRaw "oninput"++-- | The @oninvalid@ attribute.+oninvalid_ :: Text -> Attributes+oninvalid_ = makeAttributesRaw "oninvalid"++-- | The @onkeydown@ attribute.+onkeydown_ :: Text -> Attributes+onkeydown_ = makeAttributesRaw "onkeydown"++-- | The @onkeyup@ attribute.+onkeyup_ :: Text -> Attributes+onkeyup_ = makeAttributesRaw "onkeyup"++-- | The @onload@ attribute.+onload_ :: Text -> Attributes+onload_ = makeAttributesRaw "onload"++-- | The @onloadeddata@ attribute.+onloadeddata_ :: Text -> Attributes+onloadeddata_ = makeAttributesRaw "onloadeddata"++-- | The @onloadedmetadata@ attribute.+onloadedmetadata_ :: Text -> Attributes+onloadedmetadata_ = makeAttributesRaw "onloadedmetadata"++-- | The @onloadstart@ attribute.+onloadstart_ :: Text -> Attributes+onloadstart_ = makeAttributesRaw "onloadstart"++-- | The @onmessage@ attribute.+onmessage_ :: Text -> Attributes+onmessage_ = makeAttributesRaw "onmessage"++-- | The @onmousedown@ attribute.+onmousedown_ :: Text -> Attributes+onmousedown_ = makeAttributesRaw "onmousedown"++-- | The @onmousemove@ attribute.+onmousemove_ :: Text -> Attributes+onmousemove_ = makeAttributesRaw "onmousemove"++-- | The @onmouseout@ attribute.+onmouseout_ :: Text -> Attributes+onmouseout_ = makeAttributesRaw "onmouseout"++-- | The @onmouseover@ attribute.+onmouseover_ :: Text -> Attributes+onmouseover_ = makeAttributesRaw "onmouseover"++-- | The @onmouseup@ attribute.+onmouseup_ :: Text -> Attributes+onmouseup_ = makeAttributesRaw "onmouseup"++-- | The @onmousewheel@ attribute.+onmousewheel_ :: Text -> Attributes+onmousewheel_ = makeAttributesRaw "onmousewheel"++-- | The @ononline@ attribute.+ononline_ :: Text -> Attributes+ononline_ = makeAttributesRaw "ononline"++-- | The @onpagehide@ attribute.+onpagehide_ :: Text -> Attributes+onpagehide_ = makeAttributesRaw "onpagehide"++-- | The @onpageshow@ attribute.+onpageshow_ :: Text -> Attributes+onpageshow_ = makeAttributesRaw "onpageshow"++-- | The @onpause@ attribute.+onpause_ :: Text -> Attributes+onpause_ = makeAttributesRaw "onpause"++-- | The @onplay@ attribute.+onplay_ :: Text -> Attributes+onplay_ = makeAttributesRaw "onplay"++-- | The @onplaying@ attribute.+onplaying_ :: Text -> Attributes+onplaying_ = makeAttributesRaw "onplaying"++-- | The @onprogress@ attribute.+onprogress_ :: Text -> Attributes+onprogress_ = makeAttributesRaw "onprogress"++-- | The @onpropstate@ attribute.+onpropstate_ :: Text -> Attributes+onpropstate_ = makeAttributesRaw "onpropstate"++-- | The @onratechange@ attribute.+onratechange_ :: Text -> Attributes+onratechange_ = makeAttributesRaw "onratechange"++-- | The @onreadystatechange@ attribute.+onreadystatechange_ :: Text -> Attributes+onreadystatechange_ = makeAttributesRaw "onreadystatechange"++-- | The @onredo@ attribute.+onredo_ :: Text -> Attributes+onredo_ = makeAttributesRaw "onredo"++-- | The @onresize@ attribute.+onresize_ :: Text -> Attributes+onresize_ = makeAttributesRaw "onresize"++-- | The @onscroll@ attribute.+onscroll_ :: Text -> Attributes+onscroll_ = makeAttributesRaw "onscroll"++-- | The @onseeked@ attribute.+onseeked_ :: Text -> Attributes+onseeked_ = makeAttributesRaw "onseeked"++-- | The @onseeking@ attribute.+onseeking_ :: Text -> Attributes+onseeking_ = makeAttributesRaw "onseeking"++-- | The @onselect@ attribute.+onselect_ :: Text -> Attributes+onselect_ = makeAttributesRaw "onselect"++-- | The @onstalled@ attribute.+onstalled_ :: Text -> Attributes+onstalled_ = makeAttributesRaw "onstalled"++-- | The @onstorage@ attribute.+onstorage_ :: Text -> Attributes+onstorage_ = makeAttributesRaw "onstorage"++-- | The @onsubmit@ attribute.+onsubmit_ :: Text -> Attributes+onsubmit_ = makeAttributesRaw "onsubmit"++-- | The @onsuspend@ attribute.+onsuspend_ :: Text -> Attributes+onsuspend_ = makeAttributesRaw "onsuspend"++-- | The @ontimeupdate@ attribute.+ontimeupdate_ :: Text -> Attributes+ontimeupdate_ = makeAttributesRaw "ontimeupdate"++-- | The @onundo@ attribute.+onundo_ :: Text -> Attributes+onundo_ = makeAttributesRaw "onundo"++-- | The @onunload@ attribute.+onunload_ :: Text -> Attributes+onunload_ = makeAttributesRaw "onunload"++-- | The @onvolumechange@ attribute.+onvolumechange_ :: Text -> Attributes+onvolumechange_ = makeAttributesRaw "onvolumechange"++-- | The @onwaiting@ attribute.+onwaiting_ :: Text -> Attributes+onwaiting_ = makeAttributesRaw "onwaiting"++-- | The @open@ attribute.+open_ :: Text -> Attributes+open_ = makeAttributes "open"++-- | The @optimum@ attribute.+optimum_ :: Text -> Attributes+optimum_ = makeAttributes "optimum"++-- | The @pattern@ attribute.+pattern_ :: Text -> Attributes+pattern_ = makeAttributes "pattern"++-- | The @ping@ attribute.+ping_ :: Text -> Attributes+ping_ = makeAttributes "ping"++-- | The @placeholder@ attribute.+placeholder_ :: Text -> Attributes+placeholder_ = makeAttributes "placeholder"++-- | The @poster@ attribute.+poster_ :: Text -> Attributes+poster_ = makeAttributes "poster"++-- | The @preload@ attribute.+preload_ :: Text -> Attributes+preload_ = makeAttributes "preload"++-- | The @pubdate@ attribute.+pubdate_ :: Text -> Attributes+pubdate_ = makeAttributes "pubdate"++-- | The @radiogroup@ attribute.+radiogroup_ :: Text -> Attributes+radiogroup_ = makeAttributes "radiogroup"++-- | The @readonly@ attribute.+readonly_ :: Text -> Attributes+readonly_ = makeAttributes "readonly"++-- | The @rel@ attribute.+rel_ :: Text -> Attributes+rel_ = makeAttributes "rel"++-- | The @required@ attribute.+required_ :: Text -> Attributes+required_ = makeAttributes "required"++-- | The @reversed@ attribute.+reversed_ :: Text -> Attributes+reversed_ = makeAttributes "reversed"++-- | The @role@ attribute.+role_ :: Text -> Attributes+role_ = makeAttributes "role"++-- | The @rows@ attribute.+rows_ :: Text -> Attributes+rows_ = makeAttributes "rows"++-- | The @rowspan@ attribute.+rowspan_ :: Text -> Attributes+rowspan_ = makeAttributes "rowspan"++-- | The @sandbox@ attribute.+sandbox_ :: Text -> Attributes+sandbox_ = makeAttributes "sandbox"++-- | The @scope@ attribute.+scope_ :: Text -> Attributes+scope_ = makeAttributes "scope"++-- | The @scoped@ attribute.+scoped_ :: Text -> Attributes+scoped_ = makeAttributes "scoped"++-- | The @seamless@ attribute.+seamless_ :: Text -> Attributes+seamless_ = makeAttributes "seamless"++-- | The @selected@ attribute.+selected_ :: Text -> Attributes+selected_ = makeAttributes "selected"++-- | The @shape@ attribute.+shape_ :: Text -> Attributes+shape_ = makeAttributes "shape"++-- | The @size@ attribute.+size_ :: Text -> Attributes+size_ = makeAttributes "size"++-- | The @sizes@ attribute.+sizes_ :: Text -> Attributes+sizes_ = makeAttributes "sizes"++-- | The @spellcheck@ attribute.+spellcheck_ :: Text -> Attributes+spellcheck_ = makeAttributes "spellcheck"++-- | The @src@ attribute.+src_ :: Text -> Attributes+src_ = makeAttributes "src"++-- | The @srcdoc@ attribute.+srcdoc_ :: Text -> Attributes+srcdoc_ = makeAttributes "srcdoc"++-- | The @start@ attribute.+start_ :: Text -> Attributes+start_ = makeAttributes "start"++-- | The @step@ attribute.+step_ :: Text -> Attributes+step_ = makeAttributes "step"++-- | The @subject@ attribute.+subject_ :: Text -> Attributes+subject_ = makeAttributes "subject"++-- | The @tabindex@ attribute.+tabindex_ :: Text -> Attributes+tabindex_ = makeAttributes "tabindex"++-- | The @target@ attribute.+target_ :: Text -> Attributes+target_ = makeAttributes "target"++-- | The @type@ attribute.+type_ :: Text -> Attributes+type_ = makeAttributes "type"++-- | The @usemap@ attribute.+usemap_ :: Text -> Attributes+usemap_ = makeAttributes "usemap"++-- | The @value@ attribute.+value_ :: Text -> Attributes+value_ = makeAttributes "value"++-- | The @width@ attribute.+width_ :: Text -> Attributes+width_ = makeAttributes "width"++-- | The @wrap@ attribute.+wrap_ :: Text -> Attributes+wrap_ = makeAttributes "wrap"++-- | The @xmlns@ attribute.+xmlns_ :: Text -> Attributes+xmlns_ = makeAttributes "xmlns"
+ test/Main.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ExtendedDefaultRules #-}++-- | Test suite for Lucid.++module Main where++import Lucid+import Lucid.Base++import Control.Applicative+import Control.Monad.State.Strict++import qualified Data.Text as T++import Test.HUnit+import Test.Hspec++-- | Test suite entry point, returns exit failure if any test fails.+main :: IO ()+main = hspec spec++-- | Test suite.+spec :: Spec+spec = do+  describe "text" testText+  describe "elements" testElements+  describe "attributes" testAttributes+  describe "special-elements" testSpecials+  describe "self-closing" testSelfClosing++(==?*) :: (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 =+  do it "simple"+        (renderText "foo" `shouldBe`+         "foo")+     it "escaping"+        (renderText "'<>" `shouldBe`+         "&#39;&lt;&gt;")+     it "unicode"+        (renderText "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381" `shouldBe`+         "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381")++-- | Test basic elements and nesting.+testElements :: Spec+testElements =+  do it "simple"+        (renderText (p_ "foo") `shouldBe`+         "<p>foo</p>")+     it "escaping"+        (renderText (p_ "'<>") `shouldBe`+         "<p>&#39;&lt;&gt;</p>")+     it "unicode"+        (renderText (p_ "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381") `shouldBe`+         ("<p>fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381</p>"))+     it "nesting"+        (renderText (p_ (p_ "Hello!")) `shouldBe`+         "<p><p>Hello!</p></p>")+     it "empty"+        (renderText (p_ (p_ "")) `shouldBe`+         "<p><p></p></p>")+     it "mixed"+        (renderText (p_ (style_ "")) `shouldBe`+         "<p><style></style></p>")+     it "no closing"+        (renderText (p_ (input_ [])) `shouldBe`+         "<p><input></p>")++-- | Test that attribute assigning works properly.+testAttributes :: Spec+testAttributes =+  do it "simple"+        (renderText (p_ [class_ "foo"] "foo") `shouldBe`+         "<p class=\"foo\">foo</p>")+     it "simple raw"+        (renderText (p_ [style_ "background-image: url('foo')"] "foo") `shouldBe`+         "<p style=\"background-image: url('foo')\">foo</p>")+     it "simple raw (href)"+        (renderText (p_ [onclick_ "window.location.href='asdf';"] "foo") `shouldBe`+         "<p onclick=\"window.location.href='asdf';\">foo</p>")+     it "duplicates (class)"+        (renderText (p_ [class_ "foo", class_ "bar"] "foo") `shouldBe`+         "<p class=\"foo bar\">foo</p>")+     it "duplicates (id)"+        (renderText (p_ [id_ "foo", id_ "bar"] "foo") `shouldBe`+         "<p id=\"foobar\">foo</p>")+     it "duplicates (style)"+        (renderText (p_ [style_ "foo", style_ "bar"] "foo") `shouldBe`+         "<p style=\"foo;bar\">foo</p>")+     it "escaping"+        (renderText (p_ [class_ "foo"] "'<>") `shouldBe`+         "<p class=\"foo\">&#39;&lt;&gt;</p>")+     it "unicode"+        (renderText+           (p_ [class_ "foo"]+               "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381") `shouldBe`+         ("<p class=\"foo\">fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381</p>"))+     it "nesting"+        (renderText+           (p_ [class_ "foo"]+               (p_ "Hello!")) `shouldBe`+         "<p class=\"foo\"><p>Hello!</p></p>")+     it "empty"+        (renderText+           (p_ [class_ "foo"]+               (p_ "")) `shouldBe`+         "<p class=\"foo\"><p></p></p>")+     it "mixed" $+        renderText+           (p_ [class_ "foo",style_ "attrib"]+               (do style_ ""+                   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_ [])) `shouldBe`+         "<p class=\"foo\"><input></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") `shouldBe`+         "<p class=\"foo&lt;&gt;\">foo</p>")++-- | Test special elements that do something different to normal+-- elements.+testSpecials :: Spec+testSpecials =+  do it "script"+        (renderText (script_ "alert('Hello, World!')") `shouldBe`+         "<script>alert('Hello, World!')</script>")+     it "style"+        (renderText (style_ "body{background:url('Hello, World!')}") `shouldBe`+         "<style>body{background:url('Hello, World!')}</style>")++-- | Elements which do not contain children.+testSelfClosing :: Spec+testSelfClosing =+  do it "br" (renderText (br_ []) `shouldBe` "<br>")+     it "hr" (renderText (hr_ []) `shouldBe` "<hr>")+     it "input"+        (renderText (input_ []) `shouldBe`+         "<input>")+     it "input"+        (renderText (input_ [type_ "text"]) `shouldBe`+         "<input type=\"text\">")