diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,13 @@ +# Revision history for type-of-html + +## 0.2.1.0 -- 2017-08-04 + +* Escape strings + +## 0.2.0.0 -- 2017-07-30 + +* Full implementation + +## 0.1.0.0 -- 2017-07-09 + +* First draft diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Florian Knupfer + +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 Florian Knupfer nor the names of other + 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 THE COPYRIGHT +OWNER OR CONTRIBUTORS 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,53 @@ +# Type of html + +`Type of html` is a library for generating html in a highly performant +and type safe manner. + +Please read the documentation of the module: +[Html](https://hackage.haskell.org/package/type-of-html/docs/Html.html) + +Note that you need at least ghc 8.2. + +## Typesafety + +Part of the html spec is encoded at the typelevel, turning a lot of +mistakes into type errors. + +## Performance + +`Type of html` is normally a lot faster than `blaze html`. Criterion +says about the following snippet that `Type of html` needs only ~450 +ns, `blaze html` needs ten times more time. + +```haskell +example x = + html_ + ( body_ + ( h1_ + ( img_ + # strong_ "0" + ) + # div_ + ( div_ "1" + ) + # div_ + ( form_ + ( fieldset_ + ( div_ + ( div_ + ( label_ "a" + # select_ + ( option_ "b" + # option_ "c" + ) + # div_ "d" + ) + # i_ x + ) + # button_ (i_ "e") + ) + ) + ) + ) + ) +``` 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/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module Main where + +import Html + +import Data.String +import Control.Monad + +import Data.Text.Lazy.Builder (Builder, toLazyText) +import Text.Blaze.Html5 ((!)) + +import Data.ByteString.Lazy (ByteString) + +import qualified Data.Text as S +import qualified Data.Text.Lazy as L +import qualified Text.Blaze.Html5 as B +import qualified Text.Blaze.Html5.Attributes as B (class_, id) +import qualified Text.Blaze.Html.Renderer.Text as RT +import qualified Text.Blaze.Html.Renderer.Utf8 as RB + +import Criterion.Main + +main :: IO () +main = defaultMain + [ bgroup "minimal" + [ bench "blaze.text" $ nf (RT.renderHtml . blazeMinimal :: B.Html -> L.Text) "TEST" + , bench "blaze.utf8" $ nf (RB.renderHtml . blazeMinimal :: B.Html -> ByteString) "TEST" + , bench "string" $ nf (render . minimal :: String -> String) "TEST" + , bench "strict text" $ nf (render . minimal :: S.Text -> S.Text) "TEST" + , bench "lazy text" $ nf (render . minimal :: L.Text -> L.Text) "TEST" + , bench "builder" $ nf (toLazyText . render . minimal :: Builder -> L.Text) "TEST" + ] + , bgroup "hello world" + [ bench "blaze.text" $ nf (RT.renderHtml . blazeHelloWorld :: B.Html -> L.Text) "TEST" + , bench "blaze.utf8" $ nf (RB.renderHtml . blazeHelloWorld :: B.Html -> ByteString) "TEST" + , bench "string" $ nf (render . helloWorld :: String -> String) "TEST" + , bench "strict text" $ nf (render . helloWorld :: S.Text -> S.Text) "TEST" + , bench "lazy text" $ nf (render . helloWorld :: L.Text -> L.Text) "TEST" + , bench "builder" $ nf (toLazyText . render . helloWorld :: Builder -> L.Text) "TEST" + ] + , bgroup "big page" + [ bench "blaze.text" $ nf (RT.renderHtml . blazeBigPage :: B.Html -> L.Text) "TEST" + , bench "blaze.utf8" $ nf (RB.renderHtml . blazeBigPage :: B.Html -> ByteString) "TEST" + , bench "string" $ nf (render . bigPage :: String -> String) "TEST" + , bench "strict text" $ nf (render . bigPage :: S.Text -> S.Text) "TEST" + , bench "lazy text" $ nf (render . bigPage :: L.Text -> L.Text) "TEST" + , bench "builder" $ nf (toLazyText . render . bigPage :: Builder -> L.Text) "TEST" + ] + , bgroup "big page with attributes" + [ bench "blaze.text" $ nf (RT.renderHtml . blazeBigPageA :: B.Html -> L.Text) "TEST" + , bench "blaze.utf8" $ nf (RB.renderHtml . blazeBigPageA :: B.Html -> ByteString) "TEST" + , bench "string" $ nf (render . bigPageA :: String -> String) "TEST" + , bench "strict text" $ nf (render . bigPageA :: S.Text -> S.Text) "TEST" + , bench "lazy text" $ nf (render . bigPageA :: L.Text -> L.Text) "TEST" + , bench "builder" $ nf (toLazyText . render . bigPageA :: Builder -> L.Text) "TEST" + ] + , bgroup "big table" + [ bench "blaze.text" $ nf (RT.renderHtml . blazeBigTable :: (Int, Int) -> L.Text) (4,4) + , bench "blaze.utf8" $ nf (RB.renderHtml . blazeBigTable :: (Int, Int) -> ByteString) (4,4) + , bench "string" $ nf (render . bigTable :: (Int, Int) -> String) (4,4) + , bench "strict text" $ nf (render . bigTable :: (Int, Int) -> S.Text) (4,4) + , bench "lazy text" $ nf (render . bigTable :: (Int, Int) -> L.Text) (4,4) + , bench "builder" $ nf (toLazyText . render . bigTable :: (Int, Int) -> L.Text) (4,4) + ] + ] + +-- Blaze based functions + +blazeMinimal :: B.Html -> B.Html +blazeMinimal = B.div + +blazeHelloWorld :: B.Html -> B.Html +blazeHelloWorld x = + B.html $ do + B.head $ do + B.title x + B.body $ do + B.p "Hello World!" + +blazeBigPage :: B.Html -> B.Html +blazeBigPage x = + B.html $ do + B.body $ do + B.h1 $ do + B.img + B.strong "0" + B.div $ do + B.div "1" + B.div $ do + B.form $ do + B.fieldset $ do + B.div $ do + B.div $ do + B.label "a" + B.select $ do + B.option "b" + B.option "c" + B.div "d" + B.i x + B.button $ B.i "e" + +blazeBigPageA :: B.Html -> B.Html +blazeBigPageA x = + B.html $ do + B.body $ do + B.h1 ! B.id "a" $ do + B.img + B.strong ! B.class_ "b" $ "0" + B.div $ do + B.div ! B.id "c" $ "1" + B.div $ do + B.form ! B.class_ "d" $ do + B.fieldset $ do + B.div ! B.id "e" $ do + B.div $ do + B.label ! B.class_ "f" $ "a" + B.select $ do + B.option ! B.id "g" $ "b" + B.option "c" + B.div ! B.class_ "h" $ "d" + B.i x + B.button ! B.id "i" $ B.i "e" + +blazeBigTable :: (Int, Int) -> B.Html +blazeBigTable (n, m) + = B.table + . replicateM_ n + . B.tr + $ mapM_ (B.td . fromString . show) [1..m] + +-- Type of Html based functions + +minimal :: ('Div ?> a) => a -> 'Div > a +minimal = div_ + +helloWorld + :: (IsString a, 'Title ?> a) + => a + -> + 'Html > ( 'Head > 'Title > a + # 'Body > 'P > String + ) +helloWorld x = + html_ + ( head_ + ( title_ x + ) + # body_ + ( p_ ("Hello World!" :: String) + ) + ) + +bigPage + :: ('I ?> a) + => a + -> + 'Html > + ( 'Body > + ( 'H1 > + ( 'Img > () + # 'Strong > String + ) + # 'Div > 'Div > String + # 'Div > 'Form > 'Fieldset > + ( 'Div > + ( 'Div > + ( 'Label > String + # 'Select > + ( 'Option > String + # 'Option > String + ) + # 'Div > String + ) + # 'I > a + ) + # 'Button > 'I > String + ) + ) + ) +bigPage x = + html_ + ( body_ + ( h1_ + ( img_ + # strong_ ("0" :: String) + ) + # div_ + ( div_ ("1" :: String) + ) + # div_ + ( form_ + ( fieldset_ + ( div_ + ( div_ + ( label_ ("a" :: String) + # select_ + ( option_ ("b" :: String) + # option_ ("c" :: String) + ) + # div_ ("d" :: String) + ) + # i_ x + ) + # button_ (i_ ("e" :: String)) + ) + ) + ) + ) + ) + +bigPageA + :: ('I ?> a) + => a + -> + 'Html > + ( 'Body > + ( 'H1 :> + ( 'Img > () + # 'Strong :> String + ) + # 'Div > 'Div :> String + # 'Div > 'Form :> 'Fieldset > + ( 'Div :> + ( 'Div > + ( 'Label :> String + # 'Select > + ( 'Option :> String + # 'Option > String + ) + # 'Div :> String + ) + # 'I > a + ) + # 'Button :> 'I > String + ) + ) + ) +bigPageA x = + html_ + ( body_ + ( h1_A [("id","a")] + ( img_ + # strong_A [("class","b")] ("0" :: String) + ) + # div_ + ( div_A [("id","c")] ("1" :: String) + ) + # div_ + ( form_A [("class","d")] + ( fieldset_ + ( div_A [("id","e")] + ( div_ + ( label_A [("class","f")] ("a" :: String) + # select_ + ( option_A [("id","g")] ("b" :: String) + # option_ ("c" :: String) + ) + # div_A [("class","h")] ("d" :: String) + ) + # i_ x + ) + # button_A [("id","i")] (i_ ("e" :: String)) + ) + ) + ) + ) + ) + +bigTable :: (Int, Int) -> 'Table > ['Tr > ['Td > Int]] +bigTable (n, m) = table_ . replicate n . tr_ $ map td_ [1..m] diff --git a/src/Html.hs b/src/Html.hs new file mode 100644 --- /dev/null +++ b/src/Html.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +{-| With type-of-html are three main goals: + +* Type safety + +* Modularity + +* Performance + +Let's check out the /type safety/ in ghci: + +> Html> td_ (tr_ "a") +> +> :1:1: error: +> • 'Tr is not a valid child of 'Td +> • In the expression: td_ (tr_ "a") +> In an equation for ‘it’: it = td_ (tr_ "a") +> +> :1:6: error: +> • 'Tr can't contain a string +> • In the first argument of ‘td_’, namely ‘(tr_ "a")’ +> In the expression: td_ (tr_ "a") +> In an equation for ‘it’: it = td_ (tr_ "a") + +For every child, it is checked if it could possibly be lawful. + +The checking is a bit lenient at the moment: + +* some elements can't contain itself as any descendant: at the moment we look only at direct children. This allows some (quite exotic) invalid html documents. +* some elements change their permitted content based on attributes: we don't know at compile time the attributes, therefore we always allow content as if all relevant attributes are set. +* some elements can't be brethren: we look only at parent child relations, therefore if you don't specify the parent, it'll compile + +Never the less: these cases are seldom. In the vast majority of the time you're only allowed to construct valid html. + +Let's talk about /modularity/: + +Rosetrees of html are just ordinary haskell values which can be composed or abstracted over: + +> Html> let table = table_ . map (tr_ . map td_) +> Html> :t table +> table :: ('Td ?> a) => [[a]] -> 'Table > ['Tr > ['Td > a]] +> Html> table [["A","B"],["C"]] +>
AB
C
+> Html> import Data.Char +> Html Data.Char> html_ . body_ . table $ map (\c -> [[c], show $ ord c]) ['a'..'d'] +>
a97
b98
c99
d100
+ +And here's an example module + +@ +{\-\# LANGUAGE TypeOperators \#-\} +{\-\# LANGUAGE DataKinds \#-\} + +module Main where + +import Html + +import Data.Text.Lazy.IO as T +import Data.Text.Lazy.Builder as T + +main :: IO () +main + = T.putStrLn + . T.toLazyText + . render + . page + $ map td_ [1..(10::Int)] + +page + :: 'Tr ?> a + => a + -> 'Div + > ( 'Div > [Char] + # 'Div > [Char] + # 'Table > 'Tr > a + ) +page tds = + div_ + ( div_ "foo" + # div_ "bar" + # table_ (tr_ tds) + ) +@ + +Please note that the type of page is inferable, so ask ghc-mod or +whatever you use to write it for you. If you choose not to write the +types, you don't need the language extensions. + +Last and fast: /performance/! + +Don't look any further, there is no option for faster html +generation. type-of-html up to 10 times faster than blaze-html, which +is until now the fastest generation library and the foundation block +of lucid and shakespeare. + +Wait! 10 times faster? How is this possible? We supercompile lots of +parts of the generation process. This is possible thanks to the new +features of GHC 8.2: AppendSymbol. We represent tags as kinds and +remove according to the html specification omittable closing tags with +type families. Afterwards we map these tags to (a :: [Symbol]) and +then fold all neighbouring Proxies with AppendSymbol. Afterwards we +retrieve the Proxies with symbolVal which will be embedded in the +executable as CString. All this happens at compile time. At runtime we +do only generate the content and mconcat. + +For example, if you write: + +> render $ div_ "a" + +The compiler does actually optimize it to the following: + +> mconcat [ fromString $ symbolVal (Proxy :: Proxy "
") +> , fromString "a" +> , fromString $ symbolVal (Proxy :: Proxy "
") +> ] + +If you write + +> render $ div_ (div_ ()) + +The compiler does actually optimize it to the following: + +> mconcat [ fromString $ symbolVal (Proxy :: Proxy "
") ] + +If you write + +> render $ tr_ (td_ "test") + +The compiler does actually optimize it to the following: + +> mconcat [ fromString $ symbolVal (Proxy :: Proxy "") +> , fromString "test" +> , fromString $ symbolVal (Proxy :: Proxy "") +> ] + +Let's look at core: + +We take an extremely simple library + +> module Minimal where +> +> import Html +> +> minimal :: String +> minimal = render +> ( div_ "a" +> # div_ "b" +> # table_ (tr_ (td_ "c")) +> ) + +compile it with + +> ghc -O2 Minimal.hs -ddump-to-file -ddump-simpl -dsuppress-idinfo -dsuppress-module-prefixes -dsuppress-type-applications -dsuppress-uniques + +and clean up a bit: + +> minimal1 :: Addr# +> minimal1 = "
a
b
c
"# +> +> minimal :: String +> minimal = unpackCString# minimal1 + +Well, that's a perfect optimization! Not only was *all* overhead +removed, optional ending tags were chopped off (tr, td). This sort of +compiletime optimization isn't for free. Running ghc with -v says +that desugaring resulted in 675 types and 5507 coercions: Compile +times will increase, some medium size html documents will take 10 secs +to compile. + +-} + +module Html + ( render + , type (>)(..) + , type (:>)(..) + , addAttributes + , type (#)(..) + , (#) + , type (?>) + , Convert(..) + , Escape(..) + , Element(..) + , module Html.Element + ) where + +import Html.Element + +import Html.Type + ( type (>)(..) + , type (:>)(..) + , type (?>) + , type (#)(..) + , (#) + , Element(..) + ) + +import Html.Function + ( render + , addAttributes + , Convert(..) + , Escape(..) + ) diff --git a/src/Html/Element.hs b/src/Html/Element.hs new file mode 100644 --- /dev/null +++ b/src/Html/Element.hs @@ -0,0 +1,888 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module Html.Element where + +import Html.Type +import Html.Function (addAttributes) + +doctype_ :: 'DOCTYPE > () +doctype_ = Child () + +a_ :: ('A ?> a) => a -> 'A > a +a_ = Child + +a_A :: ('A ?> a) => [(String, String)] -> a -> 'A :> a +a_A xs = addAttributes xs . Child + +abbr_ :: ('Abbr ?> a) => a -> 'Abbr > a +abbr_ = Child + +abbr_A :: ('Abbr ?> a) => [(String, String)] -> a -> 'Abbr :> a +abbr_A xs = addAttributes xs . Child + +acronym_ :: ('Acronym ?> a) => a -> 'Acronym > a +acronym_ = Child + +acronym_A :: ('Acronym ?> a) => [(String, String)] -> a -> 'Acronym :> a +acronym_A xs = addAttributes xs . Child + +address_ :: ('Address ?> a) => a -> 'Address > a +address_ = Child + +address_A :: ('Address ?> a) => [(String, String)] -> a -> 'Address :> a +address_A xs = addAttributes xs . Child + +applet_ :: ('Applet ?> a) => a -> 'Applet > a +applet_ = Child + +applet_A :: ('Applet ?> a) => [(String, String)] -> a -> 'Applet :> a +applet_A xs = addAttributes xs . Child + +area_ :: 'Area > () +area_ = Child () + +area_A :: [(String, String)] -> 'Area :> () +area_A xs = addAttributes xs $ Child () + +article_ :: ('Article ?> a) => a -> 'Article > a +article_ = Child + +article_A :: ('Article ?> a) => [(String, String)] -> a -> 'Article :> a +article_A xs = addAttributes xs . Child + +aside_ :: ('Aside ?> a) => a -> 'Aside > a +aside_ = Child + +aside_A :: ('Aside ?> a) => [(String, String)] -> a -> 'Aside :> a +aside_A xs = addAttributes xs . Child + +audio_ :: ('Audio ?> a) => a -> 'Audio > a +audio_ = Child + +audio_A :: ('Audio ?> a) => [(String, String)] -> a -> 'Audio :> a +audio_A xs = addAttributes xs . Child + +b_ :: ('B ?> a) => a -> 'B > a +b_ = Child + +b_A :: ('B ?> a) => [(String, String)] -> a -> 'B :> a +b_A xs = addAttributes xs . Child + +base_ :: 'Base > () +base_ = Child () + +base_A :: [(String, String)] -> 'Base :> () +base_A xs = addAttributes xs $ Child () + +basefont_ :: ('Basefont ?> a) => a -> 'Basefont > a +basefont_ = Child + +basefont_A :: ('Basefont ?> a) => [(String, String)] -> a -> 'Basefont :> a +basefont_A xs = addAttributes xs . Child + +bdi_ :: ('Bdi ?> a) => a -> 'Bdi > a +bdi_ = Child + +bdi_A :: ('Bdi ?> a) => [(String, String)] -> a -> 'Bdi :> a +bdi_A xs = addAttributes xs . Child + +bdo_ :: ('Bdo ?> a) => a -> 'Bdo > a +bdo_ = Child + +bdo_A :: ('Bdo ?> a) => [(String, String)] -> a -> 'Bdo :> a +bdo_A xs = addAttributes xs . Child + +bgsound_ :: ('Bgsound ?> a) => a -> 'Bgsound > a +bgsound_ = Child + +bgsound_A :: ('Bgsound ?> a) => [(String, String)] -> a -> 'Bgsound :> a +bgsound_A xs = addAttributes xs . Child + +big_ :: ('Big ?> a) => a -> 'Big > a +big_ = Child + +big_A :: ('Big ?> a) => [(String, String)] -> a -> 'Big :> a +big_A xs = addAttributes xs . Child + +blink_ :: ('Blink ?> a) => a -> 'Blink > a +blink_ = Child + +blink_A :: ('Blink ?> a) => [(String, String)] -> a -> 'Blink :> a +blink_A xs = addAttributes xs . Child + +blockquote_ :: ('Blockquote ?> a) => a -> 'Blockquote > a +blockquote_ = Child + +blockquote_A :: ('Blockquote ?> a) => [(String, String)] -> a -> 'Blockquote :> a +blockquote_A xs = addAttributes xs . Child + +body_ :: ('Body ?> a) => a -> 'Body > a +body_ = Child + +body_A :: ('Body ?> a) => [(String, String)] -> a -> 'Body :> a +body_A xs = addAttributes xs . Child + +br_ :: 'Br > () +br_ = Child () + +br_A :: [(String, String)] -> 'Br :> () +br_A xs = addAttributes xs $ Child () + +button_ :: ('Button ?> a) => a -> 'Button > a +button_ = Child + +button_A :: ('Button ?> a) => [(String, String)] -> a -> 'Button :> a +button_A xs = addAttributes xs . Child + +canvas_ :: ('Canvas ?> a) => a -> 'Canvas > a +canvas_ = Child + +canvas_A :: ('Canvas ?> a) => [(String, String)] -> a -> 'Canvas :> a +canvas_A xs = addAttributes xs . Child + +caption_ :: ('Caption ?> a) => a -> 'Caption > a +caption_ = Child + +caption_A :: ('Caption ?> a) => [(String, String)] -> a -> 'Caption :> a +caption_A xs = addAttributes xs . Child + +center_ :: ('Center ?> a) => a -> 'Center > a +center_ = Child + +center_A :: ('Center ?> a) => [(String, String)] -> a -> 'Center :> a +center_A xs = addAttributes xs . Child + +cite_ :: ('Cite ?> a) => a -> 'Cite > a +cite_ = Child + +cite_A :: ('Cite ?> a) => [(String, String)] -> a -> 'Cite :> a +cite_A xs = addAttributes xs . Child + +code_ :: ('Code ?> a) => a -> 'Code > a +code_ = Child + +code_A :: ('Code ?> a) => [(String, String)] -> a -> 'Code :> a +code_A xs = addAttributes xs . Child + +col_ :: 'Col > () +col_ = Child () + +col_A :: [(String, String)] -> 'Col :> () +col_A xs = addAttributes xs $ Child () + +colgroup_ :: ('Colgroup ?> a) => a -> 'Colgroup > a +colgroup_ = Child + +colgroup_A :: ('Colgroup ?> a) => [(String, String)] -> a -> 'Colgroup :> a +colgroup_A xs = addAttributes xs . Child + +command_ :: ('Command ?> a) => a -> 'Command > a +command_ = Child + +command_A :: ('Command ?> a) => [(String, String)] -> a -> 'Command :> a +command_A xs = addAttributes xs . Child + +content_ :: ('Content ?> a) => a -> 'Content > a +content_ = Child + +content_A :: ('Content ?> a) => [(String, String)] -> a -> 'Content :> a +content_A xs = addAttributes xs . Child + +data_ :: ('Data ?> a) => a -> 'Data > a +data_ = Child + +data_A :: ('Data ?> a) => [(String, String)] -> a -> 'Data :> a +data_A xs = addAttributes xs . Child + +datalist_ :: ('Datalist ?> a) => a -> 'Datalist > a +datalist_ = Child + +datalist_A :: ('Datalist ?> a) => [(String, String)] -> a -> 'Datalist :> a +datalist_A xs = addAttributes xs . Child + +dd_ :: ('Dd ?> a) => a -> 'Dd > a +dd_ = Child + +dd_A :: ('Dd ?> a) => [(String, String)] -> a -> 'Dd :> a +dd_A xs = addAttributes xs . Child + +del_ :: ('Del ?> a) => a -> 'Del > a +del_ = Child + +del_A :: ('Del ?> a) => [(String, String)] -> a -> 'Del :> a +del_A xs = addAttributes xs . Child + +details_ :: ('Details ?> a) => a -> 'Details > a +details_ = Child + +details_A :: ('Details ?> a) => [(String, String)] -> a -> 'Details :> a +details_A xs = addAttributes xs . Child + +dfn_ :: ('Dfn ?> a) => a -> 'Dfn > a +dfn_ = Child + +dfn_A :: ('Dfn ?> a) => [(String, String)] -> a -> 'Dfn :> a +dfn_A xs = addAttributes xs . Child + +dialog_ :: ('Dialog ?> a) => a -> 'Dialog > a +dialog_ = Child + +dialog_A :: ('Dialog ?> a) => [(String, String)] -> a -> 'Dialog :> a +dialog_A xs = addAttributes xs . Child + +dir_ :: ('Dir ?> a) => a -> 'Dir > a +dir_ = Child + +dir_A :: ('Dir ?> a) => [(String, String)] -> a -> 'Dir :> a +dir_A xs = addAttributes xs . Child + +div_ :: ('Div ?> a) => a -> 'Div > a +div_ = Child + +div_A :: ('Div ?> a) => [(String, String)] -> a -> 'Div :> a +div_A xs = addAttributes xs . Child + +dl_ :: ('Dl ?> a) => a -> 'Dl > a +dl_ = Child + +dl_A :: ('Dl ?> a) => [(String, String)] -> a -> 'Dl :> a +dl_A xs = addAttributes xs . Child + +dt_ :: ('Dt ?> a) => a -> 'Dt > a +dt_ = Child + +dt_A :: ('Dt ?> a) => [(String, String)] -> a -> 'Dt :> a +dt_A xs = addAttributes xs . Child + +element_ :: ('Element ?> a) => a -> 'Element > a +element_ = Child + +element_A :: ('Element ?> a) => [(String, String)] -> a -> 'Element :> a +element_A xs = addAttributes xs . Child + +em_ :: ('Em ?> a) => a -> 'Em > a +em_ = Child + +em_A :: ('Em ?> a) => [(String, String)] -> a -> 'Em :> a +em_A xs = addAttributes xs . Child + +embed_ :: 'Embed > () +embed_ = Child () + +embed_A :: [(String, String)] -> 'Embed :> () +embed_A xs = addAttributes xs $ Child () + +fieldset_ :: ('Fieldset ?> a) => a -> 'Fieldset > a +fieldset_ = Child + +fieldset_A :: ('Fieldset ?> a) => [(String, String)] -> a -> 'Fieldset :> a +fieldset_A xs = addAttributes xs . Child + +figcaption_ :: ('Figcaption ?> a) => a -> 'Figcaption > a +figcaption_ = Child + +figcaption_A :: ('Figcaption ?> a) => [(String, String)] -> a -> 'Figcaption :> a +figcaption_A xs = addAttributes xs . Child + +figure_ :: ('Figure ?> a) => a -> 'Figure > a +figure_ = Child + +figure_A :: ('Figure ?> a) => [(String, String)] -> a -> 'Figure :> a +figure_A xs = addAttributes xs . Child + +font_ :: ('Font ?> a) => a -> 'Font > a +font_ = Child + +font_A :: ('Font ?> a) => [(String, String)] -> a -> 'Font :> a +font_A xs = addAttributes xs . Child + +footer_ :: ('Footer ?> a) => a -> 'Footer > a +footer_ = Child + +footer_A :: ('Footer ?> a) => [(String, String)] -> a -> 'Footer :> a +footer_A xs = addAttributes xs . Child + +form_ :: ('Form ?> a) => a -> 'Form > a +form_ = Child + +form_A :: ('Form ?> a) => [(String, String)] -> a -> 'Form :> a +form_A xs = addAttributes xs . Child + +frame_ :: ('Frame ?> a) => a -> 'Frame > a +frame_ = Child + +frame_A :: ('Frame ?> a) => [(String, String)] -> a -> 'Frame :> a +frame_A xs = addAttributes xs . Child + +frameset_ :: ('Frameset ?> a) => a -> 'Frameset > a +frameset_ = Child + +frameset_A :: ('Frameset ?> a) => [(String, String)] -> a -> 'Frameset :> a +frameset_A xs = addAttributes xs . Child + +h1_ :: ('H1 ?> a) => a -> 'H1 > a +h1_ = Child + +h1_A :: ('H1 ?> a) => [(String, String)] -> a -> 'H1 :> a +h1_A xs = addAttributes xs . Child + +h2_ :: ('H2 ?> a) => a -> 'H2 > a +h2_ = Child + +h2_A :: ('H2 ?> a) => [(String, String)] -> a -> 'H2 :> a +h2_A xs = addAttributes xs . Child + +h3_ :: ('H3 ?> a) => a -> 'H3 > a +h3_ = Child + +h3_A :: ('H3 ?> a) => [(String, String)] -> a -> 'H3 :> a +h3_A xs = addAttributes xs . Child + +h4_ :: ('H4 ?> a) => a -> 'H4 > a +h4_ = Child + +h4_A :: ('H4 ?> a) => [(String, String)] -> a -> 'H4 :> a +h4_A xs = addAttributes xs . Child + +h5_ :: ('H5 ?> a) => a -> 'H5 > a +h5_ = Child + +h5_A :: ('H5 ?> a) => [(String, String)] -> a -> 'H5 :> a +h5_A xs = addAttributes xs . Child + +h6_ :: ('H6 ?> a) => a -> 'H6 > a +h6_ = Child + +h6_A :: ('H6 ?> a) => [(String, String)] -> a -> 'H6 :> a +h6_A xs = addAttributes xs . Child + +head_ :: ('Head ?> a) => a -> 'Head > a +head_ = Child + +head_A :: ('Head ?> a) => [(String, String)] -> a -> 'Head :> a +head_A xs = addAttributes xs . Child + +header_ :: ('Header ?> a) => a -> 'Header > a +header_ = Child + +header_A :: ('Header ?> a) => [(String, String)] -> a -> 'Header :> a +header_A xs = addAttributes xs . Child + +hgroup_ :: ('Hgroup ?> a) => a -> 'Hgroup > a +hgroup_ = Child + +hgroup_A :: ('Hgroup ?> a) => [(String, String)] -> a -> 'Hgroup :> a +hgroup_A xs = addAttributes xs . Child + +hr_ :: 'Hr > () +hr_ = Child () + +hr_A :: [(String, String)] -> 'Hr :> () +hr_A xs = addAttributes xs $ Child () + +html_ :: ('Html ?> a) => a -> 'Html > a +html_ = Child + +html_A :: ('Html ?> a) => [(String, String)] -> a -> 'Html :> a +html_A xs = addAttributes xs . Child + +i_ :: ('I ?> a) => a -> 'I > a +i_ = Child + +i_A :: ('I ?> a) => [(String, String)] -> a -> 'I :> a +i_A xs = addAttributes xs . Child + +iframe_ :: 'Iframe > () +iframe_ = Child () + +iframe_A :: [(String, String)] -> 'Iframe :> () +iframe_A xs = addAttributes xs $ Child () + +image_ :: ('Image ?> a) => a -> 'Image > a +image_ = Child + +image_A :: ('Image ?> a) => [(String, String)] -> a -> 'Image :> a +image_A xs = addAttributes xs . Child + +img_ :: 'Img > () +img_ = Child () + +img_A :: [(String, String)] -> 'Img :> () +img_A xs = addAttributes xs $ Child () + +input_ :: ('Input ?> a) => a -> 'Input > a +input_ = Child + +input_A :: ('Input ?> a) => [(String, String)] -> a -> 'Input :> a +input_A xs = addAttributes xs . Child + +ins_ :: ('Ins ?> a) => a -> 'Ins > a +ins_ = Child + +ins_A :: ('Ins ?> a) => [(String, String)] -> a -> 'Ins :> a +ins_A xs = addAttributes xs . Child + +isindex_ :: ('Isindex ?> a) => a -> 'Isindex > a +isindex_ = Child + +isindex_A :: ('Isindex ?> a) => [(String, String)] -> a -> 'Isindex :> a +isindex_A xs = addAttributes xs . Child + +kbd_ :: ('Kbd ?> a) => a -> 'Kbd > a +kbd_ = Child + +kbd_A :: ('Kbd ?> a) => [(String, String)] -> a -> 'Kbd :> a +kbd_A xs = addAttributes xs . Child + +keygen_ :: ('Keygen ?> a) => a -> 'Keygen > a +keygen_ = Child + +keygen_A :: ('Keygen ?> a) => [(String, String)] -> a -> 'Keygen :> a +keygen_A xs = addAttributes xs . Child + +label_ :: ('Label ?> a) => a -> 'Label > a +label_ = Child + +label_A :: ('Label ?> a) => [(String, String)] -> a -> 'Label :> a +label_A xs = addAttributes xs . Child + +legend_ :: ('Legend ?> a) => a -> 'Legend > a +legend_ = Child + +legend_A :: ('Legend ?> a) => [(String, String)] -> a -> 'Legend :> a +legend_A xs = addAttributes xs . Child + +li_ :: ('Li ?> a) => a -> 'Li > a +li_ = Child + +li_A :: ('Li ?> a) => [(String, String)] -> a -> 'Li :> a +li_A xs = addAttributes xs . Child + +link_ :: 'Link > () +link_ = Child () + +link_A :: [(String, String)] -> 'Link :> () +link_A xs = addAttributes xs $ Child () + +listing_ :: ('Listing ?> a) => a -> 'Listing > a +listing_ = Child + +listing_A :: ('Listing ?> a) => [(String, String)] -> a -> 'Listing :> a +listing_A xs = addAttributes xs . Child + +main_ :: ('Main ?> a) => a -> 'Main > a +main_ = Child + +main_A :: ('Main ?> a) => [(String, String)] -> a -> 'Main :> a +main_A xs = addAttributes xs . Child + +map_ :: ('Map ?> a) => a -> 'Map > a +map_ = Child + +map_A :: ('Map ?> a) => [(String, String)] -> a -> 'Map :> a +map_A xs = addAttributes xs . Child + +mark_ :: ('Mark ?> a) => a -> 'Mark > a +mark_ = Child + +mark_A :: ('Mark ?> a) => [(String, String)] -> a -> 'Mark :> a +mark_A xs = addAttributes xs . Child + +marquee_ :: ('Marquee ?> a) => a -> 'Marquee > a +marquee_ = Child + +marquee_A :: ('Marquee ?> a) => [(String, String)] -> a -> 'Marquee :> a +marquee_A xs = addAttributes xs . Child + +math_ :: ('Math ?> a) => a -> 'Math > a +math_ = Child + +math_A :: ('Math ?> a) => [(String, String)] -> a -> 'Math :> a +math_A xs = addAttributes xs . Child + +menu_ :: ('Menu ?> a) => a -> 'Menu > a +menu_ = Child + +menu_A :: ('Menu ?> a) => [(String, String)] -> a -> 'Menu :> a +menu_A xs = addAttributes xs . Child + +menuitem_ :: 'Menuitem > () +menuitem_ = Child () + +menuitem_A :: [(String, String)] -> 'Menuitem :> () +menuitem_A xs = addAttributes xs $ Child () + +meta_ :: 'Meta > () +meta_ = Child () + +meta_A :: [(String, String)] -> 'Meta :> () +meta_A xs = addAttributes xs $ Child () + +meter_ :: ('Meter ?> a) => a -> 'Meter > a +meter_ = Child + +meter_A :: ('Meter ?> a) => [(String, String)] -> a -> 'Meter :> a +meter_A xs = addAttributes xs . Child + +multicol_ :: ('Multicol ?> a) => a -> 'Multicol > a +multicol_ = Child + +multicol_A :: ('Multicol ?> a) => [(String, String)] -> a -> 'Multicol :> a +multicol_A xs = addAttributes xs . Child + +nav_ :: ('Nav ?> a) => a -> 'Nav > a +nav_ = Child + +nav_A :: ('Nav ?> a) => [(String, String)] -> a -> 'Nav :> a +nav_A xs = addAttributes xs . Child + +nextid_ :: ('Nextid ?> a) => a -> 'Nextid > a +nextid_ = Child + +nextid_A :: ('Nextid ?> a) => [(String, String)] -> a -> 'Nextid :> a +nextid_A xs = addAttributes xs . Child + +nobr_ :: ('Nobr ?> a) => a -> 'Nobr > a +nobr_ = Child + +nobr_A :: ('Nobr ?> a) => [(String, String)] -> a -> 'Nobr :> a +nobr_A xs = addAttributes xs . Child + +noembed_ :: ('Noembed ?> a) => a -> 'Noembed > a +noembed_ = Child + +noembed_A :: ('Noembed ?> a) => [(String, String)] -> a -> 'Noembed :> a +noembed_A xs = addAttributes xs . Child + +noframes_ :: ('Noframes ?> a) => a -> 'Noframes > a +noframes_ = Child + +noframes_A :: ('Noframes ?> a) => [(String, String)] -> a -> 'Noframes :> a +noframes_A xs = addAttributes xs . Child + +noscript_ :: ('Noscript ?> a) => a -> 'Noscript > a +noscript_ = Child + +noscript_A :: ('Noscript ?> a) => [(String, String)] -> a -> 'Noscript :> a +noscript_A xs = addAttributes xs . Child + +object_ :: ('Object ?> a) => a -> 'Object > a +object_ = Child + +object_A :: ('Object ?> a) => [(String, String)] -> a -> 'Object :> a +object_A xs = addAttributes xs . Child + +ol_ :: ('Ol ?> a) => a -> 'Ol > a +ol_ = Child + +ol_A :: ('Ol ?> a) => [(String, String)] -> a -> 'Ol :> a +ol_A xs = addAttributes xs . Child + +optgroup_ :: ('Optgroup ?> a) => a -> 'Optgroup > a +optgroup_ = Child + +optgroup_A :: ('Optgroup ?> a) => [(String, String)] -> a -> 'Optgroup :> a +optgroup_A xs = addAttributes xs . Child + +option_ :: ('Option ?> a) => a -> 'Option > a +option_ = Child + +option_A :: ('Option ?> a) => [(String, String)] -> a -> 'Option :> a +option_A xs = addAttributes xs . Child + +output_ :: ('Output ?> a) => a -> 'Output > a +output_ = Child + +output_A :: ('Output ?> a) => [(String, String)] -> a -> 'Output :> a +output_A xs = addAttributes xs . Child + +p_ :: ('P ?> a) => a -> 'P > a +p_ = Child + +p_A :: ('P ?> a) => [(String, String)] -> a -> 'P :> a +p_A xs = addAttributes xs . Child + +param_ :: 'Param > () +param_ = Child () + +param_A :: [(String, String)] -> 'Param :> () +param_A xs = addAttributes xs $ Child () + +picture_ :: ('Picture ?> a) => a -> 'Picture > a +picture_ = Child + +picture_A :: ('Picture ?> a) => [(String, String)] -> a -> 'Picture :> a +picture_A xs = addAttributes xs . Child + +plaintext_ :: ('Plaintext ?> a) => a -> 'Plaintext > a +plaintext_ = Child + +plaintext_A :: ('Plaintext ?> a) => [(String, String)] -> a -> 'Plaintext :> a +plaintext_A xs = addAttributes xs . Child + +pre_ :: ('Pre ?> a) => a -> 'Pre > a +pre_ = Child + +pre_A :: ('Pre ?> a) => [(String, String)] -> a -> 'Pre :> a +pre_A xs = addAttributes xs . Child + +progress_ :: ('Progress ?> a) => a -> 'Progress > a +progress_ = Child + +progress_A :: ('Progress ?> a) => [(String, String)] -> a -> 'Progress :> a +progress_A xs = addAttributes xs . Child + +q_ :: ('Q ?> a) => a -> 'Q > a +q_ = Child + +q_A :: ('Q ?> a) => [(String, String)] -> a -> 'Q :> a +q_A xs = addAttributes xs . Child + +rp_ :: ('Rp ?> a) => a -> 'Rp > a +rp_ = Child + +rp_A :: ('Rp ?> a) => [(String, String)] -> a -> 'Rp :> a +rp_A xs = addAttributes xs . Child + +rt_ :: ('Rt ?> a) => a -> 'Rt > a +rt_ = Child + +rt_A :: ('Rt ?> a) => [(String, String)] -> a -> 'Rt :> a +rt_A xs = addAttributes xs . Child + +rtc_ :: ('Rtc ?> a) => a -> 'Rtc > a +rtc_ = Child + +rtc_A :: ('Rtc ?> a) => [(String, String)] -> a -> 'Rtc :> a +rtc_A xs = addAttributes xs . Child + +ruby_ :: ('Ruby ?> a) => a -> 'Ruby > a +ruby_ = Child + +ruby_A :: ('Ruby ?> a) => [(String, String)] -> a -> 'Ruby :> a +ruby_A xs = addAttributes xs . Child + +s_ :: ('S ?> a) => a -> 'S > a +s_ = Child + +s_A :: ('S ?> a) => [(String, String)] -> a -> 'S :> a +s_A xs = addAttributes xs . Child + +samp_ :: ('Samp ?> a) => a -> 'Samp > a +samp_ = Child + +samp_A :: ('Samp ?> a) => [(String, String)] -> a -> 'Samp :> a +samp_A xs = addAttributes xs . Child + +script_ :: ('Script ?> a) => a -> 'Script > a +script_ = Child + +script_A :: ('Script ?> a) => [(String, String)] -> a -> 'Script :> a +script_A xs = addAttributes xs . Child + +section_ :: ('Section ?> a) => a -> 'Section > a +section_ = Child + +section_A :: ('Section ?> a) => [(String, String)] -> a -> 'Section :> a +section_A xs = addAttributes xs . Child + +select_ :: ('Select ?> a) => a -> 'Select > a +select_ = Child + +select_A :: ('Select ?> a) => [(String, String)] -> a -> 'Select :> a +select_A xs = addAttributes xs . Child + +shadow_ :: ('Shadow ?> a) => a -> 'Shadow > a +shadow_ = Child + +shadow_A :: ('Shadow ?> a) => [(String, String)] -> a -> 'Shadow :> a +shadow_A xs = addAttributes xs . Child + +slot_ :: ('Slot ?> a) => a -> 'Slot > a +slot_ = Child + +slot_A :: ('Slot ?> a) => [(String, String)] -> a -> 'Slot :> a +slot_A xs = addAttributes xs . Child + +small_ :: ('Small ?> a) => a -> 'Small > a +small_ = Child + +small_A :: ('Small ?> a) => [(String, String)] -> a -> 'Small :> a +small_A xs = addAttributes xs . Child + +source_ :: 'Source > () +source_ = Child () + +source_A :: [(String, String)] -> 'Source :> () +source_A xs = addAttributes xs $ Child () + +spacer_ :: ('Spacer ?> a) => a -> 'Spacer > a +spacer_ = Child + +spacer_A :: ('Spacer ?> a) => [(String, String)] -> a -> 'Spacer :> a +spacer_A xs = addAttributes xs . Child + +span_ :: ('Span ?> a) => a -> 'Span > a +span_ = Child + +span_A :: ('Span ?> a) => [(String, String)] -> a -> 'Span :> a +span_A xs = addAttributes xs . Child + +strike_ :: ('Strike ?> a) => a -> 'Strike > a +strike_ = Child + +strike_A :: ('Strike ?> a) => [(String, String)] -> a -> 'Strike :> a +strike_A xs = addAttributes xs . Child + +strong_ :: ('Strong ?> a) => a -> 'Strong > a +strong_ = Child + +strong_A :: ('Strong ?> a) => [(String, String)] -> a -> 'Strong :> a +strong_A xs = addAttributes xs . Child + +style_ :: ('Style ?> a) => a -> 'Style > a +style_ = Child + +style_A :: ('Style ?> a) => [(String, String)] -> a -> 'Style :> a +style_A xs = addAttributes xs . Child + +sub_ :: ('Sub ?> a) => a -> 'Sub > a +sub_ = Child + +sub_A :: ('Sub ?> a) => [(String, String)] -> a -> 'Sub :> a +sub_A xs = addAttributes xs . Child + +summary_ :: ('Summary ?> a) => a -> 'Summary > a +summary_ = Child + +summary_A :: ('Summary ?> a) => [(String, String)] -> a -> 'Summary :> a +summary_A xs = addAttributes xs . Child + +sup_ :: ('Sup ?> a) => a -> 'Sup > a +sup_ = Child + +sup_A :: ('Sup ?> a) => [(String, String)] -> a -> 'Sup :> a +sup_A xs = addAttributes xs . Child + +svg_ :: ('Svg ?> a) => a -> 'Svg > a +svg_ = Child + +svg_A :: ('Svg ?> a) => [(String, String)] -> a -> 'Svg :> a +svg_A xs = addAttributes xs . Child + +table_ :: ('Table ?> a) => a -> 'Table > a +table_ = Child + +table_A :: ('Table ?> a) => [(String, String)] -> a -> 'Table :> a +table_A xs = addAttributes xs . Child + +tbody_ :: ('Tbody ?> a) => a -> 'Tbody > a +tbody_ = Child + +tbody_A :: ('Tbody ?> a) => [(String, String)] -> a -> 'Tbody :> a +tbody_A xs = addAttributes xs . Child + +td_ :: ('Td ?> a) => a -> 'Td > a +td_ = Child + +td_A :: ('Td ?> a) => [(String, String)] -> a -> 'Td :> a +td_A xs = addAttributes xs . Child + +template_ :: ('Template ?> a) => a -> 'Template > a +template_ = Child + +template_A :: ('Template ?> a) => [(String, String)] -> a -> 'Template :> a +template_A xs = addAttributes xs . Child + +textarea_ :: ('Textarea ?> a) => a -> 'Textarea > a +textarea_ = Child + +textarea_A :: ('Textarea ?> a) => [(String, String)] -> a -> 'Textarea :> a +textarea_A xs = addAttributes xs . Child + +tfoot_ :: ('Tfoot ?> a) => a -> 'Tfoot > a +tfoot_ = Child + +tfoot_A :: ('Tfoot ?> a) => [(String, String)] -> a -> 'Tfoot :> a +tfoot_A xs = addAttributes xs . Child + +th_ :: ('Th ?> a) => a -> 'Th > a +th_ = Child + +th_A :: ('Th ?> a) => [(String, String)] -> a -> 'Th :> a +th_A xs = addAttributes xs . Child + +thead_ :: ('Thead ?> a) => a -> 'Thead > a +thead_ = Child + +thead_A :: ('Thead ?> a) => [(String, String)] -> a -> 'Thead :> a +thead_A xs = addAttributes xs . Child + +time_ :: ('Time ?> a) => a -> 'Time > a +time_ = Child + +time_A :: ('Time ?> a) => [(String, String)] -> a -> 'Time :> a +time_A xs = addAttributes xs . Child + +title_ :: ('Title ?> a) => a -> 'Title > a +title_ = Child + +title_A :: ('Title ?> a) => [(String, String)] -> a -> 'Title :> a +title_A xs = addAttributes xs . Child + +tr_ :: ('Tr ?> a) => a -> 'Tr > a +tr_ = Child + +tr_A :: ('Tr ?> a) => [(String, String)] -> a -> 'Tr :> a +tr_A xs = addAttributes xs . Child + +track_ :: 'Track > () +track_ = Child () + +track_A :: [(String, String)] -> 'Track :> () +track_A xs = addAttributes xs $ Child () + +tt_ :: ('Tt ?> a) => a -> 'Tt > a +tt_ = Child + +tt_A :: ('Tt ?> a) => [(String, String)] -> a -> 'Tt :> a +tt_A xs = addAttributes xs . Child + +u_ :: ('U ?> a) => a -> 'U > a +u_ = Child + +u_A :: ('U ?> a) => [(String, String)] -> a -> 'U :> a +u_A xs = addAttributes xs . Child + +ul_ :: ('Ul ?> a) => a -> 'Ul > a +ul_ = Child + +ul_A :: ('Ul ?> a) => [(String, String)] -> a -> 'Ul :> a +ul_A xs = addAttributes xs . Child + +var_ :: ('Var ?> a) => a -> 'Var > a +var_ = Child + +var_A :: ('Var ?> a) => [(String, String)] -> a -> 'Var :> a +var_A xs = addAttributes xs . Child + +video_ :: ('Video ?> a) => a -> 'Video > a +video_ = Child + +video_A :: ('Video ?> a) => [(String, String)] -> a -> 'Video :> a +video_A xs = addAttributes xs . Child + +wbr_ :: 'Wbr > () +wbr_ = Child () + +wbr_A :: [(String, String)] -> 'Wbr :> () +wbr_A xs = addAttributes xs $ Child () + +xmp_ :: ('Xmp ?> a) => a -> 'Xmp > a +xmp_ = Child + +xmp_A :: ('Xmp ?> a) => [(String, String)] -> a -> 'Xmp :> a +xmp_A xs = addAttributes xs . Child diff --git a/src/Html/Function.hs b/src/Html/Function.hs new file mode 100644 --- /dev/null +++ b/src/Html/Function.hs @@ -0,0 +1,422 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module Html.Function where + +import Html.Type + +import GHC.Exts +import GHC.TypeLits +import Data.Proxy +import Data.Monoid hiding (Last) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as TLB + +-- | Render a html document. The resulting type can be a String, +-- strict Text, lazy Text, or Builder. For performance it is +-- recommended to use a lazy Text or a Builder. +-- +-- >>> render "a" :: String +-- "a" +-- +-- >>> render (div_ "a") :: Text +-- "
a
" +-- +-- For prototyping, there's as well a Show instance: +-- +-- >>> i_ "a" +-- a +-- +-- Please note the extra quotes for String when using show: +-- +-- >>> show "a" == render "a" +-- False +-- +-- >>> show img_ == render img_ +-- True + +{-# INLINE render #-} +render :: forall a b. + ( Document a + , Escape b + , Monoid b + , IsString b + ) => a -> b +render x = render_ (Tagged x :: Tagged (Symbols a) a ()) + + ------------------- + -- internal code -- + ------------------- + +type Document a = + ( Renderchunks (Tagged (Symbols a) a ()) + , Renderstring (Tagged (Symbols a) a ()) + , KnownSymbol (Last' (Symbols a)) + ) + +{-# RULES +"render_/renderB" render_ = renderB +"render_/renderS" render_ = renderS +"render_/renderLT" render_ = renderLT +#-} + +{-# INLINE [2] render_ #-} +render_ :: forall b prox val nex. + ( KnownSymbol (Last' prox) + , Renderstring (Tagged prox val nex) + , Renderchunks (Tagged prox val nex) + , Escape b + , Monoid b + , IsString b + ) => Tagged prox val nex -> b +render_ x = mconcat $ renderchunks x ++ [closing] + where closing = convert (Proxy :: Proxy (Last' prox)) + +{-# INLINE renderLT #-} +renderLT :: forall prox val nex. + ( KnownSymbol (Last' prox) + , Renderchunks (Tagged prox val nex) + ) => Tagged prox val nex -> LT.Text +renderLT x = mconcat $ renderchunks x ++ [closing] + where closing = convert (Proxy :: Proxy (Last' prox)) + +{-# INLINE renderS #-} +renderS :: forall prox val nex. + ( KnownSymbol (Last' prox) + , Renderchunks (Tagged prox val nex) + ) => Tagged prox val nex -> String +renderS x = foldr (<>) closing $ renderchunks x + where closing = convert (Proxy :: Proxy (Last' prox)) + +{-# INLINE renderB #-} +renderB :: forall prox val nex. + ( KnownSymbol (Last' prox) + , Renderstring (Tagged prox val nex) + ) => Tagged prox val nex -> TLB.Builder +renderB x = renderstring x <> closing + where closing = convert (Proxy :: Proxy (Last' prox)) + +{-# INLINE addAttributes #-} +addAttributes :: (a ?> b) => [(String, String)] -> (a > b) -> (a :> b) +addAttributes xs (Child b) = WithAttributes (Attributes xs) b + +class Renderchunks a where + renderchunks :: (Escape b, IsString b, Monoid b) => a -> [b] + +instance KnownSymbol a => Renderchunks (Tagged prox (Proxy a) nex) where + {-# INLINE renderchunks #-} + renderchunks _ = [] + +instance {-# OVERLAPPABLE #-} + ( Convert val + , KnownSymbol (HeadL prox) + ) => Renderchunks (Tagged prox val nex) where + {-# INLINE renderchunks #-} + renderchunks (Tagged x) + = convert (Proxy :: Proxy (HeadL prox)) + : [convert x] + +instance Renderchunks (Tagged prox () nex) where + {-# INLINE renderchunks #-} + renderchunks _ = [] + +instance + ( Renderchunks (Tagged (Take (CountContent a) prox) a b) + , Renderchunks (Tagged (Drop (CountContent a) prox) b nex) + ) => Renderchunks (Tagged prox (a # b) nex) where + {-# INLINE renderchunks #-} + renderchunks ~(Tagged (a :#: b)) + = renderchunks (Tagged a :: Tagged (Take (CountContent a) prox) a b) + <> renderchunks (Tagged b :: Tagged (Drop (CountContent a) prox) b nex) + +instance {-# OVERLAPPING #-} + ( Renderchunks (Tagged (Drop 1 prox) (a > b) nex) + , KnownSymbol (HeadL prox) + , a ?> b + ) => Renderchunks (Tagged prox (a :> b) nex) where + {-# INLINE renderchunks #-} + renderchunks ~(Tagged (WithAttributes a b)) + = convert (Proxy :: Proxy (HeadL prox)) + : convert a + : renderchunks (Tagged (Child b) :: Tagged (Drop 1 prox) (a > b) nex) + +instance + ( Renderchunks (Tagged prox b (Close a)) + ) => Renderchunks (Tagged prox (a > b) nex) where + {-# INLINE renderchunks #-} + renderchunks ~(Tagged (Child b)) + = renderchunks (Tagged b :: Tagged prox b (Close a)) + +instance + ( Renderchunks (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ()) + , KnownSymbol (Last' (Symbols (Next (a :> b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderchunks (Tagged prox [a :> b] nex) where + {-# INLINE renderchunks #-} + renderchunks (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + : concatMap + (\x -> renderchunks + (Tagged x :: Tagged (Symbols (Next (a :> b) nex)) (a :> b) ()) + ++ [closing] + ) xs + where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a :> b) nex)))) + +instance + ( Renderchunks (Tagged (Symbols (Next (a > b) nex)) (a > b) ()) + , KnownSymbol (Last' (Symbols (Next (a > b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderchunks (Tagged prox [a > b] nex) where + {-# INLINE renderchunks #-} + renderchunks (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + : concatMap + (\x -> renderchunks + (Tagged x :: Tagged (Symbols (Next (a > b) nex)) (a > b) ()) + ++ [closing] + ) xs + where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a > b) nex)))) + +instance + ( Renderchunks (Tagged (Symbols (Next (a # b) nex)) (a # b) ()) + , KnownSymbol (Last' (Symbols (Next (a # b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderchunks (Tagged prox [a # b] nex) where + {-# INLINE renderchunks #-} + renderchunks (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + : concatMap + (\x -> renderchunks + (Tagged x :: Tagged (Symbols (Next (a # b) nex)) (a # b) ()) + ++ [closing] + ) xs + where closing = convert (Proxy :: Proxy (Last' (Symbols (Next (a # b) nex)))) + +class Renderstring a where + renderstring :: (Escape b, IsString b, Monoid b) => a -> b + +instance KnownSymbol a => Renderstring (Tagged prox (Proxy a) nex) where + {-# INLINE renderstring #-} + renderstring _ = mempty + +instance {-# OVERLAPPABLE #-} + ( Convert val + , KnownSymbol (HeadL prox) + ) => Renderstring (Tagged prox val nex) where + {-# INLINE renderstring #-} + renderstring (Tagged x) + = convert (undefined :: Proxy (HeadL prox)) + <> convert x + +instance Renderstring (Tagged prox () nex) where + {-# INLINE renderstring #-} + renderstring _ = mempty + +instance + ( Renderstring (Tagged (Take (CountContent a) prox) a b) + , Renderstring (Tagged (Drop (CountContent a) prox) b nex) + ) => Renderstring (Tagged prox (a # b) nex) where + {-# INLINE renderstring #-} + renderstring ~(Tagged (a :#: b)) + = renderstring (Tagged a :: Tagged (Take (CountContent a) prox) a b) + <> renderstring (Tagged b :: Tagged (Drop (CountContent a) prox) b nex) + +instance {-# OVERLAPPING #-} + ( Renderstring (Tagged (Drop 1 prox) (a > b) nex) + , KnownSymbol (HeadL prox) + , a ?> b + ) => Renderstring (Tagged prox (a :> b) nex) where + {-# INLINE renderstring #-} + renderstring ~(Tagged (WithAttributes a b)) + = convert (Proxy :: Proxy (HeadL prox)) + <> convert a + <> renderstring (Tagged (Child b) :: Tagged (Drop 1 prox) (a > b) nex) + +instance + ( Renderstring (Tagged prox b (Close a)) + ) => Renderstring (Tagged prox (a > b) nex) where + {-# INLINE renderstring #-} + renderstring ~(Tagged (Child b)) + = renderstring (Tagged b :: Tagged prox b (Close a)) + +instance + ( Renderstring (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ()) + , Renderchunks (Tagged (Symbols (Next (a :> b) nex)) (a :> b) ()) + , KnownSymbol (Last' (Symbols (Next (a :> b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderstring (Tagged prox [a :> b] nex) where + {-# INLINE renderstring #-} + renderstring (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + <> foldMap + (\x -> + render_ + (Tagged x :: Tagged (Symbols (Next (a :> b) nex)) (a :> b) ()) + ) xs + +instance + ( Renderstring (Tagged (Symbols (Next (a > b) nex)) (a > b) ()) + , Renderchunks (Tagged (Symbols (Next (a > b) nex)) (a > b) ()) + , KnownSymbol (Last' (Symbols (Next (a > b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderstring (Tagged prox [a > b] nex) where + {-# INLINE renderstring #-} + renderstring (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + <> foldMap + (\x -> + render_ + (Tagged x :: Tagged (Symbols (Next (a > b) nex)) (a > b) ()) + ) xs + +instance + ( Renderstring (Tagged (Symbols (Next (a # b) nex)) (a # b) ()) + , Renderchunks (Tagged (Symbols (Next (a # b) nex)) (a # b) ()) + , KnownSymbol (Last' (Symbols (Next (a # b) nex))) + , KnownSymbol (HeadL prox) + ) => Renderstring (Tagged prox [a # b] nex) where + {-# INLINE renderstring #-} + renderstring (Tagged xs) + = convert (undefined :: Proxy (HeadL prox)) + <> foldMap + (\x -> + render_ + (Tagged x :: Tagged (Symbols (Next (a # b) nex)) (a # b) ()) + ) xs + +{-# RULES +"fromString_/builder" fromString_ = TLB.fromLazyText . LT.pack + #-} + +{-# INLINE [2] fromString_ #-} +fromString_ :: IsString a => String -> a +fromString_ = fromString + +{-# RULES +"convert/a/a" forall f. convert_ f = escape +"convert/string/builder" forall f. convert_ f = TLB.fromLazyText . escape . LT.pack +"convert/lazy text/builder" forall f. convert_ f = TLB.fromLazyText . escape +"convert/strict text/builder" forall f. convert_ f = TLB.fromText . escape +"convert/builder/lazy text" forall f. convert_ f = escape . TLB.toLazyText +"convert/lazy text/strict text" forall f. convert_ f = LT.toStrict . escape +"convert/strict text/lazy text" forall f. convert_ f = escape . LT.fromStrict + #-} + +{-# INLINE [1] convert_ #-} +convert_ :: (Escape b, IsString a, IsString b) => (a -> b) -> (a -> b) +convert_ f = escape . f + +class (IsString a, Monoid a) => Escape a where + escape :: a -> a + +instance Escape TLB.Builder where + + escape + = TLB.fromLazyText + . escape + . TLB.toLazyText + +instance Escape T.Text where + + escape = T.foldr f mempty + where + f '<' b = "<" <> b + f '>' b = ">" <> b + f '&' b = "&" <> b + f '"' b = """ <> b + f '\'' b = "'" <> b + f x b = T.singleton x <> b + +instance Escape LT.Text where + + escape = foldr (<>) "" . LT.foldr f [] + where + f '<' b = "<" : b + f '>' b = ">" : b + f '&' b = "&" : b + f '"' b = """ : b + f '\'' b = "'" : b + f x b = LT.singleton x : b + +instance Escape String where + + escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '&' = "&" + f '"' = """ + f '\'' = "'" + f x = [x] + +-- | Convert something to a target stringlike thing. +class Convert a where + convert :: (Escape b, IsString b, Monoid b) => a -> b + +instance KnownSymbol a => Convert (Proxy a) where + {-# INLINE convert #-} + convert = fromString_ . symbolVal + +instance Convert a => Convert (Maybe a) where + {-# INLINE convert #-} + convert Nothing = "" + convert (Just x) = convert x + +instance Convert Attributes where + {-# INLINE convert #-} + convert ~(Attributes xs) = fromString $ concat [ ' ' : a ++ "=\"" ++ escape b ++ "\"" | (a,b) <- xs] + +instance Convert String where + {-# INLINE convert #-} + convert = convert_ fromString + +instance Convert T.Text where + {-# INLINE convert #-} + convert = convert_ (fromString . T.unpack) + +instance Convert LT.Text where + {-# INLINE convert #-} + convert = convert_ (fromString . LT.unpack) + +instance Convert TLB.Builder where + {-# INLINE convert #-} + convert = convert_ (fromString . LT.unpack . TLB.toLazyText) + +instance Convert Int where + {-# INLINE convert #-} + convert = fromString . show + +instance Convert Integer where + {-# INLINE convert #-} + convert = fromString . show + +instance Convert Float where + {-# INLINE convert #-} + convert = fromString . show + +instance Convert Double where + {-# INLINE convert #-} + convert = fromString . show + +instance Convert Word where + {-# INLINE convert #-} + convert = fromString . show + +-- | Orphan show instances to faciliate ghci development. +instance Document (a # b) => Show (a # b) where show = render +instance {-# OVERLAPPING #-} Document [a # b] => Show [a # b] where show = render +instance Document (a > b) => Show (a > b) where show = render +instance {-# OVERLAPPING #-} Document [a > b] => Show [a > b] where show = render +instance Document (a :> b) => Show (a :> b) where show = render +instance {-# OVERLAPPING #-} Document [a :> b] => Show [a :> b] where show = render diff --git a/src/Html/Type.hs b/src/Html/Type.hs new file mode 100644 --- /dev/null +++ b/src/Html/Type.hs @@ -0,0 +1,1208 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Html.Type where + +import GHC.TypeLits +import GHC.Exts +import Data.Proxy +import Data.Type.Bool + +{-# DEPRECATED + + Acronym , + Applet , + Basefont , + Big , + Blink , + Center , + Command , + Content , + Dir , + Font , + Frame , + Frameset , + Isindex , + Keygen , + Listing , + Marquee , + Multicol , + Noembed , + Plaintext , + Shadow , + Spacer , + Strike , + Tt , + Xmp , + Nextid + + "This is an obsolete html element and should not be used." #-} + +-- | The data type of all html elements and the kind of elements. +data Element + = DOCTYPE + + | A + | Abbr + | Acronym + | Address + | Applet + | Area + | Article + | Aside + | Audio + | B + | Base + | Basefont + | Bdi + | Bdo + | Bgsound + | Big + | Blink + | Blockquote + | Body + | Br + | Button + | Canvas + | Caption + | Center + | Cite + | Code + | Col + | Colgroup + | Command + | Content + | Data + | Datalist + | Dd + | Del + | Details + | Dfn + | Dialog + | Dir + | Div + | Dl + | Dt + | Element + | Em + | Embed + | Fieldset + | Figcaption + | Figure + | Font + | Footer + | Form + | Frame + | Frameset + | H1 + | H2 + | H3 + | H4 + | H5 + | H6 + | Head + | Header + | Hgroup + | Hr + | Html + | I + | Iframe + | Image + | Img + | Input + | Ins + | Isindex + | Kbd + | Keygen + | Label + | Legend + | Li + | Link + | Listing + | Main + | Map + | Mark + | Marquee + | Math + | Menu + | Menuitem + | Meta + | Meter + | Multicol + | Nav + | Nextid + | Nobr + | Noembed + | Noframes + | Noscript + | Object + | Ol + | Optgroup + | Option + | Output + | P + | Param + | Picture + | Plaintext + | Pre + | Progress + | Q + | Rp + | Rt + | Rtc + | Ruby + | S + | Samp + | Script + | Section + | Select + | Shadow + | Slot + | Small + | Source + | Spacer + | Span + | Strike + | Strong + | Style + | Sub + | Summary + | Sup + | Svg + | Table + | Tbody + | Td + | Template + | Textarea + | Tfoot + | Th + | Thead + | Time + | Title + | Tr + | Track + | Tt + | U + | Ul + | Var + | Video + | Wbr + | Xmp + +-- | Check whether `b` is a valid child of `a`. You'll propably never +-- need to call this directly. Through a GADT, it is enforced that +-- every child is lawful. +-- +-- The only way to circumvent this would be to use 'undefined' or +-- 'error' in combination with only type level values. +-- +-- >>> undefined :: 'Div > ('Html > ()) +--
+-- +-- >>> undefined :: 'Div > ('Html > Proxy "a") +--
a
+-- +-- >>> undefined :: 'Div > ('Html > String) +--
*** Exception: Prelude.undefined +type family (a :: Element) ?> b :: Constraint where + a ?> (b # c) = (a ?> b, a ?> c) + a ?> (b > _) = MaybeTypeError a b (TestPaternity (SingleElement b) (GetInfo a) (GetInfo b)) + a ?> (b :> _) = MaybeTypeError a b (TestPaternity (SingleElement b) (GetInfo a) (GetInfo b)) + a ?> Maybe b = a ?> b + a ?> Either b c = (a ?> b, a ?> c) + a ?> f (b > c) = a ?> (b > c) + a ?> f (b :> c) = a ?> (b > c) + a ?> f (b # c) = a ?> (b # c) + a ?> () = () + a ?> (b -> c) = (TypeError (Text "Html elements can't contain functions")) + a ?> b = CheckString a + +-- | Combine two elements sequentially. +-- +-- >>> render (i_ () # div_ ()) :: String +-- "
" +data (#) a b = (:#:) a b +(#) :: a -> b -> a # b +(#) = (:#:) +infixr 5 # + +-- | Descend to a valid child of an element. +-- It is recommended to use the predefined elements. +-- +-- >>> Child "a" :: 'Div > String +--
a
+-- +-- >>> div_ "a" +--
a
+data (>) (a :: Element) b where + Child :: (a ?> b) => b -> a > b +infixr 8 > + +-- | Decorate an element with attributes and descend to a valid child. +-- +-- >>> WithAttributes [("foo","bar")] "a" :: 'Div :> String +--
a
+data (:>) (a :: Element) b where + WithAttributes :: (a ?> b) => Attributes -> b -> a :> b +infixr 8 :> + + ------------------- + -- internal code -- + ------------------- + +type family ShowElement e where + ShowElement DOCTYPE = "!DOCTYPE html" + ShowElement A = "a" + ShowElement Abbr = "abbr" + ShowElement Acronym = "acronym" + ShowElement Address = "address" + ShowElement Applet = "applet" + ShowElement Area = "area" + ShowElement Article = "article" + ShowElement Aside = "aside" + ShowElement Audio = "audio" + ShowElement B = "b" + ShowElement Base = "base" + ShowElement Basefont = "basefont" + ShowElement Bdi = "bdi" + ShowElement Bdo = "bdo" + ShowElement Bgsound = "bgsound" + ShowElement Big = "big" + ShowElement Blink = "blink" + ShowElement Blockquote = "blockquote" + ShowElement Body = "body" + ShowElement Br = "br" + ShowElement Button = "button" + ShowElement Canvas = "canvas" + ShowElement Caption = "caption" + ShowElement Center = "center" + ShowElement Cite = "cite" + ShowElement Code = "code" + ShowElement Col = "col" + ShowElement Colgroup = "colgroup" + ShowElement Command = "command" + ShowElement Content = "content" + ShowElement Data = "data" + ShowElement Datalist = "datalist" + ShowElement Dd = "dd" + ShowElement Del = "del" + ShowElement Details = "details" + ShowElement Dfn = "dfn" + ShowElement Dialog = "dialog" + ShowElement Dir = "dir" + ShowElement Div = "div" + ShowElement Dl = "dl" + ShowElement Dt = "dt" + ShowElement 'Element = "element" + ShowElement Em = "em" + ShowElement Embed = "embed" + ShowElement Fieldset = "fieldset" + ShowElement Figcaption = "figcaption" + ShowElement Figure = "figure" + ShowElement Font = "font" + ShowElement Footer = "footer" + ShowElement Form = "form" + ShowElement Frame = "frame" + ShowElement Frameset = "frameset" + ShowElement H1 = "h1" + ShowElement H2 = "h2" + ShowElement H3 = "h3" + ShowElement H4 = "h4" + ShowElement H5 = "h5" + ShowElement H6 = "h6" + ShowElement Head = "head" + ShowElement Header = "header" + ShowElement Hgroup = "hgroup" + ShowElement Hr = "hr" + ShowElement Html = "html" + ShowElement I = "i" + ShowElement Iframe = "iframe" + ShowElement Image = "image" + ShowElement Img = "img" + ShowElement Input = "input" + ShowElement Ins = "ins" + ShowElement Isindex = "isindex" + ShowElement Kbd = "kbd" + ShowElement Keygen = "keygen" + ShowElement Label = "label" + ShowElement Legend = "legend" + ShowElement Li = "li" + ShowElement Link = "link" + ShowElement Listing = "listing" + ShowElement Main = "main" + ShowElement Map = "map" + ShowElement Mark = "mark" + ShowElement Marquee = "marquee" + ShowElement Math = "math" + ShowElement Menu = "menu" + ShowElement Menuitem = "menuitem" + ShowElement Meta = "meta" + ShowElement Meter = "meter" + ShowElement Multicol = "multicol" + ShowElement Nav = "nav" + ShowElement Nextid = "nextid" + ShowElement Nobr = "nobr" + ShowElement Noembed = "noembed" + ShowElement Noframes = "noframes" + ShowElement Noscript = "noscript" + ShowElement Object = "object" + ShowElement Ol = "ol" + ShowElement Optgroup = "optgroup" + ShowElement Option = "option" + ShowElement Output = "output" + ShowElement P = "p" + ShowElement Param = "param" + ShowElement Picture = "picture" + ShowElement Plaintext = "plaintext" + ShowElement Pre = "pre" + ShowElement Progress = "progress" + ShowElement Q = "q" + ShowElement Rp = "rp" + ShowElement Rt = "rt" + ShowElement Rtc = "rtc" + ShowElement Ruby = "ruby" + ShowElement S = "s" + ShowElement Samp = "samp" + ShowElement Script = "script" + ShowElement Section = "section" + ShowElement Select = "select" + ShowElement Shadow = "shadow" + ShowElement Slot = "slot" + ShowElement Small = "small" + ShowElement Source = "source" + ShowElement Spacer = "spacer" + ShowElement Span = "span" + ShowElement Strike = "strike" + ShowElement Strong = "strong" + ShowElement Style = "style" + ShowElement Sub = "sub" + ShowElement Summary = "summary" + ShowElement Sup = "sup" + ShowElement Svg = "svg" + ShowElement Table = "table" + ShowElement Tbody = "tbody" + ShowElement Td = "td" + ShowElement Template = "template" + ShowElement Textarea = "textarea" + ShowElement Tfoot = "tfoot" + ShowElement Th = "th" + ShowElement Thead = "thead" + ShowElement Time = "time" + ShowElement Title = "title" + ShowElement Tr = "tr" + ShowElement Track = "track" + ShowElement Tt = "tt" + ShowElement U = "u" + ShowElement Ul = "ul" + ShowElement Var = "var" + ShowElement Video = "video" + ShowElement Wbr = "wbr" + ShowElement Xmp = "xmp" + +type family OpenTag e where + OpenTag e = AppendSymbol (AppendSymbol "<" (ShowElement e)) ">" + +type family CloseTag e where + CloseTag e = AppendSymbol (AppendSymbol "" + +type family CountContent c where + CountContent (a # b) = CountContent a + CountContent b + CountContent (a > b) = CountContent b + CountContent (a :> b) = 1 + CountContent b + CountContent () = 0 + CountContent _ = 1 + +-- | Flatten a html tree of elements into a type list of tags. +type family ToTypeList a where + ToTypeList (Next val nex) = Next (ToTypeList val) (ToTypeList nex) + ToTypeList (a # b) = Append (ToTypeList a) (ToTypeList b) + ToTypeList (a > ()) = If (HasContent (GetInfo a)) (Open a, Close a) (Open a) + ToTypeList (a :> ()) = If (HasContent (GetInfo a)) (OpenAttr a, (Attributes, (EndOfOpen, Close a))) (OpenAttr a, (Attributes, EndOfOpen)) + ToTypeList (a > b) = Append (Open a, ToTypeList b) (Close a) + ToTypeList (a :> b) = Append (OpenAttr a, (Attributes, (EndOfOpen, ToTypeList b))) (Close a) + ToTypeList x = x + +-- | Append two type lists. +type family Append a b where + Append (a, b) c = (a, Append b c) + Append a b = (a, b) + +-- | Check whether an element may have content. +type family HasContent a where + HasContent (ElementInfo _ NoContent _) = False + HasContent _ = True + +-- | Remove omittable and empty tags from a type list of tags. +type family PruneTags a where + PruneTags ((), a) = PruneTags a + PruneTags (a , ()) = PruneTags a + PruneTags (Close a, b) = IsOmittable (GetInfo a) (Close a, b) + PruneTags (Next a b) = IsOmittableL (Head' (PruneTags a)) (PruneTags a) (Last (PruneTags a)) b + PruneTags (a, b) = (a, PruneTags b) + PruneTags a = a + +data Next v nex + +type family IsOmittableL head val last next where + IsOmittableL (OpenAttr head) val (Close last) (Close next) = IsOmittable2 (Open head) val (GetInfo last) (Close next) + IsOmittableL (Open head) val (Close last) (Close next) = IsOmittable2 (Open head) val (GetInfo last) (Close next) + +-- Base case + IsOmittableL _head val _last next = val + +type family IsOmittable2 head list last next where + IsOmittable2 + (Open head) + val + (ElementInfo _ _ (LastChildOrFollowedBy (head ': _))) -- last + (Close next) + = Init val + + IsOmittable2 + (Open head) + val + (ElementInfo a b (LastChildOrFollowedBy (_ ': xs))) -- last + (Close next) + = IsOmittable2 (Open head) val (ElementInfo a b (LastChildOrFollowedBy xs)) (Close next) + +-- Base case + IsOmittable2 + _head + val + _last + next + = val + +-- | Checks whether a tag is omittable. Sadly, returning a kind Bool +-- would make the compiler loop, so we inline the if into the type +-- function. +type family IsOmittable a b where + IsOmittable (ElementInfo _ _ RightOmission) (_,c) = PruneTags c + IsOmittable (ElementInfo _ _ (LastChildOrFollowedBy _)) (_,(Close b, c)) = PruneTags (Close b, c) + IsOmittable (ElementInfo _ _ (LastChildOrFollowedBy _)) (_,Close b) = Close b + IsOmittable (ElementInfo _ _ (LastChildOrFollowedBy '[])) (b,c) = (b, PruneTags c) + IsOmittable (ElementInfo _ _ (LastChildOrFollowedBy (x ': _))) (c, (Open x, d)) = PruneTags (Open x, d) + IsOmittable (ElementInfo _ _ (LastChildOrFollowedBy (x ': _))) (c, (OpenAttr x, d)) = PruneTags (OpenAttr x, d) + IsOmittable (ElementInfo a b (LastChildOrFollowedBy (_ ': xs))) c = IsOmittable (ElementInfo a b (LastChildOrFollowedBy xs)) c + IsOmittable _ (c,d) = (c, PruneTags d) + +-- | Convert tags to type level strings. +type family RenderTags a where + RenderTags (a, b) = (RenderTags a, RenderTags b) + RenderTags (Open a) = Proxy (OpenTag a) + RenderTags (OpenAttr a) = Proxy (AppendSymbol "<" (ShowElement a)) + RenderTags (Close a) = Proxy (CloseTag a) + RenderTags EndOfOpen = Proxy ">" + RenderTags a = a + +-- | Fuse neighbouring type level strings. +type family Fuse a where + Fuse (Proxy (a :: Symbol), (Proxy (b :: Symbol), c)) = Fuse (Proxy (AppendSymbol a b), c) + Fuse (Proxy (a :: Symbol), Proxy (b :: Symbol)) = '[AppendSymbol a b] + Fuse (Proxy (a :: Symbol), (b,c)) = a ': Fuse c + Fuse (Proxy (a :: Symbol), b) = a ': Fuse b + Fuse (Proxy (a :: Symbol)) = '[a] + Fuse (a, b) = "" ': Fuse b + Fuse a = '[""] + +type family Drop n xs :: [Symbol] where + Drop 0 xs = xs + Drop 1 (_ ': xs) = xs + Drop 2 (_ ': _ ': xs) = xs + Drop 3 (_ ': _ ': _ ': xs) = xs + Drop 4 (_ ': _ ': _ ': _ ': xs) = xs + Drop n (_ ': _ ': _ ': _ ': _ ': xs) = Drop (n-5) xs + +type family Take n xs :: [Symbol] where + Take 0 _ = '[] + Take 1 (x1 ': _) = '[x1] + Take 2 (x1 ': x2 ': _) = [x1,x2] + Take 3 (x1 ': x2 ': x3 ': _) = [x1,x2,x3] + Take 4 (x1 ': x2 ': x3 ': x4 ': _) = [x1,x2,x3,x4] + Take n (x1 ': x2 ': x3 ': x4 ': x5 ': xs) = x1 ': x2 ': x3 ': x4 ': x5 ': Take (n-5) xs + +-- | Init for type level lists. +type family Init xs where + Init (a, (b, (c, d))) = (a, (b, Init (c, d))) + Init (a, (b,c)) = (a, b) + Init (a, b) = a + Init a = a + +-- | Last for type level lists. +type family Last a where + Last (a, (b, (c, d))) = Last d + Last (a, (b, c)) = c + Last (a, b) = b + Last a = a + +-- | Last for type level lists. +type family Last' (xs :: [Symbol]) where + Last' (_ ': _ ': _ ': _ ': x ': xs) = Last' (x ': xs) + Last' (_ ': _ ': _ ': x ': xs) = x + Last' (_ ': _ ': x ': xs) = x + Last' (_ ': x ': xs) = x + Last' (x ': xs) = x + Last' _ = "" + +-- | Head for type level lists. +type family Head' a where + Head' (a, as) = a + Head' a = a + +type family HeadL a :: Symbol where + HeadL (a ': _) = a + +-- | Utility types. +data EndOfOpen +data Open (a :: Element) +data OpenAttr (a :: Element) +data Close (a :: Element) +newtype Attributes = Attributes [(String, String)] + +-- | Type of type level information about tags. +data ElementInfo + (contentCategories :: [ContentCategory]) + (permittedContent :: ContentCategory) + (tagOmission :: TagOmission) + +-- | Kind describing whether it is valid to delete a closing tag. +data TagOmission + = NoOmission + | RightOmission + | LastChildOrFollowedBy [Element] + +type family TestPaternity a b c :: Bool where + TestPaternity a (ElementInfo _ ps _) (ElementInfo cs _ _) = CheckContentCategory ps (a ': cs) + +type family CheckContentCategory (a :: ContentCategory) (b :: [ContentCategory]) :: Bool where + CheckContentCategory (a :|: b) c = CheckContentCategory a c || CheckContentCategory b c + CheckContentCategory (a :&: b) c = CheckContentCategory a c && CheckContentCategory b c + CheckContentCategory (NOT a) c = Not (CheckContentCategory a c) + CheckContentCategory a c = Elem a c + +-- | Check whether a given element may contain a string. +type family CheckString (a :: Element) where + CheckString a = If (TestPaternity OnlyText (GetInfo a) (ElementInfo '[FlowContent, PhrasingContent] NoContent NoOmission)) + (() :: Constraint) + (TypeError (ShowType a :<>: Text " can't contain a string")) + +-- | Content categories according to the html spec. +data ContentCategory + = MetadataContent + | FlowContent + | SectioningContent + | HeadingContent + | PhrasingContent + | EmbeddedContent + | InteractiveContent + | FormAssociatedContent + | TransparentContent + | PalpableContent + | SectioningRoot + | (:|:) ContentCategory ContentCategory + | (:&:) ContentCategory ContentCategory + | NOT ContentCategory + | NoContent + | OnlyText + | SingleElement Element + +infixr 2 :|: +infixr 3 :&: + +type family MaybeTypeError (a :: Element) (b :: Element) c where + MaybeTypeError a b c = If c (() :: Constraint) + (TypeError (ShowType b :<>: Text " is not a valid child of " :<>: ShowType a)) + +type family Elem (a :: ContentCategory) (xs :: [ContentCategory]) where + Elem a (a : xs) = True + Elem a (_ : xs) = Elem a xs + Elem a '[] = False + +newtype Tagged (proxies :: [Symbol]) target (next :: *) = Tagged target + +type Symbols a = Fuse (RenderTags (PruneTags (ToTypeList a))) + +-- | Retrieve type level meta data about elements. +type family GetInfo a where + + GetInfo DOCTYPE = ElementInfo + '[] + NoContent + RightOmission + + GetInfo A = ElementInfo + [ FlowContent, PhrasingContent, InteractiveContent, PalpableContent ] + (TransparentContent :|: FlowContent :&: NOT InteractiveContent :|: PhrasingContent) + NoOmission + + GetInfo Abbr = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Address = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :&: NOT (HeadingContent :|: SectioningContent :|: SingleElement Address :|: SingleElement Header :|: SingleElement Footer)) + NoOmission + + GetInfo Area = ElementInfo + [ FlowContent, PhrasingContent ] + NoContent + RightOmission + + GetInfo Article = ElementInfo + [ FlowContent, SectioningContent, PalpableContent ] + FlowContent + NoOmission + + GetInfo Aside = ElementInfo + [ FlowContent, SectioningContent, PalpableContent ] + FlowContent + NoOmission + + GetInfo Audio = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, InteractiveContent, PalpableContent ] + (SingleElement Source :|: SingleElement Track :|: TransparentContent :&: NOT (SingleElement Audio :|: SingleElement Video)) + NoOmission + + GetInfo B = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Base = ElementInfo + '[ MetadataContent ] + NoContent + RightOmission + + GetInfo Bdi = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Bdo = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Blockquote = ElementInfo + [ FlowContent, SectioningRoot, PalpableContent ] + FlowContent + NoOmission + + GetInfo Body = ElementInfo + '[ SectioningRoot ] + FlowContent + NoOmission -- complicated exceptions + + GetInfo Br = ElementInfo + [ FlowContent, PhrasingContent ] + NoContent + RightOmission + + GetInfo Button = ElementInfo + [ FlowContent, PhrasingContent, InteractiveContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Canvas = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, PalpableContent ] + (TransparentContent :&: NOT InteractiveContent :|: SingleElement A :|: SingleElement Button :|: SingleElement Input) + NoOmission + + GetInfo Caption = ElementInfo + '[] + FlowContent + NoOmission + + GetInfo Cite = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Code = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Col = ElementInfo + '[] + NoContent + RightOmission + + GetInfo Colgroup = ElementInfo + '[] + (SingleElement Col) + NoOmission -- complicated rules + + GetInfo Data = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Datalist = ElementInfo + [ FlowContent, PhrasingContent ] + (PhrasingContent :|: SingleElement Option) + NoOmission + + GetInfo Dd = ElementInfo + '[] + FlowContent + (LastChildOrFollowedBy '[Dd]) + + GetInfo Del = ElementInfo + [ FlowContent, PhrasingContent ] + TransparentContent + NoOmission + + GetInfo Details = ElementInfo + [ FlowContent, SectioningRoot, InteractiveContent, PalpableContent ] + ( SingleElement Summary :|: FlowContent) + NoOmission + + GetInfo Dfn = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + (PhrasingContent :&: NOT (SingleElement Dfn)) + NoOmission + + GetInfo Dialog = ElementInfo + [ FlowContent, SectioningRoot ] + FlowContent + NoOmission + + GetInfo Div = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :|: SingleElement Dt :|: SingleElement Dd :|: SingleElement Script :|: SingleElement Template) + NoOmission + + GetInfo Dl = ElementInfo + [ FlowContent, PalpableContent ] + (SingleElement Dt :|: SingleElement Dd :|: SingleElement Script :|: SingleElement Template :|: SingleElement Div) + NoOmission + + GetInfo Dt = ElementInfo + '[] + (FlowContent :&: NOT (SingleElement Header :|: SingleElement Footer :|: SectioningContent :|: HeadingContent)) + (LastChildOrFollowedBy '[Dd]) -- really? + + GetInfo Em = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Embed = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, InteractiveContent, PalpableContent ] + NoContent + RightOmission + + GetInfo Fieldset = ElementInfo + [ FlowContent, SectioningRoot, FormAssociatedContent, PalpableContent ] + (SingleElement Legend :|: FlowContent) + NoOmission + + GetInfo Figcaption = ElementInfo + '[] + FlowContent + NoOmission + + GetInfo Figure = ElementInfo + [ FlowContent, SectioningRoot, PalpableContent ] + (SingleElement Figcaption :|: FlowContent) + NoOmission + + GetInfo Footer = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :&: NOT (SingleElement Footer :|: SingleElement Header)) + NoOmission + + GetInfo Form = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :&: NOT (SingleElement Form)) + NoOmission + + GetInfo H1 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo H2 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo H3 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo H4 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo H5 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo H6 = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Head = ElementInfo + '[] + (MetadataContent :|: SingleElement Title) + NoOmission -- complicated + + GetInfo Header = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :&: NOT (SingleElement Header :|: SingleElement Footer)) + NoOmission + + GetInfo Hgroup = ElementInfo + [ FlowContent, HeadingContent, PalpableContent ] + (SingleElement H1 :|: SingleElement H2 :|: SingleElement H3 :|: SingleElement H4 :|: SingleElement H5 :|: SingleElement H6) + NoOmission + + GetInfo Hr = ElementInfo + '[ FlowContent ] + NoContent + RightOmission + + GetInfo Html = ElementInfo + '[] + (SingleElement Head :|: SingleElement Body) + NoOmission -- complicated + + GetInfo I = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Iframe = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, InteractiveContent, PalpableContent ] + NoContent -- complicated + NoOmission + + GetInfo Img = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, PalpableContent, InteractiveContent ] + NoContent + RightOmission + + GetInfo Ins = ElementInfo + [ FlowContent, PhrasingContent ] + TransparentContent + NoOmission + + GetInfo Kbd = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Label = ElementInfo + [ FlowContent, PhrasingContent, InteractiveContent, FormAssociatedContent, PalpableContent ] + (PhrasingContent :&: NOT (SingleElement Label)) + NoOmission + + GetInfo Legend = ElementInfo + '[] + PhrasingContent + NoOmission + + GetInfo Li = ElementInfo + '[] + FlowContent + (LastChildOrFollowedBy '[Li]) -- if followed by li or no more content + + GetInfo Link = ElementInfo + [ MetadataContent, FlowContent, PhrasingContent ] + NoContent + RightOmission + + GetInfo Main = ElementInfo + [ FlowContent, PalpableContent ] + FlowContent + NoOmission + + GetInfo Map = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + TransparentContent + NoOmission + + GetInfo Mark = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Menu = ElementInfo + [ FlowContent, PalpableContent ] + (FlowContent :|: SingleElement Li :|: SingleElement Script :|: SingleElement Template :|: SingleElement Menu :|: SingleElement Menuitem :|: SingleElement Hr) + NoOmission + + GetInfo Menuitem = ElementInfo + '[] + NoContent + RightOmission + + GetInfo Meta = ElementInfo + [ MetadataContent, FlowContent, PhrasingContent ] + NoContent + RightOmission + + GetInfo Meter = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + (PhrasingContent :&: NOT (SingleElement Meter)) + NoOmission + + GetInfo Nav = ElementInfo + [ FlowContent, SectioningContent, PalpableContent ] + FlowContent + NoOmission + + GetInfo Noscript = ElementInfo + [ MetadataContent, FlowContent, PhrasingContent ] + (SingleElement Link :|: SingleElement Style :|: SingleElement Meta :|: TransparentContent :&: NOT (SingleElement Noscript) :|: FlowContent :|: PhrasingContent) + NoOmission + + GetInfo Object = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, PalpableContent, InteractiveContent, FormAssociatedContent ] + (SingleElement Param :|: TransparentContent) + NoOmission + + GetInfo Ol = ElementInfo + [ FlowContent, PalpableContent ] + (SingleElement Li) + NoOmission + + GetInfo Optgroup = ElementInfo + '[] + (SingleElement Option) + (LastChildOrFollowedBy '[Optgroup]) + + GetInfo Option = ElementInfo + '[] + OnlyText + (LastChildOrFollowedBy '[Option, Optgroup]) + + GetInfo Output = ElementInfo + [ FlowContent, PhrasingContent, FormAssociatedContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo P = ElementInfo + [ FlowContent, PalpableContent ] + PhrasingContent + (LastChildOrFollowedBy '[Address, Article, Aside, Blockquote, Div, Dl, Fieldset, Footer, Form, H1, H2, H3, H4, H5, H6, Header, Hr, Menu, Nav, Ol, Pre, Section, Table, Ul, P]) + -- And parent isn't + + GetInfo Param = ElementInfo + '[] + NoContent + RightOmission + + GetInfo Picture = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent ] + (SingleElement Source :|: SingleElement Img) + NoOmission + + GetInfo Pre = ElementInfo + [ FlowContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Progress = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + (PhrasingContent :&: NOT (SingleElement Progress)) + NoOmission + + GetInfo Q = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Rp = ElementInfo + '[] + OnlyText + NoOmission + + GetInfo Rt = ElementInfo + '[] + PhrasingContent + (LastChildOrFollowedBy '[Rt, Rp]) + + GetInfo Rtc = ElementInfo + '[] + (PhrasingContent :|: SingleElement Rt) + (LastChildOrFollowedBy '[Rtc, Rt]) + + GetInfo Ruby = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo S = ElementInfo + [ FlowContent, PhrasingContent ] + PhrasingContent + NoOmission + + GetInfo Samp = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Script = ElementInfo + [ MetadataContent, FlowContent, PhrasingContent ] + OnlyText + NoOmission + + GetInfo Section = ElementInfo + [ FlowContent, SectioningContent, PalpableContent ] + FlowContent + NoOmission + + GetInfo Select = ElementInfo + [ FlowContent, PhrasingContent, InteractiveContent, FormAssociatedContent ] + (SingleElement Option :|: SingleElement Optgroup) + NoOmission + + GetInfo Slot = ElementInfo + [ FlowContent, PhrasingContent ] + TransparentContent + NoOmission + + GetInfo Small = ElementInfo + [ FlowContent, PhrasingContent ] + PhrasingContent + NoOmission + + GetInfo Source = ElementInfo + '[] + NoContent + RightOmission + + GetInfo Span = ElementInfo + [ FlowContent, PhrasingContent ] + PhrasingContent + NoOmission + + GetInfo Strong = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Style = ElementInfo + [ MetadataContent, FlowContent ] + OnlyText + NoOmission + + GetInfo Sub = ElementInfo + [ FlowContent, PhrasingContent ] + PhrasingContent + NoOmission + + GetInfo Summary = ElementInfo + '[] + (PhrasingContent :|: HeadingContent) + NoOmission + + GetInfo Sup = ElementInfo + [ FlowContent, PhrasingContent ] + PhrasingContent + NoOmission + + GetInfo Table = ElementInfo + '[FlowContent] + (SingleElement Caption :|: SingleElement Colgroup :|: SingleElement Thead :|: SingleElement Tbody :|: SingleElement Tr :|: SingleElement Tfoot) + NoOmission + + GetInfo Tbody = ElementInfo + '[] + (SingleElement Tr) + NoOmission + + GetInfo Td = ElementInfo + '[] + FlowContent + (LastChildOrFollowedBy '[Th, Td]) + + GetInfo Template = ElementInfo + [ MetadataContent, FlowContent, PhrasingContent ] + (MetadataContent :|: FlowContent) -- complicated + NoOmission + + GetInfo Textarea = ElementInfo + [ FlowContent, PhrasingContent, InteractiveContent, FormAssociatedContent ] + OnlyText + NoOmission + + GetInfo Tfoot = ElementInfo + '[] + (SingleElement Tr) + (LastChildOrFollowedBy '[]) + + GetInfo Th = ElementInfo + '[] + (FlowContent :&: NOT (SingleElement Header :|: SingleElement Footer :|: SectioningContent :|: HeadingContent)) + (LastChildOrFollowedBy '[Th, Td]) + + GetInfo Thead = ElementInfo + '[] + (SingleElement Tr) + (LastChildOrFollowedBy '[Tbody, Tfoot]) + -- nearly + + GetInfo Time = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Title = ElementInfo + '[ MetadataContent ] + OnlyText + NoOmission + + GetInfo Tr = ElementInfo + '[] + (SingleElement Td :|: SingleElement Th) + (LastChildOrFollowedBy '[Tr]) + + GetInfo Track = ElementInfo + '[] + NoContent + RightOmission + + GetInfo U = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Ul = ElementInfo + [ FlowContent, PalpableContent ] + (SingleElement Li) + NoOmission + + GetInfo Var = ElementInfo + [ FlowContent, PhrasingContent, PalpableContent ] + PhrasingContent + NoOmission + + GetInfo Video = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, InteractiveContent, PalpableContent ] + (SingleElement Track :|: TransparentContent :&: NOT (SingleElement Audio :|: SingleElement Video) :|: SingleElement Source) + NoOmission + + GetInfo Wbr = ElementInfo + [ FlowContent, PhrasingContent ] + NoContent + RightOmission + + GetInfo _ = ElementInfo + [ FlowContent, PhrasingContent, EmbeddedContent, InteractiveContent, PalpableContent ] + (FlowContent :|: PhrasingContent :|: EmbeddedContent :|: InteractiveContent :|: PalpableContent) + NoOmission diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} + +module Main where + +import Html +import Test.Hspec + +import Data.Proxy + +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LT + +main :: IO () +main = hspec spec + +spec :: Spec +spec = let {-# INLINE allT #-} + allT a b c = b (render a, render a, render a , render a ) + (c , T.pack c, LT.pack c, LT.fromString c) + + in parallel $ do + + describe "render" $ do + + it "is id on empty string" $ do + + allT "" + shouldBe + "" + + it "handles single elements" $ do + + allT (div_ "a") + shouldBe + "
a
" + + it "handles nested elements" $ do + + allT (div_ (div_ "a")) + shouldBe + "
a
" + + it "handles parallel elements" $ do + + allT (div_ "a" # div_ "b") + shouldBe + "
a
b
" + + it "doesn't use closing tags for empty elements" $ do + + allT area_ + shouldBe + "" + + allT base_ + shouldBe + "" + + allT br_ + shouldBe + "
" + + allT col_ + shouldBe + "" + + allT embed_ + shouldBe + "" + + allT hr_ + shouldBe + "
" + + allT iframe_ + shouldBe + "