{-# LANGUAGE Safe #-}
module Text.Show.Html
( HtmlOpts(..), defaultHtmlOpts
, valToHtml, valToHtmlPage, htmlPage
, Html(..)
) where
import Text.Show.Value
import Prelude hiding (span)
valToHtmlPage :: HtmlOpts -> Value -> String
valToHtmlPage :: HtmlOpts -> Value -> [Char]
valToHtmlPage HtmlOpts
opts = HtmlOpts -> Html -> [Char]
htmlPage HtmlOpts
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlOpts -> Value -> Html
valToHtml HtmlOpts
opts
data HtmlOpts = HtmlOpts
{ HtmlOpts -> [Char]
dataDir :: FilePath
, HtmlOpts -> Int
wideListWidth :: Int
} deriving Int -> HtmlOpts -> ShowS
[HtmlOpts] -> ShowS
HtmlOpts -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HtmlOpts] -> ShowS
$cshowList :: [HtmlOpts] -> ShowS
show :: HtmlOpts -> [Char]
$cshow :: HtmlOpts -> [Char]
showsPrec :: Int -> HtmlOpts -> ShowS
$cshowsPrec :: Int -> HtmlOpts -> ShowS
Show
defaultHtmlOpts :: HtmlOpts
defaultHtmlOpts :: HtmlOpts
defaultHtmlOpts = HtmlOpts
{ dataDir :: [Char]
dataDir = [Char]
""
, wideListWidth :: Int
wideListWidth = Int
80
}
valToHtml :: HtmlOpts -> Value -> Html
valToHtml :: HtmlOpts -> Value -> Html
valToHtml HtmlOpts
opts = Value -> Html
loop
where
loop :: Value -> Html
loop Value
val =
case Value
val of
Con [Char]
con [] -> [Char] -> Html -> Html
span [Char]
"con" ([Char] -> Html
text [Char]
con)
Con [Char]
con [Value]
vs -> [Char] -> [[Char]] -> [Html] -> Html
tallRecord [Char]
con (forall a b. (a -> b) -> [a] -> [b]
map forall {p}. p -> [Char]
conLab [Value]
vs) (forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs)
Rec [Char]
con [([Char], Value)]
fs -> [Char] -> [[Char]] -> [Html] -> Html
tallRecord [Char]
con (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], Value)]
fs) (forall a b. (a -> b) -> [a] -> [b]
map (Value -> Html
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Char], Value)]
fs)
Tuple [Value]
vs -> [Html] -> Html
wideTuple (forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs)
InfixCons Value
v [([Char], Value)]
ms ->
[Char] -> [Html] -> Html
table [Char]
"infix tallRecord"
[ [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ ([Char] -> Int -> Html -> Html
th [Char]
"label" Int
1 ([Char] -> Html
text [Char]
" ") forall a. a -> [a] -> [a]
:)
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Html -> Html
td forall a b. (a -> b) -> a -> b
$ Value -> Html
loop Value
v forall a. a -> [a] -> [a]
: [ Html
h | ([Char]
op,Value
u) <- [([Char], Value)]
ms
, Html
h <- [ [Char] -> Html
text [Char]
op, Value -> Html
loop Value
u ]
]
]
List [] -> [Char] -> Html -> Html
span [Char]
"list" ([Char] -> Html
text [Char]
"[]")
List vs :: [Value]
vs@(Value
v : [Value]
vs1) ->
case Value
v of
Con [Char]
c [Value]
fs
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Char] -> Value -> Bool
isCon [Char]
c) [Value]
vs1 -> [Char] -> [[Char]] -> [[Html]] -> Html
recordList [Char]
c (forall a b. (a -> b) -> [a] -> [b]
map forall {p}. p -> [Char]
conLab [Value]
fs)
[ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
xs | Con [Char]
_ [Value]
xs <- [Value]
vs ]
| Bool
otherwise -> [Html] -> Html
tallList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Value -> Html
loop) [Value]
vs
Rec [Char]
c [([Char], Value)]
fs
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Char] -> Value -> Bool
isRec [Char]
c) [Value]
vs1 -> [Char] -> [[Char]] -> [[Html]] -> Html
recordList [Char]
c (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [([Char], Value)]
fs)
[ forall a b. (a -> b) -> [a] -> [b]
map (Value -> Html
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [([Char], Value)]
xs | Rec [Char]
_ [([Char], Value)]
xs <- [Value]
vs ]
| Bool
otherwise -> [Html] -> Html
tallList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Value -> Html
loop) [Value]
vs
Tuple [Value]
fs -> Int -> [[Html]] -> Html
tupleList (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
fs)
[ forall a b. (a -> b) -> [a] -> [b]
map (Value -> Html
loop) [Value]
xs | Tuple [Value]
xs <- [Value]
vs ]
List {} -> [Html] -> Html
tallList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Neg {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Ratio {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Integer {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Float {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Char {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Date {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Time {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Quote {} -> Int -> [Html] -> Html
wideList (HtmlOpts -> Int
wideListWidth HtmlOpts
opts) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
String {} -> [Html] -> Html
tallList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
InfixCons {} -> [Html] -> Html
tallList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Value -> Html
loop [Value]
vs
Neg Value
v ->
case Value
v of
Integer [Char]
txt -> [Char] -> Html -> Html
span [Char]
"integer" forall a b. (a -> b) -> a -> b
$ [Char] -> Html
text (Char
'-' forall a. a -> [a] -> [a]
: [Char]
txt)
Float [Char]
txt -> [Char] -> Html -> Html
span [Char]
"float" forall a b. (a -> b) -> a -> b
$ [Char] -> Html
text (Char
'-' forall a. a -> [a] -> [a]
: [Char]
txt)
Value
_ -> Html -> Html
neg (Value -> Html
loop Value
v)
Ratio Value
v1 Value
v2 -> Html -> Html -> Html
ratio (Value -> Html
loop Value
v1) (Value -> Html
loop Value
v2)
Integer [Char]
txt -> [Char] -> Html -> Html
span [Char]
"integer" ([Char] -> Html
text [Char]
txt)
Float [Char]
txt -> [Char] -> Html -> Html
span [Char]
"float" ([Char] -> Html
text [Char]
txt)
Char [Char]
txt -> [Char] -> Html -> Html
span [Char]
"char" ([Char] -> Html
text [Char]
txt)
String [Char]
txt -> [Char] -> Html -> Html
span [Char]
"string" ([Char] -> Html
text [Char]
txt)
Date [Char]
txt -> [Char] -> Html -> Html
span [Char]
"date" ([Char] -> Html
text [Char]
txt)
Time [Char]
txt -> [Char] -> Html -> Html
span [Char]
"time" ([Char] -> Html
text [Char]
txt)
Quote [Char]
txt -> [Char] -> Html -> Html
span [Char]
"quote" ([Char] -> Html
text [Char]
txt)
conLab :: p -> [Char]
conLab p
_ = [Char]
" "
isCon :: [Char] -> Value -> Bool
isCon [Char]
c (Con [Char]
d [Value]
_) = [Char]
c forall a. Eq a => a -> a -> Bool
== [Char]
d
isCon [Char]
_ Value
_ = Bool
False
isRec :: [Char] -> Value -> Bool
isRec [Char]
c (Rec [Char]
d [([Char], Value)]
_) = [Char]
c forall a. Eq a => a -> a -> Bool
== [Char]
d
isRec [Char]
_ Value
_ = Bool
False
neg :: Html -> Html
neg :: Html -> Html
neg Html
e = [Char] -> [Html] -> Html
table [Char]
"negate" [ [Html] -> Html
tr [Html -> Html
td ([Char] -> Html
text [Char]
"-"), Html -> Html
td Html
e] ]
ratio :: Html -> Html -> Html
ratio :: Html -> Html -> Html
ratio Html
e1 Html
e2 = [Char] -> [Html] -> Html
table [Char]
"ratio" [ [Html] -> Html
tr [ [Char] -> Html -> Html
td' [Char]
"numerator" Html
e1 ], [Html] -> Html
tr [Html -> Html
td Html
e2] ]
wideTuple :: [Html] -> Html
wideTuple :: [Html] -> Html
wideTuple [Html]
els = [Char] -> [Html] -> Html
table [Char]
"wideTuple" [ [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Html -> Html
td [Html]
els ]
tallTuple :: [Html] -> Html
tallTuple :: [Html] -> Html
tallTuple [Html]
els = [Char] -> [Html] -> Html
table [Char]
"tallTuple" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Html] -> Html
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
td) [Html]
els
tallRecord :: Name -> [Name] -> [Html] -> Html
tallRecord :: [Char] -> [[Char]] -> [Html] -> Html
tallRecord [Char]
con [[Char]]
labs [Html]
els = [Char] -> [Html] -> Html
table [Char]
"tallRecord" forall a b. (a -> b) -> a -> b
$ Html
topHs forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Char] -> Html -> Html
row [[Char]]
labs [Html]
els
where
topHs :: Html
topHs = [Html] -> Html
tr [ [Char] -> Int -> Html -> Html
th [Char]
"con" Int
2 ([Char] -> Html
text [Char]
con) ]
row :: [Char] -> Html -> Html
row [Char]
l Html
e = [Html] -> Html
tr [ [Char] -> Int -> Html -> Html
th [Char]
"label" Int
1 ([Char] -> Html
text [Char]
l), Html -> Html
td Html
e ]
recordList :: Name -> [Name] -> [[Html]] -> Html
recordList :: [Char] -> [[Char]] -> [[Html]] -> Html
recordList [Char]
con [[Char]]
labs [[Html]]
els = [Char] -> [Html] -> Html
table [Char]
"recordList" forall a b. (a -> b) -> a -> b
$ Html
topHs forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Html] -> Html
row [Int
0..] [[Html]]
els
where
topHs :: Html
topHs = [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Html -> Html
th [Char]
"con" Int
1 ([Char] -> Html
text [Char]
con) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int -> Html -> Html
th [Char]
"label" Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Html
text) [[Char]]
labs
row :: Int -> [Html] -> Html
row Int
n [Html]
es = [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Html -> Html
th [Char]
"ix" Int
1 (Int -> Html
int Int
n) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Html -> Html
td [Html]
es
tupleList :: Int -> [[Html]] -> Html
tupleList :: Int -> [[Html]] -> Html
tupleList Int
n [[Html]]
els = [Char] -> [[Char]] -> [[Html]] -> Html
recordList [Char]
" " (forall a. Int -> a -> [a]
replicate Int
n [Char]
" ") [[Html]]
els
tallList :: [Html] -> Html
tallList :: [Html] -> Html
tallList [Html]
els = [Char] -> [Html] -> Html
table [Char]
"tallList" forall a b. (a -> b) -> a -> b
$ Html
top forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Html -> Html
row [Int
0..] [Html]
els
where
top :: Html
top = [Html] -> Html
tr [ [Char] -> Int -> Html -> Html
th [Char]
"con" Int
2 ([Char] -> Html
text [Char]
" ")]
row :: Int -> Html -> Html
row Int
n Html
e = [Html] -> Html
tr [ [Char] -> Int -> Html -> Html
th [Char]
"ix" Int
1 (Int -> Html
int Int
n), Html -> Html
td Html
e ]
wideList :: Int -> [Html] -> Html
wideList :: Int -> [Html] -> Html
wideList Int
w [Html]
els = [Char] -> [Html] -> Html
table [Char]
"wideList" forall a b. (a -> b) -> a -> b
$ Html
topHs forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [Html] -> Html
row [Int
0..] ([Html] -> [[Html]]
chop [Html]
els)
where
elNum :: Int
elNum = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Html]
els
pad :: Bool
pad = Int
elNum forall a. Ord a => a -> a -> Bool
> Int
w
chop :: [Html] -> [[Html]]
chop [] = []
chop [Html]
xs = let ([Html]
as,[Html]
bs) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
w [Html]
xs
in forall a. Int -> [a] -> [a]
take Int
w ([Html]
as forall a. [a] -> [a] -> [a]
++ if Bool
pad then forall a. a -> [a]
repeat Html
empty else []) forall a. a -> [a] -> [a]
: [Html] -> [[Html]]
chop [Html]
bs
topHs :: Html
topHs = [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Html -> Html
th [Char]
"con" Int
1 ([Char] -> Html
text [Char]
" ") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Int -> Html -> Html
th [Char]
"label" Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Html
int)
[ Int
0 .. forall a. Ord a => a -> a -> a
min Int
elNum Int
w forall a. Num a => a -> a -> a
- Int
1 ]
row :: Int -> [Html] -> Html
row Int
n [Html]
es = [Html] -> Html
tr forall a b. (a -> b) -> a -> b
$ ([Char] -> Int -> Html -> Html
th [Char]
"ix" Int
1 (Int -> Html
int (Int
nforall a. Num a => a -> a -> a
*Int
w))) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Html -> Html
td [Html]
es
newtype Html = Html { Html -> [Char]
exportHtml :: String }
table :: String -> [Html] -> Html
table :: [Char] -> [Html] -> Html
table [Char]
cl [Html]
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<table class=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
cl forall a. [a] -> [a] -> [a]
++ [Char]
">" forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Html -> [Char]
exportHtml [Html]
body forall a. [a] -> [a] -> [a]
++
[Char]
"</table>"
tr :: [Html] -> Html
tr :: [Html] -> Html
tr [Html]
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<tr>" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Html -> [Char]
exportHtml [Html]
body forall a. [a] -> [a] -> [a]
++ [Char]
"</tr>"
th :: String -> Int -> Html -> Html
th :: [Char] -> Int -> Html -> Html
th [Char]
cl Int
n Html
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<th class=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
cl forall a. [a] -> [a] -> [a]
++
[Char]
" colspan=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. Show a => a -> [Char]
show Int
n) forall a. [a] -> [a] -> [a]
++ [Char]
">" forall a. [a] -> [a] -> [a]
++
Html -> [Char]
exportHtml Html
body forall a. [a] -> [a] -> [a]
++
[Char]
"</th>"
td :: Html -> Html
td :: Html -> Html
td Html
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<td>" forall a. [a] -> [a] -> [a]
++ Html -> [Char]
exportHtml Html
body forall a. [a] -> [a] -> [a]
++ [Char]
"</td>"
td' :: String -> Html -> Html
td' :: [Char] -> Html -> Html
td' [Char]
cl Html
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<td class=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
cl forall a. [a] -> [a] -> [a]
++ [Char]
">" forall a. [a] -> [a] -> [a]
++
Html -> [Char]
exportHtml Html
body forall a. [a] -> [a] -> [a]
++
[Char]
"</td>"
span :: String -> Html -> Html
span :: [Char] -> Html -> Html
span [Char]
cl Html
body = [Char] -> Html
Html forall a b. (a -> b) -> a -> b
$ [Char]
"<span class=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
cl forall a. [a] -> [a] -> [a]
++ [Char]
">" forall a. [a] -> [a] -> [a]
++
Html -> [Char]
exportHtml Html
body forall a. [a] -> [a] -> [a]
++
[Char]
"</span>"
empty :: Html
empty :: Html
empty = [Char] -> Html
Html [Char]
""
int :: Int -> Html
int :: Int -> Html
int = [Char] -> Html
Html forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show
text :: String -> Html
text :: [Char] -> Html
text = [Char] -> Html
Html forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
esc
where
esc :: Char -> [Char]
esc Char
'<' = [Char]
"<"
esc Char
'>' = [Char]
">"
esc Char
'&' = [Char]
"&"
esc Char
' ' = [Char]
" "
esc Char
c = [Char
c]
htmlPage :: HtmlOpts -> Html -> String
htmlPage :: HtmlOpts -> Html -> [Char]
htmlPage HtmlOpts
opts Html
body =
[[Char]] -> [Char]
unlines
[ [Char]
"<html>"
, [Char]
"<head>"
, [Char]
"<link href=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
pstyle forall a. [a] -> [a] -> [a]
++ [Char]
" rel=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
"stylesheet" forall a. [a] -> [a] -> [a]
++ [Char]
">"
, [Char]
"<script src=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
jquery forall a. [a] -> [a] -> [a]
++ [Char]
"></script>"
, [Char]
"<script src=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
pjs forall a. [a] -> [a] -> [a]
++ [Char]
"></script>"
, [Char]
"<body>"
, Html -> [Char]
exportHtml Html
body
, [Char]
"</body>"
, [Char]
"</html>"
]
where
dir :: [Char]
dir = case HtmlOpts -> [Char]
dataDir HtmlOpts
opts of
[Char]
"" -> [Char]
""
[Char]
d -> [Char]
d forall a. [a] -> [a] -> [a]
++ [Char]
"/"
jquery :: [Char]
jquery = [Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"style/jquery.js"
pjs :: [Char]
pjs = [Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"style/pretty-show.js"
pstyle :: [Char]
pstyle = [Char]
dir forall a. [a] -> [a] -> [a]
++ [Char]
"style/pretty-show.css"