lucid-2.9.9/0000755000000000000000000000000013165210672011024 5ustar0000000000000000lucid-2.9.9/CHANGELOG.md0000644000000000000000000000220513165210672012634 0ustar0000000000000000## 2.9.9 * Add `commuteHtmlT` to commute `HtmlT m a` into `m (HtmlT n a)`. * Add `MonadError e m => MonadError e (HtmlT m)` and `MonadWriter w m => MonadWriter w (HtmlT m)` instances ## 2.9.8.1 * Improve performance by adding `INLINE` pragmas to `Monad` etc. combinators. ## 2.9.8 * Add `integrity_`, `crossorigin_` attributes * Add `classes_` smart attribute constructor * Add `ToHtml (HtmlT m a)` instance ## 2.9.7 * Add `Semigroup (HtmlT m a)` instance * Add `MonadState` and `MonadReader` instances ## 2.9.6 * Fix compilation of benchmarks * Add @athanclark's version of `relaxHtmlT` * Add a utility to generalize the underlying monad from Identity: `relaxHtmlT` ## 2.9.5 * Add ToHtml instance for ByteString (both) * Add `MFunctor HtmlT` instance, i.e. `hoist` from @mmorph@. ## 2.9.1 * Small performance tweaks. * Make svg_ an element. ## 2.6 * Restrict monoid instance's a to ~ () (means you can use mempty without inference errors) ## 2.2 * Export renderToFile from top-level Lucid module. ## 2.1 * Add some extra HTML tags. ## 2.0 * Use variadic HTML terms. * Add lazy Text instance for ToHtml. ## 1.0 * Initial version. lucid-2.9.9/LICENSE0000644000000000000000000000270713165210672012037 0ustar0000000000000000Copyright (c) 2014, lucid 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 lucid 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. lucid-2.9.9/Setup.hs0000644000000000000000000000005613165210672012461 0ustar0000000000000000import Distribution.Simple main = defaultMain lucid-2.9.9/lucid.cabal0000644000000000000000000000435613165210672013120 0ustar0000000000000000name: lucid version: 2.9.9 synopsis: Clear to write, read and edit DSL for HTML description: Clear to write, read and edit DSL for HTML. See the 'Lucid' module for description and documentation. homepage: https://github.com/chrisdone/lucid license: BSD3 license-file: LICENSE author: Chris Done maintainer: chrisdone@gmail.com, oleg.grenrus@iki.fi copyright: 2014-2017 Chris Done category: Web build-type: Simple cabal-version: >=1.8 extra-source-files: README.md, CHANGELOG.md tested-with: GHC==7.4.2,GHC==7.6.3,GHC==7.8.4,GHC==7.10.3,GHC==8.0.2,GHC==8.2.1 library hs-source-dirs: src/ ghc-options: -Wall -O2 exposed-modules: Lucid Lucid.Base Lucid.Html5 Lucid.Bootstrap build-depends: base >= 4.5 && <5 , blaze-builder , bytestring , containers , hashable , mmorph , mtl , text , transformers , unordered-containers if !impl(ghc >= 8.0) build-depends: semigroups test-suite test type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test other-modules: Example1 build-depends: base, lucid, HUnit, hspec, parsec, bifunctors, text, mtl benchmark bench type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Main.hs other-modules: HtmlBenchmarks build-depends: base, deepseq, criterion, blaze-builder, text, bytestring, lucid ghc-options: -O2 benchmark bench-io type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: IO.hs build-depends: base, criterion, transformers, text, lucid ghc-options: -O2 lucid-2.9.9/README.md0000644000000000000000000000547213165210672012313 0ustar0000000000000000lucid [![Hackage](https://img.shields.io/hackage/v/lucid.svg?style=flat)](https://hackage.haskell.org/package/lucid) [![Build Status](https://travis-ci.org/chrisdone/lucid.png)](https://travis-ci.org/chrisdone/lucid) ===== Clear to write, read and edit DSL for writing HTML [Documentation](http://chrisdone.github.io/lucid/) [lucid-from-html](https://github.com/dbaynard/lucid-from-html) will convert html to the `lucid` DSL, though it is experimental. ## 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. ## 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

" ``` lucid-2.9.9/src/0000755000000000000000000000000013165210672011613 5ustar0000000000000000lucid-2.9.9/src/Lucid.hs0000644000000000000000000001023713165210672013212 0ustar0000000000000000-- | 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`, `makeAttribute`, '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 ,Attribute -- * Classes -- $overloaded ,Term(..) ,ToHtml(..) ,With(..) -- * 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 => [Attribute] -> 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 => [Attribute] -> HtmlT m () -- @ -- -- And some attributes share the same name as attributes, so you can -- also overload them as attributes: -- -- @ -- style_ :: TermRaw arg result => arg -> result -- style_ :: Monad m => [Attribute] -> Text -> HtmlT m () -- style_ :: Monad m => Text -> HtmlT m () -- style_ :: Text -> Attribute -- @ -- $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". lucid-2.9.9/src/Lucid/0000755000000000000000000000000013165210672012653 5ustar0000000000000000lucid-2.9.9/src/Lucid/Base.hs0000644000000000000000000004417213165210672014071 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} -- 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 -- * Combinators ,makeElement ,makeElementNoEnd ,makeXmlElementNoEnd ,makeAttribute -- * Types ,Html ,HtmlT(HtmlT) ,Attribute(..) -- * Classes ,Term(..) ,TermRaw(..) ,ToHtml(..) ,With(..)) 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.Morph import Control.Monad.Reader import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import Data.Functor.Identity import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.Hashable (Hashable(..)) import Data.Semigroup (Semigroup (..)) import Data.Monoid (Monoid (..)) import Data.String import Data.Text (Text) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) import Prelude -------------------------------------------------------------------------------- -- Types -- | A simple attribute. Don't use the constructor, use 'makeAttribute'. data Attribute = Attribute !Text !Text deriving (Show,Eq,Typeable) instance Hashable Attribute where hashWithSalt salt (Attribute a b) = salt `hashWithSalt` a `hashWithSalt` b -- | 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 {runHtmlT :: m (HashMap Text Text -> Builder,a) -- ^ This is the low-level way to run the HTML transformer, -- finally returning an element builder and a value. You can -- pass 'mempty' for this argument for a top-level call. See -- 'evalHtmlT' and 'execHtmlT' for easier to use functions. } -- GHC 7.4 errors with -- Can't make a derived instance of `Typeable (HtmlT m a)': -- `HtmlT' must only have arguments of kind `*' -- GHC 7.6 errors with -- `HtmlT' must only have arguments of kind `*' #if __GLASGOW_HASKELL__ >= 707 deriving (Typeable) #endif -- | @since 2.9.5 instance MFunctor HtmlT where hoist f (HtmlT xs) = HtmlT (f xs) -- | @since 2.9.7 instance (a ~ (),Monad m) => Semigroup (HtmlT m a) where (<>) = liftM2 mappend -- | Monoid is right-associative, a la the 'Builder' in it. instance (a ~ (),Monad m) => Monoid (HtmlT m a) where mempty = return mempty mappend = liftM2 mappend -- | Based on the monad instance. instance Monad m => Applicative (HtmlT m) where pure a = HtmlT (return (mempty,a)) {-# INLINE pure #-} f <*> x = HtmlT $ do ~(g, f') <- runHtmlT f ~(h, x') <- runHtmlT x return (g <> h, f' x') {-# INLINE (<*>) #-} m *> n = HtmlT $ do ~(g, _) <- runHtmlT m ~(h, b) <- runHtmlT n return (g <> h, b) {-# INLINE (*>) #-} m <* n = HtmlT $ do ~(g, a) <- runHtmlT m ~(h, _) <- runHtmlT n return (g <> h, a) {-# INLINE (<*) #-} -- | Just re-uses Monad. instance Monad m => Functor (HtmlT m) where fmap = liftM (<$) = fmap . const {-# INLINE (<$) #-} -- | Basically acts like Writer. instance Monad m => Monad (HtmlT m) where return = pure {-# INLINE return #-} m >>= f = HtmlT $ do ~(g,a) <- runHtmlT m ~(h,b) <- runHtmlT (f a) return (g <> h,b) {-# INLINE (>>=) #-} (>>) = (*>) {-# INLINE (>>) #-} -- | Used for 'lift'. instance MonadTrans HtmlT where lift m = HtmlT (do a <- m return (\_ -> mempty,a)) -- MonadReader, MonadState etc instances need UndecidableInstances, -- because they do not satisfy the coverage condition. -- | @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 -- | @since 2.9.9 instance MonadError e m => MonadError e (HtmlT m) where throwError = lift . throwError catchError (HtmlT m) h = HtmlT $ catchError m (runHtmlT . h) -- | @since 2.9.9 instance MonadWriter w m => MonadWriter w (HtmlT m) where tell = lift . tell listen (HtmlT x) = HtmlT $ liftM reassoc $ listen x where reassoc ((a, b), c) = (a, (b, c)) pass (HtmlT p) = HtmlT $ pass $ liftM assoc p where assoc (a, (b, c)) = ((a, b), c) -- | 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 = build . Blaze.fromHtmlEscapedString toHtmlRaw = build . Blaze.fromString instance ToHtml Text where toHtml = build . Blaze.fromHtmlEscapedText toHtmlRaw = build . Blaze.fromText instance ToHtml LT.Text where toHtml = build . Blaze.fromHtmlEscapedLazyText toHtmlRaw = build . 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 = build . Blaze.fromHtmlEscapedText . T.decodeUtf8 toHtmlRaw = build . 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 = build . Blaze.fromHtmlEscapedLazyText . LT.decodeUtf8 toHtmlRaw = build . Blaze.fromLazyByteString -- | Create an 'HtmlT' directly from a 'Builder'. build :: Monad m => Builder -> HtmlT m () build b = HtmlT (return (const b,())) {-# INLINE build #-} -- | 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. term = flip termWith [] {-# INLINE term #-} -- | Use this if you want to make an element which inserts some -- pre-prepared attributes into the element. termWith :: Text -- ^ Name. -> [Attribute] -- ^ Attribute transformer. -> arg -- ^ Some argument. -> result -- ^ Result: either an element or an attribute. -- | Given attributes, expect more child input. instance (Monad m,f ~ HtmlT m a) => Term [Attribute] (f -> HtmlT m a) where termWith name f = with (makeElement name) . (<> f) -- | Given children immediately, just use that and expect no -- attributes. instance (Monad m) => Term (HtmlT m a) (HtmlT m a) where termWith name f = with (makeElement name) f {-# INLINE termWith #-} -- | Some terms (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for -- attributes as well as elements. instance Term Text Attribute where termWith key _ value = makeAttribute 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. termRaw = flip termRawWith [] -- | Use this if you want to make an element which inserts some -- pre-prepared attributes into the element. termRawWith :: Text -- ^ Name. -> [Attribute] -- ^ Attribute transformer. -> arg -- ^ Some argument. -> result -- ^ Result: either an element or an attribute. -- | Given attributes, expect more child input. instance (Monad m,ToHtml f, a ~ ()) => TermRaw [Attribute] (f -> HtmlT m a) where termRawWith name f attrs = with (makeElement name) (attrs <> f) . toHtmlRaw -- | Given children immediately, just use that and expect no -- attributes. instance (Monad m,a ~ ()) => TermRaw Text (HtmlT m a) where termRawWith name f = with (makeElement name) f . toHtmlRaw -- | Some termRaws (like 'Lucid.Html5.style_', 'Lucid.Html5.title_') can be used for -- attributes as well as elements. instance TermRaw Text Attribute where termRawWith key _ value = makeAttribute key value -- | With an element use these attributes. An overloaded way of adding -- attributes either to an element accepting attributes-and-children -- or one that just accepts attributes. See the two instances. class With a where -- | With the given element(s), use the given attributes. with :: a -- ^ Some element, either @Html a@ or @Html a -> Html a@. -> [Attribute] -> a -- | For the contentless elements: 'Lucid.Html5.br_' instance (Monad m) => With (HtmlT m a) where with f = \attr -> HtmlT (do ~(f',a) <- runHtmlT f return (\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr') ,a)) where toPair (Attribute x y) = (x,y) -- | For the contentful elements: 'Lucid.Html5.div_' instance (Monad m) => With (HtmlT m a -> HtmlT m a) where with f = \attr inner -> HtmlT (do ~(f',a) <- runHtmlT (f inner) return ((\attr' -> f' (unionArgs (M.fromListWith (<>) (map toPair attr)) attr') ) ,a)) where toPair (Attribute x y) = (x,y) -- | Union two sets of arguments and append duplicate keys. unionArgs :: HashMap Text Text -> HashMap Text Text -> HashMap Text Text unionArgs = M.unionWith (<>) -------------------------------------------------------------------------------- -- Running -- | 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 = liftM 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 = liftM (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 (f,_) <- runHtmlT m return (f mempty) -- | 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 = hoist 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 an attribute builder. makeAttribute :: Text -- ^ Attribute name. -> Text -- ^ Attribute value. -> Attribute makeAttribute x y = Attribute x y -- | Make an HTML builder. makeElement :: Monad m => Text -- ^ Name. -> HtmlT m a -- ^ Children HTML. -> HtmlT m a -- ^ A parent element. {-# INLINE[1] makeElement #-} makeElement name = \m' -> HtmlT (do ~(f,a) <- runHtmlT m' return (\attr -> s "<" <> Blaze.fromText name <> foldlMapWithKey buildAttr attr <> s ">" <> f mempty <> s " Blaze.fromText name <> s ">", a)) -- | Make an HTML builder for elements which have no ending tag. makeElementNoEnd :: Monad m => Text -- ^ Name. -> HtmlT m () -- ^ A parent element. makeElementNoEnd name = HtmlT (return (\attr -> s "<" <> Blaze.fromText name <> foldlMapWithKey buildAttr attr <> s ">", ())) -- | Make an XML builder for elements which have no ending tag. makeXmlElementNoEnd :: Monad m => Text -- ^ Name. -> HtmlT m () -- ^ A parent element. makeXmlElementNoEnd name = HtmlT (return (\attr -> s "<" <> Blaze.fromText name <> foldlMapWithKey buildAttr attr <> s "/>", ())) -- | Build and encode an attribute. buildAttr :: Text -> Text -> Builder buildAttr key val = s " " <> Blaze.fromText key <> if val == mempty then mempty else s "=\"" <> Blaze.fromHtmlEscapedText val <> s "\"" -- | Folding and monoidally appending attributes. foldlMapWithKey :: Monoid m => (k -> v -> m) -> HashMap k v -> m foldlMapWithKey f = M.foldlWithKey' (\m k v -> m `mappend` f k v) mempty -- | Convenience function for constructing builders. s :: String -> Builder s = Blaze.fromString {-# INLINE s #-} lucid-2.9.9/src/Lucid/Bootstrap.hs0000644000000000000000000000453413165210672015172 0ustar0000000000000000{-# OPTIONS -fno-warn-type-defaults #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} -- | Bootstrap layout elements. See -- for more -- information. module Lucid.Bootstrap ( -- * Containers container_ ,containerFluid_ -- * Rows ,row_ ,rowFluid_ -- * Spans ,span1_ ,span2_ ,span3_ ,span4_ ,span5_ ,span6_ ,span7_ ,span8_ ,span9_ ,span10_ ,span11_ ,span12_) where import Lucid.Base import Lucid.Html5 -- | A grid container. container_ :: Term arg result => arg -> result container_ = termWith "div" [class_ " container "] -- | A fluid grid container. containerFluid_ :: Term arg result => arg -> result containerFluid_ = termWith "div" [class_ " containerFluid "] -- | A grid row. row_ :: Term arg result => arg -> result row_ = termWith "div" [class_ " row "] -- | A fluid grid row. rowFluid_ :: Term arg result => arg -> result rowFluid_ = termWith "div" [class_ " rowFluid "] -- | A span of 1 column. span1_ :: Term arg result => arg -> result span1_ = termWith "div" [class_ " span1 "] -- | A span of 2 columns. span2_ :: Term arg result => arg -> result span2_ = termWith "div" [class_ " span2 "] -- | A span of 3 columns. span3_ :: Term arg result => arg -> result span3_ = termWith "div" [class_ " span3 "] -- | A span of 4 columns. span4_ :: Term arg result => arg -> result span4_ = termWith "div" [class_ " span4 "] -- | A span of 5 columns. span5_ :: Term arg result => arg -> result span5_ = termWith "div" [class_ " span5 "] -- | A span of 6 columns. span6_ :: Term arg result => arg -> result span6_ = termWith "div" [class_ " span6 "] -- | A span of 7 columns. span7_ :: Term arg result => arg -> result span7_ = termWith "div" [class_ " span7 "] -- | A span of 8 columns. span8_ :: Term arg result => arg -> result span8_ = termWith "div" [class_ " span8 "] -- | A span of 9 columns. span9_ :: Term arg result => arg -> result span9_ = termWith "div" [class_ " span9 "] -- | A span of 10 columns. span10_ :: Term arg result => arg -> result span10_ = termWith "div" [class_ " span10 "] -- | A span of 11 columns. span11_ :: Term arg result => arg -> result span11_ = termWith "div" [class_ " span11 "] -- | A span of 12 columns. span12_ :: Term arg result => arg -> result span12_ = termWith "div" [class_ " span12 "] lucid-2.9.9/src/Lucid/Html5.hs0000644000000000000000000006436413165210672014215 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS -fno-warn-type-defaults #-} -- | Html5 terms. module Lucid.Html5 where import Lucid.Base import Data.Monoid import Data.Text (Text, unwords) ------------------------------------------------------------------------------- -- Elements -- | @DOCTYPE@ element doctype_ :: Monad m => HtmlT m () doctype_ = makeElementNoEnd "!DOCTYPE HTML" -- | @DOCTYPE@ element + @html@ element doctypehtml_ :: Monad m => HtmlT m a -> HtmlT m a doctypehtml_ m = do 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 => [Attribute] -> HtmlT m () area_ = with (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 => [Attribute] -> HtmlT m () base_ = with (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 => [Attribute] -> HtmlT m () br_ = with (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 => [Attribute] -> HtmlT m () col_ = with (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 => [Attribute] -> HtmlT m () embed_ = with (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 => [Attribute] -> HtmlT m () hr_ = with (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 => [Attribute] -> HtmlT m () img_ = with (makeElementNoEnd "img") -- | @input@ element input_ :: Monad m => [Attribute] -> HtmlT m () input_ = with (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 => [Attribute] -> HtmlT m () keygen_ = with (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 => [Attribute] -> HtmlT m () link_ = with (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 => [Attribute] -> HtmlT m () menuitem_ = with (makeElementNoEnd "menuitem") -- | @meta@ element meta_ :: Monad m => [Attribute] -> HtmlT m () meta_ = with (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 => [Attribute] -> HtmlT m () param_ = with (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 => [Attribute] -> HtmlT m () source_ = with (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 => [Attribute] -> HtmlT m () track_ = with (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 => [Attribute] -> HtmlT m () wbr_ = with (makeElementNoEnd "wbr") ------------------------------------------------------------------------------- -- Attributes -- | The @accept@ attribute. accept_ :: Text -> Attribute accept_ = makeAttribute "accept" -- | The @acceptCharset@ attribute. acceptCharset_ :: Text -> Attribute acceptCharset_ = makeAttribute "accept-charset" -- | The @accesskey@ attribute. accesskey_ :: Text -> Attribute accesskey_ = makeAttribute "accesskey" -- | The @action@ attribute. action_ :: Text -> Attribute action_ = makeAttribute "action" -- | The @alt@ attribute. alt_ :: Text -> Attribute alt_ = makeAttribute "alt" -- | The @async@ attribute. async_ :: Text -> Attribute async_ = makeAttribute "async" -- | The @autocomplete@ attribute. autocomplete_ :: Text -> Attribute autocomplete_ = makeAttribute "autocomplete" -- | The @autofocus@ attribute. autofocus_ :: Attribute autofocus_ = makeAttribute "autofocus" mempty -- | The @autoplay@ attribute. autoplay_ :: Text -> Attribute autoplay_ = makeAttribute "autoplay" -- | The @challenge@ attribute. challenge_ :: Text -> Attribute challenge_ = makeAttribute "challenge" -- | The @charset@ attribute. charset_ :: Text -> Attribute charset_ = makeAttribute "charset" -- | The @checked@ attribute. checked_ :: Attribute checked_ = makeAttribute "checked" mempty -- | The @class@ attribute. class_ :: Text -> Attribute class_ = makeAttribute "class" -- | Smart constructor for @class@ attribute. -- -- @since 2.9.8 classes_ :: [Text] -> Attribute classes_ = makeAttribute "class" . Data.Text.unwords -- | The @cols@ attribute. cols_ :: Text -> Attribute cols_ = makeAttribute "cols" -- | The @colspan@ attribute. colspan_ :: Text -> Attribute colspan_ = makeAttribute "colspan" -- | The @content@ attribute. content_ :: Text -> Attribute content_ = makeAttribute "content" -- | The @contenteditable@ attribute. contenteditable_ :: Text -> Attribute contenteditable_ = makeAttribute "contenteditable" -- | The @contextmenu@ attribute. contextmenu_ :: Text -> Attribute contextmenu_ = makeAttribute "contextmenu" -- | The @controls@ attribute. controls_ :: Text -> Attribute controls_ = makeAttribute "controls" -- | The @coords@ attribute. coords_ :: Text -> Attribute coords_ = makeAttribute "coords" -- | The @crossorigin@ attribute. -- -- @since 2.9.8 crossorigin_ :: Text -> Attribute crossorigin_ = makeAttribute "crossorigin" -- | The @data@ attribute. data_ :: Text -> Text -> Attribute data_ name = makeAttribute ("data-" <> name) -- | The @datetime@ attribute. datetime_ :: Text -> Attribute datetime_ = makeAttribute "datetime" -- | The @defer@ attribute. defer_ :: Text -> Attribute defer_ = makeAttribute "defer" -- | The @dir@ attribute. dir_ :: Text -> Attribute dir_ = makeAttribute "dir" -- | The @disabled@ attribute. disabled_ :: Text -> Attribute disabled_ = makeAttribute "disabled" -- | The @download@ attribute. download_ :: Text -> Attribute download_ = makeAttribute "download" -- | The @draggable@ attribute. draggable_ :: Text -> Attribute draggable_ = makeAttribute "draggable" -- | The @enctype@ attribute. enctype_ :: Text -> Attribute enctype_ = makeAttribute "enctype" -- | The @for@ attribute. for_ :: Text -> Attribute for_ = makeAttribute "for" -- | The @formaction@ attribute. formaction_ :: Text -> Attribute formaction_ = makeAttribute "formaction" -- | The @formenctype@ attribute. formenctype_ :: Text -> Attribute formenctype_ = makeAttribute "formenctype" -- | The @formmethod@ attribute. formmethod_ :: Text -> Attribute formmethod_ = makeAttribute "formmethod" -- | The @formnovalidate@ attribute. formnovalidate_ :: Text -> Attribute formnovalidate_ = makeAttribute "formnovalidate" -- | The @formtarget@ attribute. formtarget_ :: Text -> Attribute formtarget_ = makeAttribute "formtarget" -- | The @headers@ attribute. headers_ :: Text -> Attribute headers_ = makeAttribute "headers" -- | The @height@ attribute. height_ :: Text -> Attribute height_ = makeAttribute "height" -- | The @hidden@ attribute. hidden_ :: Text -> Attribute hidden_ = makeAttribute "hidden" -- | The @high@ attribute. high_ :: Text -> Attribute high_ = makeAttribute "high" -- | The @href@ attribute. href_ :: Text -> Attribute href_ = makeAttribute "href" -- | The @hreflang@ attribute. hreflang_ :: Text -> Attribute hreflang_ = makeAttribute "hreflang" -- | The @httpEquiv@ attribute. httpEquiv_ :: Text -> Attribute httpEquiv_ = makeAttribute "http-equiv" -- | The @icon@ attribute. icon_ :: Text -> Attribute icon_ = makeAttribute "icon" -- | The @id@ attribute. id_ :: Text -> Attribute id_ = makeAttribute "id" -- | The @integrity@ attribute. -- -- @since 2.9.8 integrity_ :: Text -> Attribute integrity_ = makeAttribute "integrity" -- | The @ismap@ attribute. ismap_ :: Text -> Attribute ismap_ = makeAttribute "ismap" -- | The @item@ attribute. item_ :: Text -> Attribute item_ = makeAttribute "item" -- | The @itemprop@ attribute. itemprop_ :: Text -> Attribute itemprop_ = makeAttribute "itemprop" -- | The @keytype@ attribute. keytype_ :: Text -> Attribute keytype_ = makeAttribute "keytype" -- | The @lang@ attribute. lang_ :: Text -> Attribute lang_ = makeAttribute "lang" -- | The @list@ attribute. list_ :: Text -> Attribute list_ = makeAttribute "list" -- | The @loop@ attribute. loop_ :: Text -> Attribute loop_ = makeAttribute "loop" -- | The @low@ attribute. low_ :: Text -> Attribute low_ = makeAttribute "low" -- | The @manifest@ attribute. manifest_ :: Text -> Attribute manifest_ = makeAttribute "manifest" -- | The @max@ attribute. max_ :: Text -> Attribute max_ = makeAttribute "max" -- | The @maxlength@ attribute. maxlength_ :: Text -> Attribute maxlength_ = makeAttribute "maxlength" -- | The @media@ attribute. media_ :: Text -> Attribute media_ = makeAttribute "media" -- | The @method@ attribute. method_ :: Text -> Attribute method_ = makeAttribute "method" -- | The @min@ attribute. min_ :: Text -> Attribute min_ = makeAttribute "min" -- | The @multiple@ attribute. multiple_ :: Text -> Attribute multiple_ = makeAttribute "multiple" -- | The @name@ attribute. name_ :: Text -> Attribute name_ = makeAttribute "name" -- | The @novalidate@ attribute. novalidate_ :: Text -> Attribute novalidate_ = makeAttribute "novalidate" -- | The @onbeforeonload@ attribute. onbeforeonload_ :: Text -> Attribute onbeforeonload_ = makeAttribute "onbeforeonload" -- | The @onbeforeprint@ attribute. onbeforeprint_ :: Text -> Attribute onbeforeprint_ = makeAttribute "onbeforeprint" -- | The @onblur@ attribute. onblur_ :: Text -> Attribute onblur_ = makeAttribute "onblur" -- | The @oncanplay@ attribute. oncanplay_ :: Text -> Attribute oncanplay_ = makeAttribute "oncanplay" -- | The @oncanplaythrough@ attribute. oncanplaythrough_ :: Text -> Attribute oncanplaythrough_ = makeAttribute "oncanplaythrough" -- | The @onchange@ attribute. onchange_ :: Text -> Attribute onchange_ = makeAttribute "onchange" -- | The @onclick@ attribute. onclick_ :: Text -> Attribute onclick_ = makeAttribute "onclick" -- | The @oncontextmenu@ attribute. oncontextmenu_ :: Text -> Attribute oncontextmenu_ = makeAttribute "oncontextmenu" -- | The @ondblclick@ attribute. ondblclick_ :: Text -> Attribute ondblclick_ = makeAttribute "ondblclick" -- | The @ondrag@ attribute. ondrag_ :: Text -> Attribute ondrag_ = makeAttribute "ondrag" -- | The @ondragend@ attribute. ondragend_ :: Text -> Attribute ondragend_ = makeAttribute "ondragend" -- | The @ondragenter@ attribute. ondragenter_ :: Text -> Attribute ondragenter_ = makeAttribute "ondragenter" -- | The @ondragleave@ attribute. ondragleave_ :: Text -> Attribute ondragleave_ = makeAttribute "ondragleave" -- | The @ondragover@ attribute. ondragover_ :: Text -> Attribute ondragover_ = makeAttribute "ondragover" -- | The @ondragstart@ attribute. ondragstart_ :: Text -> Attribute ondragstart_ = makeAttribute "ondragstart" -- | The @ondrop@ attribute. ondrop_ :: Text -> Attribute ondrop_ = makeAttribute "ondrop" -- | The @ondurationchange@ attribute. ondurationchange_ :: Text -> Attribute ondurationchange_ = makeAttribute "ondurationchange" -- | The @onemptied@ attribute. onemptied_ :: Text -> Attribute onemptied_ = makeAttribute "onemptied" -- | The @onended@ attribute. onended_ :: Text -> Attribute onended_ = makeAttribute "onended" -- | The @onerror@ attribute. onerror_ :: Text -> Attribute onerror_ = makeAttribute "onerror" -- | The @onfocus@ attribute. onfocus_ :: Text -> Attribute onfocus_ = makeAttribute "onfocus" -- | The @onformchange@ attribute. onformchange_ :: Text -> Attribute onformchange_ = makeAttribute "onformchange" -- | The @onforminput@ attribute. onforminput_ :: Text -> Attribute onforminput_ = makeAttribute "onforminput" -- | The @onhaschange@ attribute. onhaschange_ :: Text -> Attribute onhaschange_ = makeAttribute "onhaschange" -- | The @oninput@ attribute. oninput_ :: Text -> Attribute oninput_ = makeAttribute "oninput" -- | The @oninvalid@ attribute. oninvalid_ :: Text -> Attribute oninvalid_ = makeAttribute "oninvalid" -- | The @onkeydown@ attribute. onkeydown_ :: Text -> Attribute onkeydown_ = makeAttribute "onkeydown" -- | The @onkeyup@ attribute. onkeyup_ :: Text -> Attribute onkeyup_ = makeAttribute "onkeyup" -- | The @onload@ attribute. onload_ :: Text -> Attribute onload_ = makeAttribute "onload" -- | The @onloadeddata@ attribute. onloadeddata_ :: Text -> Attribute onloadeddata_ = makeAttribute "onloadeddata" -- | The @onloadedmetadata@ attribute. onloadedmetadata_ :: Text -> Attribute onloadedmetadata_ = makeAttribute "onloadedmetadata" -- | The @onloadstart@ attribute. onloadstart_ :: Text -> Attribute onloadstart_ = makeAttribute "onloadstart" -- | The @onmessage@ attribute. onmessage_ :: Text -> Attribute onmessage_ = makeAttribute "onmessage" -- | The @onmousedown@ attribute. onmousedown_ :: Text -> Attribute onmousedown_ = makeAttribute "onmousedown" -- | The @onmousemove@ attribute. onmousemove_ :: Text -> Attribute onmousemove_ = makeAttribute "onmousemove" -- | The @onmouseout@ attribute. onmouseout_ :: Text -> Attribute onmouseout_ = makeAttribute "onmouseout" -- | The @onmouseover@ attribute. onmouseover_ :: Text -> Attribute onmouseover_ = makeAttribute "onmouseover" -- | The @onmouseup@ attribute. onmouseup_ :: Text -> Attribute onmouseup_ = makeAttribute "onmouseup" -- | The @onmousewheel@ attribute. onmousewheel_ :: Text -> Attribute onmousewheel_ = makeAttribute "onmousewheel" -- | The @ononline@ attribute. ononline_ :: Text -> Attribute ononline_ = makeAttribute "ononline" -- | The @onpagehide@ attribute. onpagehide_ :: Text -> Attribute onpagehide_ = makeAttribute "onpagehide" -- | The @onpageshow@ attribute. onpageshow_ :: Text -> Attribute onpageshow_ = makeAttribute "onpageshow" -- | The @onpause@ attribute. onpause_ :: Text -> Attribute onpause_ = makeAttribute "onpause" -- | The @onplay@ attribute. onplay_ :: Text -> Attribute onplay_ = makeAttribute "onplay" -- | The @onplaying@ attribute. onplaying_ :: Text -> Attribute onplaying_ = makeAttribute "onplaying" -- | The @onprogress@ attribute. onprogress_ :: Text -> Attribute onprogress_ = makeAttribute "onprogress" -- | The @onpropstate@ attribute. onpropstate_ :: Text -> Attribute onpropstate_ = makeAttribute "onpropstate" -- | The @onratechange@ attribute. onratechange_ :: Text -> Attribute onratechange_ = makeAttribute "onratechange" -- | The @onreadystatechange@ attribute. onreadystatechange_ :: Text -> Attribute onreadystatechange_ = makeAttribute "onreadystatechange" -- | The @onredo@ attribute. onredo_ :: Text -> Attribute onredo_ = makeAttribute "onredo" -- | The @onresize@ attribute. onresize_ :: Text -> Attribute onresize_ = makeAttribute "onresize" -- | The @onscroll@ attribute. onscroll_ :: Text -> Attribute onscroll_ = makeAttribute "onscroll" -- | The @onseeked@ attribute. onseeked_ :: Text -> Attribute onseeked_ = makeAttribute "onseeked" -- | The @onseeking@ attribute. onseeking_ :: Text -> Attribute onseeking_ = makeAttribute "onseeking" -- | The @onselect@ attribute. onselect_ :: Text -> Attribute onselect_ = makeAttribute "onselect" -- | The @onstalled@ attribute. onstalled_ :: Text -> Attribute onstalled_ = makeAttribute "onstalled" -- | The @onstorage@ attribute. onstorage_ :: Text -> Attribute onstorage_ = makeAttribute "onstorage" -- | The @onsubmit@ attribute. onsubmit_ :: Text -> Attribute onsubmit_ = makeAttribute "onsubmit" -- | The @onsuspend@ attribute. onsuspend_ :: Text -> Attribute onsuspend_ = makeAttribute "onsuspend" -- | The @ontimeupdate@ attribute. ontimeupdate_ :: Text -> Attribute ontimeupdate_ = makeAttribute "ontimeupdate" -- | The @onundo@ attribute. onundo_ :: Text -> Attribute onundo_ = makeAttribute "onundo" -- | The @onunload@ attribute. onunload_ :: Text -> Attribute onunload_ = makeAttribute "onunload" -- | The @onvolumechange@ attribute. onvolumechange_ :: Text -> Attribute onvolumechange_ = makeAttribute "onvolumechange" -- | The @onwaiting@ attribute. onwaiting_ :: Text -> Attribute onwaiting_ = makeAttribute "onwaiting" -- | The @open@ attribute. open_ :: Text -> Attribute open_ = makeAttribute "open" -- | The @optimum@ attribute. optimum_ :: Text -> Attribute optimum_ = makeAttribute "optimum" -- | The @pattern@ attribute. pattern_ :: Text -> Attribute pattern_ = makeAttribute "pattern" -- | The @ping@ attribute. ping_ :: Text -> Attribute ping_ = makeAttribute "ping" -- | The @placeholder@ attribute. placeholder_ :: Text -> Attribute placeholder_ = makeAttribute "placeholder" -- | The @preload@ attribute. preload_ :: Text -> Attribute preload_ = makeAttribute "preload" -- | The @pubdate@ attribute. pubdate_ :: Text -> Attribute pubdate_ = makeAttribute "pubdate" -- | The @radiogroup@ attribute. radiogroup_ :: Text -> Attribute radiogroup_ = makeAttribute "radiogroup" -- | The @readonly@ attribute. readonly_ :: Text -> Attribute readonly_ = makeAttribute "readonly" -- | The @rel@ attribute. rel_ :: Text -> Attribute rel_ = makeAttribute "rel" -- | The @required@ attribute. required_ :: Text -> Attribute required_ = makeAttribute "required" -- | The @reversed@ attribute. reversed_ :: Text -> Attribute reversed_ = makeAttribute "reversed" -- | The @role@ attribute. role_ :: Text -> Attribute role_ = makeAttribute "role" -- | The @rows@ attribute. rows_ :: Text -> Attribute rows_ = makeAttribute "rows" -- | The @rowspan@ attribute. rowspan_ :: Text -> Attribute rowspan_ = makeAttribute "rowspan" -- | The @sandbox@ attribute. sandbox_ :: Text -> Attribute sandbox_ = makeAttribute "sandbox" -- | The @scope@ attribute. scope_ :: Text -> Attribute scope_ = makeAttribute "scope" -- | The @scoped@ attribute. scoped_ :: Text -> Attribute scoped_ = makeAttribute "scoped" -- | The @seamless@ attribute. seamless_ :: Text -> Attribute seamless_ = makeAttribute "seamless" -- | The @selected@ attribute. selected_ :: Text -> Attribute selected_ = makeAttribute "selected" -- | The @shape@ attribute. shape_ :: Text -> Attribute shape_ = makeAttribute "shape" -- | The @size@ attribute. size_ :: Text -> Attribute size_ = makeAttribute "size" -- | The @sizes@ attribute. sizes_ :: Text -> Attribute sizes_ = makeAttribute "sizes" -- | The @spellcheck@ attribute. spellcheck_ :: Text -> Attribute spellcheck_ = makeAttribute "spellcheck" -- | The @src@ attribute. src_ :: Text -> Attribute src_ = makeAttribute "src" -- | The @srcdoc@ attribute. srcdoc_ :: Text -> Attribute srcdoc_ = makeAttribute "srcdoc" -- | The @start@ attribute. start_ :: Text -> Attribute start_ = makeAttribute "start" -- | The @step@ attribute. step_ :: Text -> Attribute step_ = makeAttribute "step" -- | The @subject@ attribute. subject_ :: Text -> Attribute subject_ = makeAttribute "subject" -- | The @tabindex@ attribute. tabindex_ :: Text -> Attribute tabindex_ = makeAttribute "tabindex" -- | The @target@ attribute. target_ :: Text -> Attribute target_ = makeAttribute "target" -- | The @type@ attribute. type_ :: Text -> Attribute type_ = makeAttribute "type" -- | The @usemap@ attribute. usemap_ :: Text -> Attribute usemap_ = makeAttribute "usemap" -- | The @value@ attribute. value_ :: Text -> Attribute value_ = makeAttribute "value" -- | The @width@ attribute. width_ :: Text -> Attribute width_ = makeAttribute "width" -- | The @wrap@ attribute. wrap_ :: Text -> Attribute wrap_ = makeAttribute "wrap" -- | The @xmlns@ attribute. xmlns_ :: Text -> Attribute xmlns_ = makeAttribute "xmlns" lucid-2.9.9/benchmarks/0000755000000000000000000000000013165210672013141 5ustar0000000000000000lucid-2.9.9/benchmarks/HtmlBenchmarks.hs0000644000000000000000000001063013165210672016377 0ustar0000000000000000-- | This is a collection of HTML benchmarks for BlazeMarkup. -- {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings, ExistentialQuantification #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module HtmlBenchmarks where import Data.Monoid (Monoid,mappend,mempty) import qualified Data.Text as T -- import qualified Data.Text.Lazy.Builder as B import qualified Prelude as P import Prelude hiding (div, id) import Data.String -- import BenchmarkUtils import Lucid import Lucid.Base -- import qualified BenchmarkUtils as H -- | Description of an HTML benchmark -- data HtmlBenchmark = forall a. HtmlBenchmark String -- ^ Name. (a -> Html ()) -- ^ Rendering function. a -- ^ Data. (Html ()) -- ^ Longer description. -- | List containing all benchmarks. -- benchmarks :: [HtmlBenchmark] benchmarks = [ HtmlBenchmark "bigTable" bigTable bigTableData $ let h = toHtml $ show $ length bigTableData w = toHtml $ show $ length $ P.head bigTableData in "Rendering of a big (" >> h >> "x" >> w >> ") HTML table" , HtmlBenchmark "basic" basic basicData "A simple, small basic template with a few holes to fill in" , HtmlBenchmark "wideTree" wideTree wideTreeData $ "A very wide tree (" >> toHtml (show (length wideTreeData)) >> " elements)" , HtmlBenchmark "wideTreeEscaping" wideTree wideTreeEscapingData $ do "A very wide tree (" >> toHtml (show (length wideTreeData)) >> " elements)" " with lots of escaping" , HtmlBenchmark "deepTree" deepTree deepTreeData $ do "A really deep tree (" >> toHtml (show deepTreeData) >> " nested templates)" , HtmlBenchmark "manyAttributes" manyAttributes manyAttributesData $ do "A single element with " >> toHtml (show (length manyAttributesData)) " attributes." , HtmlBenchmark "customAttribute" customAttributes customAttributesData $ "Creating custom attributes" ] rows :: Int rows = 1000 bigTableData :: [[Int]] bigTableData = replicate rows [1..10] {-# NOINLINE bigTableData #-} basicData :: (String, String, [String]) basicData = ("Just a test", "joe", items) {-# NOINLINE basicData #-} items :: [String] items = map (("Number " `mappend`) . show) [1 :: Int .. 14] {-# NOINLINE items #-} wideTreeData :: [String] wideTreeData = take 5000 $ cycle ["λf.(λx.fxx)(λx.fxx)", "These old days", "Foobar", "lol", "x ∈ A"] {-# NOINLINE wideTreeData #-} wideTreeEscapingData :: [String] wideTreeEscapingData = take 1000 $ cycle ["<><>", "\"lol\"", "<&>", "'>>'"] {-# NOINLINE wideTreeEscapingData #-} deepTreeData :: Int deepTreeData = 1000 {-# NOINLINE deepTreeData #-} manyAttributesData :: [String] manyAttributesData = wideTreeData customAttributesData :: [(String, String)] customAttributesData = zip wideTreeData wideTreeData -- | Render the argument matrix as an HTML table. -- bigTable :: [[Int]] -- ^ Matrix. -> Html () -- ^ Result. bigTable t = table_ (mapM_ row t) row :: [Int] -> Html () row r = tr_ (mapM_ (td_ . toHtml . show) r) -- | Render a simple HTML page with some data. -- basic :: (String, String, [String]) -- ^ (Title, User, Items) -> Html () -- ^ Result. basic (title', user, items') = html_ $ do head_ $ title_ $ toHtml title' body_ $ do with div_ [id_ "header"] $ (h1_ $ toHtml title') p_ $ do "Hello, "; toHtml user; "!" p_ $ "Hello, me!" p_ $ "Hello, world!" h2_ $ "loop" ol_ $ mapM_ (li_ . toHtml) items' with div_ [id_ "footer"] mempty -- | A benchmark producing a very wide but very shallow tree. -- wideTree :: [String] -- ^ Text to create a tree from. -> Html () -- ^ Result. wideTree = div_ . mapM_ ((with p_ [id_ "foo"]) . toHtml) -- | Create a very deep tree. -- deepTree :: Int -- ^ Depth of the tree. -> Html () -- ^ Result. deepTree 0 = "foo" deepTree n = p_ $ table_ $ tr_ $ td_ $ div_ $ deepTree (n - 1) -- | Create an element with many attributes. -- manyAttributes :: [String] -- ^ List of attribute values. -> Html () -- ^ Result. manyAttributes as = img_ (map (id_ . T.pack) as) customAttributes :: [(String, String)] -- ^ List of attribute name, value pairs -> Html () -- ^ Result customAttributes xs = img_ (map (\(key,val) -> makeAttribute (fromString key) (T.pack val)) xs) lucid-2.9.9/benchmarks/Main.hs0000644000000000000000000000134013165210672014357 0ustar0000000000000000-- | This is a module which runs the 'HtmlBenchmarks' module using the different -- renderers available. -- import qualified Blaze.ByteString.Builder as Blaze import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Criterion.Main import qualified Data.ByteString.Lazy as LB import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import HtmlBenchmarks (HtmlBenchmark (..), benchmarks) import Lucid (renderBS) -- | Function to run the benchmarks using criterion -- main :: IO () main = defaultMain $ map benchHtml benchmarks where benchHtml (HtmlBenchmark name f x _) = bgroup name $ [bench "ByteString" $ nf (LB.length . renderBS . f) x ] lucid-2.9.9/benchmarks/IO.hs0000644000000000000000000000142113165210672014002 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Lucid import Criterion.Main import Control.Monad (replicateM_) import qualified Data.Text.Lazy as LT import Control.Monad.Trans.Reader (runReader) import Data.Functor.Identity (runIdentity) lotsOfDivs :: Monad m => Int -> HtmlT m () lotsOfDivs n = body_ $ replicateM_ n $ div_ "hello world!" main :: IO () main = defaultMain [ bench "renderText" $ nf (renderText . lotsOfDivs) size , bench "renderTextT Identity" $ nf (runIdentity . renderTextT . lotsOfDivs) size , bench "renderTextT Reader" $ nf (\(r, s) -> flip runReader r . renderTextT . lotsOfDivs $ s) ((), size) , bench "renderTextT IO" $ nfIO (renderTextT (lotsOfDivs size) :: IO LT.Text) ] where size = 10000 lucid-2.9.9/test/0000755000000000000000000000000013165210672012003 5ustar0000000000000000lucid-2.9.9/test/Example1.hs0000644000000000000000000000735413165210672014024 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | An example which should always compile and demonstrates \"real\" -- code. module Example1 where import Control.Monad import Lucid demo :: Html () demo = doctypehtml_ (do head_ (do meta_ [charset_ "utf-8"] meta_ [name_ "viewport" ,content_ "width=device-width, initial-scale=1"] link_ [href_ "//fonts.googleapis.com/css?family=Open+Sans" ,rel_ "stylesheet" ,type_ "text/css"] link_ [href_ "//cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.1.0/css/bootstrap.min.css" ,rel_ "stylesheet" ,type_ "text/css"] title_ "YSU Closing Status") body_ (div_ [class_ "container"] (do h1_ "YSU Closing Status" t_ [class_ "deal"] "So, here's the deal:" t_ (do "The weather is currently " strong_ "(unknown)" " and " strong_ "(unknown)" ".") t_ (do "There are currently " strong_ "Closings!" " delays/closings according to a local (Youngstown) news source.") t_ (do "Youngstown State University " strong_ (if False then span_ [style_ "color: green;"] "WAS mentioned" else span_ [style_ "color: red;"] "was NOT mentioned") " among them.") t_ (do "There are currently " strong_ (toHtml (maybe "unknown" show (Just 123 :: Maybe Int))) " weather alert(s) covering Youngstown as of " strong_ "2014-23-23" ".") when (0 /= 1) (ul_ (mapM_ (\w -> li_ (do strong_ "Foo" " expiring " toHtml (show w))) [1 .. 5])) hr_ [] p_ [style_ "text-align: center;"] (small_ (do "This website is not affiliated Youngstown " "State University in any way. It was " (a_ [href_ "https://github.com/relrod/isysuclosed.com/"] "written") " to make a point.")) p_ [style_ "text-align: center;"] (small_ (do "While hopefully accurate, this is NOT an official " "resource. Always confirm " a_ [href_ "https://swww.ysu.edu/downloads/closing_procedure.pdf"] "official" " resources.")) p_ [style_ "text-align: center; color: #888888"] (small_ "Valid HTML5. Weather information via Weather Underground.") img_ [style_ "display: block; margin: 0 auto; width: 180px;" ,src_ "http://icons.wxug.com/logos/images/wundergroundLogo_4c_horz.jpg" ,alt_ "Weather Underground Logo"]))) where t_ :: Term a r => a -> r t_ = termWith "p" [class_ " t "] lucid-2.9.9/test/Main.hs0000644000000000000000000001555313165210672013234 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} -- | Test suite for Lucid. module Main where import Lucid import Lucid.Base import Lucid.Bootstrap import Control.Monad.State.Strict import Example1 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 "attributes-with" testAttributesWith describe "extension" testExtension describe "special-elements" testSpecials describe "self-closing" testSelfClosing describe "commuteHtmlT" testCommuteHtmlT -- | Test text/unicode. testText :: Spec testText = do it "simple" (renderText "foo" == "foo") it "escaping" (renderText "'<>" == "'<>") it "unicode" (renderText "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381" == "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") == "

foo

") it "escaping" (renderText (p_ "'<>") == "

'<>

") it "unicode" (renderText (p_ "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381") == ("

fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381

")) it "nesting" (renderText (p_ (p_ "Hello!")) == "

Hello!

") it "empty" (renderText (p_ (p_ "")) == "

") it "mixed" (renderText (p_ (style_ "")) == "

") it "no closing" (renderText (p_ (input_ [])) == "

") it "no closing" (renderText (makeXmlElementNoEnd "p") == "

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

foo

") it "escaping" (renderText (p_ [class_ "foo"] "'<>") == "

'<>

") it "unicode" (renderText (p_ [class_ "foo"] "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381") == ("

fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381

")) it "nesting" (renderText (p_ [class_ "foo"] (p_ "Hello!")) == "

Hello!

") it "empty" (renderText (p_ [class_ "foo"] (p_ "")) == "

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

") it "no closing" (renderText (p_ [class_ "foo"] (input_ [])) == "

") it "multiple" (renderText (p_ [class_ "foo",id_ "zot"] "foo") == "

foo

") it "encoded" (renderText (p_ [class_ "foo<>"] "foo") == "

foo

") it "nesting attributes" (renderText (with (p_ [class_ "foo"]) [class_ "bar"] "foo") == "

foo

") -- | Test that the `with' combinator still works as expected. testAttributesWith :: Spec testAttributesWith = do it "simple" (renderText (with p_ [class_ "foo"] "foo") == "

foo

") it "escaping" (renderText (with p_ [class_ "foo"] "'<>") == "

'<>

") it "unicode" (renderText (with p_ [class_ "foo"] "fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381") == ("

fo\243o\333o(\4326\728\8995\728\4326) \9835\65381*:.\65377. .\65377.:*\65381

")) it "nesting" (renderText (with p_ [class_ "foo"] (p_ "Hello!")) == "

Hello!

") it "empty" (renderText (with p_ [class_ "foo"] (p_ "")) == "

") it "mixed" (renderText (with p_ [class_ "foo",style_ "attrib"] (style_ "")) == "

") it "no closing" (renderText (with p_ [class_ "foo"] (with (input_ [type_ "text"]) [class_ "zot"])) == "

") it "multiple" (renderText (with p_ [class_ "foo",id_ "zot"] "foo") == "

foo

") it "encoded" (renderText (with p_ [class_ "foo<>"] "foo") == "

foo

") it "nesting attributes" (renderText (with (with p_ [class_ "foo"]) [class_ "bar"] "foo") == "

foo

") -- | Test that one can use elements with extensible attributes. testExtension :: Spec testExtension = do it "bootstrap" (renderText (container_ "Foo!") == "
Foo!
") it "bootstrap-attributes-extended" (renderText (container_ [class_ "bar",id_ "zot"] "Foo!") == "
Foo!
") -- | Test special elements that do something different to normal -- elements. testSpecials :: Spec testSpecials = do it "script" (renderText (script_ "alert('Hello, World!')") == "") it "style" (renderText (style_ "body{background:url('Hello, World!')}") == "") -- | Elements which do not contain children. testSelfClosing :: Spec testSelfClosing = do it "br" (renderText (br_ []) == "
") it "hr" (renderText (hr_ []) == "
") it "input" (renderText (input_ []) == "") it "input" (renderText (input_ [type_ "text"]) == "") testCommuteHtmlT :: Spec testCommuteHtmlT = do it "makes using inner monads easy" (example == renderText expected) where example = renderText $ evalState (commuteHtmlT exampleHtml) 1 exampleHtml :: MonadState Int m => HtmlT m () exampleHtml = ul_ $ replicateM_ 5 $ do x <- get put (x + 1) li_ $ toHtml $ show x expected = ul_ $ do li_ "1" li_ "2" li_ "3" li_ "4" li_ "5"