From 9aab04b189db3607c76a581c0c71ef93bca6d886 Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Tue, 4 Aug 2015 22:08:32 +0300 Subject: [PATCH] add create, alter, drop domain --- Language/SQL/SimpleSQL/Parser.lhs | 40 +++++++++- Language/SQL/SimpleSQL/Pretty.lhs | 28 +++++++ Language/SQL/SimpleSQL/Syntax.lhs | 17 ++++- .../Language/SQL/SimpleSQL/SQL2011Schema.lhs | 74 +++++++++++++++++++ 4 files changed, 151 insertions(+), 8 deletions(-) diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index a7aeffa..af1c03d 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/Language/SQL/SimpleSQL/Parser.lhs @@ -189,7 +189,7 @@ fixing them in the syntax but leaving them till the semantic checking > import Data.Char (toLower, isDigit) > import Text.Parsec (setPosition,setSourceColumn,setSourceLine,getPosition > ,option,between,sepBy,sepBy1 -> ,try,many1,(<|>),choice,eof +> ,try,many,many1,(<|>),choice,eof > ,optionMaybe,optional,runParser > ,chainl1, chainr1,()) > -- import Text.Parsec.String (Parser) @@ -1443,11 +1443,14 @@ TODO: change style > statement = choice > [keyword_ "create" *> choice [createSchema > ,createTable -> ,createView] -> ,keyword_ "alter" *> choice [alterTable] +> ,createView +> ,createDomain] +> ,keyword_ "alter" *> choice [alterTable +> ,alterDomain] > ,keyword_ "drop" *> choice [dropSchema > ,dropTable -> ,dropView] +> ,dropView +> ,dropDomain] > ,delete > ,truncateSt > ,insert @@ -1638,6 +1641,35 @@ slightly hacky parser for signed integers > dropView = keyword_ "view" >> > DropView <$> names <*> dropBehaviour +> createDomain :: Parser Statement +> createDomain = keyword_ "domain" >> +> CreateDomain +> <$> names +> <*> (optional (keyword_ "as") *> typeName) +> <*> optionMaybe (keyword_ "default" *> valueExpr) +> <*> many con +> where +> con = (,) <$> optionMaybe (keyword_ "constraint" *> names) +> <*> (keyword_ "check" *> parens valueExpr) + +> alterDomain :: Parser Statement +> alterDomain = keyword_ "domain" >> +> AlterDomain +> <$> names +> <*> (setDefault <|> constraint +> <|> (keyword_ "drop" *> (dropDefault <|> dropConstraint))) +> where +> setDefault = keywords_ ["set", "default"] >> ADSetDefault <$> valueExpr +> constraint = keyword_ "add" >> +> ADAddConstraint +> <$> optionMaybe (keyword_ "constraint" *> names) +> <*> (keyword_ "check" *> parens valueExpr) +> dropDefault = ADDropDefault <$ keyword_ "default" +> dropConstraint = keyword_ "constraint" >> ADDropConstraint <$> names + +> dropDomain :: Parser Statement +> dropDomain = keyword_ "domain" >> +> DropDomain <$> names <*> dropBehaviour ----------------- diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index 9779c87..5f78cae 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/Language/SQL/SimpleSQL/Pretty.lhs @@ -469,6 +469,34 @@ which have been changed to try to improve the layout of the output. > statement _ (DropSchema nm db) = > text "drop" <+> text "schema" <+> names nm <+> dropBehav db +> statement d (CreateDomain nm ty def cs) = +> text "create" <+> text "domain" <+> names nm +> <+> typeName ty +> <+> maybe empty (\def' -> text "default" <+> valueExpr d def') def +> <+> sep (map con cs) +> where +> con (cn, e) = +> maybe empty (\cn' -> text "constraint" <+> names cn') cn +> <+> text "check" <> parens (valueExpr d e) + +> statement d (AlterDomain nm act) = +> texts ["alter","domain"] +> <+> names nm +> <+> a act +> where +> a (ADSetDefault v) = texts ["set","default"] <+> valueExpr d v +> a (ADDropDefault) = texts ["drop","default"] +> a (ADAddConstraint nm e) = +> text "add" +> <+> maybe empty (\nm' -> text "constraint" <+> names nm') nm +> <+> text "check" <> parens (valueExpr d e) +> a (ADDropConstraint nm) = texts ["drop", "constraint"] +> <+> names nm + + +> statement _ (DropDomain nm db) = +> text "drop" <+> text "domain" <+> names nm <+> dropBehav db + == dml > statement d (SelectStatement q) = queryExpr d q diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index ef679f8..902add0 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/Language/SQL/SimpleSQL/Syntax.lhs @@ -48,6 +48,7 @@ > ,ReferentialAction(..) > ,AlterTableAction(..) > ,CheckOption(..) +> ,AlterDomainAction(..) > -- * Dialect > ,Dialect(..) > -- * Comment @@ -410,10 +411,11 @@ I'm not sure if this is valid syntax or not. > | CreateView Bool [Name] (Maybe [Name]) > QueryExpr (Maybe CheckOption) > | DropView [Name] DropBehaviour -> {- | CreateDomain -> | AlterDomain -> | DropDomain -> | CreateCharacterSet +> | CreateDomain [Name] TypeName (Maybe ValueExpr) +> [(Maybe [Name], ValueExpr)] +> | AlterDomain [Name] AlterDomainAction +> | DropDomain [Name] DropBehaviour +> {- | CreateCharacterSet > | DropCharacterSet > | CreateCollation > | DropCollation @@ -625,6 +627,13 @@ I'm not sure if this is valid syntax or not. > | LocalCheckOption > deriving (Eq,Show,Read,Data,Typeable) +> data AlterDomainAction = +> ADSetDefault ValueExpr +> | ADDropDefault +> | ADAddConstraint (Maybe [Name]) ValueExpr +> | ADDropConstraint [Name] +> deriving (Eq,Show,Read,Data,Typeable) + -------------------------- diff --git a/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs b/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs index 075c124..b38ba75 100644 --- a/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs +++ b/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs @@ -1152,6 +1152,40 @@ defintely skip [ ] [ ] +> ,(TestStatement SQL2011 +> "create domain my_int int" +> $ CreateDomain [Name "my_int"] +> (TypeName [Name "int"]) +> Nothing []) + +> ,(TestStatement SQL2011 +> "create domain my_int as int" +> $ CreateDomain [Name "my_int"] +> (TypeName [Name "int"]) +> Nothing []) + +> ,(TestStatement SQL2011 +> "create domain my_int int default 0" +> $ CreateDomain [Name "my_int"] +> (TypeName [Name "int"]) +> (Just (NumLit "0")) []) + +> ,(TestStatement SQL2011 +> "create domain my_int int check (value > 5)" +> $ CreateDomain [Name "my_int"] +> (TypeName [Name "int"]) +> Nothing [(Nothing +> ,BinOp (Iden [Name "value"]) [Name ">"] (NumLit "5"))]) + +> ,(TestStatement SQL2011 +> "create domain my_int int constraint gt5 check (value > 5)" +> $ CreateDomain [Name "my_int"] +> (TypeName [Name "int"]) +> Nothing [(Just [Name "gt5"] +> ,BinOp (Iden [Name "value"]) [Name ">"] (NumLit "5"))]) + + + 11.35 ::= @@ -1168,26 +1202,66 @@ defintely skip ::= SET +> ,(TestStatement SQL2011 +> "alter domain my_int set default 0" +> $ AlterDomain [Name "my_int"] +> $ ADSetDefault $ NumLit "0") + + 11.37 ::= DROP DEFAULT +> ,(TestStatement SQL2011 +> "alter domain my_int drop default" +> $ AlterDomain [Name "my_int"] +> $ ADDropDefault) + + 11.38 ::= ADD +> ,(TestStatement SQL2011 +> "alter domain my_int add check (value > 6)" +> $ AlterDomain [Name "my_int"] +> $ ADAddConstraint Nothing +> $ BinOp (Iden [Name "value"]) [Name ">"] (NumLit "6")) + +> ,(TestStatement SQL2011 +> "alter domain my_int add constraint gt6 check (value > 6)" +> $ AlterDomain [Name "my_int"] +> $ ADAddConstraint (Just [Name "gt6"]) +> $ BinOp (Iden [Name "value"]) [Name ">"] (NumLit "6")) + + 11.39 ::= DROP CONSTRAINT +> ,(TestStatement SQL2011 +> "alter domain my_int drop constraint gt6" +> $ AlterDomain [Name "my_int"] +> $ ADDropConstraint [Name "gt6"]) + 11.40 ::= DROP DOMAIN +> ,(TestStatement SQL2011 +> "drop domain my_int" +> $ DropDomain [Name "my_int"] DefaultDropBehaviour) + +> ,(TestStatement SQL2011 +> "drop domain my_int cascade" +> $ DropDomain [Name "my_int"] Cascade) + + + 11.41 ::=