97d73bb · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

WIP compilation checkpoint

97d73bbAgentM10 years ago

src/bin/TutorialD/Interpreter.hs+3−4

compare with master

unifiedsplit

@@ -20,7 +20,6 @@ import TutorialD.Interpreter.Export.Base

20import ProjectM36.Base

21import ProjectM36.Relation.Show.Term

22import ProjectM36.TransactionGraph

23−import ProjectM36.IsomorphicSchema

24import qualified ProjectM36.Client as C

23import qualified ProjectM36.Client as C

25import ProjectM36.Relation (attributes)

24import ProjectM36.Relation (attributes)

@@ -199,14 +198,14 @@ reprLoop config sessionId conn = do

199 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

198 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}

200 mHeadName <- C.headName sessionId conn

199 mHeadName <- C.headName sessionId conn

201 mSchemaName <- C.currentSchemaName sessionId conn

200 mSchemaName <- C.currentSchemaName sessionId conn

201+ let prompt = promptText mHeadName mSchemaName

202− maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName mSchemaName))

202+ maybeLine <- runInputT settings $ getInputLine (T.unpack prompt)

203 case maybeLine of

204 Nothing -> return ()

205 Just line -> do

206 case parseTutorialD (T.pack line) of

207 Left err -> do

208− let strErr = show err --parseErrorPretty new in megaparsec 5

208+ displayOpResult $ DisplayParseErrorResult (T.length prompt) err

209− displayOpResult $ DisplayErrorResult (T.pack strErr)

210 Right parsed -> do

209 Right parsed -> do

211 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed

210 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed

212 displayOpResult evald

211 displayOpResult evald

src/bin/TutorialD/Interpreter/Base.hs+4

@@ -25,6 +25,9 @@ displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 &&

25 outputf stderr ("ERR: " <> err)

26displayOpResult QuietSuccessResult = return ()

27displayOpResult (DisplayRelationResult rel) = TIO.putStrLn (showRelation rel)

28+displayOpResult (DisplayParseErrorResult promptLength err) = TIO.putStrLn pointyString >> TIO.putStrLn ("ERR:" <> T.pack (show err))

29+ where

30+ pointyString = T.justifyRight (promptLength + (sourceColumn (errorPos err))) ' ' "^"

29spaceConsumer :: Parser ()

32spaceConsumer :: Parser ()

30spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

33spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")

@@ -108,6 +111,7 @@ data TutorialDOperatorResult = QuitResult |

108 DisplayIOResult (IO ()) |

111 DisplayIOResult (IO ()) |

109 DisplayRelationResult Relation |

112 DisplayRelationResult Relation |

110 DisplayErrorResult StringType |

113 DisplayErrorResult StringType |

114+ DisplayParseErrorResult Int ParseError | -- Int refers to length of prompt text

111 QuietSuccessResult

115 QuietSuccessResult

112 deriving (Generic)

116 deriving (Generic)

113

117

src/bin/TutorialD/Interpreter/SchemaOperator.hs+7−7

@@ -1,7 +1,6 @@

1module TutorialD.Interpreter.SchemaOperator where

2import Text.Megaparsec

3import Text.Megaparsec.Text

4−import qualified Data.Map as M

6import ProjectM36.Base

5import ProjectM36.Base

7import ProjectM36.IsomorphicSchema

6import ProjectM36.IsomorphicSchema

@@ -24,7 +23,8 @@ setCurrentSchemaP = do

24 SetCurrentSchema <$> identifier

23 SetCurrentSchema <$> identifier

26schemaExprP :: Parser SchemaExpr

25schemaExprP :: Parser SchemaExpr

26+schemaExprP = addSubschemaIsoMorphP <|>

27−schemaExprP = addSubschemaP

27+ addSubschemaP

29addSubschemaP :: Parser SchemaExpr

30addSubschemaP = do

@@ -42,7 +42,9 @@ schemaIsomorphP = isoRestrictP <|> isoUnionP

42isoRestrictP :: Parser SchemaIsomorph

43isoRestrictP = do

44 reserved "isorestrict"

45+ relVarIn <- quotedString

