module Simulation.Aivika.Experiment.Base.HtmlWriter
(HtmlWriter,
runHtmlWriter,
composeHtml,
writeHtml,
writeHtmlLn,
writeHtmlText,
writeHtmlParagraph,
writeHtmlParagraphWithId,
writeHtmlHeader1,
writeHtmlHeader1WithId,
writeHtmlHeader2,
writeHtmlHeader2WithId,
writeHtmlHeader3,
writeHtmlHeader3WithId,
writeHtmlHeader4,
writeHtmlHeader4WithId,
writeHtmlHeader5,
writeHtmlHeader5WithId,
writeHtmlHeader6,
writeHtmlHeader6WithId,
writeHtmlBreak,
writeHtmlLink,
writeHtmlImage,
writeHtmlList,
writeHtmlListItem,
writeHtmlDocumentWithTitle,
encodeHtmlText) where
import Control.Monad
import Control.Monad.Trans
import Control.Applicative
import Network.URI
import Simulation.Aivika.Experiment.Base.ExperimentWriter
newtype HtmlWriter a =
HtmlWriter { forall a. HtmlWriter a -> ShowS -> ExperimentWriter (a, ShowS)
runHtmlWriter :: ShowS -> ExperimentWriter (a, ShowS)
}
instance Monad HtmlWriter where
(HtmlWriter ShowS -> ExperimentWriter (a, ShowS)
m) >>= :: forall a b. HtmlWriter a -> (a -> HtmlWriter b) -> HtmlWriter b
>>= a -> HtmlWriter b
k = forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f ->
do (a
a, ShowS
f') <- ShowS -> ExperimentWriter (a, ShowS)
m ShowS
f
let HtmlWriter ShowS -> ExperimentWriter (b, ShowS)
m' = a -> HtmlWriter b
k a
a
ShowS -> ExperimentWriter (b, ShowS)
m' ShowS
f'
instance MonadIO HtmlWriter where
liftIO :: forall a. IO a -> HtmlWriter a
liftIO IO a
m = forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f ->
do a
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x, ShowS
f)
instance Functor HtmlWriter where
fmap :: forall a b. (a -> b) -> HtmlWriter a -> HtmlWriter b
fmap a -> b
f HtmlWriter a
m = HtmlWriter a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a)
instance Applicative HtmlWriter where
pure :: forall a. a -> HtmlWriter a
pure a
a = forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, ShowS
f)
<*> :: forall a b. HtmlWriter (a -> b) -> HtmlWriter a -> HtmlWriter b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
writeHtml :: String -> HtmlWriter ()
writeHtml :: String -> HtmlWriter ()
writeHtml String
code =
forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), ShowS
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
code forall a. [a] -> [a] -> [a]
++))
writeHtmlLn :: String -> HtmlWriter ()
writeHtmlLn :: String -> HtmlWriter ()
writeHtmlLn String
code =
do String -> HtmlWriter ()
writeHtml String
code
String -> HtmlWriter ()
writeHtml String
"\n"
writeHtmlText :: String -> HtmlWriter ()
writeHtmlText :: String -> HtmlWriter ()
writeHtmlText String
text =
forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), ShowS
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS
encodeHtmlText String
text forall a. [a] -> [a] -> [a]
++))
composeHtml :: ShowS -> HtmlWriter ()
composeHtml :: ShowS -> HtmlWriter ()
composeHtml ShowS
g =
forall a. (ShowS -> ExperimentWriter (a, ShowS)) -> HtmlWriter a
HtmlWriter forall a b. (a -> b) -> a -> b
$ \ShowS
f -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), ShowS
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
g)
writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlLink :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlLink String
uri HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<a href=\""
String -> HtmlWriter ()
writeHtml forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
isUnescapedInURI String
uri
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</a>"
writeHtmlImage :: String -> HtmlWriter ()
writeHtmlImage :: String -> HtmlWriter ()
writeHtmlImage String
uri =
do String -> HtmlWriter ()
writeHtml String
"<img src=\""
String -> HtmlWriter ()
writeHtml forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
escapeURIString Char -> Bool
isUnescapedInURI String
uri
String -> HtmlWriter ()
writeHtml String
"\" />"
writeHtmlParagraph :: HtmlWriter () -> HtmlWriter ()
writeHtmlParagraph :: HtmlWriter () -> HtmlWriter ()
writeHtmlParagraph HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<p>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</p>"
writeHtmlHeader1 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h1>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h1>"
writeHtmlHeader2 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h2>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h2>"
writeHtmlHeader3 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h3>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h3>"
writeHtmlHeader4 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h4>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h4>"
writeHtmlHeader5 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h5>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h5>"
writeHtmlHeader6 :: HtmlWriter () -> HtmlWriter ()
HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h6>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h6>"
writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlParagraphWithId :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlParagraphWithId String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<p id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</p>"
writeHtmlHeader1WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h1 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h1>"
writeHtmlHeader2WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h2 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h2>"
writeHtmlHeader3WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h3 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h3>"
writeHtmlHeader4WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h4 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h4>"
writeHtmlHeader5WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h5 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h5>"
writeHtmlHeader6WithId :: String -> HtmlWriter () -> HtmlWriter ()
String
id HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<h6 id=\""
String -> HtmlWriter ()
writeHtml String
id
String -> HtmlWriter ()
writeHtml String
"\">"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</h6>"
writeHtmlBreak :: HtmlWriter ()
writeHtmlBreak :: HtmlWriter ()
writeHtmlBreak =
String -> HtmlWriter ()
writeHtml String
"<br />"
writeHtmlList :: HtmlWriter () -> HtmlWriter ()
writeHtmlList :: HtmlWriter () -> HtmlWriter ()
writeHtmlList HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<ul>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</ul>"
writeHtmlListItem :: HtmlWriter () -> HtmlWriter ()
writeHtmlListItem :: HtmlWriter () -> HtmlWriter ()
writeHtmlListItem HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<li>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"</li>"
writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlDocumentWithTitle :: String -> HtmlWriter () -> HtmlWriter ()
writeHtmlDocumentWithTitle String
title HtmlWriter ()
inner =
do String -> HtmlWriter ()
writeHtml String
"<html>"
String -> HtmlWriter ()
writeHtml String
"<head>"
String -> HtmlWriter ()
writeHtml String
"<meta http-equiv='Content-Type' content='text/html; charset=utf-8' />"
String -> HtmlWriter ()
writeHtml String
"<title>"
String -> HtmlWriter ()
writeHtmlText String
title
String -> HtmlWriter ()
writeHtml String
"</title>"
HtmlWriter ()
writeHtmlCss
String -> HtmlWriter ()
writeHtml String
"</head>"
String -> HtmlWriter ()
writeHtml String
"<body>"
HtmlWriter () -> HtmlWriter ()
writeHtmlHeader1 forall a b. (a -> b) -> a -> b
$
String -> HtmlWriter ()
writeHtmlText String
title
String -> HtmlWriter ()
writeHtml String
"</h1>"
HtmlWriter ()
inner
String -> HtmlWriter ()
writeHtml String
"<br /><p><font size=\"-1\">Automatically generated by "
String -> HtmlWriter ()
writeHtml String
"<a href=\"http://www.aivikasoft.com\">"
String -> HtmlWriter ()
writeHtml String
"Aivika</a>"
String -> HtmlWriter ()
writeHtml String
"</font></p>"
String -> HtmlWriter ()
writeHtml String
"</body>"
String -> HtmlWriter ()
writeHtml String
"</html>"
encodeHtmlText :: String -> String
encodeHtmlText :: ShowS
encodeHtmlText String
x = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> String
encodeHtmlChar String
x
encodeHtmlChar :: Char -> String
encodeHtmlChar :: Char -> String
encodeHtmlChar Char
'<' = String
"<"
encodeHtmlChar Char
'>' = String
">"
encodeHtmlChar Char
'&' = String
"&"
encodeHtmlChar Char
'"' = String
"""
encodeHtmlChar Char
'\'' = String
"'"
encodeHtmlChar Char
c = [Char
c]
writeHtmlCss :: HtmlWriter ()
writeHtmlCss :: HtmlWriter ()
writeHtmlCss =
do String -> HtmlWriter ()
writeHtmlLn String
"<style type=\"text/css\">"
String -> HtmlWriter ()
writeHtmlLn String
"* { margin: 0; padding: 0 }"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"html {"
String -> HtmlWriter ()
writeHtmlLn String
" background-color: white;"
String -> HtmlWriter ()
writeHtmlLn String
" width: 100%;"
String -> HtmlWriter ()
writeHtmlLn String
" height: 100%;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"body {"
String -> HtmlWriter ()
writeHtmlLn String
" background: white;"
String -> HtmlWriter ()
writeHtmlLn String
" color: black;"
String -> HtmlWriter ()
writeHtmlLn String
" text-align: left;"
String -> HtmlWriter ()
writeHtmlLn String
" min-height: 100%;"
String -> HtmlWriter ()
writeHtmlLn String
" width: 90%;"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0px auto 0px auto;"
String -> HtmlWriter ()
writeHtmlLn String
" position: relative;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"p {"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0.8em 0;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"ul, ol {"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0.8em 0 0.8em 2em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"dl {"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0.8em 0;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"dt {"
String -> HtmlWriter ()
writeHtmlLn String
" font-weight: bold;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"dd {"
String -> HtmlWriter ()
writeHtmlLn String
" margin-left: 2em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"a { text-decoration: none; }"
String -> HtmlWriter ()
writeHtmlLn String
"a[href]:link { color: rgb(196,69,29); }"
String -> HtmlWriter ()
writeHtmlLn String
"a[href]:visited { color: rgb(171,105,84); }"
String -> HtmlWriter ()
writeHtmlLn String
"a[href]:hover { text-decoration:underline; }"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"body {"
String -> HtmlWriter ()
writeHtmlLn String
" font-size:medium;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"h1 { font-size: 146.5%; /* 19pt */ } "
String -> HtmlWriter ()
writeHtmlLn String
"h2 { font-size: 131%; /* 17pt */ }"
String -> HtmlWriter ()
writeHtmlLn String
"h3 { font-size: 116%; /* 15pt */ }"
String -> HtmlWriter ()
writeHtmlLn String
"h4 { font-size: 100%; /* 13pt */ }"
String -> HtmlWriter ()
writeHtmlLn String
"h5 { font-size: 100%; /* 13pt */ }"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"select, input, button, textarea {"
String -> HtmlWriter ()
writeHtmlLn String
" font:99% sans-serif;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"table {"
String -> HtmlWriter ()
writeHtmlLn String
" font-size:inherit;"
String -> HtmlWriter ()
writeHtmlLn String
" font:100%;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"pre, code, kbd, samp, tt, .src {"
String -> HtmlWriter ()
writeHtmlLn String
" font-family:monospace;"
String -> HtmlWriter ()
writeHtmlLn String
" *font-size:108%;"
String -> HtmlWriter ()
writeHtmlLn String
" line-height: 124%;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
".links, .link {"
String -> HtmlWriter ()
writeHtmlLn String
" font-size: 85%; /* 11pt */"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
".info {"
String -> HtmlWriter ()
writeHtmlLn String
" font-size: 85%; /* 11pt */"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
".caption, h1, h2, h3, h4, h5, h6 { "
String -> HtmlWriter ()
writeHtmlLn String
" font-weight: bold;"
String -> HtmlWriter ()
writeHtmlLn String
" color: rgb(78,98,114);"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0.8em 0 0.4em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 {"
String -> HtmlWriter ()
writeHtmlLn String
" margin-top: 2em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 {"
String -> HtmlWriter ()
writeHtmlLn String
" margin-top: inherit;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"ul.links {"
String -> HtmlWriter ()
writeHtmlLn String
" list-style: none;"
String -> HtmlWriter ()
writeHtmlLn String
" text-align: left;"
String -> HtmlWriter ()
writeHtmlLn String
" float: right;"
String -> HtmlWriter ()
writeHtmlLn String
" display: inline-table;"
String -> HtmlWriter ()
writeHtmlLn String
" margin: 0 0 0 1em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"ul.links li {"
String -> HtmlWriter ()
writeHtmlLn String
" display: inline;"
String -> HtmlWriter ()
writeHtmlLn String
" border-left: 1px solid #d5d5d5; "
String -> HtmlWriter ()
writeHtmlLn String
" white-space: nowrap;"
String -> HtmlWriter ()
writeHtmlLn String
" padding: 0;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
""
String -> HtmlWriter ()
writeHtmlLn String
"ul.links li a {"
String -> HtmlWriter ()
writeHtmlLn String
" padding: 0.2em 0.5em;"
String -> HtmlWriter ()
writeHtmlLn String
"}"
String -> HtmlWriter ()
writeHtmlLn String
"</style>"