Read You A Blaze

2020-07-31

This is a continuation of the ’Read You A _’™ series. In this series we will learn to create a toy version blaze-html library. After reading this article, the reader should be able to easily read through the blaze-markup and blaze-html libraries. In addition the reader can gain good insight in building EDSL support in their projects.

HTML Blaze

blaze-html is a Haskell library that provides a simple EDSL that can be used to build HTML pages in Haskell. This approach gives good type level guarantees while building HTML pages while sharing Haskell data structures.

To understand this tutorial, I suggest you familiarize yourself with some basic usage of this library. You should be able to follow this tutorial just with very basic understanding of how this library can be used.

Layout of this article:

Objective
First Iteration
Second Iteration
Third Iteration
Fourth Iteration
Conclusion

Objective

The objective of ’Read You A _’™ series article is to understand how to build libraries in Haskell by reading and learning from some well known Haskell libraries. With that in mind, our objective for this tutorial would be to implement a toy version of the blaze-markup library along with blaze-html.

In this tutorial, we will not implement all the features of this library. But, we will end up in a position which will easily allow us to extend our toy example to include the other missing features.

Our goal for this tutorial is to be able to support the following snippet of code that is provided as a first example.

Code snippet that our final implementation will support

{-# LANGUAGE OverloadedStrings #-}
import Prelude hiding (head, id, div)
import Text.Blaze.Html4.Strict hiding (map)
import Text.Blaze.Html4.Strict.Attributes hiding (title)

import Text.Blaze.Renderer.Utf8 (renderMarkup)

page1 :: Markup
page1 = html $ do
    head $ do
        title "Introduction page."
        link ! rel "stylesheet" ! type "text/css" ! href "screen.css"
    body $ do
        div ! id "header" $ "Syntax"
        p "This is an example of BlazeMarkup syntax."
        ul $ mapM_ (li . toMarkup . show) [1, 2, 3]

--- And to render, we will also implement the `renderMarkup` function.
renderMarkup page1

If you are in a hurry and just would like to play with the example yourselves, all code shown in this article is available at read-you-a-blaze-html. Each iteration, in this tutorial produces a independent haskell modules. The four modules this tutorial produces are available in this repository.

About the Code snippet

The code snippet shown about uses functions from blaze-html which internally uses functions provided by the blaze-markup library. In this tutorial, we will be implementing data structures that overlap with both these libraries. It will become clear towards the end regarding where this data structures reside.

Before, we start off with the toy example, lets review the code snippet closely and identify the parts that we need to build. We are focusing our attention on the page1 function. The page1 function returns a Markup type, which is defined in (Text.Blaze.Internal)[https://hackage.haskell.org/package/blaze-markup-0.8.2.7/docs/Text-Blaze-Internal.html] as


data MarkupM a = ...
    ....
    ...

type Markup = MarkupM ()

type Html = MarkupM ()  -- as defined in blase-html

Note, there is a type synonym Html in blaze-html that is also defined as type Html = MarkupM ().

The MarkupM type will be the algebraic data type we will eventually build.

Also notice that html, head, body functions take a Monad. All these functions accept the Markup type and return a Markup type. Therefore, what ever data structure we end up with, we will also have to make that data structure implement the Monad interface. We will also eventually define the functions html, head, title etc.

Eventually, we also want to implement a version of renderMarkup to render the data structure we cook up. We will add an implementation for that function as we go.

As you notice, we are taking a top down approach here. We are going to start with specific functions/data types that support HTML to help us support this code snippet. Gradually, we will generalize our code to work with any markup and not just HTML.

First Iteration (first.hs)

In our first iteration, we are going to support a slightly modified version of page1 that will help us build some understanding on the basic data structures we need.

Notice that functions that are used in the original page1 function, roughly have the following types:

-- for attributes

type Attribute = _  <- Yet to be defined

href :: String -> Attribute
type :: String -> Attribute
id :: String -> Attribute
rel :: String -> Attribute

-- for functions working on `Markup`, we have

type Html = _  <- Yet to be defined

link :: Html
title :: String -> Html
head :: Html -> Html
div :: Html -> Html
p :: Html -> Html
ul :: Html -> Html
li :: Html -> Html

-- and some helper functions
(!) = _

The types of the above listed function informs us that we need two types Html and Attributes. Rather than work with these helper function, lets implement a more concrete version of page1 and then we will abstract away parts of it to use the helper functions.

Here is the modified version of page1 we will support in our first iteration:

page1 :: Html
page1 = let
  link' = Link ! rel "style.css" ! type_ "text/html"
  title' = Title "Introduction page."
  head' = Head (Append link' title')
  div' = mult Div (id_ "header") $ (Content "Syntax")
  p' = P $ Content "This is an example of Blazemarkup syntax."
  ul' = UL $ foldHtml $ (map (LI . toMarkup . show) [1, 2, 3])
  body' = Body (Append (Append div' p') ul')
  html' = HTML $ Append head' body'
  in
    html'

Notice that we have replaced calls to helper function with some data constructors which we are yet to define. Since, all helper function’s are returning Html as the data structure, lets create one that fits that setup.

data Attribute = Attribute String String

And, for Markup, let’s define. (Since, we are dealing concretely with HTML at this stage, lets name the data type accordingly

data Html = HTML Html
  | Head Html
  | Body Html
  | Link
  | Title String
  | HRef String
  | Div Html
  | UL Html
  | LI Html
  | P Html
  | Append Html Html
  | AddAttribute Attribute Html
  | Content String
  | Empty
  deriving (Show)

type Markup = Html

Note, the Link, Title, HRef, Content and Empty are Leaf values. The other data constructors are recursive. Now, with this type, we can start filling in our place holder functions. This data structure covers all the values that are used in the first version of page1 function.

We will also add the following helper functions.


-- helper functions to build attributes
href :: String -> Attribute
href value = Attribute "href" value

type_ :: String -> Attribute
type_ value = Attribute "type" value

id :: String -> Attribute
id value = Attribute "id" value

rel :: String -> Attribute
rel value = Attribute "rel=" value

Other helpers

toMarkup :: String -> Html
toMarkup s = Content s

(!) :: Html -> Attribute -> Html
(!) html attr = AddAttribute attr html

-- We will replace this definition later. For now assume, it is a version of (!) that supports a slightly different type.
mult :: (Html -> Html) -> Attribute -> Html -> Html
mult html1 attr = \html2 -> AddAttribute attr (html1 html2)

foldHtml :: [Html] -> Html
foldHtml (x:xs) = Append x (foldHtml xs)
foldHtml [] = Empty

We will also need a function that implements renderMarkup. The first iteration of that function will be as follows. The renderMarkup function walks over the Html type and constructs the HTML string.

renderMarkup :: String -> Html -> String
renderMarkup attrs (HTML inner) =
        "<html" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</html>"
renderMarkup attrs (Head inner) =
        "<head" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</head>"
renderMarkup attrs (Body inner) =
        "<body" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</body>"
renderMarkup attrs (P inner) =
        "<p" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</p>"
renderMarkup attrs Link = "<link" ++ attrs ++ ">"
renderMarkup attrs (Title s) = "<title" ++ attrs ++ ">" ++ s ++ "</title>"
renderMarkup attrs (HRef content) = "<a" ++ attrs ++ ">" ++ content ++ "</a>"
renderMarkup attrs (Div content) =
        "<div" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</div>"
renderMarkup attrs (UL content) =
        "<ul" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</ul>"
renderMarkup attrs (LI content) =
        "<li" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</li>"
renderMarkup attrs (Append html1 html2) =
  (renderMarkup attrs html1) ++ (renderMarkup attrs html2)
renderMarkup attrs (AddAttribute (Attribute k v) html) = flip renderMarkup html $
  " " ++ k ++ "\"" ++ v ++ "\""
renderMarkup attrs (Content content) = content
renderMarkup attrs Empty = ""

With the above definitions we are ready to test out our first iteration. The fully implemented example of our first iteration can be found here: first.hs

Running this should produce the following output:

<html><head><link rel="style.css"><title>Introduction page.</title></head><body><div id"header">Syntax</div><p>This is an example of Blazemarkup syntax.</p><ul><li>1</li><li>2</li><li>3</li></ul></body></html>

End of first iteration

We created a concrete version data structures that will help us construct a HTML string. Our page1 function uses these concrete data structures to build the HTML structure which can be converted to a HTML string using the renderMarkup function.

But, page1 is very verbose compared to the original version. We will need to extend our definitions to improve on the page1 function.

Second Iteration (second.hs)

As we have seen in the first iteration, it would be nice to implement functionality to support the original page1 function. We need to construct some sort of an EDSL to support this functionality. We will just do that in this iteration.

We need to support the EDSL used in page1. To add that support, we will provide Functor, Applicative and Monad instances to the Html data type. But, before we do that, we need to update our Html type to accept a type variable.

data HtmlM a = Html (HtmlM a)
  | Head (HtmlM a)
  | Body (HtmlM a)
  | Link a
  | Title String a
  | HRef String a
  | Div (HtmlM a)
  | UL (HtmlM a)
  | LI (HtmlM a)
  | P (HtmlM a)
  | forall b. Append (HtmlM b) (HtmlM a)
  | AddAttribute Attribute (HtmlM a)
  | Content String a
  | Empty a

-- type synonyms for convenience
type Html = HtmlM ()
type Markup = HtmlM ()

We also also build a function’s which walks this type and yields the embedded value:


-- Walk through the Html data structure to return the embedded value. Used in Functor, Applicative and Monad instances
htmlValue :: HtmlM a -> a
htmlValue (Html x          ) = htmlValue x
htmlValue (Head x          ) = htmlValue x
htmlValue (Link x          ) = x
htmlValue (HRef _ x) = x
htmlValue (Div x) = htmlValue x
htmlValue (LI x) = htmlValue x
htmlValue (UL x) = htmlValue x
htmlValue (P x) = htmlValue x
htmlValue (Append       _ x) = htmlValue x
htmlValue (AddAttribute _ x) = htmlValue x
htmlValue (Content      _ x) = x
htmlValue (Empty x         ) = x

We also have to accordingly update the version of renderMarkup that we used in first.hs as follows:

--- Same as the version in first.hs
renderMarkup :: String -> HtmlM a -> String
renderMarkup attrs (Html inner) =
        "<html" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</html>"
renderMarkup attrs (Head inner) =
        "<head" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</head>"
renderMarkup attrs (Body inner) =
        "<body" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</body>"
renderMarkup attrs (P inner) =
        "<p" ++ attrs ++ ">" ++ renderMarkup "" inner ++ "</p>"
renderMarkup attrs (Link _) = "<link" ++ attrs ++ ">"
renderMarkup attrs (Title s _ ) = "<title" ++ attrs ++ ">" ++ s ++ "</title>"
renderMarkup attrs (HRef content _) = "<a" ++ attrs ++ ">" ++ content ++ "</a>"
renderMarkup attrs (Div content) =
        "<div" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</div>"
renderMarkup attrs (UL content) =
        "<ul" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</ul>"
renderMarkup attrs (LI content) =
        "<li" ++ attrs ++ ">" ++ (renderMarkup "" content) ++ "</li>"
renderMarkup attrs (Append html1 html2) =
  (renderMarkup attrs html1) ++ (renderMarkup attrs html2)
renderMarkup attrs (AddAttribute (Attribute k v) html) = flip renderMarkup html $
  " " ++ k ++ "\"" ++ v ++ "\""
renderMarkup attrs (Content content _) = content
renderMarkup attrs (Empty _) = ""

Also, update the helper functions

toMarkup :: String -> Html
toMarkup s = Content s ()

foldHtml :: [Html] -> Html
foldHtml (x:xs) = Append x (foldHtml xs)
foldHtml [] = Empty ()

Once we have made these updates we are ready to implement the instances.

-- Need to update type of Append with existential
instance Functor HtmlM where
        fmap f x = Append x (Empty (f (htmlValue x)))

instance Applicative HtmlM where
        pure x = Empty x

        -- Why are we not discarding the first value?
        (*>) = Append
        (<*>) x y = --Empty (htmlValue x (htmlValue y))
                Append (Append x y) (Empty (htmlValue x (htmlValue y)))

instance Monad HtmlM where
        return = pure
        m >>= f = Append m (f (htmlValue m))
        (>>) = Append

Note that the Applicative and Monad instances here append the Html. For our page1 to work it is sufficient to implement the Monad instance. But, we have provided the Applicative instance for completeness.

And, finally, our improved version of page1 is as follows. Note, that within each do we append the HTML parts and provide those parts as arguments to Html, Head and Body.

page1 :: Html
page1 = Html $ do
  Head $ do
    Link () ! rel "style.css" ! type_ "text/html"
    Title "Introduction page." ()
  Body $ do
    mult Div (id "header") $ Content "Syntax" ()
    P $ Content "This is an example of Blazemarkup syntax." ()
    UL $ foldHtml $ (map (LI . toMarkup . show) [1, 2, 3])

End of Second Iteration

We are pretty close know to the original implementation of page1. We just need to provide some more syntax sugar. We can replace calls to Content "Syntax" () with just "Syntax". We can do this by providing a IsString instance.

First, we add this import and extension

{-# LANGUAGE TypeSynonymInstances #-} -- needed for ToMarkup String

import GHC.Exts  (IsString (..))

and then provide an IsString instance for the HtmlM a type as follows:

instance (a ~ ()) => IsString (HtmlM a) where
  fromString x = Content (fromString x) mempty

Also, since HtmlM a is a monad, we can replace the call for foldHtml with the standard ‘mapM_’ function. The revised page1 after removing call to Content and foldHTML.

page1 :: Html
page1 = Html $ do
        Head $ do
                Link () ! rel "style.css" ! type_ "text/html"
                Title "Introduction page." ()
        Body $ do
                mult Div (id "header") $ "Syntax"
                P $ "This is an example of Blazemarkup syntax."
                UL $ mapM_ (LI . toMarkup . show) [1, 2, 3]

Third Iteration (third.hs)

If we review the final version of page1 from the second iteration you will notice that the client/user directly is using the HtmlM a data structure. We would like to abstract that away into some helper function. This gives us the flexibility of updating/extending the data structure without affecting the client code. In this iteration we will do just that. We will provide helper functions that the client can use to construct these HTML elements and attributes.

Here are the list of helper functions we need to define:

-- HTML helpers
html :: Html -> Html
html = Html

head :: Html -> Html
head = Head

link :: Html
link = Link ()

title :: String -> Html
title s = Title s ()

div :: Html -> Html
div = Div

p :: Html -> Html
p = P

ul :: Html -> Html
ul = UL

li :: Html -> Html
li = LI

body :: Html -> Html
body = Body

And now the client can use these helper functions rather than constructing the HTML elements using the HtmlM a data type. There is another benefit for this abstraction that will become clear when we do our final fourth iteration.

After replacing the page1 function with the helper function, the new version of page will be as follows:

page1 :: Html
page1 = html $ do
        head $ do
                link ! rel "style.css" ! type_ "text/html"
                title "Introduction page."
        body $ do
                mult Div (id "header") $ "Syntax"
                p $ "This is an example of Blazemarkup syntax."
                ul $ mapM_ (li . toMarkup . show) [1, 2, 3]

Almost close!

We just need to replace mult with a (!) call and we have achieved the objective we started with. Let’s wrap up this iteration with that change. To replace mul with (!), we need to define a type class that will support both HtmlM a and HtmlM a -> HtmlM a.

First add some language extensions

{-# LANGUAGE FlexibleInstances    #-}

class Attributable h where
    (!) :: h -> Attribute -> h

instance Attributable (Html) where
  (!) html attr = AddAttribute attr html

instance Attributable (Html -> Html ) where
  f ! attr = \f1 -> AddAttribute attr $ f f1

Also, we remove our previous implementation of (!).

-- Remove this function after adding the above Attributable interfaces
(!) :: Html -> Attribute -> Html
(!) html attr = AddAttribute attr html

The first instance will support leaf level Html elements such as Link, Title etc. The second instance is for elements such as Div, P etc. That is any element, that can embed more Html elements.

With that change, we have our final page1 function which looks exactly like the one we start off with as our objective.

page1 :: Html
page1 = html $ do
        head $ do
                link ! rel "style.css" ! type_ "text/html"
                title "Introduction page."
        body $ do
                div ! (id "header") $ "Syntax"
                p $ "This is an example of Blazemarkup syntax."
                ul $ mapM_ (li . toMarkup . show) [1, 2, 3]

One Last Iteration (fourth.hs)

So, far we have seen that the algebraic data type HtmlM a only works for Html. But, if you look closely the pattern we followed so far would work for a wider range of Markups. Html or other Markups have a tree like structure with Parent Nodes, Siblings and Leaf Nodes with attributes attaching themselves to these nodes. If we can transform our current HtmlM a into a more generic structure, then we could extend our library to other markups that share similar structure. In this iteration, that is precisely what we will do. We will update the code to make it support a more general markup declaration and see how it works with the concrete HTML implementation.

As stated, if we view the Markup syntax as a syntax to build a tree, then we can arrive at this type:

type Tag = String
type Open = String
type Close = String
type Key = String
type Value = String

data MarkupM a
  = Parent Tag Open Close (MarkupM a)
  | Leaf Tag Open Close a
  | Content String a
  | forall b. Append (MarkupM b) (MarkupM a)
  | AddAttribute Attribute (MarkupM a)
  | Empty a

type Markup = MarkupM ()

Note that leaf elements like Link, Href, Content in previous HtmlM a declaration or just Leaf here, and elements that support HTML embedding like Div, P can be represented as Parent here. The values to the data constructor have been added to replicate the declaration in the (Text.Blaze.Internal)[http://hackage.haskell.org/package/blaze-markup-0.8.2.1/docs/src/Text.Blaze.Internal.html#MarkupM]

With that it is time to update our htmlValue function and replace it with the generic markupValue function. This again is the same as the markupValue function in (Text.Blaze.Internal)[http://hackage.haskell.org/package/blaze-markup-0.8.2.1/docs/src/Text.Blaze.Internal.html]

Here are the updated definitions:

markupValue :: MarkupM a -> a
markupValue (Parent _ _ _ x) = markupValue x
markupValue (Leaf _ _ _ x) = x
markupValue (Content _ x) = x
markupValue (Append _ m1) = markupValue m1
markupValue (AddAttribute _  m1) = markupValue m1
markupValue (Empty x) = x

We also need to apply similar updates to the Functor, Applicative and Monad instances, and also to IsString and Attributable instances.

-- Need to update type of Append with existential
instance Functor MarkupM where
  fmap f x = Append x (Empty (f (markupValue x)))

-- Why isn't this just an `(Empty (htmlValue x (htmlValue y)))`
-- The `homomorphism` law is not followed here.
instance Applicative MarkupM where
  pure x = Empty x

  -- Why are we not discarding the first value?
  (*>) = Append
  (<*>) x y = --Empty (htmlValue x (htmlValue y))
    Append (Append x y) (Empty (markupValue x (markupValue y)))

instance Monad MarkupM where
  return = pure

  m >>= f = Append m (f (markupValue m))
  (>>) = Append

-- other instances
instance (a ~ ()) => IsString (MarkupM a) where
  fromString x = Content (fromString x) mempty

class Attributable h where
    (!) :: h -> Attribute -> h

instance Attributable Markup where
  (!) html attr = AddAttribute attr html

instance Attributable (Markup -> Markup) where
  f ! attr = \f1 -> AddAttribute attr $ f f1

class ToMarkup a where
    toMarkup :: a -> Markup

instance ToMarkup String where
    toMarkup = string

Finally, if you remember, in our previous iteration, we abstracted away the creation of HTML elements into small helper functions. That move come in handy here, to construct concrete values for the new Markup type. You can observe that in the updates that we make to the helper functions as follows. This is the part that is made available to the client from the blaze-html library, whereas the code we saw above is abstracted away int blaze-markup library.

href value = Attribute "href=\"" value
type_ value = Attribute "type=\"" value

rel value = Attribute "rel=\"" value

id value = Attribute "id=\"" value

type Html = MarkupM ()

html :: Html -> Html
html = Parent "html" "<html" "</head>"

head :: Html -> Html
head = Parent "head" "<head" "</head>"

title :: Html -> Html
title = Parent "title" "<title" "</title>"

link :: Html
link = Leaf "link" "<link" ">" ()

body :: Html -> Html
body = Parent "body" "<body" "</body>"

div :: Html -> Html
div = Parent "div" "<div" "</div>"

p :: Html -> Html
p = Parent "p" "<p" "</p>"

ul :: Html -> Html
ul = Parent "ul" "<ul" "</ul>"

li :: Html -> Html
li = Parent "li" "<li" "</li>"

string :: String -> Html
string a = Content a ()

Note that we are constructing values from the Markup type and providing the ‘string’ rendered version of Html elements. This would mean we also update our renderMarkup version to support this version. This function is also available in the generic markup library!

renderString :: String -> MarkupM a -> String
renderString attrs (Parent tag open close content) =
    open ++ attrs ++ ">" ++ (renderString "" content) ++ close
renderString attrs (Leaf _ begin end _) = begin ++ attrs ++ end
renderString attrs (Content x _) = x
renderString attrs (Append m1 m2) =
  renderString attrs m1 ++ renderString attrs m2
renderString attrs (AddAttribute (Attribute key value) m1) =
    flip renderString m1 $
        " " ++ key ++ value ++ "\"" ++ attrs
renderString attrs (Empty x) = ""

Finally, our version of page1 from previous iteration will continue to work.

page1 :: Html
page1 = html
  $ do
    head $ do
        title "Introduction page."
        link ! rel "stylesheet" ! type_ "text/css" ! href "screen.css"
    body $ do
        div ! id "header" $ "Syntax"
        p "This is an example of BlazeMarkup syntax."
        ul $ mapM_ (li . toMarkup . show) [1, 2, 3]

Here is the final version of the code that will support the original version of page1 function. fourth.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeSynonymInstances #-} -- needed for ToMarkup String
{-# LANGUAGE FlexibleInstances    #-}

--module Main1 where
import Prelude hiding (head, id, div)
import GHC.Exts  (IsString (..))

data Attribute = Attribute String String
  deriving (Show)

type Tag = String
type Open = String
type Close = String
type Key = String
type Value = String

data MarkupM a
  = Parent Tag Open Close (MarkupM a)
  | Leaf Tag Open Close a
  | Content String a
  | forall b. Append (MarkupM b) (MarkupM a)
  | AddAttribute Attribute (MarkupM a)
  | Empty a


instance (a ~ ()) => IsString (MarkupM a) where
  fromString x = Content (fromString x) mempty

markupValue :: MarkupM a -> a
markupValue (Parent _ _ _ x) = markupValue x
markupValue (Leaf _ _ _ x) = x
markupValue (Content _ x) = x
markupValue (Append _ m1) = markupValue m1
markupValue (AddAttribute _  m1) = markupValue m1
markupValue (Empty x) = x

type Markup = MarkupM ()

-- Need to update type of Append with existential
instance Functor MarkupM where
  fmap f x = Append x (Empty (f (markupValue x)))

-- Why isn't this just an `(Empty (htmlValue x (htmlValue y)))`
-- The `homomorphism` law is not followed here.
instance Applicative MarkupM where
  pure x = Empty x

  -- Why are we not discarding the first value?
  (*>) = Append
  (<*>) x y = --Empty (htmlValue x (htmlValue y))
    Append (Append x y) (Empty (markupValue x (markupValue y)))

instance Monad MarkupM where
  return = pure

  m >>= f = Append m (f (markupValue m))
  (>>) = Append


renderString :: String -> MarkupM a -> String
renderString attrs (Parent tag open close content) =
    open ++ attrs ++ ">" ++ (renderString "" content) ++ close
renderString attrs (Leaf _ begin end _) = begin ++ attrs ++ end
renderString attrs (Content x _) = x
renderString attrs (Append m1 m2) =
  renderString attrs m1 ++ renderString attrs m2
renderString attrs (AddAttribute (Attribute key value) m1) =
    flip renderString m1 $
        " " ++ key ++ value ++ "\"" ++ attrs
renderString attrs (Empty x) = ""


href value = Attribute "href=\"" value
type_ value = Attribute "type=\"" value

rel value = Attribute "rel=\"" value

id value = Attribute "id=\"" value

class Attributable h where
    (!) :: h -> Attribute -> h

instance Attributable Markup where
  (!) html attr = AddAttribute attr html

instance Attributable (Markup -> Markup) where
  f ! attr = \f1 -> AddAttribute attr $ f f1
  --f ! attr = AddAttribute attr $ f

type Html = MarkupM ()

html :: Html -> Html
html = Parent "html" "<html" "</head>"

head :: Html -> Html
head = Parent "head" "<head" "</head>"

title :: Html -> Html
title = Parent "title" "<title" "</title>"

link :: Html
link = Leaf "link" "<link" ">" ()

body :: Html -> Html
body = Parent "body" "<body" "</body>"

div :: Html -> Html
div = Parent "div" "<div" "</div>"

p :: Html -> Html
p = Parent "p" "<p" "</p>"

ul :: Html -> Html
ul = Parent "ul" "<ul" "</ul>"

li :: Html -> Html
li = Parent "li" "<li" "</li>"

string :: String -> Html
string a = Content a ()

class ToMarkup a where
    toMarkup :: a -> Markup

instance ToMarkup String where
    toMarkup = string
    -- Implement escaping
    --preEscapedToMarkup = preEscapedString

page1 :: Html
page1 = html
  $ do
    head $ do
        title "Introduction page."
        link ! rel "stylesheet" ! type_ "text/css" ! href "screen.css"
    body $ do
        div ! id "header" $ "Syntax"
        p "This is an example of BlazeMarkup syntax."
        ul $ mapM_ (li . toMarkup . show) [1, 2, 3]

main :: IO ()
main = putStrLn $ renderString "" page1

Conclusion

If you have stayed with me so far, Congrats! We just implemented a simple version of EDSL which allows clients to build HTML contents using Haskell syntax. In the process we learned how to define the abstract data types that defined the EDSL and also provide a friendly monadic interfaces. In this process, we also identified the parts of code that are currently available as part of the two libraries, namely, blaze-markup and blaze-html.

There are other important pieces in the blaze-html and blaze-markup libraries that this article does not touch upon. That is using efficient String types by way of a ChoiceString data type. But, that information and other missed pieces of the implementations should be easy to understand by reading the source code of these libraries.

Hopefully, the insights you gained building this toy example, will help you read and understand the internals of these 2 libraries easily. This should also help you build a good foundation based on which you would be able to create your own EDSL’s. Happy Haskell hacking!

See you in the next ‘Read Your A _ Series’™.

References

blaze-markup

blaze-html

Special thanks to jaspervdj and other contributors for creating such a nice set of libraries.

Other ‘Read You A _ Series’™

Read You A Scotty