git.iko.soy/project-m36
on 69ff6cd help sign in
project-m36/src/lib/ProjectM36/Relation/Show/HTML.hs
63 lines 2.5 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
11#if __GLASGOW_HASKELL__ < 804
12import Data.Monoid
13#endif
14import qualified Data.Vector as V
16attributesAsHTML :: Attributes -> Text
17attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"
18 where
19 oneAttrHTML attr = "<th>" <> prettyAttribute attr <> "</th>"
21relationAsHTML :: Relation -> Text
22-- 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
23relationAsHTML rel@(Relation attrNameSet tupleSet)
24 | rel == relationTrue = pm36relcss <>
25 tablestart <>
26 "<tr><th></th></tr>" <>
27 "<tr><td></td></tr>" <>
28 tablefooter <> "</table>"
29 | rel == relationFalse = pm36relcss <>
30 tablestart <>
31 "<tr><th></th></tr>" <>
32 tablefooter <>
33 "</table>"
34 | otherwise = pm36relcss <>
35 tablestart <>
36 attributesAsHTML attrNameSet <>
37 tupleSetAsHTML tupleSet <>
38 tablefooter <>
39 "</table>"
40 where
41 pm36relcss = "<style>.pm36relation {empty-cells: show;} .pm36relation tbody td, .pm36relation th { border: 1px solid black;}</style>"
42 tablefooter = "<tfoot><tr><td colspan=\"100%\">" <> pack (show (cardinality rel)) <> " tuples</td></tr></tfoot>"
43 tablestart = "<table class=\"pm36relation\"\">"
45writeHTML :: Text -> IO ()
46writeHTML = TIO.writeFile "/home/agentm/rel.html"
48writeRel :: Relation -> IO ()
49writeRel = writeHTML . relationAsHTML
51tupleAsHTML :: RelationTuple -> Text
52tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "</tr>"
53 where
54 tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"
55 atomAsHTML (RelationAtom rel) = relationAsHTML rel
56 atomAsHTML (TextAtom t) = "&quot;" <> t <> "&quot;"
57 atomAsHTML atom = atomToText atom
59tupleSetAsHTML :: RelationTupleSet -> Text
60tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)
61 where
62 folder tuple acc = acc <> tupleAsHTML tuple