Created
November 22, 2014 23:11
-
-
Save josuf107/d1e5bd994422d53f66f7 to your computer and use it in GitHub Desktop.
Haskell Html builder using polyvariadic functions
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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