small reformatting

Language/SQL/SimpleSQL/Parser.lhs

@@ -26,8 +26,7 @@
 >                -> Either ParseError QueryExpr
 > parseQueryExpr f p src =
 >     either (Left . convParseError src) Right
->     $ parse (setPos p *> whiteSpace
+>     $ parse (setPos p *> whiteSpace *> queryExpr <* eof) f src
->              *> queryExpr <* eof) f src
 
 > parseQueryExprs :: FilePath
 >                 -> Maybe (Int,Int)
@@ -35,8 +34,7 @@
 >                 -> Either ParseError [QueryExpr]
 > parseQueryExprs f p src =
 >     either (Left . convParseError src) Right
->     $ parse (setPos p *> whiteSpace
+>     $ parse (setPos p *> whiteSpace *> queryExprs <* eof) f src
->              *> queryExprs <* eof) f src
 
 > parseScalarExpr :: FilePath
 >                 -> Maybe (Int,Int)
@@ -44,14 +42,7 @@
 >                 -> Either ParseError ScalarExpr
 > parseScalarExpr f p src =
 >     either (Left . convParseError src) Right
->     $ parse (setPos p *> whiteSpace
+>     $ parse (setPos p *> whiteSpace *> scalarExpr <* eof) f src
->              *> scalarExpr <* eof) f src
-
-> setPos :: Maybe (Int,Int) -> P ()
-> setPos Nothing = return ()
-> setPos (Just (l,c)) = fmap f getPosition >>= setPosition
->   where f = flip setSourceColumn c
->             . flip setSourceLine l
 
 > data ParseError = ParseError
 >                   {peErrorString :: String
@@ -60,39 +51,10 @@
 >                   ,peFormattedError :: String
 >                   } deriving (Eq,Show)
 
-> convParseError :: String -> P.ParseError -> ParseError
+------------------------------------------------
-> convParseError src e =
->     ParseError
->     {peErrorString = show e
->     ,peFilename = sourceName p
->     ,pePosition = (sourceLine p, sourceColumn p)
->     ,peFormattedError = formatError src e
->     }
->   where
->     p = errorPos e
-
-format the error more nicely: emacs format for positioning, plus
-context
-
-> formatError :: String -> P.ParseError -> String
-> formatError src e =
->     sourceName p ++ ":" ++ show (sourceLine p)
->     ++ ":" ++ show (sourceColumn p) ++ ":"
->     ++ context
->     ++ show e
->   where
->     context =
->         let lns = take 1 $ drop (sourceLine p - 1) $ lines src
->         in case lns of
->              [x] -> "\n" ++ x ++ "\n"
->                     ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"
->              _ -> ""
->     p = errorPos e
 
 > type P a = ParsecT String () Identity a
 
-------------------------------------------------
-
 = scalar expressions
 
 > stringLiteral :: P String
