1f2e267 · project-m36 · git.iko.soy

git.iko.soy/project-m36

add websocket and HTML support for dataframes

commit1f2e26707e00e05cce14b9e4504bad7c754fac88 authorAgentM <agentm@themactionfaction.com> dateSun 6 Jan 2019, 23:42 (8 years ago) parenta92ad77

7 files changed+121−35

compare with master

unifiedsplit

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+13 src/bin/ProjectM36/Server/WebSocket.hs+8−1 src/lib/ProjectM36/Client.hs+3−3 src/lib/ProjectM36/DataFrame.hs+84−20 test/DataFrame.hs+1−1 test/TutorialD/Interpreter.hs+11−10 test/TutorialD/Interpreter/TestBase.hs+1

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs+13

@@ -4,6 +4,7 @@

44module ProjectM36.Server.RemoteCallTypes.Json where

55import ProjectM36.AtomFunctionError

66import ProjectM36.Base

7+import ProjectM36.DataFrame

78import ProjectM36.DatabaseContextFunctionError

89import ProjectM36.DataTypes.Primitive

910import ProjectM36.Error

@@ -63,6 +64,18 @@ instance FromJSON SchemaExpr

6364instance ToJSON SchemaIsomorph

6465instance FromJSON SchemaIsomorph

6566

67+instance ToJSON DataFrame

68+instance FromJSON DataFrame

69+

70+instance ToJSON DataFrameTuple

71+instance FromJSON DataFrameTuple

72+

73+instance ToJSON AttributeOrder

74+instance FromJSON AttributeOrder

75+

76+instance ToJSON Order

77+instance FromJSON Order

78+

6679instance ToJSON Atom where

6780 toJSON atom@(IntegerAtom i) = object [ "type" .= atomTypeForAtom atom,

6881 "val" .= i ]

src/bin/ProjectM36/Server/WebSocket.hs+8−1

@@ -10,6 +10,7 @@ import qualified Data.Text as T

1010import qualified Network.WebSockets as WS

1111import ProjectM36.Server.RemoteCallTypes.Json ()

1212import ProjectM36.Client.Json ()

13+import ProjectM36.DataFrame

1314import ProjectM36.Relation.Show.Term

1415import ProjectM36.Relation.Show.HTML

1516import Data.Aeson

@@ -94,6 +95,12 @@ handleOpResult conn _ presentation (DisplayRelationResult rel) = do

9495 texto = ["text" .= showRelation rel | textPresentation presentation]

9596 htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation]

9697 WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)]))

98+handleOpResult conn _ presentation (DisplayDataFrameResult df) = do

99+ let jsono = ["json" .= df | jsonPresentation presentation]

100+ texto = ["text" .= showDataFrame df | textPresentation presentation]

101+ htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation]

102+ WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)]))

103+

97104-- get current schema and head name for client

98105promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

99106promptInfo sessionId conn = do

@@ -124,4 +131,4 @@ parseExecuteMessage = do

124131 HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags

125132 _ <- char ':'

126133 tutd <- T.pack <$> manyTill anyChar endOfInput

127− pure (presentation, tutd)

134+ pure (presentation, tutd)

src/lib/ProjectM36/Client.hs+3−3

@@ -87,9 +87,9 @@ module ProjectM36.Client

8787 IncDepName,

8888 InclusionDependency(..),

8989 AttributeName,

90− DF.DataFrame(..),

91− DF.DataFrameExpr(..),

92− DF.AttributeOrderExpr(..),

90+ DF.DataFrame,

91+ DF.DataFrameExpr,

92+ DF.AttributeOrderExpr,

9393 DF.Order(..),

9494 RelationalError(..),

9595 RequestTimeoutException(..),

src/lib/ProjectM36/DataFrame.hs+84−20

@@ -6,8 +6,10 @@ import ProjectM36.Attribute as A

66import ProjectM36.Error

77import qualified ProjectM36.Relation as R

