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>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Attribute -> Text) -> [Attribute] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> Text
oneAttrHTML (Attributes -> [Attribute]
A.toList Attributes
attrs)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</tr>"
  where
    oneAttrHTML :: Attribute -> Text
oneAttrHTML Attribute
attr = Text
"<th>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Attribute -> Text
prettyAttribute Attribute
attr Text -> Text -> Text
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 Relation -> Relation -> Bool
forall a. Eq a => a -> a -> Bool
== Relation
relationTrue = Text
pm36relcss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                          Text
tablestart Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                          Text
"<tr><th></th></tr>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                          Text
"<tr><td></td></tr>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                          Text
tablefooter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</table>"
  | Relation
rel Relation -> Relation -> Bool
forall a. Eq a => a -> a -> Bool
== Relation
relationFalse = Text
pm36relcss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
tablestart Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
"<tr><th></th></tr>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                           Text
tablefooter Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                           Text
"</table>"
  | Bool
otherwise = Text
pm36relcss Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                Text
tablestart Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                Attributes -> Text
attributesAsHTML Attributes
attrNameSet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                RelationTupleSet -> Text
tupleSetAsHTML RelationTupleSet
tupleSet Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 
                Text
tablefooter Text -> Text -> Text
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%\">" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (RelationCardinality -> String
forall a. Show a => a -> String
show (Relation -> RelationCardinality
cardinality Relation
rel)) Text -> Text -> Text
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 (Text -> IO ()) -> (Relation -> Text) -> Relation -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation -> Text
relationAsHTML

tupleAsHTML :: RelationTuple -> Text
tupleAsHTML :: RelationTuple -> Text
tupleAsHTML RelationTuple
tuple = Text
"<tr>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat (((Text, Atom) -> Text) -> [(Text, Atom)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
L.map (Text, Atom) -> Text
forall a. (a, Atom) -> Text
tupleFrag (RelationTuple -> [(Text, Atom)]
tupleAssocs RelationTuple
tuple)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</tr>"
  where
    tupleFrag :: (a, Atom) -> Text
tupleFrag (a, Atom)
tup = Text
"<td>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Atom -> Text
atomAsHTML ((a, Atom) -> Atom
forall a b. (a, b) -> b
snd (a, Atom)
tup) Text -> Text -> Text
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;" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t Text -> Text -> Text
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 = (RelationTuple -> Text -> Text) -> Text -> [RelationTuple] -> Text
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RelationTuple -> Text
tupleAsHTML RelationTuple
tuple