46+ relvarsOut <- isoRestrictOutRelVarsP

45− IsoRestrict <$> quotedString <*> restrictionPredicateP <*> isoRestrictOutRelVarsP

47+ IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut

47isoRestrictOutRelVarsP :: Parser (Maybe RelVarName, Maybe RelVarName)

49isoRestrictOutRelVarsP :: Parser (Maybe RelVarName, Maybe RelVarName)

48isoRestrictOutRelVarsP = (,) <$> maybeRelVarP <*> maybeRelVarP

50isoRestrictOutRelVarsP = (,) <$> maybeRelVarP <*> maybeRelVarP

@@ -58,9 +60,7 @@ isoUnionP = do

58isoUnionInRelVarsP :: Parser (RelVarName, Maybe RelVarName)

60isoUnionInRelVarsP :: Parser (RelVarName, Maybe RelVarName)

59isoUnionInRelVarsP = (,) <$> quotedString <*> maybeRelVarP

61isoUnionInRelVarsP = (,) <$> quotedString <*> maybeRelVarP

61−evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> Either RelationalError Session

63+evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Maybe RelationalError)

62−evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = do

64+evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr

63− newSubschemas <- evalSchemaExpr sessionId conn expr (subschemas session)

64− pure (Session (DisconnectedTransaction (parentId session) (Schemas (concreteDatabaseContext session) newSubschemas)) (schemaName session))

65evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname

src/lib/ProjectM36/Client.hs+33−5

@@ -362,6 +362,27 @@ sessionForSessionId sessionId sessions = do

362 maybeSession <- STMMap.lookup sessionId sessions

363 pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession

364

365+schemaForSessionId :: Session -> STM (Either RelationalError Schema)

366+schemaForSessionId session = do

367+ let sname = schemaName session

368+ if sname == defaultSchemaName then

369+ pure (Right (Schema [])) -- the main schema includes no transformations

370+ else

371+ case M.lookup sname (subschemas session) of

372+ Nothing -> pure (Left (SubschemaNameNotInUseError sname))

373+ Just schema -> pure (Right schema)

374+

375+sessionAndSchema :: SessionId -> Sessions -> STM (Either RelationalError (Session, Schema))

376+sessionAndSchema sessionId sessions = do

377+ eSession <- sessionForSessionId sessionId sessions

378+ case eSession of

379+ Left err -> pure (Left err)

380+ Right session -> do

381+ eSchema <- schemaForSessionId session

382+ case eSchema of

383+ Left err -> pure (Left err)

384+ Right schema -> pure (Right (session, schema))

385+

365currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName)

386currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName)

366currentSchemaName sessionId (InProcessConnection _ _ sessions _ _) = atomically $ do

387currentSchemaName sessionId (InProcessConnection _ _ sessions _ _) = atomically $ do

367 eSession <- sessionForSessionId sessionId sessions

388 eSession <- sessionForSessionId sessionId sessions

@@ -507,12 +528,16 @@ executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _ _) tgr

507

528

508executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError)

529executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError)

509executeSchemaExpr sessionId (InProcessConnection _ _ sessions _ _) schemaExpr = atomically $ do

530executeSchemaExpr sessionId (InProcessConnection _ _ sessions _ _) schemaExpr = atomically $ do

510− eSession <- sessionForSessionId sessionId sessions

531+ eSession <- sessionAndSchema sessionId sessions

511 case eSession of

532 case eSession of

512 Left err -> pure (Just err)

533 Left err -> pure (Just err)

513− Right session -> do

534+ Right (session, schema) -> do

514 let subschemas' = subschemas session

535 let subschemas' = subschemas session

536+ underlyingRelVarNames = if schemaName session == defaultSchemaName then

537+ M.keysSet (relationVariables (Sess.concreteDatabaseContext session))

538+ else

539+ Schema.isomorphsInRelVarNames (Schema.isomorphs schema)

515− case Schema.evalSchemaExpr schemaExpr subschemas' of

540+ case Schema.evalSchemaExpr schemaExpr underlyingRelVarNames subschemas' of

516 Left err -> pure (Just err)

