fix/work around issues with the keywords parsing

fix the infix and postfix keywords parsing
minor refactoring

Language/SQL/SimpleSQL/Parser.lhs

@@ -119,7 +119,7 @@ which parses as a typed literal
 >     mkIt <$> stringToken
 >     <*> optionMaybe
 >         ((,) <$> identifierBlacklist blacklist
->              <*> optionMaybe (parens integer))
+>              <*> optionMaybe (parens unsignedInteger))
 >   where
 >     mkIt val Nothing = TypedLit (TypeName "interval") val
 >     mkIt val (Just (a,b)) = IntervalLit val a b
@@ -541,7 +541,7 @@ todo: timestamp types:
      | TIMESTAMParser [ <left paren> <timestamp precision> <right paren> ] [ WITH TIME ZONE ]
 
 
->     precision t = parens (commaSep integer) >>= makeWrap t
+>     precision t = parens (commaSep unsignedInteger) >>= makeWrap t
 >     makeWrap (TypeName t) [a] = return $ PrecTypeName t a
 >     makeWrap (TypeName t) [a,b] = return $ PrecScaleTypeName t a b
 >     makeWrap _ _ = fail "there must be one or two precision components"
@@ -574,8 +574,8 @@ There is probably a simpler way of doing this but I am a bit
 thick.
 
 > makeKeywordTree :: [String] -> Parser [String]
-> makeKeywordTree sets = do
+> makeKeywordTree sets =
->     reverse <$> parseTrees (sort $ map words sets)
+>     parseTrees (sort $ map words sets)
 >     --  ?? <?> intercalate "," sets
 >   where
 >     parseTrees :: [[String]] -> Parser [String]
@@ -584,14 +584,14 @@ thick.
 >           gs = groupBy ((==) `on` head) ws
 >       choice $ map parseGroup gs
 >     parseGroup :: [[String]] -> Parser [String]
->     parseGroup l = do
+>     parseGroup l@((k:_):_) = 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
+>     parseGroup _ = guard False >> error "impossible"
 
 == operator parsing
 
@@ -673,12 +673,12 @@ messages, but both of these are considered too important.
 >     binaryKeyword nm assoc = binary (keyword_ nm) nm assoc
 >     binaryKeywords p =
 >         E.Infix (do
->             o <- p
+>             o <- try p
 >             return (\a b -> BinOp a [Name $ unwords o] b))
 >             E.AssocNone
 >     postfixKeywords p =
 >       postfix' $ do
->           o <- p
+>           o <- try p
 >           return $ PostfixOp [Name $ unwords o]
 >     binary p nm assoc =
 >       E.Infix (p >> return (\a b -> BinOp a [Name nm] b)) assoc
@@ -979,8 +979,8 @@ whitespace parser which skips comments also
 > lexeme :: Parser a -> Parser a
 > lexeme p = p <* whitespace
 
-> integer :: Parser Integer
+> unsignedInteger :: Parser Integer
-> integer = read <$> lexeme (many1 digit) <?> "integer"
+> unsignedInteger = read <$> lexeme (many1 digit) <?> "integer"
 
 
 number literals

Language/SQL/SimpleSQL/Pretty.lhs

@@ -40,15 +40,13 @@ which have been changed to try to improve the layout of the output.
 > valueExpr (IntervalLit v u p) =
 >     text "interval" <+> quotes (text v)
 >     <+> text u
->     <+> maybe empty (parens . text . show ) p
+>     <+> me (parens . text . show ) p
 > valueExpr (Iden i) = names i
 > valueExpr Star = text "*"
 > valueExpr Parameter = text "?"
 > valueExpr (HostParameter p i) =
 >     text (':':p)
->     <+> maybe empty
+>     <+> me (\i' -> text "indicator" <+> text (':':i')) i
->         (\i' -> text "indicator" <+> text (':':i'))
->         i
 
 > valueExpr (App f es) = names f <> parens (commaSep (map valueExpr es))
 
