module ProjectM36.Relation.Show.HTML where
import ProjectM36.Base
import ProjectM36.Relation
import ProjectM36.Tuple
import ProjectM36.Atom
import ProjectM36.Attribute as A
import ProjectM36.AtomType
import qualified Data.List as L
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif

attributesAsHTML :: Attributes -> Text
attributesAsHTML :: Attributes -> Text
attributesAsHTML Attributes
attrs = Text
"<tr>" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Text
oneAttrHTML (Attributes -> [Attribute]
A.toList Attributes
attrs)) forall a. Semigroup a => a -> a -> a
<> Text
"</tr>"
  where
    oneAttrHTML :: Attribute -> Text
oneAttrHTML Attribute
attr = Text
"<th>" forall a. Semigroup a => a -> a -> a
<> Attribute -> Text
prettyAttribute Attribute
attr forall a. Semigroup a => a -> a -> a
<> Text
"</th>"

relationAsHTML :: Relation -> Text
-- 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
relationAsHTML :: Relation -> Text
relationAsHTML rel :: Relation
rel@(Relation Attributes
attrNameSet RelationTupleSet
tupleSet) 
  | Relation
rel forall a. Eq a => a -> a -> Bool
== Relation
relationTrue = Text
pm36relcss forall a. Semigroup a => a -> a -> a
<>
                          Text
tablestart forall a. Semigroup a => a -> a -> a
<>
                          Text
"<tr><th></th></tr>" forall a. Semigroup a => a -> a -> a
<>
                          Text
"<tr><td></td></tr>" forall a. Semigroup a => a -> a -> a
<> 
                          Text
tablefooter forall a. Semigroup a => a -> a -> a
<> Text
"</table>"
  | Relation
rel forall a. Eq a => a -> a -> Bool
== Relation
relationFalse = Text
pm36relcss forall a. Semigroup a => a -> a -> a
<>
                           Text
tablestart forall a. Semigroup a => a -> a -> a
<>
                           Text
"<tr><th></th></tr>" forall a. Semigroup a => a -> a -> a
<>
                           Text
tablefooter forall a. Semigroup a => a -> a -> a
<> 
                           Text
"</table>"
  | Bool
otherwise = Text
pm36relcss forall a. Semigroup a => a -> a -> a
<>
                Text
tablestart forall a. Semigroup a => a -> a -> a
<> 
                Attributes -> Text
attributesAsHTML Attributes
attrNameSet forall a. Semigroup a => a -> a -> a
<> 
                RelationTupleSet -> Text
tupleSetAsHTML RelationTupleSet
tupleSet forall a. Semigroup a => a -> a -> a
<> 
                Text
tablefooter forall a. Semigroup a => a -> a -> a
<> 
                Text
"</table>"
  where
    pm36relcss :: Text
pm36relcss = Text
"<style>.pm36relation {empty-cells: show;} .pm36relation tbody td, .pm36relation th { border: 1px solid black;}</style>"
    tablefooter :: Text
tablefooter = Text
"<tfoot><tr><td colspan=\"100%\">" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show (Relation -> RelationCardinality
cardinality Relation
rel)) forall a. Semigroup a => a -> a -> a
<> Text
" tuples</td></tr></tfoot>"
    tablestart :: Text
tablestart = Text
"<table class=\"pm36relation\"\">"

writeHTML :: Text -> IO ()
writeHTML :: Text -> IO ()
writeHTML = String -> Text -> IO ()
TIO.writeFile String
"/home/agentm/rel.html"

writeRel :: Relation -> IO ()
writeRel :: Relation -> IO ()
writeRel = Text -> IO ()
writeHTML forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation -> Text
relationAsHTML

tupleAsHTML :: RelationTuple -> Text
tupleAsHTML :: RelationTuple -> Text
tupleAsHTML RelationTuple
tuple = Text
"<tr>" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
L.map forall {a}. (a, Atom) -> Text
tupleFrag (RelationTuple -> [(Text, Atom)]
tupleAssocs RelationTuple
tuple)) forall a. Semigroup a => a -> a -> a
<> Text
"</tr>"
  where
    tupleFrag :: (a, Atom) -> Text
tupleFrag (a, Atom)
tup = Text
"<td>" forall a. Semigroup a => a -> a -> a
<> Atom -> Text
atomAsHTML (forall a b. (a, b) -> b
snd (a, Atom)
tup) forall a. Semigroup a => a -> a -> a
<> Text
"</td>"
    atomAsHTML :: Atom -> Text
atomAsHTML (RelationAtom Relation
rel) = Relation -> Text
relationAsHTML Relation
rel
    atomAsHTML (TextAtom Text
t) = Text
"&quot;" forall a. Semigroup a => a -> a -> a
<> Text
t forall a. Semigroup a => a -> a -> a
<> Text
"&quot;"
    atomAsHTML Atom
atom = Atom -> Text
atomToText Atom
atom

tupleSetAsHTML :: RelationTupleSet -> Text
tupleSetAsHTML :: RelationTupleSet -> Text
tupleSetAsHTML RelationTupleSet
tupSet = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RelationTuple -> Text -> Text
folder Text
"" (RelationTupleSet -> [RelationTuple]
asList RelationTupleSet
tupSet)
  where
    folder :: RelationTuple -> Text -> Text
folder RelationTuple
tuple Text
acc = Text
acc forall a. Semigroup a => a -> a -> a
<> RelationTuple -> Text
tupleAsHTML RelationTuple
tuple