541 Left err -> pure (Just err)

517 Right newSubschemas -> do

542 Right newSubschemas -> do

518 --hm- maybe we should start using lenses

543 --hm- maybe we should start using lenses

@@ -554,10 +579,13 @@ typeForRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = rem

554

579

555typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

580typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)

556typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExpr = do

581typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExpr = do

557− eSession <- sessionForSessionId sessionId sessions

582+ eSession <- sessionAndSchema sessionId sessions

558 case eSession of

583 case eSession of

559 Left err -> pure $ Left err

584 Left err -> pure $ Left err

585+ Right (session, schema) -> do

586+ case Schema.processRelationalExprInSchema schema relExpr of

587+ Left err -> pure (Left err)

560− Right session -> pure $ evalState (RE.typeForRelationalExpr relExpr) (Sess.concreteDatabaseContext session)

588+ Right relExpr' -> pure $ evalState (RE.typeForRelationalExpr relExpr') (Sess.concreteDatabaseContext session)

561

589

562typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

590typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"

563

591

src/lib/ProjectM36/IsomorphicSchema.hs+62−11

@@ -7,6 +7,7 @@ import Control.Monad

7import GHC.Generics

8import Data.Binary

9import qualified Data.Map as M

10+import qualified Data.Set as S

10-- isomorphic schemas offer bi-directional functors between two schemas

11-- isomorphic schemas offer bi-directional functors between two schemas

12--TODO: note that renaming a relvar should alter any stored isomorphisms as well

13--TODO: note that renaming a relvar should alter any stored isomorphisms as well

@@ -25,18 +26,47 @@ isFullyIsomorphic :: SchemaIsomorph -> Bool

25isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b

26isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b

26isFullyIsomorphic (IsoUnion (_, a) _ _) = isJust a

27isFullyIsomorphic (IsoUnion (_, a) _ _) = isJust a

29+isomorphs :: Schema -> SchemaIsomorphs

30+isomorphs (Schema i) = i

31+

28-- | Convenience function which renames a relvar in schemaA to another name in schemaB.

32-- | Convenience function which renames a relvar in schemaA to another name in schemaB.

29isomorphRename :: RelVarName -> RelVarName -> SchemaIsomorph

33isomorphRename :: RelVarName -> RelVarName -> SchemaIsomorph

30isomorphRename nameA nameB = IsoRestrict nameA TruePredicate (Just nameB, Nothing)

34isomorphRename nameA nameB = IsoRestrict nameA TruePredicate (Just nameB, Nothing)

32−isomorphHide :: RelVarName -> SchemaIsomorph

36+{- -- useful for transforming a concrete context into a virtual schema and vice versa

33−isomorphHide nameA = IsoRestrict nameA (NotPredicate TruePredicate) (Nothing, Nothing)

34−

35−{-

36invert :: SchemaIsomorph -> SchemaIsomorph

37invert :: SchemaIsomorph -> SchemaIsomorph

37invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA

38invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA

38-}

39-}

41+isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]

42+isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]

43+isomorphInRelVarNames (IsoUnion (rvA, mRvB) _ _) = rvA : maybe [] (\x -> [x]) mRvB

44+

45+-- | Relation variables names represented in the virtual schema space. Useful for determining if a relvar name is valid in the schema.

46+isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

47+isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)

48+ where

49+ rvnames morph acc = acc ++ isomorphInRelVarNames morph

50+

51+isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]

52+isomorphOutRelVarNames (IsoRestrict _ _ (mRvA, mRvB)) = catMaybes [mRvA, mRvB]

53+isomorphOutRelVarNames (IsoUnion _ _ rvA) = [rvA]

54+

55+isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName

56+isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)

57+ where

58+ rvnames morph acc = acc ++ isomorphOutRelVarNames morph

59+

60+processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr

61+processRelationalExprInSchema (Schema morphs) relExprIn = do

62+ let validRelVarNames = isomorphsInRelVarNames morphs

63+ --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)

64+ let processRelExpr rexpr morph = relExprMogrify (\expr -> case expr of

65+ RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)

66+ ex -> relExprMorph morph ex) rexpr

67+

