git.iko.soy/project-m36
on master help sign in
WIP compilation checkpoint

:addschema, :addschemaisomorph, :type (schema-based) working

commit97d73bbee00994583f084e3fa2d52484260a975e authorAgentM <agentm@themactionfaction.com> dateWed 19 Oct 2016, 22:30 (10 years ago) parente7e0776
5 files changed+109−27
compare with master
unifiedsplit
src/bin/TutorialD/Interpreter.hs+3−4 src/bin/TutorialD/Interpreter/Base.hs+4 src/bin/TutorialD/Interpreter/SchemaOperator.hs+7−7 src/lib/ProjectM36/Client.hs+33−5 src/lib/ProjectM36/IsomorphicSchema.hs+62−11
src/bin/TutorialD/Interpreter.hs+3−4
@@ -20,7 +20,6 @@ import TutorialD.Interpreter.Export.Base
2020import ProjectM36.Base
2121import ProjectM36.Relation.Show.Term
2222import ProjectM36.TransactionGraph
23−import ProjectM36.IsomorphicSchema
2423import qualified ProjectM36.Client as C
2524import ProjectM36.Relation (attributes)
2625
@@ -199,14 +198,14 @@ reprLoop config sessionId conn = do
199198 let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}
200199 mHeadName <- C.headName sessionId conn
201200 mSchemaName <- C.currentSchemaName sessionId conn
202− maybeLine <- runInputT settings $ getInputLine (T.unpack (promptText mHeadName mSchemaName))
201+ let prompt = promptText mHeadName mSchemaName
202+ maybeLine <- runInputT settings $ getInputLine (T.unpack prompt)
203203 case maybeLine of
204204 Nothing -> return ()
205205 Just line -> do
206206 case parseTutorialD (T.pack line) of
207207 Left err -> do
208− let strErr = show err --parseErrorPretty new in megaparsec 5
209− displayOpResult $ DisplayErrorResult (T.pack strErr)
208+ displayOpResult $ DisplayParseErrorResult (T.length prompt) err
210209 Right parsed -> do
211210 evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed
212211 displayOpResult evald
src/bin/TutorialD/Interpreter/Base.hs+4
@@ -25,6 +25,9 @@ displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 &&
2525 outputf stderr ("ERR: " <> err)
2626displayOpResult QuietSuccessResult = return ()
2727displayOpResult (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))) ' ' "^"
2831
2932spaceConsumer :: Parser ()
3033spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")
@@ -108,6 +111,7 @@ data TutorialDOperatorResult = QuitResult |
108111 DisplayIOResult (IO ()) |
109112 DisplayRelationResult Relation |
110113 DisplayErrorResult StringType |
114+ DisplayParseErrorResult Int ParseError | -- Int refers to length of prompt text
111115 QuietSuccessResult
112116 deriving (Generic)
113117
src/bin/TutorialD/Interpreter/SchemaOperator.hs+7−7
@@ -1,7 +1,6 @@
11module TutorialD.Interpreter.SchemaOperator where
22import Text.Megaparsec
33import Text.Megaparsec.Text
4−import qualified Data.Map as M
54
65import ProjectM36.Base
76import ProjectM36.IsomorphicSchema
@@ -24,7 +23,8 @@ setCurrentSchemaP = do
2423 SetCurrentSchema <$> identifier
2524
2625schemaExprP :: Parser SchemaExpr
27−schemaExprP = addSubschemaP
26+schemaExprP = addSubschemaIsoMorphP <|>
27+ addSubschemaP
2828
2929addSubschemaP :: Parser SchemaExpr
3030addSubschemaP = do
@@ -42,7 +42,9 @@ schemaIsomorphP = isoRestrictP <|> isoUnionP
4242isoRestrictP :: Parser SchemaIsomorph
4343isoRestrictP = do
4444 reserved "isorestrict"
45− IsoRestrict <$> quotedString <*> restrictionPredicateP <*> isoRestrictOutRelVarsP
45+ relVarIn <- quotedString
46+ relvarsOut <- isoRestrictOutRelVarsP
47+ IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut
4648
4749isoRestrictOutRelVarsP :: Parser (Maybe RelVarName, Maybe RelVarName)
4850isoRestrictOutRelVarsP = (,) <$> maybeRelVarP <*> maybeRelVarP
@@ -58,9 +60,7 @@ isoUnionP = do
5860isoUnionInRelVarsP :: Parser (RelVarName, Maybe RelVarName)
5961isoUnionInRelVarsP = (,) <$> quotedString <*> maybeRelVarP
6062
61−evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> Either RelationalError Session
62−evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = do
63− newSubschemas <- evalSchemaExpr sessionId conn expr (subschemas session)
64− pure (Session (DisconnectedTransaction (parentId session) (Schemas (concreteDatabaseContext session) newSubschemas)) (schemaName session))
63+evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Maybe RelationalError)
64+evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr
6565evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname
6666
src/lib/ProjectM36/Client.hs+33−5
@@ -362,6 +362,27 @@ sessionForSessionId sessionId sessions = do
362362 maybeSession <- STMMap.lookup sessionId sessions
363363 pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession
364364
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+
365386currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName)
366387currentSchemaName sessionId (InProcessConnection _ _ sessions _ _) = atomically $ do
367388 eSession <- sessionForSessionId sessionId sessions
@@ -507,12 +528,16 @@ executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _ _) tgr
507528
508529executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError)
509530executeSchemaExpr sessionId (InProcessConnection _ _ sessions _ _) schemaExpr = atomically $ do
510− eSession <- sessionForSessionId sessionId sessions
531+ eSession <- sessionAndSchema sessionId sessions
511532 case eSession of
512533 Left err -> pure (Just err)
513− Right session -> do
534+ Right (session, schema) -> do
514535 let subschemas' = subschemas session
515− case Schema.evalSchemaExpr schemaExpr subschemas' of
536+ underlyingRelVarNames = if schemaName session == defaultSchemaName then
537+ M.keysSet (relationVariables (Sess.concreteDatabaseContext session))
538+ else
539+ Schema.isomorphsInRelVarNames (Schema.isomorphs schema)
540+ case Schema.evalSchemaExpr schemaExpr underlyingRelVarNames subschemas' of
516541 Left err -> pure (Just err)
517542 Right newSubschemas -> do
518543 --hm- maybe we should start using lenses
@@ -554,10 +579,13 @@ typeForRelationalExpr sessionId conn@(RemoteProcessConnection _ _) relExpr = rem
554579
555580typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)
556581typeForRelationalExprSTM sessionId (InProcessConnection _ _ sessions _ _) relExpr = do
557− eSession <- sessionForSessionId sessionId sessions
582+ eSession <- sessionAndSchema sessionId sessions
558583 case eSession of
559584 Left err -> pure $ Left err
560− Right session -> pure $ evalState (RE.typeForRelationalExpr relExpr) (Sess.concreteDatabaseContext session)
585+ Right (session, schema) -> do
586+ case Schema.processRelationalExprInSchema schema relExpr of
587+ Left err -> pure (Left err)
588+ Right relExpr' -> pure $ evalState (RE.typeForRelationalExpr relExpr') (Sess.concreteDatabaseContext session)
561589
562590typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"
563591
src/lib/ProjectM36/IsomorphicSchema.hs+62−11
@@ -7,6 +7,7 @@ import Control.Monad
77import GHC.Generics
88import Data.Binary
99import qualified Data.Map as M
10+import qualified Data.Set as S
1011-- isomorphic schemas offer bi-directional functors between two schemas
1112
1213--TODO: note that renaming a relvar should alter any stored isomorphisms as well
@@ -25,18 +26,47 @@ isFullyIsomorphic :: SchemaIsomorph -> Bool
2526isFullyIsomorphic (IsoRestrict _ _ (a, b)) = isJust a && isJust b
2627isFullyIsomorphic (IsoUnion (_, a) _ _) = isJust a
2728
29+isomorphs :: Schema -> SchemaIsomorphs
30+isomorphs (Schema i) = i
31+
2832-- | Convenience function which renames a relvar in schemaA to another name in schemaB.
2933isomorphRename :: RelVarName -> RelVarName -> SchemaIsomorph
3034isomorphRename nameA nameB = IsoRestrict nameA TruePredicate (Just nameB, Nothing)
3135
32−isomorphHide :: RelVarName -> SchemaIsomorph
33−isomorphHide nameA = IsoRestrict nameA (NotPredicate TruePredicate) (Nothing, Nothing)
34−
35−{-
36+{- -- useful for transforming a concrete context into a virtual schema and vice versa
3637invert :: SchemaIsomorph -> SchemaIsomorph
3738invert (IsoRelVarName nameA nameB) = IsoRelVarName nameB nameA
3839-}
3940
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+
4070-- | Morph a relational expression in one schema to another isomorphic schema.
4171relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)
4272relExprMorph (IsoRestrict relIn predi split) = \expr -> case expr of
@@ -162,9 +192,17 @@ inclusionDependenciesMorph iso = \(InclusionDependency subExpr expr) -> Inclusio
162192applyInclusionDependenciesSchemaIsoMorphs :: SchemaIsomorphs -> InclusionDependencies -> Either RelationalError InclusionDependencies
163193--add inc deps for restriction with some automatic name
164194applyInclusionDependenciesSchemaIsoMorphs morphs incDeps = undefined
195+
196+{-
197+proposal
198+data DatabaseContext =
199+Concrete ...|
200+Virtual Isomorphs
201+-}
165202
166203applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables
167204applyRelationVariablesSchemaIsomorphs = undefined
205+
168206
169207applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext
170208applySchemaIsomorphsToDatabaseContext morphs context = do
@@ -176,16 +214,29 @@ applySchemaIsomorphsToDatabaseContext morphs context = do
176214 --notifications = notifs,
177215 --typeConstructorMapping = tconsmapping
178216 })
179−
180−evalSchemaExpr :: SchemaExpr -> Subschemas -> Either RelationalError Subschemas
181−evalSchemaExpr (AddSubschema sname) sschemas = if M.member sname sschemas then
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
228+evalSchemaExpr :: SchemaExpr -> S.Set RelVarName -> Subschemas -> Either RelationalError Subschemas
229+evalSchemaExpr (AddSubschema sname) _ sschemas = if M.member sname sschemas then
182230 Left (SubschemaNameInUseError sname)
183− else
231+ else
184232 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
186234 Nothing -> Left (SubschemaNameNotInUseError sname)
187− Just (Schema oldMorphs) -> pure (M.insert sname (Schema (oldMorphs ++ [morph])) sschemas)
188−evalSchemaExpr (RemoveSubschema sname) sschemas = if M.member sname sschemas then
235+ Just (Schema oldMorphs) -> do
236+ morph' <- validate morph underlyingRvNames
237+ pure (M.insert sname (Schema (oldMorphs ++ [morph'])) sschemas)
238+evalSchemaExpr (RemoveSubschema sname) _ sschemas = if M.member sname sschemas then
189239 pure (M.delete sname sschemas)
190240 else
191241 Left (SubschemaNameNotInUseError sname)
242+