add support for column constraints in create table

2015-08-02 19:27:39 +03:00 · 2015-08-02 19:27:39 +03:00 · e6e8264b3d
parent 4f80ec96d4
commit e6e8264b3d
5 changed files with 303 additions and 16 deletions
--- a/Language/SQL/SimpleSQL/Parser.lhs
+++ b/Language/SQL/SimpleSQL/Parser.lhs
@ -1465,10 +1465,12 @@ TODO: change style
 > createTable = keyword_ "table" >>
 >     CreateTable
 >     <$> names
+>     -- todo: is this order mandatory or is it a perm?
 >     <*> parens (commaSep1 columnDef)
 >   where
 >     columnDef = ColumnDef <$> name <*> typeName
 >                 <*> optionMaybe defaultClause
+>                 <*> option [] (many1 constraintDef)
 >     defaultClause = choice [
 >         keyword_ "default" >>
 >         DefaultClause <$> valueExpr
@ -1509,6 +1511,39 @@ TODO: change style
 >     scycle = SGOCycle <$ keyword_ "cycle"
 >     noCycle = SGONoCycle <$ try (keywords_ ["no","cycle"])

+
+> constraintDef :: Parser ConstraintDef
+> constraintDef =
+>     ConstraintDef
+>     <$> (optionMaybe (keyword_ "constraint" *> names))
+>     <*> (notNull <|> unique <|> primaryKey <|> check <|> references)
+>   where
+>     notNull = NotNullConstraint <$ keywords_ ["not", "null"]
+>     unique = UniqueConstraint <$ keyword_ "unique"
+>     primaryKey = PrimaryKeyConstraint <$ keywords_ ["primary", "key"]
+>     check = keyword_ "check" >> CheckConstraint <$> parens valueExpr
+>     references = keyword_ "references" >>
+>         (\t c m (ou,od) -> ReferencesConstraint t c m ou od)
+>         <$> names
+>         <*> optionMaybe (parens name)
+>         <*> option DefaultReferenceMatch
+>             (keyword_ "match" *>
+>              choice [MatchFull <$ keyword_ "full"
+>                     ,MatchPartial <$ keyword_ "partial"
+>                     ,MatchSimple <$ keyword_ "simple"])
+>         <*> permute ((,) <$?> (DefaultReferentialAction, onUpdate)
+>                          <|?> (DefaultReferentialAction, onDelete))
+>     -- todo: left factor?
+>     onUpdate = try (keywords_ ["on", "update"]) *> referentialAction
+>     onDelete = try (keywords_ ["on", "delete"]) *> referentialAction
+>     referentialAction = choice [
+>          RefCascade <$ keyword_ "cascade"
+>          -- todo: left factor?
+>         ,RefSetNull <$ try (keywords_ ["set", "null"])
+>         ,RefSetDefault <$ try (keywords_ ["set", "default"])
+>         ,RefRestrict <$ keyword_ "restrict"
+>         ,RefNoAction <$ keywords_ ["no", "action"]]
+
 slightly hacky parser for signed integers

 > signedInteger :: Parser Integer
--- a/Language/SQL/SimpleSQL/Pretty.lhs
+++ b/Language/SQL/SimpleSQL/Pretty.lhs
@ -457,7 +457,7 @@ which have been changed to try to improve the layout of the output.
 >     text "create" <+> text "table" <+> names nm
 >     <+> parens (commaSep $ map cd cds)
 >   where
->     cd (ColumnDef n t mdef) =
+>     cd (ColumnDef n t mdef cons) =
 >       name n <+> typeName t
 >       <+> case mdef of
 >              Nothing -> empty
@ -475,6 +475,7 @@ which have been changed to try to improve the layout of the output.
 >                  <+> (case o of
 >                          [] -> empty
 >                          os -> parens (sep $ map sgo os))
+>       <+> sep (map cdef cons)
 >     sgo (SGOStartWith i) = texts ["start",  "with", show i]
 >     sgo (SGOIncrementBy i) = texts ["increment", "by", show i]
 >     sgo (SGOMaxValue i) = texts ["maxvalue", show i]
@ -483,6 +484,36 @@ which have been changed to try to improve the layout of the output.
 >     sgo SGONoMinValue = texts ["no", "minvalue"]
 >     sgo SGOCycle = text "cycle"
 >     sgo SGONoCycle = text "no cycle"
+>     cdef (ConstraintDef cnm con) =
+>         maybe empty (\s -> text "constraint" <+> names s) cnm
+>         <+> pcon con
+>     pcon NotNullConstraint = texts ["not","null"]
+>     pcon UniqueConstraint = text "unique"
+>     pcon PrimaryKeyConstraint = texts ["primary","key"]
+>     pcon (CheckConstraint v) = text "check" <+> parens (valueExpr d v)
+>     pcon (ReferencesConstraint t c m u del) =
+>         text "references"
+>         <+> names t
+>         <+> maybe empty (\c' -> parens (name c')) c
+>         <+> (case m of
+>                  DefaultReferenceMatch -> empty
+>                  MatchFull -> texts ["match", "full"]
+>                  MatchPartial -> texts ["match","partial"]
+>                  MatchSimple -> texts ["match", "simple"])
+>         <+> (case u of
+>                  DefaultReferentialAction -> empty
+>                  RefCascade -> texts ["on", "update", "cascade"]
+>                  RefSetNull -> texts ["on", "update", "set", "null"]
+>                  RefSetDefault -> texts ["on", "update", "set", "default"]
+>                  RefRestrict -> texts ["on", "update", "restrict"]
+>                  RefNoAction -> texts ["on", "update", "no", "action"])
+>         <+> (case del of
+>                  DefaultReferentialAction -> empty
+>                  RefCascade -> texts ["on", "delete", "cascade"]
+>                  RefSetNull -> texts ["on", "delete", "set", "null"]
+>                  RefSetDefault -> texts ["on", "delete", "set", "default"]
+>                  RefRestrict -> texts ["on", "delete", "restrict"]
+>                  RefNoAction -> texts ["on", "delete", "no", "action"])

 > statement _ (DropSchema nm db) =
 >     text "drop" <+> text "schema" <+> names nm <+> dropBehav db
--- a/Language/SQL/SimpleSQL/Syntax.lhs
+++ b/Language/SQL/SimpleSQL/Syntax.lhs
@ -40,6 +40,10 @@
 >     ,DefaultClause(..)
 >     ,IdentityWhen(..)
 >     ,SequenceGeneratorOption(..)
+>     ,ConstraintDef(..)
+>     ,Constraint(..)
+>     ,ReferenceMatch(..)
+>     ,ReferentialAction(..)
 >      -- * Dialect
 >     ,Dialect(..)
 >      -- * Comment
@ -493,11 +497,68 @@ I'm not sure if this is valid syntax or not.
 > data TableElement =
 >     ColumnDef Name TypeName
 >        (Maybe DefaultClause)
->        -- (Maybe ColumnConstraintDef)
+>        [ConstraintDef]
 >        -- (Maybe CollateClause)
 >   --   | TableConstraintDef
 >     deriving (Eq,Show,Read,Data,Typeable)

+> data ConstraintDef =
+>     ConstraintDef (Maybe [Name]) Constraint
+>       -- (Maybe [ConstraintCharacteristics])
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data Constraint =
+>     NotNullConstraint
+>   | UniqueConstraint
+>   | PrimaryKeyConstraint
+>   | ReferencesConstraint [Name] (Maybe Name)
+>        ReferenceMatch
+>        ReferentialAction
+>        ReferentialAction
+>   | CheckConstraint ValueExpr
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data ReferenceMatch =
+>     DefaultReferenceMatch
+>   | MatchFull
+>   | MatchPartial
+>   | MatchSimple
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data ReferentialAction =
+>     DefaultReferentialAction
+>   | RefCascade
+>   | RefSetNull
+>   | RefSetDefault
+>   | RefRestrict
+>   | RefNoAction
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> {-data ConstraintCharacteristics =
+>     ConstraintCharacteristics
+>         ConstraintCheckTime
+>         Deferrable
+>         ConstraintEnforcement
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data ConstraintCheckTime =
+>     DefaultConstraintCheckTime
+>   | InitiallyDeferred
+>   | InitiallyImmeditate
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data Deferrable =
+>     DefaultDefferable
+>   | Deferrable
+>   | NotDeferrable
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+> data ConstraintEnforcement =
+>     DefaultConstraintEnforcement
+>   | Enforced
+>   | NotEnforced
+>     deriving (Eq,Show,Read,Data,Typeable) -}
+
 > {-data TableConstraintDef
 >     deriving (Eq,Show,Read,Data,Typeable) -}

--- a/tools/Language/SQL/SimpleSQL/SQL2011Queries.lhs
+++ b/tools/Language/SQL/SimpleSQL/SQL2011Queries.lhs
@ -1,16 +1,28 @@

-This file goes through the grammar for SQL 2011 (using the draft standard).
+This file goes through the grammar for SQL 2011 queries (using the
+draft standard).

-We are only looking at the query syntax, and no other parts.
+There are other files which cover some of the other sections from SQL
+2011 (ddl, non-query dml, etc).
+
+Possible sections not in the todo which could
+be covered:

-There are other files which cover some of the other sections.
-Possible sections not covered yet:
 13 modules
 16 control statements
+18 connection management
 20 dynamic
 22 direct
 23 diagnostics

+procedural sql
+
+some of the main areas being left for now:
+temporal and versioning stuff
+modules
+ref stuff
+todo: finish this list
+


 The goal is to create some example tests for each bit of grammar, with
--- a/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs
+++ b/tools/Language/SQL/SimpleSQL/SQL2011Schema.lhs
@ -92,8 +92,8 @@ schema name can be quoted iden or unicode quoted iden

 >     ,(TestStatement SQL2011 "create table t (a int, b int);"
 >      $ CreateTable [Name "t"]
->        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
->        ,ColumnDef (Name "b") (TypeName [Name "int"]) Nothing])
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing []
+>        ,ColumnDef (Name "b") (TypeName [Name "int"]) Nothing []])


 <table contents source> ::=
@ -296,6 +296,154 @@ defintely skip
  | <references specification>
  | <check constraint definition>

+
+can have more than one
+whitespace separated
+
+one constratint:
+optional name: constraint [Name]
+not null | unique | references | check
+todo: constraint characteristics
+
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int not null);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing NotNullConstraint]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int constraint a_not_null not null);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef (Just [Name "a_not_null"]) NotNullConstraint]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int unique);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing UniqueConstraint]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int primary key);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing PrimaryKeyConstraint]])
+
+references t(a,b)
+  [ Full |partial| simepl]
+  [perm: on update [cascade | set null | set default | restrict | no action]
+         on delete ""
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          DefaultReferentialAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u(a));"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] (Just $ Name "a") DefaultReferenceMatch
+>          DefaultReferentialAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u match full);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing MatchFull
+>          DefaultReferentialAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u match partial);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing MatchPartial
+>          DefaultReferentialAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u match simple);"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing MatchSimple
+>          DefaultReferentialAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on update cascade );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefCascade DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on update set null );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefSetNull DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on update set default );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefSetDefault DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on update no action );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefNoAction DefaultReferentialAction]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on delete cascade );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          DefaultReferentialAction RefCascade]])
+
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on update cascade on delete restrict );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefCascade RefRestrict]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int references u on delete restrict on update cascade );"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing $ ReferencesConstraint
+>          [Name "u"] Nothing DefaultReferenceMatch
+>          RefCascade RefRestrict]])
+
+>     ,(TestStatement SQL2011
+>       "create table t (a int check (a>5));"
+>      $ CreateTable [Name "t"]
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>         [ConstraintDef Nothing
+>          (CheckConstraint $ BinOp (Iden [Name "a"]) [Name ">"] (NumLit "5"))]])
+
+
+check (valueexpr)
+
+
+
 <identity column specification> ::=
  GENERATED { ALWAYS | BY DEFAULT } AS IDENTITY
      [ <left paren> <common sequence generator options> <right paren> ]
@ -303,17 +451,17 @@ defintely skip
 >     ,(TestStatement SQL2011 "create table t (a int generated as identity);"
 >      $ CreateTable [Name "t"]
 >        [ColumnDef (Name "a") (TypeName [Name "int"])
->         (Just $ IdentityColumnSpec GeneratedDefault [])])
+>         (Just $ IdentityColumnSpec GeneratedDefault []) []])

 >     ,(TestStatement SQL2011 "create table t (a int generated always as identity);"
 >      $ CreateTable [Name "t"]
 >        [ColumnDef (Name "a") (TypeName [Name "int"])
->         (Just $ IdentityColumnSpec GeneratedAlways [])])
+>         (Just $ IdentityColumnSpec GeneratedAlways []) []])

 >     ,(TestStatement SQL2011 "create table t (a int generated by default as identity);"
 >      $ CreateTable [Name "t"]
 >        [ColumnDef (Name "a") (TypeName [Name "int"])
->         (Just $ IdentityColumnSpec GeneratedByDefault [])])
+>         (Just $ IdentityColumnSpec GeneratedByDefault []) []])


 >     ,(TestStatement SQL2011
@ -326,7 +474,7 @@ defintely skip
 >          ,SGOIncrementBy 5
 >          ,SGOMaxValue 500
 >          ,SGOMinValue 5
->          ,SGOCycle])])
+>          ,SGOCycle]) []])

 >     ,(TestStatement SQL2011
 >       "create table t (a int generated as identity\
@ -337,7 +485,7 @@ defintely skip
 >          [SGOStartWith (-4)
 >          ,SGONoMaxValue
 >          ,SGONoMinValue
->          ,SGONoCycle])])
+>          ,SGONoCycle]) []])

 I think <common sequence generator options> is supposed to just
 whitespace separated. In db2 it seems to be csv, but the grammar here
@ -360,10 +508,10 @@ generated always (valueexpr)
 >       "create table t (a int, \
 >       \                a2 int generated always as (a * 2));"
 >      $ CreateTable [Name "t"]
->        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing
+>        [ColumnDef (Name "a") (TypeName [Name "int"]) Nothing []
 >        ,ColumnDef (Name "a2") (TypeName [Name "int"])
 >         (Just $ GenerationClause
->          (BinOp (Iden [Name "a"]) [Name "*"] (NumLit "2")))])
+>          (BinOp (Iden [Name "a"]) [Name "*"] (NumLit "2"))) []])



@ -389,7 +537,7 @@ generated always (valueexpr)
 >     ,(TestStatement SQL2011 "create table t (a int default 0);"
 >      $ CreateTable [Name "t"]
 >        [ColumnDef (Name "a") (TypeName [Name "int"])
->         (Just $ DefaultClause $ NumLit "0")])
+>         (Just $ DefaultClause $ NumLit "0") []])