From 666d1f877f4797e9e9b8ae6291036c33148ed712 Mon Sep 17 00:00:00 2001
From: Jake Wheat <jakewheatmail@gmail.com>
Date: Tue, 4 Aug 2015 22:53:08 +0300
Subject: [PATCH] add basic transction control

---
 Language/SQL/SimpleSQL/Parser.lhs            | 27 +++++++++++++
 Language/SQL/SimpleSQL/Pretty.lhs            | 16 ++++++++
 Language/SQL/SimpleSQL/Syntax.lhs            | 13 ++++---
 tools/Language/SQL/SimpleSQL/SQL2011Bits.lhs | 40 +++++++++++++++++++-
 4 files changed, 89 insertions(+), 7 deletions(-)

diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs
index 2d37a1b..f3d6781 100644
--- a/Language/SQL/SimpleSQL/Parser.lhs
+++ b/Language/SQL/SimpleSQL/Parser.lhs
@@ -1458,6 +1458,11 @@ TODO: change style
 >     ,truncateSt
 >     ,insert
 >     ,update
+>     ,startTransaction
+>     ,savepoint
+>     ,releaseSavepoint
+>     ,commit
+>     ,rollback
 >     ,SelectStatement <$> queryExpr
 >     ]
 
@@ -1752,6 +1757,28 @@ slightly hacky parser for signed integers
 >     (Restrict <$ keyword_ "restrict"
 >     <|> Cascade <$ keyword_ "cascade")
 
+-----------------------------
+
+= access control
+
+> startTransaction :: Parser Statement
+> startTransaction = StartTransaction <$ keywords_ ["start","transaction"]
+
+> savepoint :: Parser Statement
+> savepoint = keyword_ "savepoint" >>
+>     Savepoint <$> name
+
+> releaseSavepoint :: Parser Statement
+> releaseSavepoint = keywords_ ["release","savepoint"] >>
+>     ReleaseSavepoint <$> name
+
+> commit :: Parser Statement
+> commit = Commit <$ keyword_ "commit" <* optional (keyword_ "work")
+
+> rollback :: Parser Statement
+> rollback = keyword_ "rollback" >> optional (keyword_ "work") >>
+>     Rollback <$> optionMaybe (keywords_ ["to", "savepoint"] *> name)
+
 ----------------------------
 
 wrapper to parse a series of statements. They must be separated by
diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs
index 6bed655..ce898f5 100644
--- a/Language/SQL/SimpleSQL/Pretty.lhs
+++ b/Language/SQL/SimpleSQL/Pretty.lhs
@@ -562,6 +562,22 @@ which have been changed to try to improve the layout of the output.
 
 == access control
 
+> statement _ StartTransaction =
+>     texts ["start", "transaction"]
+
+> statement _ (Savepoint nm) =
+>     text "savepoint" <+> name nm
+
+> statement _ (ReleaseSavepoint nm) =
+>     texts ["release", "savepoint"] <+> name nm
+
+> statement _ Commit =
+>     text "commit"
+
+> statement _ (Rollback mn) =
+>     text "rollback"
+>     <+> maybe empty (\n -> texts ["to","savepoint"] <+> name n) mn
+
 == transactions
 
 == sessions
diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs
index cbdbcaa..a551445 100644
--- a/Language/SQL/SimpleSQL/Syntax.lhs
+++ b/Language/SQL/SimpleSQL/Syntax.lhs
@@ -465,12 +465,13 @@ I'm not sure if this is valid syntax or not.
 >   | RevokePrivilege
 >   | RevokeRole -}
 >     -- transaction management
->   {-  | StartTransaction
->   | SetTransaction
->   | SetContraints
->   | SavePoint
->   | ReleaseSavePoint
->   | Rollback -}
+>   | StartTransaction
+>   --  | SetTransaction
+>   --  | SetContraints
+>   | Savepoint Name
+>   | ReleaseSavepoint Name
+>   | Commit
+>   | Rollback (Maybe Name)
 >     -- session
 >   {-  | SetSessionCharacteristics
 >   | SetSessionAuthorization
diff --git a/tools/Language/SQL/SimpleSQL/SQL2011Bits.lhs b/tools/Language/SQL/SimpleSQL/SQL2011Bits.lhs
index 541193e..dc76b90 100644
--- a/tools/Language/SQL/SimpleSQL/SQL2011Bits.lhs
+++ b/tools/Language/SQL/SimpleSQL/SQL2011Bits.lhs
@@ -8,9 +8,10 @@ commit, savepoint, etc.), and session management (set).
 > module Language.SQL.SimpleSQL.SQL2011Bits (sql2011BitsTests) where
 
 > import Language.SQL.SimpleSQL.TestTypes
+> import Language.SQL.SimpleSQL.Syntax
 
 > sql2011BitsTests :: TestItem
-> sql2011BitsTests = Group "sql 2011 bits tests" []
+> sql2011BitsTests = Group "sql 2011 bits tests" [
 
 17 Transaction management
 
@@ -21,6 +22,10 @@ commit, savepoint, etc.), and session management (set).
 
 BEGIN is not in the standard!
 
+>      (TestStatement SQL2011
+>       "start transaction"
+>      $ StartTransaction)
+
 17.2 <set transaction statement>
 
 <set transaction statement> ::=
@@ -72,16 +77,35 @@ BEGIN is not in the standard!
 <savepoint specifier> ::=
   <savepoint name>
 
+>     ,(TestStatement SQL2011
+>       "savepoint difficult_bit"
+>      $ Savepoint $ Name "difficult_bit")
+
+
 17.6 <release savepoint statement>
 
 <release savepoint statement> ::=
   RELEASE SAVEPOINT <savepoint specifier>
 
+>     ,(TestStatement SQL2011
+>       "release savepoint difficult_bit"
+>      $ ReleaseSavepoint $ Name "difficult_bit")
+
+
 17.7 <commit statement>
 
 <commit statement> ::=
   COMMIT [ WORK ] [ AND [ NO ] CHAIN ]
 
+>     ,(TestStatement SQL2011
+>       "commit"
+>      $ Commit)
+
+>     ,(TestStatement SQL2011
+>       "commit work"
+>      $ Commit)
+
+
 17.8 <rollback statement>
 
 <rollback statement> ::=
@@ -90,6 +114,18 @@ BEGIN is not in the standard!
 <savepoint clause> ::=
   TO SAVEPOINT <savepoint specifier>
 
+>     ,(TestStatement SQL2011
+>       "rollback"
+>      $ Rollback Nothing)
+
+>     ,(TestStatement SQL2011
+>       "rollback work"
+>      $ Rollback Nothing)
+
+>     ,(TestStatement SQL2011
+>       "rollback to savepoint difficult_bit"
+>      $ Rollback $ Just $ Name "difficult_bit")
+
 
 19 Session management
 
@@ -179,3 +215,5 @@ BEGIN is not in the standard!
 
 <collation specification> ::=
   <value specification>
+
+>    ]