8b18689 · project-m36 · git.iko.soy

git.iko.soy/project-m36

WIP: getting data constructors to tutd

commit8b186892d7a69badafdf2a5cbc9c21a0dc9b191c authorAgentM <agentm@themactionfaction.com> dateSun 7 Feb 2016, 09:33 (11 years ago) parentcbf399c

11 files changed+70−14

compare with master

unifiedsplit

ProjectM36/AtomType.hs+18−5 ProjectM36/Base.hs+2−1 ProjectM36/Client.hs+9−4 ProjectM36/Error.hs+1 ProjectM36/RelationalExpression.hs+9 ProjectM36/Server.hs+2−1 ProjectM36/Server/EntryPoints.hs+6−1 ProjectM36/Server/RemoteCallTypes.hs+2 TutorialD/Interpreter/DatabaseExpr.hs+3−1 TutorialD/Interpreter/RODatabaseContextOperator.hs+7 TutorialD/Interpreter/RelationalExpr.hs+11−1

ProjectM36/AtomType.hs+18−5

@@ -8,9 +8,10 @@ import ProjectM36.Attribute

88import ProjectM36.Atom

99import qualified Data.Map as M

1010import qualified Data.Vector as V

11+import Data.Either (isRight)

1112

12−atomTypesAsRelation :: AtomTypes -> Either RelationalError Relation

13−atomTypesAsRelation aTypes = mkRelationFromTuples attrs tuples

13+typesAsRelation :: AtomTypes -> Either RelationalError Relation

14+typesAsRelation aTypes = mkRelationFromTuples attrs tuples

1415 where

1516 attrs = attributesFromList [Attribute "TypeConstructor" stringAtomType,

1617 Attribute "DataConstructors" dConsType]

@@ -18,6 +19,18 @@ atomTypesAsRelation aTypes = mkRelationFromTuples attrs tuples

1819 dConsType = RelationAtomType subAttrs

1920 tuples = map mkTypeConsDescription (M.toList aTypes)

2021 mkTypeConsDescription (tConsName, (_, AtomConstructor dConsMap)) = RelationTuple attrs (V.fromList [stringAtom tConsName, mkDataConsRelation dConsMap])

21− mkDataConsRelation dConsMap = case mkRelationFromTuples subAttrs $ map (\(dConsName, dConsTypeNames) -> RelationTuple subAttrs (V.singleton $ T.intercalate " " dConsName:dConsTypeNames)) $ M.toList dConsMap of

22− Left err -> error "mkRelationFromTuples pooped"

23− Right rel -> Atom rel

22+ mkDataConsRelation dConsMap = case mkRelationFromTuples subAttrs $ map (\(dConsName, dConsTypeNames) -> RelationTuple subAttrs (V.singleton $ stringAtom $ T.intercalate " " (dConsName:dConsTypeNames))) (M.toList dConsMap) of

23+ Left err -> error ("mkRelationFromTuples pooped " ++ show err)

24+ Right rel -> Atom rel

25+

26+-- | Scan all type constructors for the proper data constructor

27+dataConstructorForName :: DataConstructorName -> AtomTypes -> Either RelationalError (DataConstructorName, [AtomTypeName])

28+dataConstructorForName dConsName aTypes = M.foldrWithKey typeFolder defaultErr aTypes

29+ where

30+ defaultErr = Left (NoSuchDataConstructor dConsName)

31+ typeFolder _ (_, AtomConstructor dConsMap) accum = if isRight accum then

32+ accum

33+ else

34+ case M.lookup dConsName dConsMap of

35+ Nothing -> accum

36+ Just aTypeNames -> Right (dConsName, aTypeNames)

ProjectM36/Base.hs+2−1

@@ -388,7 +388,8 @@ instance Ord Transaction where

388388data AtomExpr = AttributeAtomExpr AttributeName |

389389 NakedAtomExpr Atom |

390390 FunctionAtomExpr AtomFunctionName [AtomExpr] |

391− RelationAtomExpr RelationalExpr

391+ RelationAtomExpr RelationalExpr |

392+ ConstructedAtomExpr DataConstructorName [AtomExpr]

392393 deriving (Eq,Show,Generic)

393394

394395instance Binary AtomExpr

ProjectM36/Client.hs+9−4

@@ -44,6 +44,7 @@ module ProjectM36.Client

4444 NotificationCallback,

4545 emptyNotificationCallback,

4646 EvaluatedNotification(..),

47+ atomTypesAsRelation,

