modify basic typenames to support dotted names in the syntax

add syntax for most of the other kinds of typenames
add pretty printing for these
todo: the parsing and the tests

Language/SQL/SimpleSQL/Parser.lhs

@@ -121,7 +121,7 @@ which parses as a typed literal
 >         ((,) <$> identifierBlacklist blacklist
 >              <*> optionMaybe (parens unsignedInteger))
 >   where
->     mkIt val Nothing = TypedLit (TypeName "interval") val
+>     mkIt val Nothing = TypedLit (TypeName [Name "interval"]) val
 >     mkIt val (Just (a,b)) = IntervalLit val a b
 
 > characterSetLiteral :: Parser ValueExpr
@@ -514,12 +514,13 @@ that SQL supports.
 
 > typeName :: Parser TypeName
 > typeName =
->   (choice [multiWordParsers
+>   (choice [try multiWordParsers
->           ,TypeName <$> identifierBlacklist blacklist]
+>           ,mktn <$> identifierBlacklist blacklist]
 >    >>= optionSuffix precision
 >   ) <?> "typename"
 >   where
->     multiWordParsers = (TypeName . unwords) <$> makeKeywordTree
+>     mktn = TypeName . (:[]) . Name
+>     multiWordParsers = mktn . unwords <$> makeKeywordTree
 >         ["double precision"
 >         ,"character varying"
 >         ,"char varying"

Language/SQL/SimpleSQL/Pretty.lhs

@@ -208,10 +208,53 @@ which have been changed to try to improve the layout of the output.
 > names ns = hcat $ punctuate (text ".") $ map name ns
 
 > typeName :: TypeName -> Doc
-> typeName (TypeName t) = text t
+> typeName (TypeName t) = names t
-> typeName (PrecTypeName t a) = text t <+> parens (text $ show a)
+> typeName (PrecTypeName t a) = names t <+> parens (text $ show a)
 > typeName (PrecScaleTypeName t a b) =
->     text t <+> parens (text (show a) <+> comma <+> text (show b))
+>     names t <+> parens (text (show a) <+> comma <+> text (show b))
+> typeName (LobTypeName t i m u) =
+>     names t
+>     <> parens (text (show i)
+>                 <> me (\x -> case x of
+>                            LobK -> text "K"
+>                            LobM -> text "M"
+>                            LobG -> text "G") m)
+>     <+> me (\x -> case x of
+>                    LobCharacters -> text "CHARACTERS"
+>                    LobCodeUnits -> text "CODE_UNITS"
+>                    LobOctets -> text "OCTETS") u
+> typeName (CharTypeName t i cs col) =
+>     names t
+>     <> me (\x -> parens (text $ show x)) i
+>     <+> (if null cs
+>          then empty
+>          else text "character set" <+> names cs)
+>     <+> me (\x -> text "collate" <+> name x) col
+> typeName (TimeTypeName t i tz) =
+>     names t
+>     <> me (\x -> parens (text $ show x)) i
+>     <+> text (if tz
+>               then "with time zone"
+>               else "without time zone")
+> typeName (RowTypeName cs) =
+>     text "row" <> parens (commaSep $ map f cs)
+>   where
+>     f (n,t) = name n <+> typeName t
+> typeName (IntervalTypeName f t) =
+>     text "interval"
+>     <+> it f
+>     <+> me (\x -> text "to" <+> it x) t
+>   where
+>     it (Itf n p) =
+>         text n
+>         <+> me (\(x,x1) -> parens (text (show x)
+>                               <+> me (\y -> (sep [comma,text (show y)])) x1)) p
+
+> typeName (ArrayType tn sz) =
+>     typeName tn <+> text "array" <+> me (text . show) sz
+
+> typeName (MultisetType tn) =
+>     typeName tn <+> text "multiset"
 
 
 = query expressions

Language/SQL/SimpleSQL/Syntax.lhs

@@ -6,6 +6,9 @@
 >      ValueExpr(..)
 >     ,Name(..)
 >     ,TypeName(..)
+>     ,IntervalTypeField(..)
+>     ,LobMultiplier(..)
+>     ,LobUnits(..)
 >     ,SetQuantifier(..)
 >     ,SortSpec(..)
 >     ,Direction(..)
@@ -151,10 +154,31 @@
 >           | QName String
 >             deriving (Eq,Show,Read,Data,Typeable)
 
+TODO: add ref and scope, any others?
+
 > -- | Represents a type name, used in casts.
-> data TypeName = TypeName String
+> data TypeName
->               | PrecTypeName String Integer
+>     = TypeName [Name]
->               | PrecScaleTypeName String Integer Integer
+>     | PrecTypeName [Name] Integer
+>     | PrecScaleTypeName [Name] Integer Integer
+>     | LobTypeName [Name] Int (Maybe LobMultiplier) (Maybe LobUnits)
+>       -- precision, characterset, collate
+>     | CharTypeName [Name] (Maybe Integer) [Name] (Maybe Name)
+>     | TimeTypeName [Name] (Maybe Integer) Bool -- true == with time zone
+>     | RowTypeName [(Name,TypeName)]
+>     | IntervalTypeName IntervalTypeField (Maybe IntervalTypeField)
+>     | ArrayType TypeName (Maybe Integer)
+>     | MultisetType TypeName
+>       deriving (Eq,Show,Read,Data,Typeable)
+
+> data IntervalTypeField = Itf String (Maybe (Int, Maybe Int))
+>                          deriving (Eq,Show,Read,Data,Typeable)
+
+> data LobMultiplier = LobK | LobM | LobG
+>                      deriving (Eq,Show,Read,Data,Typeable)
+> data LobUnits = LobCharacters
+>               | LobCodeUnits
+>               | LobOctets
 >                 deriving (Eq,Show,Read,Data,Typeable)
 
 > -- | Used for 'expr in (value expression list)', and 'expr in

tools/Language/SQL/SimpleSQL/SQL2003.lhs

@@ -21,10 +21,10 @@ large amount of the SQL.
 >     ,unicodeStringLiterals
 >     ,binaryStringLiterals
 >     ,numericLiterals
->     ,dateAndTimeLiterals
+>     --,dateAndTimeLiterals
 >     ,booleanLiterals
 >     --,identifiers
->     --,typeNames
+>     ,typeNameTests
 >     --,parenthesizedValueExpression
 >     ,targetSpecification
 >     ,contextuallyTypeValueSpec
@@ -657,11 +657,12 @@ TODO: separator stuff for all the string literals?
 
 <datetime value>    ::=   <unsigned integer>
 
-All these date literals are just like a restricted version of string
+TODO: interval literals
-literals. This parser doesn't check the format inside these literals
++ consider whether to support date and time literals better
-at this time.
+(e.g. parse the literal string), at the moment they are treated as
+normal typed literals
 
-> dateAndTimeLiterals :: TestItem
+> {-dateAndTimeLiterals :: TestItem
 > dateAndTimeLiterals = Group "date and time literals" $ map (uncurry TestValueExpr)
 >     [("date 'date literal'"
 >      ,TypedLit (TypeName "date") "date literal")
@@ -669,7 +670,7 @@ at this time.
 >      ,TypedLit (TypeName "time") "time literal")
 >     ,("timestamp 'timestamp literal'"
 >      ,TypedLit (TypeName "timestamp") "timestamp literal")
->     ]
+>     ]-}
 
 TODO: intervals + more date and time literals
 