@@ -69,7 +67,7 @@ which have been changed to try to improve the layout of the output.
 >                     _ -> text "partition by"
 >                           <+> nest 13 (commaSep $ map valueExpr pb))
 >                 <+> orderBy od
->     <+> maybe empty frd fr)
+>     <+> me frd fr)
 >   where
 >     frd (FrameFrom rs fp) = rsd rs <+> fpd fp
 >     frd (FrameBetween rs fps fpe) =
@@ -120,7 +118,7 @@ which have been changed to try to improve the layout of the output.
 >     valueExpr e0 <+> names f <+> valueExpr e1
 
 > valueExpr (Case t ws els) =
->     sep $ [text "case" <+> maybe empty valueExpr t]
+>     sep $ [text "case" <+> me valueExpr t]
 >           ++ map w ws
 >           ++ maybeToList (fmap e els)
 >           ++ [text "end"]
@@ -231,9 +229,9 @@ which have been changed to try to improve the layout of the output.
 >       ,grpBy gb
 >       ,maybeValueExpr "having" hv
 >       ,orderBy od
->       ,maybe empty (\e -> text "offset" <+> valueExpr e <+> text "rows") off
+>       ,me (\e -> text "offset" <+> valueExpr e <+> text "rows") off
->       ,maybe empty (\e -> text "fetch first" <+> valueExpr e
+>       ,me (\e -> text "fetch first" <+> valueExpr e
->                           <+> text "rows only") fe
+>                  <+> text "rows only") fe
 >       ]
 > queryExpr (CombineQueryExpr q1 ct d c q2) =
 >   sep [queryExpr q1
@@ -264,12 +262,12 @@ which have been changed to try to improve the layout of the output.
 > alias :: Alias -> Doc
 > alias (Alias nm cols) =
 >     text "as" <+> name nm
->     <+> maybe empty (parens . commaSep . map name) cols
+>     <+> me (parens . commaSep . map name) cols
 
 > selectList :: [(ValueExpr,Maybe Name)] -> Doc
 > selectList is = commaSep $ map si is
 >   where
->     si (e,al) = valueExpr e <+> maybe empty als al
+>     si (e,al) = valueExpr e <+> me als al
 >     als al = text "as" <+> name al
 
 > from :: [TableRef] -> Doc
@@ -307,7 +305,7 @@ which have been changed to try to improve the layout of the output.
 >     joinCond (Just JoinNatural) = empty
 
 > maybeValueExpr :: String -> Maybe ValueExpr -> Doc
-> maybeValueExpr k = maybe empty
+> maybeValueExpr k = me
 >       (\e -> sep [text k
 >                  ,nest (length k + 1) $ valueExpr e])
 
@@ -342,3 +340,6 @@ which have been changed to try to improve the layout of the output.
 
 > commaSep :: [Doc] -> Doc
 > commaSep ds = sep $ punctuate comma ds
+
+> me :: (a -> Doc) -> Maybe a -> Doc
+> me = maybe empty

Language/SQL/SimpleSQL/Syntax.lhs

@@ -127,12 +127,12 @@
 >                                           -- Maybe String is for the
 >                                           -- indicator, e.g. :var
 >                                           -- indicator :nl
->       | QuantifiedComparison
+>     | QuantifiedComparison
 >             ValueExpr
 >             [Name] -- operator
 >             CompPredQuantifier
 >             QueryExpr
->       | Match ValueExpr Bool -- true if unique
+>     | Match ValueExpr Bool -- true if unique
 >           QueryExpr
 >     | Array ValueExpr [ValueExpr] -- ^ represents an array
 >                                   -- access expression, or an array ctor
@@ -157,7 +157,6 @@
 >               | PrecScaleTypeName String Integer Integer
 >                 deriving (Eq,Show,Read,Data,Typeable)
 
-
 > -- | Used for 'expr in (value expression list)', and 'expr in
 > -- (subquery)' syntax.
 > data InPredValue = InList [ValueExpr]