@@ -217,24 +179,20 @@ to be.
 > extract :: P ScalarExpr
 > extract = try (keyword_ "extract") >>
 >     parens (makeOp <$> identifierString
->                    <*> (keyword_ "from"
+>                    <*> (keyword_ "from" *> scalarExpr'))
->                         *> scalarExpr'))
 >   where makeOp n e = SpecialOp "extract" [Iden n, e]
 
 > substring :: P ScalarExpr
 > substring = try (keyword_ "substring") >>
 >     parens (makeOp <$> scalarExpr'
->                    <*> (keyword_ "from"
+>                    <*> (keyword_ "from" *> scalarExpr')
->                         *> scalarExpr')
+>                    <*> (keyword_ "for" *> scalarExpr')
->                    <*> (keyword_ "for"
->                         *> scalarExpr')
 >                    )
 >   where makeOp a b c = SpecialOp "substring" [a,b,c]
 
 > inSuffix :: ScalarExpr -> P ScalarExpr
 > inSuffix e =
->     In
+>     In <$> inty
->     <$> inty
 >        <*> return e
 >        <*> parens (choice
 >                    [InQueryExpr <$> queryExpr
@@ -245,8 +203,7 @@ to be.
 
 > betweenSuffix :: ScalarExpr -> P ScalarExpr
 > betweenSuffix e =
->     makeOp
+>     makeOp <$> opName
->     <$> opName
 >            <*> return e
 >            <*> scalarExpr'' True
 >            <*> (keyword_ "and" *> scalarExpr')
@@ -277,14 +234,13 @@ to be.
 >     ,TypeName <$> identifierString]
 
 > binOpSymbolNames :: [String]
-> binOpSymbolNames = ["=", "<=", ">="
+> binOpSymbolNames =
->                    ,"!=", "<>", "<", ">"
+>     ["=", "<=", ">=", "!=", "<>", "<", ">"
 >     ,"*", "/", "+", "-"
 >     ,"||"]
 
 > binOpKeywordNames :: [String]
-> binOpKeywordNames = ["and", "or", "like"
+> binOpKeywordNames = ["and", "or", "like", "overlaps"]
->                     ,"overlaps"]
 
 > binOpMultiKeywordNames :: [[String]]
 > binOpMultiKeywordNames = map words
@@ -329,8 +285,7 @@ used for between parsing
 >           ,"is unknown"
 >           ,"is not unknown"]
 >     opPairs = flip map ops $ \o -> (o, words o)
->     makeOp (o,ws) =
+>     makeOp (o,ws) = try $ PostfixOp o e <$ keywords_ ws
->       try $ PostfixOp o e <$ keywords_ ws
 >     keywords_ = try . mapM_ keyword_
 
 > scalarExpr' :: P ScalarExpr
@@ -352,7 +307,7 @@ postgresql handles this
 >                     ,substring
 >                     ,subquery
 >                     ,prefixUnaryOp
->                     ,(try app) >>= windowSuffix
+>                     ,try app >>= windowSuffix
 >                     ,try dottedIden
 >                     ,identifier
 >                     ,sparens]
@@ -527,9 +482,7 @@ attempt to fix the precedence and associativity. Doesn't work
 > having = optionalScalarExpr "having"
 
 > orderBy :: P [(ScalarExpr,Direction)]
-> orderBy = try (keyword_ "order")
+> orderBy = try (keyword_ "order") *> keyword_ "by" *> commaSep1 ob
->               *> keyword_ "by"
->               *> commaSep1 ob
 >   where
 >     ob = (,) <$> scalarExpr
 >              <*> option Asc (choice [Asc <$ keyword_ "asc"
@@ -543,11 +496,10 @@ attempt to fix the precedence and associativity. Doesn't work
 
 > with :: P QueryExpr
 > with = try (keyword_ "with") >>
->     With <$> commaSep1 withQuery
+>     With <$> commaSep1 withQuery <*> queryExpr
->          <*> queryExpr
 >   where
->     withQuery = (,) <$> (identifierString
+>     withQuery =
->                          <* optional (try $ keyword_ "as"))
+>         (,) <$> (identifierString <* optional (try $ keyword_ "as"))
 >             <*> parens queryExpr
 
 > queryExpr :: P QueryExpr
@@ -574,8 +526,8 @@ attempt to fix the precedence and associativity. Doesn't work
 >                       ,Intersect <$ keyword_ "intersect"
 >                       ,Except <$ keyword_ "except"])
 >              <*> (fromMaybe All <$> duplicates)
->              <*> (option Respectively
+>              <*> option Respectively
->                   $ try (Corresponding
+>                         (try (Corresponding
 >                               <$ keyword_ "corresponding"))
 >              <*> queryExpr)
 >             >>= queryExprSuffix
@@ -591,7 +543,7 @@ attempt to fix the precedence and associativity. Doesn't work
 
 ------------------------------------------------
 
-= helper functions
+= helper parsers
 
 > whiteSpace :: P ()
 > whiteSpace =
@@ -628,7 +580,7 @@ attempt to fix the precedence and associativity. Doesn't work
 > symbol_ s = symbol s *> return ()
 
 > keyword :: String -> P String
-> keyword s = ((map toLower) <$> string s)
+> keyword s = (map toLower <$> string s)
 >             <* notFollowedBy (char '_' <|> alphaNum)
 >             <* whiteSpace
 
@@ -637,3 +589,42 @@ attempt to fix the precedence and associativity. Doesn't work
 
 > commaSep1 :: P a -> P [a]
 > commaSep1 = (`sepBy1` symbol_ ",")
+
+--------------------------------------------
+
+= helper functions
+
+> setPos :: Maybe (Int,Int) -> P ()
+> setPos Nothing = return ()
+> setPos (Just (l,c)) = fmap f getPosition >>= setPosition
+>   where f = flip setSourceColumn c
+>             . flip setSourceLine l
+
+> convParseError :: String -> P.ParseError -> ParseError
+> convParseError src e =
+>     ParseError
+>     {peErrorString = show e
+>     ,peFilename = sourceName p
+>     ,pePosition = (sourceLine p, sourceColumn p)
+>     ,peFormattedError = formatError src e
+>     }
+>   where
+>     p = errorPos e
+
+format the error more nicely: emacs format for positioning, plus
+context
+
+> formatError :: String -> P.ParseError -> String
+> formatError src e =
+>     sourceName p ++ ":" ++ show (sourceLine p)
+>     ++ ":" ++ show (sourceColumn p) ++ ":"
+>     ++ context
+>     ++ show e
+>   where
+>     context =
+>         let lns = take 1 $ drop (sourceLine p - 1) $ lines src
+>         in case lns of
+>              [x] -> "\n" ++ x ++ "\n"
+>                     ++ replicate (sourceColumn p - 1) ' ' ++ "^\n"
+>              _ -> ""
+>     p = errorPos e

Language/SQL/SimpleSQL/Pretty.lhs

@@ -165,7 +165,7 @@ back into SQL source text. It attempts to format the output nicely.
 >     tr (SimpleTableRef t) = text t
 >     tr (JoinAlias t a cs) =
 >         tr t <+> text "as" <+> text a
->         <+> maybe empty (\cs' -> parens $ commaSep $ map text cs') cs
+>         <+> maybe empty (parens . commaSep . map text) cs
 >     tr (JoinParens t) = parens $ tr t
 >     tr (JoinQueryExpr q) = parens $ queryExpr q
 >     tr (JoinTableRef jt t0 t1 jc) =

PrettyIt.lhs

@@ -1,3 +1,4 @@
+
 > import System.Environment
 
 > import Language.SQL.SimpleSQL.Pretty