4748 AtomType(..)) where

4849import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well

4950import qualified ProjectM36.Base as B

@@ -53,11 +54,11 @@ import Control.Monad.State

5354import qualified ProjectM36.RelationalExpression as RE

5455import ProjectM36.TransactionGraph

5556import ProjectM36.TransactionGraph.Persist

56−import ProjectM36.Attribute

57+import ProjectM36.Attribute hiding (atomTypes)

5758import ProjectM36.Persist (DiskSync(..))

5859import ProjectM36.Notifications

5960import ProjectM36.Server.RemoteCallTypes

60−import ProjectM36.AtomType (atomTypesAsRelation)

61+import ProjectM36.AtomType (typesAsRelation)

6162import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)

6263import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess)

6364import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)

@@ -506,10 +507,14 @@ headName sessionId (InProcessConnection _ _ sessions graphTvar) = do

506507headName sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (ExecuteHeadName sessionId)

507508

508509atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

509−atomTypesAsRelation sessionId (InProcessConnection _ _ sessions) = do

510+atomTypesAsRelation sessionId (InProcessConnection _ _ sessions _) = do

510511 atomically $ do

511512 eSession <- sessionForSessionId sessionId sessions

512513 case eSession of

513514 Left err -> pure (Left err)

514− Right (Session discon) -> do

515+ Right (Session (DisconnectedTransaction _ context)) -> do

516+ case typesAsRelation (atomTypes context) of

517+ Left err -> pure (Left err)

518+ Right rel -> pure (Right rel)

519+atomTypesAsRelation sessionId conn@(RemoteProcessConnection _ _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

515520

ProjectM36/Error.hs+1

@@ -35,6 +35,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

3535 | AtomTypeMismatchError AtomType AtomType

3636 | AtomTypeNameInUseError AtomTypeName

3737 | AtomTypeNameNotInUseError AtomTypeName

38+ | NoSuchDataConstructor DataConstructorName

3839 | InvalidAtomTypeName AtomTypeName

3940 | AtomTypeNotSupported AttributeName --used by persistent driver

4041 | AtomOperatorNotSupported T.Text --used by persistent driver

ProjectM36/RelationalExpression.hs+9

@@ -6,6 +6,7 @@ import ProjectM36.TupleSet

66import ProjectM36.Base

77import ProjectM36.Error

88import ProjectM36.Atom

9+import ProjectM36.AtomType

910import ProjectM36.Key

1011import ProjectM36.AtomFunction

1112import ProjectM36.DataTypes.Interval

@@ -499,6 +500,10 @@ evalAtomExpr tupIn context (FunctionAtomExpr funcName arguments) = do

499500evalAtomExpr _ context (RelationAtomExpr relExpr) = do

500501 relAtom <- evalState (evalRelationalExpr relExpr) context

501502 return $ Atom relAtom

503+evalAtomExpr _ context (ConstructedAtomExpr dConsName dConsArgs) = do

504+ --type-checking presumed!

505+ dataConstructorForName

506+

502507

503508typeFromAtomExpr :: Attributes -> DatabaseContext -> AtomExpr -> Either RelationalError AtomType

504509typeFromAtomExpr attrs _ (AttributeAtomExpr attrName) = A.atomTypeForAttributeName attrName attrs

@@ -510,6 +515,8 @@ typeFromAtomExpr _ context (FunctionAtomExpr funcName _) = do

510515typeFromAtomExpr _ context (RelationAtomExpr relExpr) = do

511516 relType <- evalState (typeForRelationalExpr relExpr) context

512517 return $ RelationAtomType (attributes relType)

518+typeFromAtomExpr _ context (ConstructedAtomExpr dConsName dConsArgs) = do

519+

513520

514521verifyAtomExprTypes :: Relation -> DatabaseContext -> AtomExpr -> AtomType -> Either RelationalError AtomType

515522verifyAtomExprTypes relIn _ (AttributeAtomExpr attrName) expectedType = do

@@ -533,6 +540,8 @@ verifyAtomExprTypes _ context (RelationAtomExpr relationExpr) expectedType = do

533540 case runState (typeForRelationalExpr relationExpr) context of

534541 (Left err, _) -> Left err

535542 (Right relType, _) -> atomTypeVerify expectedType (RelationAtomType (attributes relType))

543+verifyAtomExprTypes _ context (ConstructedAtomExpr dConsName dConsArgs) = do

544+

536545

537546

538547basicAtomFunctions :: AtomFunctions

ProjectM36/Server.hs+2−1

@@ -32,7 +32,8 @@ serverDefinition = defaultProcess {

3232 handleCall (\conn (Login procId) -> handleLogin conn procId),

3333 handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead headn conn),

3434 handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit commitId conn),

