diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index 2eea14b..769856b 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/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 -> ,TypeName <$> identifierBlacklist blacklist] +> (choice [try multiWordParsers +> ,mktn <$> identifierBlacklist blacklist] > >>= optionSuffix precision > ) "typename" > where -> multiWordParsers = (TypeName . unwords) <$> makeKeywordTree +> mktn = TypeName . (:[]) . Name +> multiWordParsers = mktn . unwords <$> makeKeywordTree > ["double precision" > ,"character varying" > ,"char varying" diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index 4ab6166..a31ac7e 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/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 (PrecTypeName t a) = text t <+> parens (text $ show a) +> typeName (TypeName t) = names t +> 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 diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs index bb71af7..5c22ad9 100644 --- a/Language/SQL/SimpleSQL/Syntax.lhs +++ b/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 -> | PrecTypeName String Integer -> | PrecScaleTypeName String Integer Integer +> data TypeName +> = TypeName [Name] +> | 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 diff --git a/tools/Language/SQL/SimpleSQL/SQL2003.lhs b/tools/Language/SQL/SimpleSQL/SQL2003.lhs index 8fc670c..a59335f 100644 --- a/tools/Language/SQL/SimpleSQL/SQL2003.lhs +++ b/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? ::= -All these date literals are just like a restricted version of string -literals. This parser doesn't check the format inside these literals -at this time. +TODO: interval literals ++ consider whether to support date and time literals better +(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 -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: ::= [ ] -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 > 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)