git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/lib/ProjectM36/Relation/Show/HTML.hs
60 lines 2.4 kB history raw
1module ProjectM36.Relation.Show.HTML where
2import ProjectM36.Base
3import ProjectM36.Relation
4import ProjectM36.Tuple
5import ProjectM36.Atom
6import ProjectM36.AtomType
7import qualified Data.List as L
8import Data.Text (Text, pack)
9import qualified Data.Text as T
10import qualified Data.Text.IO as TIO
11import Data.Monoid
12import qualified Data.Vector as V
14attributesAsHTML :: Attributes -> Text
15attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"
16 where
17 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> "</th>"
19relationAsHTML :: Relation -> Text
20-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser
21relationAsHTML rel@(Relation attrNameSet tupleSet)
22 | rel == relationTrue = pm36relcss <>
23 tablestart <>
24 "<tr><th></th></tr>" <>
25 "<tr><td></td></tr>" <>
26 tablefooter <> "</table>"
27 | rel == relationFalse = pm36relcss <>
28 tablestart <>
29 "<tr><th></th></tr>" <>
30 tablefooter <>
31 "</table>"
32 | otherwise = pm36relcss <>
33 tablestart <>
34 attributesAsHTML attrNameSet <>
35 tupleSetAsHTML tupleSet <>
36 tablefooter <>
37 "</table>"
38 where
39 pm36relcss = "<style>.pm36relation {empty-cells: show;} .pm36relation tbody td, .pm36relation th { border: 1px solid black;}</style>"
40 tablefooter = "<tfoot><tr><td colspan=\"100%\">" <> pack (show (cardinality rel)) <> " tuples</td></tr></tfoot>"
41 tablestart = "<table class=\"pm36relation\"\">"
43writeHTML :: Text -> IO ()
44writeHTML = TIO.writeFile "/home/agentm/rel.html"
46writeRel :: Relation -> IO ()
47writeRel = writeHTML . relationAsHTML
49tupleAsHTML :: RelationTuple -> Text
50tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "</tr>"
51 where
52 tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"
53 atomAsHTML (RelationAtom rel) = relationAsHTML rel
54 atomAsHTML atom = atomToText atom
56tupleSetAsHTML :: RelationTupleSet -> Text
57tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)
58 where
59 folder tuple acc = acc <> tupleAsHTML tuple