35− handleCall (\conn (CloseSession sessionId) -> handleCloseSession sessionId conn)

35+ handleCall (\conn (CloseSession sessionId) -> handleCloseSession sessionId conn),

36+ handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleAtomTypesAsRelation sessionId conn),

3637 ],

3738 unhandledMessagePolicy = Log

3839 }

ProjectM36/Server/EntryPoints.hs+6−1

@@ -72,4 +72,9 @@ handleCreateSessionAtHead headn conn = do

7272handleCloseSession :: SessionId -> Connection -> Process (ProcessReply () Connection)

7373handleCloseSession sessionId conn = do

7474 liftIO $ closeSession sessionId conn

75− reply () conn

75+ reply () conn

76+

77+handleRetrieveAtomTypesAsRelation :: SessionId -> Connection -> Process (ProcessReply (Either RelationalError Relation) Connection)

78+handleRetrieveAtomTypesAsRelation = do

79+ ret <- liftIO $ atomTypesAsRelation sessionId conn

80+ reply ret conn

ProjectM36/Server/RemoteCallTypes.hs+2

@@ -38,3 +38,5 @@ data CreateSessionAtHead = CreateSessionAtHead HeadName

3838 deriving (Binary, Generic)

3939data CloseSession = CloseSession SessionId

4040 deriving (Binary, Generic)

41+data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

42+ deriving (Binary, Generic)

TutorialD/Interpreter/DatabaseExpr.hs+3−1

@@ -143,7 +143,9 @@ dataConstructorP = do

143143 pure (T.pack dConsName, atomTypeNames)

144144

145145removeAtomConstructorP :: Parser DatabaseExpr

146−removeAtomConstructorP = RemoveAtomConstructor <$> liftM T.pack identifier

146+removeAtomConstructorP = do

147+ reserved "undata"

148+ RemoveAtomConstructor <$> liftM T.pack identifier

147149

148150databaseExprOpP :: Parser DatabaseExpr

149151databaseExprOpP = multipleDatabaseExprP

TutorialD/Interpreter/RODatabaseContextOperator.hs+7

@@ -69,6 +69,7 @@ roDatabaseContextOperatorP = typeP

6969 <|> plotRelExprP

7070 <|> showConstraintsP

7171 <|> showPlanP

72+ <|> showTypesP

7273 <|> quitP

7374

7475--logically, these read-only operations could happen purely, but not if a remote call is required

@@ -109,6 +110,12 @@ evalRODatabaseContextOp sessionId conn (ShowPlan dbExpr) = do

109110 Left err -> DisplayErrorResult (T.pack (show err))

110111 Right optDbExpr -> DisplayResult $ T.pack (show optDbExpr)

111112

113+evalRODatabaseContextOp sessionId conn ShowTypes = do

114+ eRel <- C.atomTypesAsRelation sessionId conn

115+ case eRel of

116+ Left err -> pure $ DisplayErrorResult (T.pack (show err))

117+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

118+

112119evalRODatabaseContextOp _ _ (Quit) = pure QuitResult

113120

114121interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> String -> IO TutorialDOperatorResult

TutorialD/Interpreter/RelationalExpr.hs+11−1

@@ -230,6 +230,15 @@ attributeAtomExprP = do

230230nakedAtomExprP :: Parser AtomExpr

231231nakedAtomExprP = NakedAtomExpr <$> atomP

232232

233+-- | Uses square brackets for TutorialD support.

234+constructedAtomP :: Parser AtomExpr

235+constructedAtomP = do

236+ reserved "["

237+ dConsName <- identifier

238+ dConsArgs <- sepBy atomExprP spaces

239+ reserved "]"

240+ pure $ AtomConstructor dConsName dConsArgs

241+

233242atomP :: Parser Atom

234243atomP = dateTimeAtomP <|>

235244 intervalDateTimeAtomP <|>

@@ -241,7 +250,8 @@ atomP = dateTimeAtomP <|>

241250 doubleAtomP <|>

242251 intAtomP <|>

243252 boolAtomP <|>

244− relationAtomP

253+ relationAtomP <|>

254+ constructedAtomP

245255

246256functionAtomExprP :: Parser AtomExpr

247257functionAtomExprP = do