Skip to content

Instantly share code, notes, and snippets.

@josuf107
Created November 22, 2014 23:11
Show Gist options
  • Save josuf107/d1e5bd994422d53f66f7 to your computer and use it in GitHub Desktop.
Save josuf107/d1e5bd994422d53f66f7 to your computer and use it in GitHub Desktop.
Haskell Html builder using polyvariadic functions
import Data.Monoid
class IsNodes ns where
toNodes :: ns -> Nodes
fromSeveral :: [ns] -> Nodes
instance IsNodes Nodes where
toNodes = id
fromSeveral = mconcat
instance IsNodes Node where
toNodes n = Nodes [n]
fromSeveral = Nodes
instance IsNodes Char where
toNodes c = Nodes [Inner [c]]
fromSeveral cs = Nodes [Inner cs]
instance IsNodes n => IsNodes [n] where
toNodes = fromSeveral
fromSeveral = fromSeveral
class HtmlBuilder a where
build :: IsNodes nodes => nodes -> a
data Tag = Html | Head | Body | P | Div | Ul | Ol | Li deriving (Eq)
data Node
= Open Tag
| Close Tag
| Inner String
| Attribute String String
deriving Show
newtype Nodes = Nodes [Node]
instance Show Tag where
show Html = "html"
show Head = "head"
show Body = "body"
show P = "p"
show Div = "div"
show Ul = "ul"
show Ol = "ol"
show Li = "li"
instance Show Nodes where
show (Nodes (Open t:ns)) = "<"
++ show t
++ (when (' ':) (not . null) . unwords . fmap showAttribute . takeWhile isAttribute $ ns)
++ ">"
++ show (Nodes . dropWhile isAttribute $ ns)
show (Nodes (Close t:ns)) = "</" ++ show t ++ ">" ++ (show . Nodes $ ns)
show (Nodes (Inner s:ns)) = s ++ (show . Nodes $ ns)
show (Nodes []) = ""
show (Nodes (Attribute _ _:_)) = error "Attribute without opening tag"
when :: (a -> a) -> (a -> Bool) -> a -> a
when f p i = if p i then f i else i
showAttribute :: Node -> String
showAttribute (Attribute k v) = k ++ "=" ++ v
showAttribute n = error $ "Can't show attribute for node " ++ show n
isAttribute :: Node -> Bool
isAttribute (Attribute _ _) = True
isAttribute _ = False
instance Monoid Nodes where
mempty = Nodes mempty
mappend (Nodes xs) (Nodes ys) = Nodes (mappend xs ys)
instance (IsNodes h, HtmlBuilder b) => HtmlBuilder (h -> b) where
build h x = build (toNodes h <> toNodes x)
instance HtmlBuilder Nodes where
build = toNodes
instance HtmlBuilder Html where
build = htmlFromNodes
data Html = Block Tag [(String, String)] [Html] deriving (Show, Eq)
htmlFromNodes :: IsNodes n => n -> Html
htmlFromNodes = (\(Nodes ns) -> htmlFromNodes' ns) . toNodes
where
htmlFromNodes' = undefined
html_ = Open Html
_html = Close Html
head_ = Open Head
_head = Close Head
body_ = Open Body
_body = Close Body
p_ = Open P
_p = Close P
div_ = Open Div
_div = Close Div
li_ = Open Li
_li = Close Li
ol_ = Open Ol
_ol = Close Ol
ul_ = Open Ul
_ul = Close Ul
inner = Inner
asNodes :: Nodes -> Nodes
asNodes = toNodes
id_ = Attribute "id"
example :: Nodes
example = build
html_
div_
p_ "This is some text" _p
_div
div_ (id_ "main")
p_ "This is some more text" _p
p_ "This is the last paragraph" _p
_div
_html
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment