81f03b6 · project-m36 · git.iko.soy

git.iko.soy/project-m36

switch DateExamples.tutd to include more newlines for ease of reading and parser testing

commit81f03b685ab3270de2b6f1efc67f253894665976 authorAgentM <agentm@themactionfaction.com> dateTue 30 Aug 2016, 21:29 (10 years ago) parent8b5e115

9 files changed+57−41

compare with master

unifiedsplit

scripts/DateExamples.tutd+24−5 src/bin/ProjectM36/Server/WebSocket.hs+1−1 src/bin/TutorialD/Interpreter/Base.hs+4−19 src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+6−3 src/bin/TutorialD/Interpreter/Import/TutorialD.hs+3−6 src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+1−1 src/bin/benchmark/bigrel.hs+3−2 test/TutorialD/Interpreter.hs+13−3 test/TutorialD/Interpreter/TestBase.hs+2−1

scripts/DateExamples.tutd+24−5

@@ -1,5 +1,24 @@

1−s := relation{tuple{s# "S1",sname "Smith",status 20, city "London"}, tuple{s# "S2",sname "Jones",status 10,city "Paris"}, tuple{s# "S3",sname "Blake",status 30,city "Paris"}, tuple{s# "S4",sname "Clark",status 20,city "London"}, tuple{s# "S5",sname "Adams",status 30,city "Athens"}}

2−p := relation{tuple{p# "P1",pname "Nut",color "Red",weight 12,city "London"}, tuple{p# "P2",pname "Bolt",color "Green",weight 17,city "Paris"}, tuple{p# "P3",pname "Screw",color "Blue",weight 17,city "Oslo"}, tuple{p# "P4",pname "Screw",color "Red",weight 14,city "London"}, tuple{p# "P5",pname "Cam",color "Blue",weight 12,city "Paris"}, tuple{p# "P6", pname "Cog", color "Red",weight 19,city "London"}}

3−sp := relation{tuple{s# "S1",p# "P1",qty 300}, tuple{s# "S1",p# "P2",qty 200}, tuple{s# "S1",p# "P3",qty 400}, tuple{s# "S1",p# "P4",qty 200}, tuple{s# "S1",p# "P5",qty 100}, tuple{s# "S1",p# "P6",qty 100}, tuple{s# "S2",p# "P1",qty 300}, tuple{s# "S2",p# "P2",qty 400}, tuple{s# "S3",p# "P2",qty 200}, tuple{s# "S4",p# "P4",qty 300}, tuple{s# "S4",p# "P5",qty 400}}

4−foreign key sp2s sp{s#} in s{s#}

5−foreign key sp2p sp{p#} in p{p#}

1+s := relation{tuple{s# "S1",sname "Smith",status 20, city "London"},

2+ tuple{s# "S2",sname "Jones",status 10,city "Paris"},

3+ tuple{s# "S3",sname "Blake",status 30,city "Paris"},

4+ tuple{s# "S4",sname "Clark",status 20,city "London"},

5+ tuple{s# "S5",sname "Adams",status 30,city "Athens"}};

6+p := relation{tuple{p# "P1",pname "Nut",color "Red",weight 12,city "London"},

7+ tuple{p# "P2",pname "Bolt",color "Green",weight 17,city "Paris"},

8+ tuple{p# "P3",pname "Screw",color "Blue",weight 17,city "Oslo"},

9+ tuple{p# "P4",pname "Screw",color "Red",weight 14,city "London"},

10+ tuple{p# "P5",pname "Cam",color "Blue",weight 12,city "Paris"},

11+ tuple{p# "P6", pname "Cog", color "Red",weight 19,city "London"}};

12+sp := relation{tuple{s# "S1",p# "P1",qty 300},

13+ tuple{s# "S1",p# "P2",qty 200},

14+ tuple{s# "S1",p# "P3",qty 400},

15+ tuple{s# "S1",p# "P4",qty 200},

16+ tuple{s# "S1",p# "P5",qty 100},

17+ tuple{s# "S1",p# "P6",qty 100},

18+ tuple{s# "S2",p# "P1",qty 300},

19+ tuple{s# "S2",p# "P2",qty 400},

20+ tuple{s# "S3",p# "P2",qty 200},

21+ tuple{s# "S4",p# "P4",qty 300},

22+ tuple{s# "S4",p# "P5",qty 400}};

23+foreign key sp2s sp{s#} in s{s#};

24+foreign key sp2p sp{p#} in p{p#};

src/bin/ProjectM36/Server/WebSocket.hs+1−1

@@ -44,7 +44,7 @@ websocketProxyServer port host pending = do

4444 case msg of

4545 _ | tutdprefix `T.isPrefixOf` msg -> do

4646 let tutdString = T.drop (T.length tutdprefix) msg

47− case parseTutorialD (T.unpack tutdString) of

47+ case parseTutorialD tutdString of

4848 Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))

4949 Right parsed -> do

5050 result <- evalTutorialD sessionId dbconn SafeEvaluation parsed

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

@@ -20,7 +20,8 @@ displayOpResult :: TutorialDOperatorResult -> IO ()

2020displayOpResult QuitResult = return ()

2121displayOpResult (DisplayResult out) = TIO.putStrLn out

2222displayOpResult (DisplayIOResult ioout) = ioout

23−displayOpResult (DisplayErrorResult err) = TIO.hPutStrLn stderr ("ERR: " <> err)

23+displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in

24+ outputf stderr ("ERR: " <> err)

2425displayOpResult QuietSuccessResult = return ()

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

2627

@@ -28,7 +29,7 @@ spaceConsumer :: Parser ()

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

2930

3031opChar :: Parser Char

31−opChar = oneOf (":!#$%&*+./<=>?\\^|-~"::String)-- remove "@" so it can be used as attribute marker without spaces

32+opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces

3233

3334reserved :: String -> Parser ()

3435reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)

@@ -111,22 +112,6 @@ data TutorialDOperatorResult = QuitResult |

111112

112113type TransactionGraphWasUpdated = Bool

113114

114−escapedChar :: Parser Char

115−escapedChar = do

116− _ <- char '\\'

117− let lookupAssoc = [('n','\n'), ('\"','\"'), ('\\', '\\')]

118− c <- oneOf ("\\\"n"::String) -- all the characters which can be escaped

119− case lookup c lookupAssoc of

120− Just v -> pure v

121− Nothing -> fail "failed to handle escaped character"

122−

123−--http://stackoverflow.com/questions/24106314/parser-for-quoted-string-using-parsec

124−nonEscapedChar :: Parser Char

125−nonEscapedChar = noneOf ("\\\""::String)

126−

127−quotedChar :: Parser Char

128−quotedChar = escapedChar <|> nonEscapedChar

129−

130115--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying

131116tripleQuotedString :: Parser Text

132117tripleQuotedString = do

@@ -134,7 +119,7 @@ tripleQuotedString = do

134119 pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))

135120

136121normalQuotedString :: Parser Text

137−normalQuotedString = quote *> (T.pack <$> manyTill quotedChar quote)

122+normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)

138123

139124quotedString :: Parser Text

140125quotedString = try tripleQuotedString <|> normalQuotedString

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs+6−3

@@ -16,8 +16,8 @@ import ProjectM36.Key

1616import Data.Monoid

1717

1818--parsers which create "database expressions" which modify the database context (such as relvar assignment)

19−databaseExprP :: Parser DatabaseContextExpr

20−databaseExprP = choice $ map (\p -> p <* optional commentP) [insertP,

19+databaseContextExprP :: Parser DatabaseContextExpr

20+databaseContextExprP = choice $ map (\p -> p <* optional commentP) [insertP,

2121 deleteConstraintP,

2222 deleteP,

2323 updateP,

@@ -46,10 +46,13 @@ assignP = do

4646 return relVarName

4747 expr <- relExprP

4848 pure $ Assign relVarName expr

49+

50+multilineSep :: Parser T.Text

51+multilineSep = newline >> pure "\n"

4952

5053multipleDatabaseContextExprP :: Parser DatabaseContextExpr

5154multipleDatabaseContextExprP = do

52− exprs <- sepBy1 databaseExprP semi

55+ exprs <- sepBy1 databaseContextExprP semi

5356 pure $ MultipleExpr exprs

5457

5558insertP :: Parser DatabaseContextExpr

src/bin/TutorialD/Interpreter/Import/TutorialD.hs+3−6

@@ -7,7 +7,6 @@ import Text.Megaparsec.Text

77import Text.Megaparsec hiding (try)

88import ProjectM36.Error

99import qualified ProjectM36.Error as PM36E

10−import Data.Either

1110import qualified Data.Text as T

1211import Control.Exception

1312import qualified Data.Text.IO as TIO

@@ -19,11 +18,9 @@ importTutorialD pathIn = do

1918 case tutdData of

2019 Left err -> return $ Left (ImportError $ T.pack (show err))

2120 Right tutdData' -> do

22− let dbexprsErr = map (parse databaseExprP "import") (T.lines tutdData')

23− errs = lefts dbexprsErr

24− case errs of

25− err2:_ -> return $ Left (PM36E.ParseError (T.pack (show err2)))

26− [] -> return $ Right (MultipleExpr (rights dbexprsErr))

21+ case parse multipleDatabaseContextExprP "import" tutdData' of

22+ Left err -> pure (Left (PM36E.ParseError (T.pack (parseErrorPretty err))))

23+ Right expr -> pure (Right expr)

2724

2825tutdImportP :: Parser DatabaseContextDataImportOperator

2926tutdImportP = do

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+1−1

@@ -40,7 +40,7 @@ showRelP = do

4040showPlanP :: Parser RODatabaseContextOperator

4141showPlanP = do

4242 reservedOp ":showplan"

43− expr <- databaseExprP

43+ expr <- databaseContextExprP

4444 return $ ShowPlan expr

4545

4646showTypesP :: Parser RODatabaseContextOperator

src/bin/benchmark/bigrel.hs+3−2

@@ -21,13 +21,14 @@ import qualified Data.Text.IO as TIO

2121import System.IO

2222import Control.Monad.State

2323import Control.DeepSeq

24+import Data.Text hiding (map)

2425

2526dumpcsv :: Relation -> IO ()

2627dumpcsv rel = case relationAsCSV rel of

2728 Left err -> hPutStrLn stderr (show err)

2829 Right bsData -> BS.putStrLn bsData

2930

30−data BigrelArgs = BigrelArgs Int Int String

31+data BigrelArgs = BigrelArgs Int Int Text

3132

3233parseAttributeCount :: Parser Int

3334parseAttributeCount = option auto (short 'a' <> long "attribute-count")

@@ -39,7 +40,7 @@ parseTutD :: Parser String

3940parseTutD = strOption (short 'd' <> long "tutoriald")

4041

4142parseArgs :: Parser BigrelArgs

42−parseArgs = BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> parseTutD

43+parseArgs = BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> (pack <$> parseTutD)

4344

4445main :: IO ()

4546main = do

test/TutorialD/Interpreter.hs+13−3

@@ -25,13 +25,14 @@ import Control.Concurrent.STM

2525import Control.Concurrent

2626import qualified STMContainers.Map as STMMap

2727import qualified Data.Set as S

28+import Data.Text hiding (map)

2829

2930main :: IO ()

3031main = do

3132 tcounts <- runTestTT (TestList tests)

3233 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

3334 where

34− tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions]

35+ tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments]

3536 simpleRelTests = [("x:=true", Right relationTrue),

3637 ("x:=false", Right relationFalse),

3738 ("x:=true union false", Right relationTrue),

@@ -125,8 +126,8 @@ main = do

125126 ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntAtomType TextAtomType) [IntAtom 3]]])

126127 ]

127128

128−assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> String -> Assertion

129−assertTutdEqual databaseContext expected tutd = assertEqual tutd expected interpreted

129+assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion

130+assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted

130131 where

131132 interpreted = case interpretDatabaseContextExpr databaseContext tutd of

132133 Left err -> Left err

@@ -289,3 +290,12 @@ testMergeTransactions = TestCase $ do

289290 case eRv of

290291 Left err -> assertFailure (show err)

291292 Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv

293+

294+testComments :: Test

295+testComments = TestCase $ do

296+ (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback

297+ mapM_ (executeTutorialD sessionId dbconn) [

298+ ":branch testbranch --test comment",

299+ ":jumphead {- test comment -} master"]

300+

301+

test/TutorialD/Interpreter/TestBase.hs+2−1

@@ -6,6 +6,7 @@ import qualified ProjectM36.Base as Base

66import ProjectM36.DateExamples

77import Test.HUnit

88import qualified Data.Map as M

9+import Data.Text

910

1011dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)

1112dateExamplesConnection callback = do

@@ -24,7 +25,7 @@ dateExamplesConnection callback = do

2425 commit sessionId conn >>= maybeFail

2526 pure (sessionId, conn)

2627

27−executeTutorialD :: SessionId -> Connection -> String -> IO ()

28+executeTutorialD :: SessionId -> Connection -> Text -> IO ()

2829executeTutorialD sessionId conn tutd = case parseTutorialD tutd of

2930 Left err -> assertFailure (show tutd ++ ": " ++ show err)

3031 Right parsed -> do