@@ -924,9 +925,38 @@ TODO: module stuff
 
 <multiset type>    ::=   <data type> MULTISET
 
-TODO: review this list better and fill in lots of missing bits:
+create a list of type name variations:
 
-> typeNames :: TestItem
+> typeNames :: [(String,TypeName)]
+> typeNames =
+>     [-- example of every standard type name
+>       ("character", TypeName "character")
+>      -- 1 single prec + 1 with multiname
+>      -- 1 scale + with multiname
+>      -- lob prec + with multiname
+>      -- 1 with and without tz
+>      -- chars: (single/multiname) x prec x charset x collate
+>      -- single row field, two row field
+>      -- interval each type raw
+>      -- one type with single suff
+>      -- one type with double suff
+>      -- a to b with raw
+>      -- a to b with single suff
+>    ]
+
+Now test each variation in both cast expression and typed literal
+expression
+
+> typeNameTests :: TestItem
+> typeNameTests = Group "type names" $ map (uncurry TestValueExpr)
+>     $ concatMap makeTests typeNames
+>   where
+>     makeTests (ctn, stn) =
+>         [("cast('test' as " ++ ctn ++ ")", Cast (StringLit "test") stn)
+>         ,(ctn ++ " 'test'", TypedLit stn "test")
+>         ]
+
+> {-typeNames :: TestItem
 > typeNames = Group "type names" $ map (uncurry TestValueExpr)
 >     [("cast('test' as character(5))", undefined)
 >     ,("cast('test' as character)", undefined)
@@ -966,7 +996,7 @@ TODO: review this list better and fill in lots of missing bits:
 >     ,("cast('01-01-99' as timestamp(3))", undefined)
 >     ,("cast('01-01-99' as timestamp with time zone)", undefined)
 >     ,("cast('01-01-99' as time(3) with time zone)", undefined)
->     ]
+>     ]-}
 
 
 
@@ -975,7 +1005,7 @@ TODO: review this list better and fill in lots of missing bits:
 
 <field definition>    ::=   <field name> <data type> [ <reference scope check> ]
 
-This is used when e.g. casting to a row type. TODO
+This is used when e.g. casting to a row type.
 
 
 
@@ -1108,7 +1138,7 @@ for or how it works
 <default specification>    ::=   DEFAULT
 
 > contextuallyTypeValueSpec :: TestItem
-> contextuallyTypeValueSpec = Group "ontextually typed value specification" $ map (uncurry TestValueExpr)
+> contextuallyTypeValueSpec = Group "contextually typed value specification" $ map (uncurry TestValueExpr)
 >     [("null", Iden "null")
 >     ,("array[]", Array (Iden "array") [])
 >     --,("multiset[]", undefined)