diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 < 456 +``` + +Elements nest by function application: + +``` haskell +λ> table_ (tr_ (td_ (p_ "Hello, World!"))) :: Html () +``` + +``` html +

Hello, World!

+``` + +Elements are juxtaposed via monoidal append: + +``` haskell +λ> p_ "hello" <> p_ "sup" :: Html () +``` + +``` html +

hello

sup

+``` + +Or monadic sequencing: + +``` haskell +λ> div_ (do p_ "hello"; p_ "sup") :: Html () +``` + +``` html +

hello

sup

+``` + +Attributes are set by providing an argument list: + +``` haskell +λ> p_ [class_ "brand"] "Lucid Inc" :: Html () +``` + +``` html +

Lucid Inc

+``` + +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 + + + + + +
+

Hello, attributes!

+ 		yay!
+``` + +## Rendering + +For proper rendering you can easily run some HTML immediately with: + +``` haskell +λ> renderText (p_ "Hello!") +``` + +``` html +"

Hello!

" +``` + +Or to bytes: + +``` haskell +λ> renderBS (p_ [style_ "color:red"] "Hello!") +``` + +``` html +"

Hello!

" +``` + +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 +"

Chris

" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lucid2.cabal b/lucid2.cabal new file mode 100644 --- /dev/null +++ b/lucid2.cabal @@ -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 + . + 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 diff --git a/src/Lucid.hs b/src/Lucid.hs new file mode 100644 --- /dev/null +++ b/src/Lucid.hs @@ -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 +-- +-- 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 < 456 +-- +-- Except some elements, like 'script_': +-- +-- >>> script_ "alert('Hello!' > 12)" :: Html () +-- +-- +-- Elements nest by function application: +-- +-- >>> table_ (tr_ (td_ (p_ "Hello, World!"))) :: Html () +--

Hello, World!

+-- +-- Elements are juxtaposed via monoidal append (remember to import "Data.Monoid"): +-- +-- >>> p_ "hello" <> p_ "sup" :: Html () +--

hello

sup

+-- +-- Or monadic sequencing: +-- +-- >>> div_ (do p_ "hello"; p_ "sup") :: Html () +--

hello

sup

+-- +-- Attributes are set by providing an argument list: +-- +-- >>> p_ [class_ "brand"] "Lucid Inc" :: Html () +--

Lucid Inc

+-- +-- >>> p_ [data_ "zot" "foo",checked_] "Go!" :: Html () +--

go

+-- +-- Attribute and element terms are not conflicting: +-- +-- >>> style_ [style_ "inception"] "Go deeper." :: Html () +-- +-- +-- 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!") +-- > "

Hello!

" +-- +-- >>> renderBS (p_ [style_ "color:red"] "Hello!") +-- "

Hello!

" +-- +-- 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". diff --git a/src/Lucid/Base.hs b/src/Lucid/Base.hs new file mode 100644 --- /dev/null +++ b/src/Lucid/Base.hs @@ -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 diff --git a/src/Lucid/Html5.hs b/src/Lucid/Html5.hs new file mode 100644 --- /dev/null +++ b/src/Lucid/Html5.hs @@ -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 ("" :: 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" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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` + "'<>") + 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` + "

foo

") + it "escaping" + (renderText (p_ "'<>") `shouldBe` + "

'<>

") + it "unicode" + (renderText (p_ "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

")) + it "nesting" + (renderText (p_ (p_ "Hello!")) `shouldBe` + "

Hello!

") + it "empty" + (renderText (p_ (p_ "")) `shouldBe` + "

") + it "mixed" + (renderText (p_ (style_ "")) `shouldBe` + "

") + it "no closing" + (renderText (p_ (input_ [])) `shouldBe` + "

") + +-- | Test that attribute assigning works properly. +testAttributes :: Spec +testAttributes = + do it "simple" + (renderText (p_ [class_ "foo"] "foo") `shouldBe` + "

foo

") + it "simple raw" + (renderText (p_ [style_ "background-image: url('foo')"] "foo") `shouldBe` + "

foo

") + it "simple raw (href)" + (renderText (p_ [onclick_ "window.location.href='asdf';"] "foo") `shouldBe` + "

foo

") + it "duplicates (class)" + (renderText (p_ [class_ "foo", class_ "bar"] "foo") `shouldBe` + "

foo

") + it "duplicates (id)" + (renderText (p_ [id_ "foo", id_ "bar"] "foo") `shouldBe` + "

foo

") + it "duplicates (style)" + (renderText (p_ [style_ "foo", style_ "bar"] "foo") `shouldBe` + "

foo

") + it "escaping" + (renderText (p_ [class_ "foo"] "'<>") `shouldBe` + "

'<>

") + it "unicode" + (renderText + (p_ [class_ "foo"] + "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

")) + it "nesting" + (renderText + (p_ [class_ "foo"] + (p_ "Hello!")) `shouldBe` + "

Hello!

") + it "empty" + (renderText + (p_ [class_ "foo"] + (p_ "")) `shouldBe` + "

") + it "mixed" $ + renderText + (p_ [class_ "foo",style_ "attrib"] + (do style_ "" + style_ "")) ==?* + [ "

" + , "

" + ] + it "no closing" + (renderText (p_ [class_ "foo"] (input_ [])) `shouldBe` + "

") + it "multiple" $ + renderText (p_ [class_ "foo",id_ "zot"] "foo") ==?* + [ "

foo

" + , "

foo

" + ] + it "encoded" + (renderText (p_ [class_ "foo<>"] "foo") `shouldBe` + "

foo

") + +-- | Test special elements that do something different to normal +-- elements. +testSpecials :: Spec +testSpecials = + do it "script" + (renderText (script_ "alert('Hello, World!')") `shouldBe` + "") + it "style" + (renderText (style_ "body{background:url('Hello, World!')}") `shouldBe` + "") + +-- | Elements which do not contain children. +testSelfClosing :: Spec +testSelfClosing = + do it "br" (renderText (br_ []) `shouldBe` "
") + it "hr" (renderText (hr_ []) `shouldBe` "
") + it "input" + (renderText (input_ []) `shouldBe` + "") + it "input" + (renderText (input_ [type_ "text"]) `shouldBe` + "")