88import ProjectM36.Relation.Show.Term

9+import qualified ProjectM36.Relation.Show.HTML as RelHTML

910import ProjectM36.DataTypes.Sorting

1011import ProjectM36.AtomType

12+import ProjectM36.Atom

1113import qualified Data.Vector as V

1214import GHC.Generics

1315import qualified Data.List as L

@@ -15,20 +17,28 @@ import qualified Data.Set as S

1517import Data.Maybe

1618import qualified Data.Text as T

1719import Data.Binary

20+import Control.Arrow

1821

1922data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary)

2023data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary)

2124data Order = AscendingOrder | DescendingOrder deriving (Eq, Show, Generic, Binary)

2225

23−data DataFrame = DataFrame Attributes [DataFrameTuple] deriving (Show, Generic, Binary)

26+ascending :: T.Text

27+ascending = "⬆"

2428

25−data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary)

29+descending :: T.Text

30+descending = "⬇"

31+

32+arbitrary :: T.Text

33+arbitrary = "↕"

2634

27−attributes :: DataFrame -> Attributes

28−attributes (DataFrame attrs _) = attrs

35+data DataFrame = DataFrame {

36+ orders :: [AttributeOrder],

37+ attributes :: Attributes,

38+ tuples :: [DataFrameTuple]

39+ } deriving (Show, Generic, Binary)

2940

30−tuples :: DataFrame -> [DataFrameTuple]

31−tuples (DataFrame _ tups) = tups

41+data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom) deriving (Eq, Show, Generic, Binary)

3242

3343sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame

3444sortDataFrameBy attrOrders frame = do

@@ -37,7 +47,7 @@ sortDataFrameBy attrOrders frame = do

3747 Left (AttributeNotSortableError attr)

3848 else

3949 pure ()) attrs

40− pure $ DataFrame (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame))

50+ pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame))

4151

4252sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple]

4353sortTuplesBy = L.sortBy

@@ -69,36 +79,40 @@ atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findInde

6979 Just atom -> Right atom

7080

7181take' :: Integer -> DataFrame -> DataFrame

