add support for column constraints in create table

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

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

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) -}