68+ foldM processRelExpr relExprIn morphs

69+

40-- | Morph a relational expression in one schema to another isomorphic schema.

70-- | Morph a relational expression in one schema to another isomorphic schema.

41relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)

71relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)

42relExprMorph (IsoRestrict relIn predi split) = \expr -> case expr of

72relExprMorph (IsoRestrict relIn predi split) = \expr -> case expr of

@@ -162,9 +192,17 @@ inclusionDependenciesMorph iso = \(InclusionDependency subExpr expr) -> Inclusio

162applyInclusionDependenciesSchemaIsoMorphs :: SchemaIsomorphs -> InclusionDependencies -> Either RelationalError InclusionDependencies

192applyInclusionDependenciesSchemaIsoMorphs :: SchemaIsomorphs -> InclusionDependencies -> Either RelationalError InclusionDependencies

163--add inc deps for restriction with some automatic name

193--add inc deps for restriction with some automatic name

164applyInclusionDependenciesSchemaIsoMorphs morphs incDeps = undefined

194applyInclusionDependenciesSchemaIsoMorphs morphs incDeps = undefined

195+

196+{-

197+proposal

198+data DatabaseContext =

199+Concrete ...|

200+Virtual Isomorphs

201+-}

165

202

166applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables

203applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables

167applyRelationVariablesSchemaIsomorphs = undefined

204applyRelationVariablesSchemaIsomorphs = undefined

205+

168

206

169applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext

207applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext

170applySchemaIsomorphsToDatabaseContext morphs context = do

208applySchemaIsomorphsToDatabaseContext morphs context = do

@@ -176,16 +214,29 @@ applySchemaIsomorphsToDatabaseContext morphs context = do

176 --notifications = notifs,

214 --notifications = notifs,

177 --typeConstructorMapping = tconsmapping

215 --typeConstructorMapping = tconsmapping

178 })

216 })

179−

217+

218+validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph

219+validate morph underlyingRvNames = if S.size invalidRvNames > 0 then

220+ Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))

221+ else

222+ Right morph

223+ where

224+ morphRvNames = S.fromList (isomorphOutRelVarNames morph)

225+ invalidRvNames = S.difference morphRvNames underlyingRvNames

226+

227+-- the second argument really should be a database context in the future so we can morph other context items

180−evalSchemaExpr :: SchemaExpr -> Subschemas -> Either RelationalError Subschemas

228+evalSchemaExpr :: SchemaExpr -> S.Set RelVarName -> Subschemas -> Either RelationalError Subschemas

181−evalSchemaExpr (AddSubschema sname) sschemas = if M.member sname sschemas then

229+evalSchemaExpr (AddSubschema sname) _ sschemas = if M.member sname sschemas then

182 Left (SubschemaNameInUseError sname)

230 Left (SubschemaNameInUseError sname)

183− else

231+ else

184 pure (M.insert sname (Schema []) sschemas)

232 pure (M.insert sname (Schema []) sschemas)

185−evalSchemaExpr (AddSubschemaIsomorph sname morph) sschemas = case M.lookup sname sschemas of

233+evalSchemaExpr (AddSubschemaIsomorph sname morph) underlyingRvNames sschemas = case M.lookup sname sschemas of

186 Nothing -> Left (SubschemaNameNotInUseError sname)

234 Nothing -> Left (SubschemaNameNotInUseError sname)

235+ Just (Schema oldMorphs) -> do

236+ morph' <- validate morph underlyingRvNames

187− Just (Schema oldMorphs) -> pure (M.insert sname (Schema (oldMorphs ++ [morph])) sschemas)

237+ pure (M.insert sname (Schema (oldMorphs ++ [morph'])) sschemas)

188−evalSchemaExpr (RemoveSubschema sname) sschemas = if M.member sname sschemas then

238+evalSchemaExpr (RemoveSubschema sname) _ sschemas = if M.member sname sschemas then

189 pure (M.delete sname sschemas)

239 pure (M.delete sname sschemas)

190 else

240 else

191 Left (SubschemaNameNotInUseError sname)

241 Left (SubschemaNameNotInUseError sname)

242+