git.iko.soy/project-m36
on master help sign in
add relation variable summary RO context operator
commit447534c9b1011d29f79558136f987884d20667a2 authorAgentM <agentm@themactionfaction.com> dateSun 3 Apr 2016, 15:47 (11 years ago) parent8b0c800
10 files changed+120−17
compare with master
unifiedsplit
ProjectM36/AtomType.hs+16−1 ProjectM36/Client.hs+13 ProjectM36/Relation.hs+17−1 ProjectM36/Relation/Show/Term.hs+1−12 ProjectM36/Server.hs+2−1 ProjectM36/Server/EntryPoints.hs+7−1 ProjectM36/Server/RemoteCallTypes.hs+3−1 TutorialD/Interpreter/RODatabaseContextOperator.hs+12 docs/tutd_tutorial.markdown+40 test/Server/Main.hs+9
ProjectM36/AtomType.hs+16−1
@@ -1,6 +1,8 @@
11{-# LANGUAGE OverloadedStrings #-}
22module ProjectM36.AtomType where
33import ProjectM36.Base
4+import ProjectM36.ConcreteTypeRep
5+import Data.Typeable
46import qualified ProjectM36.TypeConstructorDef as TCD
57import qualified ProjectM36.TypeConstructor as TC
68import qualified ProjectM36.DataConstructorDef as DCD
@@ -14,6 +16,7 @@ import Data.Maybe (isJust)
1416import Data.Either (rights)
1517import Control.Monad.Writer
1618import qualified Data.Map as M
19+import qualified Data.Text as T
1720--import Debug.Trace
1821
1922findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)
@@ -249,4 +252,16 @@ atomTypeVerify x y = if x == y then
249252
250253-- | Determine if two typeVar
251254typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool
252−typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a
255+typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a
256+
257+prettyAtomType :: AtomType -> T.Text
258+prettyAtomType (AtomType primitiveType) = T.pack (tyConName (fst (splitTyConApp (unCTR primitiveType))))
259+prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"
260+prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))
261+ where
262+ showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"
263+-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)
264+prettyAtomType AnyAtomType = "?AnyAtomType?"
265+
266+prettyAttribute :: Attribute -> T.Text
267+prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)
ProjectM36/Client.hs+13
@@ -18,6 +18,7 @@ module ProjectM36.Client
1818 planForDatabaseContextExpr,
1919 processPersistence,
2020 transactionGraphAsRelation,
21+ relationVariablesAsRelation,
2122 headName,
2223 remoteDBLookupName,
2324 defaultServerPort,
@@ -35,6 +36,7 @@ module ProjectM36.Client
3536 createSessionAtHead,
3637 closeSession,
3738 addClientNode,
39+ RelationCardinality(..),
3840 TransactionGraphOperator(..),
3941 Atomable,
4042 NodeId(..),
@@ -62,6 +64,7 @@ import ProjectM36.Persist (DiskSync(..))
6264import ProjectM36.Notifications
6365import ProjectM36.Server.RemoteCallTypes
6466import ProjectM36.Relation (typesAsRelation)
67+import qualified ProjectM36.Relation as R
6568import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)
6669import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)
6770import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)
@@ -483,6 +486,16 @@ transactionGraphAsRelation sessionId (InProcessConnection _ _ sessions tvar) = d
483486
484487transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveTransactionGraph sessionId)
485488
489+relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)
490+relationVariablesAsRelation sessionId (InProcessConnection _ _ sessions _) = do
491+ atomically $ do
492+ eSession <- sessionForSessionId sessionId sessions
493+ case eSession of
494+ Left err -> pure (Left err)
495+ Right (Session (DisconnectedTransaction _ context)) -> pure $ R.relationVariablesAsRelation (relationVariables context)
496+
497+relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)
498+
486499-- | Returns the UUID for the connection's disconnected transaction committed parent transaction.
487500headTransactionUUID :: SessionId -> Connection -> IO (Maybe UUID)
488501headTransactionUUID sessionId (InProcessConnection _ _ sessions _) = do
ProjectM36/Relation.hs+17−1
@@ -4,7 +4,9 @@ import qualified Data.Set as S
44import qualified Data.HashSet as HS
55import Control.Monad
66import qualified Data.Vector as V
7+import qualified Data.Map as M
78import ProjectM36.Atom
9+import ProjectM36.AtomType
810import ProjectM36.Base
911import ProjectM36.Tuple
1012import ProjectM36.DataTypes.Primitive
@@ -276,6 +278,7 @@ imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSe
276278 tupleSetJoiner tup1 acc = undefined
277279-}
278280
281+-- | Return a Relation describing the types in the mapping.
279282typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation
280283typesAsRelation types = mkRelationFromTuples attrs tuples
281284 where
@@ -291,5 +294,18 @@ typesAsRelation types = mkRelationFromTuples attrs tuples
291294 Left err -> error ("mkRelationFromTuples pooped " ++ show err)
292295 Right rel -> Atom rel
293296
294−
297+-- | Return a Relation describing the relation variables.
298+relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation
299+relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups
300+ where
301+ subrelAttrs = A.attributesFromList [Attribute "attribute" textAtomType, Attribute "type" textAtomType]
302+ attrs = A.attributesFromList [Attribute "name" textAtomType,
303+ Attribute "attributes" (RelationAtomType subrelAttrs)]
304+ tups = map relVarToAtomList (M.toList relVarMap)
305+ relVarToAtomList (rvName, rel) = [textAtom rvName, attributesToRel (attributes rel)]
306+ attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of
307+ Left err -> error ("relationVariablesAsRelation pooped " ++ show err)
308+ Right rel -> Atom rel
309+ attrAtoms a = [textAtom (A.attributeName a), textAtom (prettyAtomType (A.atomType a))]
310+
295311
ProjectM36/Relation/Show/Term.hs+1−12
@@ -2,6 +2,7 @@
22--writes Relation to a String suitable for terminal output
33module ProjectM36.Relation.Show.Term where
44import ProjectM36.Base
5+import ProjectM36.AtomType
56import ProjectM36.Tuple
67import ProjectM36.Relation
78import ProjectM36.Attribute
@@ -82,18 +83,6 @@ cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . brea
8283 lengths row = map T.length (breakLines row)
8384 allRows = [header] ++ body
8485
85−attributeAsCell :: Attribute -> Cell
86−attributeAsCell attr = attributeName attr `T.append` "::" `T.append` prettyAtomType (atomType attr)
87−
88−prettyAtomType :: AtomType -> T.Text
89−prettyAtomType (AtomType primitiveType) = T.pack (tyConName (fst (splitTyConApp (unCTR primitiveType))))
90−prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map attributeAsCell (V.toList attrs)) `T.append` "}"
91−prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))
92− where
93− showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"
94−-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)
95−prettyAtomType AnyAtomType = "?AnyAtomType?"
96−
9786relationAsTable :: Relation -> Table
9887relationAsTable rel@(Relation _ tupleSet) = (header, body)
9988 where
ProjectM36/Server.hs+2−1
@@ -33,7 +33,8 @@ serverDefinition = defaultProcess {
3333 handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead headn conn),
3434 handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit commitId conn),
3535 handleCall (\conn (CloseSession sessionId) -> handleCloseSession sessionId conn),
36− handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation sessionId conn)
36+ handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation sessionId conn),
37+ handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary sessionId conn)
3738 ],
3839 unhandledMessagePolicy = Log
3940 }
ProjectM36/Server/EntryPoints.hs+7−1
@@ -77,4 +77,10 @@ handleCloseSession sessionId conn = do
7777handleRetrieveAtomTypesAsRelation :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)
7878handleRetrieveAtomTypesAsRelation sessionId conn = do
7979 ret <- liftIO $ atomTypesAsRelation sessionId conn
80− reply ret conn
80+ reply ret conn
81+
82+-- | Returns a relation which lists the names of relvars in the current session as well as its types.
83+handleRetrieveRelationVariableSummary :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)
84+handleRetrieveRelationVariableSummary sessionId conn = do
85+ ret <- liftIO $ relationVariablesAsRelation sessionId conn
86+ reply ret conn
ProjectM36/Server/RemoteCallTypes.hs+3−1
@@ -39,4 +39,6 @@ data CreateSessionAtHead = CreateSessionAtHead HeadName
3939data CloseSession = CloseSession SessionId
4040 deriving (Binary, Generic)
4141data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId
42− deriving (Binary, Generic)
42+ deriving (Binary, Generic)
43+data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId
44+ deriving (Binary, Generic)
TutorialD/Interpreter/RODatabaseContextOperator.hs+12
@@ -22,6 +22,7 @@ data RODatabaseContextOperator where
2222 ShowConstraint :: StringType -> RODatabaseContextOperator
2323 ShowPlan :: DatabaseExpr -> RODatabaseContextOperator
2424 ShowTypes :: RODatabaseContextOperator
25+ ShowRelationVariables :: RODatabaseContextOperator
2526 Quit :: RODatabaseContextOperator
2627 deriving (Show)
2728
@@ -46,6 +47,9 @@ showPlanP = do
4647showTypesP :: Parser RODatabaseContextOperator
4748showTypesP = reserved ":showtypes" >> pure ShowTypes
4849
50+showRelationVariables :: Parser RODatabaseContextOperator
51+showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables
52+
4953quitP :: Parser RODatabaseContextOperator
5054quitP = do
5155 reservedOp ":quit"
@@ -66,6 +70,7 @@ plotRelExprP = do
6670roDatabaseContextOperatorP :: Parser RODatabaseContextOperator
6771roDatabaseContextOperatorP = typeP
6872 <|> showRelP
73+ <|> showRelationVariables
6974 <|> plotRelExprP
7075 <|> showConstraintsP
7176 <|> showPlanP
@@ -115,6 +120,13 @@ evalRODatabaseContextOp sessionId conn ShowTypes = do
115120 case eRel of
116121 Left err -> pure $ DisplayErrorResult (T.pack (show err))
117122 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))
123+
124+evalRODatabaseContextOp sessionId conn ShowRelationVariables = do
125+ eRel <- C.relationVariablesAsRelation sessionId conn
126+ case eRel of
127+ Left err -> pure $ DisplayErrorResult (T.pack (show err))
128+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))
129+
118130
119131evalRODatabaseContextOp _ _ (Quit) = pure QuitResult
120132
docs/tutd_tutorial.markdown+40
@@ -97,6 +97,46 @@ TutorialD (master): :showexpr p
9797└──────┴─────┴──┴─────┴──────┘
9898```
9999
100+To show all relation variables in the current session, use ```:showrelvars```:
101+
102+```
103+TutorialD (master): :showrelvars
104+┌─────────────────────────────────────────────────┬──────────┐
105+│attributes::relation {attribute::Text,type::Text}│name::Text│
106+├─────────────────────────────────────────────────┼──────────┤
107+│┌───────────────┬──────────┐ │"sp" │
108+││attribute::Text│type::Text│ │ │
109+│├───────────────┼──────────┤ │ │
110+││"p#" │"Text" │ │ │
111+││"qty" │"Int" │ │ │
112+││"s#" │"Text" │ │ │
113+│└───────────────┴──────────┘ │ │
114+│┌───────────────┬──────────┐ │"true" │
115+││attribute::Text│type::Text│ │ │
116+│└───────────────┴──────────┘ │ │
117+│┌───────────────┬──────────┐ │"p" │
118+││attribute::Text│type::Text│ │ │
119+│├───────────────┼──────────┤ │ │
120+││"weight" │"Int" │ │ │
121+││"p#" │"Text" │ │ │
122+││"color" │"Text" │ │ │
123+││"city" │"Text" │ │ │
124+││"pname" │"Text" │ │ │
125+│└───────────────┴──────────┘ │ │
126+│┌───────────────┬──────────┐ │"s" │
127+││attribute::Text│type::Text│ │ │
128+│├───────────────┼──────────┤ │ │
129+││"status" │"Int" │ │ │
130+││"s#" │"Text" │ │ │
131+││"sname" │"Text" │ │ │
132+││"city" │"Text" │ │ │
133+│└───────────────┴──────────┘ │ │
134+│┌───────────────┬──────────┐ │"false" │
135+││attribute::Text│type::Text│ │ │
136+│└───────────────┴──────────┘ │ │
137+└─────────────────────────────────────────────────┴──────────┘
138+```
139+
100140### Using Relational Operators
101141
102142Relational operators generate new relations from existing relations. The operators form the closed algebra against relations.
test/Server/Main.hs+9
@@ -4,6 +4,7 @@ test client/server interaction
44-}
55import Test.HUnit
66import ProjectM36.Client
7+import qualified ProjectM36.Client as C
78import ProjectM36.Server
89import ProjectM36.Server.Config
910import ProjectM36.Relation
@@ -26,6 +27,7 @@ testList sessionId conn notificationTestMVar = TestList $ map (\t -> t sessionId
2627 testHeadTransactionUUID,
2728 testHeadName,
2829 testSession,
30+ testRelationVariableSummary,
2931 testNotification notificationTestMVar
3032 ]
3133
@@ -126,6 +128,13 @@ testHeadName sessionId conn = TestCase $ do
126128 mHeadName <- headName sessionId conn
127129 assertEqual "headName failure" (Just "master") mHeadName
128130
131+testRelationVariableSummary :: SessionId -> Connection -> Test
132+testRelationVariableSummary sessionId conn = TestCase $ do
133+ eRel <- C.relationVariablesAsRelation sessionId conn
134+ case eRel of
135+ Left err -> assertFailure ("relvar summary failed " ++ show err)
136+ Right rel -> assertBool "invalid tuple count in relvar summary" (cardinality rel == Finite 2)
137+
129138testSession :: SessionId -> Connection -> Test
130139testSession _ conn = TestCase $ do
131140 -- create and close a new session using AtHead and AtCommit