git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/TutorialD/Interpreter/SchemaOperator.hs
77 lines 2.5 kB history raw
1module TutorialD.Interpreter.SchemaOperator where
2import Text.Megaparsec
3import ProjectM36.Base
4import ProjectM36.IsomorphicSchema
5import ProjectM36.Session
6import ProjectM36.Client
7import TutorialD.Interpreter.RelationalExpr
8import TutorialD.Interpreter.Base
10data SchemaOperator = ModifySchemaExpr SchemaExpr |
11 SetCurrentSchema SchemaName
12 deriving Show
14schemaOperatorP :: Parser SchemaOperator
15schemaOperatorP = (ModifySchemaExpr <$> schemaExprP) <|>
16 setCurrentSchemaP
18setCurrentSchemaP :: Parser SchemaOperator
19setCurrentSchemaP = do
20 reserved ":setschema"
21 SetCurrentSchema <$> identifier
23schemaExprP :: Parser SchemaExpr
24schemaExprP = addSubschemaP <|>
25 removeSubschemaP
27addSubschemaP :: Parser SchemaExpr
28addSubschemaP = do
29 reserved ":addschema"
30 AddSubschema <$> identifier <*> parens (sepBy schemaIsomorphP comma)
32schemaIsomorphP :: Parser SchemaIsomorph
33schemaIsomorphP = isoRestrictP <|> isoUnionP <|> isoRenameP <|> isoPassthrough
35removeSubschemaP :: Parser SchemaExpr
36removeSubschemaP = do
37 reserved ":removeschema"
38 RemoveSubschema <$> identifier
40isoRestrictP :: Parser SchemaIsomorph
41isoRestrictP = do
42 reserved "isorestrict"
43 relVarIn <- qrelVarP
44 relvarsOut <- isoRestrictOutRelVarsP
45 IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut
47isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)
48isoRestrictOutRelVarsP = (,) <$> qrelVarP <*> qrelVarP
50qrelVarP :: Parser RelVarName
51qrelVarP = quotedString
53isoUnionP :: Parser SchemaIsomorph
54isoUnionP = do
55 reserved "isounion"
56 relVarsIn <- isoUnionInRelVarsP
57 relVarsOut <- qrelVarP
58 IsoUnion <$> pure relVarsIn <*> restrictionPredicateP <*> pure relVarsOut
60isoRenameP :: Parser SchemaIsomorph
61isoRenameP = do
62 reserved "isorename"
63 IsoRename <$> qrelVarP <*> qrelVarP
65isoPassthrough :: Parser SchemaIsomorph
66isoPassthrough = do
67 reserved "isopassthrough"
68 rv <- qrelVarP
69 pure (IsoRename rv rv)
71isoUnionInRelVarsP :: Parser (RelVarName, RelVarName)
72isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP
74evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Either RelationalError ())
75evalSchemaOperator sessionId conn (ModifySchemaExpr expr) = executeSchemaExpr sessionId conn expr
76evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname