add table constraint definitions to create table

Language/SQL/SimpleSQL/Parser.lhs

@@ -1466,11 +1466,11 @@ TODO: change style
 >     CreateTable
 >     <$> names
 >     -- todo: is this order mandatory or is it a perm?
->     <*> parens (commaSep1 columnDef)
+>     <*> parens (commaSep1 (tableConstraintDef <|> columnDef))
 >   where
 >     columnDef = ColumnDef <$> name <*> typeName
 >                 <*> optionMaybe defaultClause
->                 <*> option [] (many1 constraintDef)
+>                 <*> option [] (many1 colConstraintDef)
 >     defaultClause = choice [
 >         keyword_ "default" >>
 >         DefaultClause <$> valueExpr
@@ -1511,28 +1511,35 @@ TODO: change style
 >     scycle = SGOCycle <$ keyword_ "cycle"
 >     noCycle = SGONoCycle <$ try (keywords_ ["no","cycle"])
 
-
-> constraintDef :: Parser ConstraintDef
-> constraintDef =
->     ConstraintDef
+> tableConstraintDef :: Parser TableElement
+> tableConstraintDef =
+>     TableConstraintDef
 >     <$> (optionMaybe (keyword_ "constraint" *> names))
->     <*> (notNull <|> unique <|> primaryKey <|> check <|> references)
+>     <*> (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
+>     unique = keyword_ "unique" >>
+>         TableUniqueConstraint <$> parens (commaSep1 name)
+>     primaryKey = keywords_ ["primary", "key"] >>
+>         TablePrimaryKeyConstraint <$> parens (commaSep1 name)
+>     check = keyword_ "check" >> TableCheckConstraint <$> parens valueExpr
+>     references = keywords_ ["foreign", "key"] >>
+>         (\cs ft ftcs m (u,d) -> TableReferencesConstraint cs ft ftcs m u d)
+>         <$> parens (commaSep1 name)
+>         <*> (keyword_ "references" *> names)
+>         <*> optionMaybe (parens $ commaSep1 name)
+>         <*> refMatch
+>         <*> refActions
+
+> refMatch :: Parser ReferenceMatch
+> refMatch = option DefaultReferenceMatch
 >             (keyword_ "match" *>
 >              choice [MatchFull <$ keyword_ "full"
 >                     ,MatchPartial <$ keyword_ "partial"
 >                     ,MatchSimple <$ keyword_ "simple"])
->         <*> permute ((,) <$?> (DefaultReferentialAction, onUpdate)
->                          <|?> (DefaultReferentialAction, onDelete))
+> refActions :: Parser (ReferentialAction,ReferentialAction)
+> refActions = permute ((,) <$?> (DefaultReferentialAction, onUpdate)
+>                           <|?> (DefaultReferentialAction, onDelete))
+>   where
 >     -- todo: left factor?
 >     onUpdate = try (keywords_ ["on", "update"]) *> referentialAction
 >     onDelete = try (keywords_ ["on", "delete"]) *> referentialAction
@@ -1544,6 +1551,23 @@ TODO: change style
 >         ,RefRestrict <$ keyword_ "restrict"
 >         ,RefNoAction <$ keywords_ ["no", "action"]]
 
+> colConstraintDef :: Parser ColConstraintDef
+> colConstraintDef =
+>     ColConstraintDef
+>     <$> (optionMaybe (keyword_ "constraint" *> names))
+>     <*> (notNull <|> unique <|> primaryKey <|> check <|> references)
+>   where
+>     notNull = ColNotNullConstraint <$ keywords_ ["not", "null"]
+>     unique = ColUniqueConstraint <$ keyword_ "unique"
+>     primaryKey = ColPrimaryKeyConstraint <$ keywords_ ["primary", "key"]
+>     check = keyword_ "check" >> ColCheckConstraint <$> parens valueExpr
+>     references = keyword_ "references" >>
+>         (\t c m (ou,od) -> ColReferencesConstraint t c m ou od)
+>         <$> names
+>         <*> optionMaybe (parens name)
+>         <*> refMatch
+>         <*> refActions
+
 slightly hacky parser for signed integers
 
 > signedInteger :: Parser Integer

Language/SQL/SimpleSQL/Pretty.lhs

@@ -476,6 +476,24 @@ which have been changed to try to improve the layout of the output.
 >                          [] -> empty
 >                          os -> parens (sep $ map sgo os))
 >       <+> sep (map cdef cons)
+>     cd (TableConstraintDef n con) =
+>         maybe empty (\s -> text "constraint" <+> names s) n
+>         <+> ptcon con
+>     ptcon (TableUniqueConstraint ns) =
+>          text "unique" <+> parens (commaSep $ map name ns)
+>     ptcon (TablePrimaryKeyConstraint ns) =
+>         texts ["primary","key"] <+> parens (commaSep $ map name ns)
+>     ptcon (TableReferencesConstraint cs t tcs m u del) =
+>         texts ["foreign", "key"]
+>         <+> parens (commaSep $ map name cs)
+>         <+> text "references"
+>         <+> names t
+>         <+> maybe empty (\c' -> parens (commaSep $ map name c')) tcs
+>         <+> refMatch m
+>         <+> refAct "update" u
+>         <+> refAct "delete" del
+>     ptcon (TableCheckConstraint v) = text "check" <+> parens (valueExpr d v)
+
 >     sgo (SGOStartWith i) = texts ["start",  "with", show i]
 >     sgo (SGOIncrementBy i) = texts ["increment", "by", show i]
 >     sgo (SGOMaxValue i) = texts ["maxvalue", show i]
@@ -484,36 +502,32 @@ 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) =
+>     cdef (ColConstraintDef 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) =
+>     pcon ColNotNullConstraint = texts ["not","null"]
+>     pcon ColUniqueConstraint = text "unique"
+>     pcon ColPrimaryKeyConstraint = texts ["primary","key"]
+>     pcon (ColCheckConstraint v) = text "check" <+> parens (valueExpr d v)
+>     pcon (ColReferencesConstraint 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"])
+>         <+> refMatch m
+>         <+> refAct "update" u
+>         <+> refAct "delete" del
+>     refMatch m = case m of
+>                      DefaultReferenceMatch -> empty
+>                      MatchFull -> texts ["match", "full"]
+>                      MatchPartial -> texts ["match","partial"]
+>                      MatchSimple -> texts ["match", "simple"]
+>     refAct t a = case a of
+>                      DefaultReferentialAction -> empty
+>                      RefCascade -> texts ["on", t, "cascade"]
+>                      RefSetNull -> texts ["on", t, "set", "null"]
+>                      RefSetDefault -> texts ["on", t, "set", "default"]
+>                      RefRestrict -> texts ["on", t, "restrict"]
+>                      RefNoAction -> texts ["on", t, "no", "action"]
 
 > statement _ (DropSchema nm db) =
 >     text "drop" <+> text "schema" <+> names nm <+> dropBehav db

Language/SQL/SimpleSQL/Syntax.lhs

@@ -40,8 +40,9 @@
 >     ,DefaultClause(..)
 >     ,IdentityWhen(..)
 >     ,SequenceGeneratorOption(..)
->     ,ConstraintDef(..)
->     ,Constraint(..)
+>     ,ColConstraintDef(..)
+>     ,ColConstraint(..)
+>     ,TableConstraint(..)
 >     ,ReferenceMatch(..)
 >     ,ReferentialAction(..)
 >      -- * Dialect
@@ -497,27 +498,38 @@ I'm not sure if this is valid syntax or not.
 > data TableElement =
 >     ColumnDef Name TypeName
 >        (Maybe DefaultClause)
->        [ConstraintDef]
+>        [ColConstraintDef]
 >        -- (Maybe CollateClause)
->   --   | TableConstraintDef
+>   | TableConstraintDef (Maybe [Name]) TableConstraint
 >     deriving (Eq,Show,Read,Data,Typeable)
 
-> data ConstraintDef =
->     ConstraintDef (Maybe [Name]) Constraint
+> data ColConstraintDef =
+>     ColConstraintDef (Maybe [Name]) ColConstraint
 >       -- (Maybe [ConstraintCharacteristics])
 >     deriving (Eq,Show,Read,Data,Typeable)
 
-> data Constraint =
->     NotNullConstraint
->   | UniqueConstraint
->   | PrimaryKeyConstraint
->   | ReferencesConstraint [Name] (Maybe Name)
+> data ColConstraint =
+>     ColNotNullConstraint
+>   | ColUniqueConstraint
+>   | ColPrimaryKeyConstraint
+>   | ColReferencesConstraint [Name] (Maybe Name)
 >        ReferenceMatch
 >        ReferentialAction
 >        ReferentialAction
->   | CheckConstraint ValueExpr
+>   | ColCheckConstraint ValueExpr
 >     deriving (Eq,Show,Read,Data,Typeable)
 
+> data TableConstraint =
+>     TableUniqueConstraint [Name]
+>   | TablePrimaryKeyConstraint [Name]
+>   | TableReferencesConstraint [Name] [Name] (Maybe [Name])
+>        ReferenceMatch
+>        ReferentialAction
+>        ReferentialAction
+>   | TableCheckConstraint ValueExpr
+>     deriving (Eq,Show,Read,Data,Typeable)
+
+
 > data ReferenceMatch =
 >     DefaultReferenceMatch
 >   | MatchFull