72−take' n (DataFrame attrs tuples') = DataFrame attrs (take (fromInteger n) tuples')

82+take' n df = df { tuples = take (fromInteger n) (tuples df) }

7383

7484drop' :: Integer -> DataFrame -> DataFrame

75−drop' n (DataFrame attrs tuples') = DataFrame attrs (drop (fromInteger n) tuples')

85+drop' n df = df { tuples = drop (fromInteger n) (tuples df) }

7686

7787toDataFrame :: Relation -> DataFrame

78−toDataFrame (Relation attrs (RelationTupleSet tuples')) = DataFrame attrs (map (\(RelationTuple tupAttrs tupVec) -> DataFrameTuple tupAttrs tupVec) tuples')

88+toDataFrame (Relation attrs (RelationTupleSet tuples')) = DataFrame [] attrs (map (\(RelationTuple tupAttrs tupVec) -> DataFrameTuple tupAttrs tupVec) tuples')

7989

8090fromDataFrame :: DataFrame -> Either RelationalError Relation

81−fromDataFrame (DataFrame attrs dftuples) = R.mkRelation attrs (RelationTupleSet tuples')

91+fromDataFrame df = R.mkRelation (attributes df) (RelationTupleSet tuples')

8292 where

83− tuples' = map (\(DataFrameTuple attrs' tupVec) -> RelationTuple attrs' tupVec) dftuples

93+ tuples' = map (\(DataFrameTuple attrs' tupVec) -> RelationTuple attrs' tupVec) (tuples df)

8494

95+showDataFrame :: DataFrame -> T.Text

96+showDataFrame = renderTable . dataFrameAsTable

97+

8598--terminal display

8699dataFrameAsTable :: DataFrame -> Table

87−dataFrameAsTable (DataFrame attrs tups) = (header, body)

100+dataFrameAsTable df = (header, body)

88101 where

89− oAttrNames = orderedAttributeNames attrs

90− oAttrs = orderedAttributes attrs

91− header = "DF" : map prettyAttribute oAttrs

92− body = snd (L.foldl' tupleFolder (1 :: Int,[]) tups)

102+ oAttrNames = orderedAttributeNames (attributes df)

103+ oAttrs = orderedAttributes (attributes df)

104+ header = "DF" : map dfPrettyAttribute oAttrs

105+ dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == attributeName attr) (orders df) of

106+ Nothing -> arbitrary

107+ Just (AttributeOrder _ AscendingOrder) -> ascending

108+ Just (AttributeOrder _ DescendingOrder) -> descending

109+ body = snd (L.foldl' tupleFolder (1 :: Int,[]) (tuples df))

93110 tupleFolder (count, acc) tuple = (count + 1,

94111 acc ++ [T.pack (show count) : map (\attrName -> case atomForAttributeName attrName tuple of

95112 Left _ -> "?"

96113 Right atom -> showAtom 0 atom

97114 ) oAttrNames])

98115

99−showDataFrame :: DataFrame -> StringType

100−showDataFrame = renderTable . dataFrameAsTable

101−

102116-- | A Relation can be converted to a DataFrame for sorting, limits, and offsets.

103117data DataFrameExpr = DataFrameExpr {

104118 convertExpr :: RelationalExpr,

@@ -106,3 +120,53 @@ data DataFrameExpr = DataFrameExpr {

106120 offset :: Maybe Integer,

107121 limit :: Maybe Integer

108122 } deriving (Show, Binary, Generic)

123+

124+dataFrameAsHTML :: DataFrame -> T.Text

125+-- 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

126+dataFrameAsHTML df

127+ | length (tuples df) == 1 && length (attributes df) == 0 = style <>

128+ tablestart <>

129+ "<tr><th></th></tr>" <>

130+ "<tr><td></td></tr>" <>

131+ tablefooter <> "</table>"

132+ | length (tuples df) == 0 && length (attributes df) == 0 = style <>

133+ tablestart <>

134+ "<tr><th></th></tr>" <>

135+ tablefooter <>

136+ "</table>"

137+ | otherwise = style <>

138+ tablestart <>

139+ attributesAsHTML (attributes df) (orders df) <>

140+ tuplesAsHTML (tuples df) <>

141+ tablefooter <>

142+ "</table>"

143+ where

144+ cardinality = T.pack (show (length (tuples df)))

145+ style = "<style>.pm36dataframe {empty-cells: show;} .pm36dataframe tbody td, .pm36relation th { border: 1px solid black;}</style>"

146+ tablefooter = "<tfoot><tr><td colspan=\"100%\">" <> cardinality <> " tuples</td></tr></tfoot>"

147+ tablestart = "<table class=\"pm36dataframe\"\">"

148+

149+tuplesAsHTML :: [DataFrameTuple] -> T.Text

150+tuplesAsHTML tups = foldr folder "" tups

151+ where

152+ folder tuple acc = acc <> tupleAsHTML tuple

153+

154+tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)]

155+tupleAssocs (DataFrameTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)

156+

157+

158+tupleAsHTML :: DataFrameTuple -> T.Text

159+tupleAsHTML tuple = "<tr>" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "</tr>"

160+ where

161+ tupleFrag tup = "<td>" <> atomAsHTML (snd tup) <> "</td>"

162+ atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel

163+ atomAsHTML atom = atomToText atom

164+

165+attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text

166+attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"

167+ where

168+ oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"

169+ ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of

170+ Nothing -> "(arb)"

171+ Just (AttributeOrder _ AscendingOrder) -> "(asc)"

172+ Just (AttributeOrder _ DescendingOrder) -> "(desc)"

test/DataFrame.hs+1−1

@@ -1,5 +1,5 @@

11import ProjectM36.Client

2−import ProjectM36.DataFrame (atomForAttributeName, tuples)

2+import ProjectM36.DataFrame

33import TutorialD.Interpreter.TestBase

55import Test.HUnit

test/TutorialD/Interpreter.hs+11−10

@@ -3,7 +3,7 @@ import TutorialD.Interpreter.TestBase

33import TutorialD.Interpreter

44import TutorialD.Interpreter.Base

55import Test.HUnit

6−import ProjectM36.Relation

6+import ProjectM36.Relation as R

77import ProjectM36.Tuple

88import ProjectM36.TupleSet

99import ProjectM36.Error

@@ -121,7 +121,7 @@ main = do

121121 simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]

122122 simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]

123123 nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]

124− extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]

124+ extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]

125125 byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]

126126 groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]

127127 minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]

@@ -133,10 +133,10 @@ main = do

133133 else Right tuple) suppliersRel

134134 dateExampleRelTests = [("x:=s where true", Right suppliersRel),

135135 ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),

136− ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),

137− ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),

136+ ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),

137+ ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),

138138 ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),

139− ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),

139+ ("x:=s minus (s where status=20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),

140140 --atom function tests

141141 ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),

142142 ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),

@@ -149,11 +149,11 @@ main = do

149149 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),

150150 ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),

151151 --boolean function restriction

152− ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),

153− ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],

152+ ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),

153+ ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],

154154 [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),

155155 ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),

156− ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),

156+ ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),

157157 --test "all but" attribute inversion syntax

158158 ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),

159159 --test key syntax

@@ -202,6 +202,7 @@ transactionGraphAddCommitTest = TestCase $ do

202202 DisplayResult _ -> assertFailure "display?"

203203 DisplayIOResult _ -> assertFailure "displayIO?"

204204 DisplayRelationResult _ -> assertFailure "displayrelation?"

205+ DisplayDataFrameResult _ -> assertFailure "displaydataframe?"

205206 DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"

206207 DisplayErrorResult err -> assertFailure (show err)

207208 QuietSuccessResult -> do

@@ -522,7 +523,7 @@ testRestrictionPredicateExprs = TestCase $ do

522523 -- and

523524 executeTutorialD sessionId dbconn "x:=s where status=20 and status=10"

524525 eRvAnd <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())

525− let expectedRelAnd = Right (emptyRelationWithAttrs (attributes suppliersRel))

526+ let expectedRelAnd = Right (emptyRelationWithAttrs (R.attributes suppliersRel))

526527 assertEqual "status 20 and 10" expectedRelAnd eRvAnd

527528

528529testRelationalAttributeNames :: Test

@@ -533,7 +534,7 @@ testRelationalAttributeNames = TestCase $ do

533534 case eRv of

534535 Left err -> assertFailure (show err)

535536 Right rel ->

536− assertEqual "attributes from sp" (attributes supplierProductsRel) (attributes rel)

537+ assertEqual "attributes from sp" (R.attributes supplierProductsRel) (R.attributes rel)

537538

538539testSemijoin :: Test

539540testSemijoin = TestCase $ do

test/TutorialD/Interpreter/TestBase.hs+1

@@ -35,6 +35,7 @@ executeTutorialD sessionId conn tutd = case parseTutorialD tutd of

3535 DisplayResult _ -> putStrLn "xxx" >> assertFailure "display?"

3636 DisplayIOResult _ -> putStrLn "z" >> assertFailure "displayIO?"

3737 DisplayRelationResult _ -> putStrLn "Y" >> assertFailure "displayrelation?"

38+ DisplayDataFrameResult _ -> putStrLn "DF" >> assertFailure "displaydataframe?"

3839 DisplayParseErrorResult _ _ -> putStrLn "X" >> assertFailure "displayparseerrorresult?"

3940 DisplayErrorResult err -> putStrLn "asd" >> assertFailure (show tutd ++ ": " ++ show err)

4041 QuietSuccessResult -> pure ()