diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs
index 2eef067..377c660 100644
--- a/Language/SQL/SimpleSQL/Parser.lhs
+++ b/Language/SQL/SimpleSQL/Parser.lhs
@@ -22,8 +22,8 @@
> import qualified Text.Parsec as P (ParseError)
> import Text.Parsec.Perm (permute,(<$?>), (<|?>))
> import qualified Text.Parsec.Expr as E
-> import Data.List (intercalate)
-
+> import Data.List (intercalate,sort,groupBy)
+> import Data.Function (on)
> import Language.SQL.SimpleSQL.Syntax
The public API functions.
@@ -513,15 +513,13 @@ typename: used in casts. Special cases for the multi keyword typenames
that SQL supports.
> typeName :: Parser TypeName
-> typeName = (choice (multiWordParsers
-> ++ [TypeName <$> identifierBlacklist blacklist])
-> >>= optionSuffix precision
-> ) <?> "typename"
+> typeName =
+> (choice [multiWordParsers
+> ,TypeName <$> identifierBlacklist blacklist]
+> >>= optionSuffix precision
+> ) <?> "typename"
> where
-> multiWordParsers =
-> flip map multiWordTypeNames
-> $ \ks -> (TypeName . unwords) <$> try (keywords ks)
-> multiWordTypeNames = map words
+> multiWordParsers = (TypeName . unwords) <$> makeKeywordTree
> ["double precision"
> ,"character varying"
> ,"char varying"
@@ -559,6 +557,41 @@ todo: timestamp types:
> ctor [a] = Parens a
> ctor as = SpecialOp [Name "rowctor"] as
+== multi keyword helper
+
+This helper is to help parsing multiple options of multiple keywords
+with similar prefixes, e.g. parsing 'is null' and 'is not null'.
+
+use to left factor/ improve:
+typed literal and general identifiers
+not like, not in, not between operators
+help with factoring keyword functions and other app-likes
+the join keyword sequences
+fetch first/next
+row/rows only
+
+There is probably a simpler way of doing this but I am a bit
+thick.
+
+> makeKeywordTree :: [String] -> Parser [String]
+> makeKeywordTree sets = do
+> reverse <$> parseTrees (sort $ map words sets)
+> -- ?? <?> intercalate "," sets
+> where
+> parseTrees :: [[String]] -> Parser [String]
+> parseTrees ws = do
+> let gs :: [[[String]]]
+> gs = groupBy ((==) `on` head) ws
+> choice $ map parseGroup gs
+> parseGroup :: [[String]] -> Parser [String]
+> parseGroup l = do
+> let k = head $ head l
+> keyword_ k
+> let tls = map tail l
+> pr = (k:) <$> parseTrees tls
+> if (or $ map null tls)
+> then pr <|> return [k]
+> else pr
== operator parsing
@@ -569,6 +602,12 @@ can be symbols (a + b), single keywords (a and b) or multiple keywords
TODO: carefully review the precedences and associativities.
+TODO: to fix the parsing completely, I think will need to parse
+without precedence and associativity and fix up afterwards, since SQL
+syntax is way too messy. It might be possible to avoid this if we
+wanted to avoid extensibility and to not be concerned with parse error
+messages, but both of these are considered too important.
+
> opTable :: Bool -> [[E.Operator String () Identity ValueExpr]]
> opTable bExpr =
> [-- parse match and quantified comparisons as postfix ops
@@ -598,21 +637,22 @@ TODO: carefully review the precedences and associativities.
> ,binarySym "|" E.AssocRight
> ,binaryKeyword "like" E.AssocNone
> ,binaryKeyword "overlaps" E.AssocNone]
-> ++ map (`binaryKeywords` E.AssocNone)
-> ["not like"
-> ,"is similar to"
-> ,"is not similar to"
-> ,"is distinct from"
-> ,"is not distinct from"]
-> ++ map postfixKeywords
-> ["is null"
-> ,"is not null"
-> ,"is true"
-> ,"is not true"
-> ,"is false"
-> ,"is not false"
-> ,"is unknown"
-> ,"is not unknown"]
+> ++ [binaryKeywords $ makeKeywordTree
+> ["not like"
+> ,"is similar to"
+> ,"is not similar to"
+> ,"is distinct from"
+> ,"is not distinct from"]
+> ,postfixKeywords $ makeKeywordTree
+> ["is null"
+> ,"is not null"
+> ,"is true"
+> ,"is not true"
+> ,"is false"
+> ,"is not false"
+> ,"is unknown"
+> ,"is not unknown"]
+> ]
> -- have to use try with inSuffix because of a conflict
> -- with 'in' in position function, and not between
> -- between also has a try in it to deal with 'not'
@@ -631,17 +671,20 @@ TODO: carefully review the precedences and associativities.
> where
> binarySym nm assoc = binary (symbol_ nm) nm assoc
> binaryKeyword nm assoc = binary (keyword_ nm) nm assoc
-> -- use try with the multi keywords because of shared
-> -- prefixes to the sets of keywords. Should left factor
-> -- somehow
-> binaryKeywords nm assoc = binary (try $ keywords_ (words nm)) nm assoc
+> binaryKeywords p =
+> E.Infix (do
+> o <- p
+> return (\a b -> BinOp a [Name $ unwords o] b))
+> E.AssocNone
+> postfixKeywords p =
+> postfix' $ do
+> o <- p
+> return $ PostfixOp [Name $ unwords o]
> binary p nm assoc =
> E.Infix (p >> return (\a b -> BinOp a [Name nm] b)) assoc
> prefixKeyword nm = prefix (keyword_ nm) nm
> prefixSym nm = prefix (symbol_ nm) nm
> prefix p nm = prefix' (p >> return (PrefixOp [Name nm]))
-> postfixKeywords nm = postfix (try $ keywords_ (words nm)) nm
-> postfix p nm = postfix' (p >> return (PostfixOp [Name nm]))
> -- hack from here
> -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported
> -- not implemented properly yet
@@ -815,11 +858,9 @@ allows offset and fetch in either order
> fetch :: Parser ValueExpr
> fetch = choice [ansiFetch, limit]
> where --todo: better left factoring
-> ansiFetch = keyword_ "fetch" >>
-> choice [keyword_ "first",keyword_ "next"]
-> *> valueExpr
-> <* choice [keyword_ "rows",keyword_ "row"]
-> <* keyword_ "only"
+> fs = makeKeywordTree ["fetch first", "fetch next"]
+> ro = makeKeywordTree ["rows only", "row only"]
+> ansiFetch = fs *> valueExpr <* ro
> limit = keyword_ "limit" *> valueExpr
== common table expressions
@@ -1070,9 +1111,6 @@ todo: work out the symbol parsing better
helper function to improve error messages
-> keywords :: [String] -> Parser [String]
-> keywords ks = mapM keyword ks <?> intercalate " " ks
-
> keywords_ :: [String] -> Parser ()
> keywords_ ks = mapM_ keyword_ ks <?> intercalate " " ks
diff --git a/Language/SQL/SimpleSQL/Syntax.lhs b/Language/SQL/SimpleSQL/Syntax.lhs
index 1c26f3a..e035a01 100644
--- a/Language/SQL/SimpleSQL/Syntax.lhs
+++ b/Language/SQL/SimpleSQL/Syntax.lhs
@@ -139,7 +139,7 @@
> -- e.g. a[3]. The first
> -- valueExpr is the array, the
> -- second is the subscripts/ctor args
-> | ArrayCtor QueryExpr -- ^ this is used for the query expression version of array constructors, e.g. array(select * from t)> deriving (Eq,Show,Read,Data,Typeable)
+> | ArrayCtor QueryExpr -- ^ this is used for the query expression version of array constructors, e.g. array(select * from t)
> | CSStringLit String String
> | Escape ValueExpr Char
> | UEscape ValueExpr Char
diff --git a/TODO b/TODO
index d62ffbb..6f5e86d 100644
--- a/TODO
+++ b/TODO
@@ -14,7 +14,8 @@ represent missing optional bits in the ast as nothing instead of the
look at fixing the expression parsing completely
represent natural and using/on in the syntax more close to the
concrete syntax - don't combine in the ast
-
+review haddock in the syntax and update
+review syntax names and representation
careful review of token parses wrt trailing delimiters/junk
review places in the parse which should allow only a fixed set of
@@ -26,10 +27,12 @@ decide whether to represent numeric literals better, instead of a
rough SQL 2003 todo, including tests to write:
+switch TypedLit to CSStringLit based on first char being underscore?
idens: "", unicode, charset?, check dotted idens and contexts
add missing type name support: lots of missing ones here, including
simple stuff like lob variations, and new things like interval,
row, ref, scope, array, multiset type names.
+ add tests for all the typenames cast and typed literal
date and time literals
multisets
review window functions, window clause
@@ -43,13 +46,15 @@ filter in aggs
within group in aggs
rows review
-support needed MODULE syntax in identifiers - already covered?
-decide how to represent special identifiers including the session
+LNR: maybe leave until after next release
+
+LNR support needed MODULE syntax in identifiers - already covered?
+LNR decide how to represent special identifiers including the session
variables or whatever they are called like current_user
-grouping - needs special syntax?
-next value for
-probably leave for now: subtypes, methods, new /routine, dereference
-double check associativity, precedence (value exprs, joins, set ops)
+LNR grouping - needs special syntax?
+LNR next value for
+LNR subtypes, methods, new /routine, dereference
+LNR double check associativity, precedence (value exprs, joins, set ops)
position expressions
length expressions
extract expression
@@ -61,7 +66,7 @@ convert
translate
trim
overlay
-specifictype
+LNR specifictype
datetime value expressions
intervals
row value constructors, expressions review
@@ -80,21 +85,24 @@ between symmetric/asymmetric
in predicate review
escape for like
escape for [not] similar to
-regular expression syntax?
+LNR regular expression syntax?
normalized predicate
overlaps predicate
distinct from predicate
member predicate
submultiset predicate
set predicate
-type predicate
+LNR type predicate
additional stuff review:
interval stuff
aggregate functions: lots of missing bits
especially: filter where, within group
complete list of keywords/reserved keywords
-select into
-other language format identifiers for host params?
+LNR select into
+LNR other language format identifiers for host params?
+
+----
+above not marked LNR are for next release
review areas where this parser is too permissive, e.g. value
expressions allowed where column reference names only should be
diff --git a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs b/tools/Language/SQL/SimpleSQL/ValueExprs.lhs
index f974e1c..bd2feec 100644
--- a/tools/Language/SQL/SimpleSQL/ValueExprs.lhs
+++ b/tools/Language/SQL/SimpleSQL/ValueExprs.lhs
@@ -132,8 +132,7 @@ Tests for parsing value expressions
> unaryOperators :: TestItem
> unaryOperators = Group "unaryOperators" $ map (uncurry TestValueExpr)
> [("not a", PrefixOp "not" $ Iden "a")
-> -- I think this is a missing feature or bug in parsec buildExpressionParser
-> --,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")
+> ,("not not a", PrefixOp "not" $ PrefixOp "not" $ Iden "a")
> ,("+a", PrefixOp "+" $ Iden "a")
> ,("-a", PrefixOp "-" $ Iden "a")
> ]