From 0da39d4498c8c2c6116e7fa0323a064f3de6fade Mon Sep 17 00:00:00 2001 From: Jake Wheat Date: Sat, 14 Dec 2013 01:14:23 +0200 Subject: [PATCH] small reformatting --- Language/SQL/SimpleSQL/Parser.lhs | 153 ++++++++++++++---------------- Language/SQL/SimpleSQL/Pretty.lhs | 2 +- PrettyIt.lhs | 1 + 3 files changed, 74 insertions(+), 82 deletions(-) diff --git a/Language/SQL/SimpleSQL/Parser.lhs b/Language/SQL/SimpleSQL/Parser.lhs index c554736..dc86dee 100644 --- a/Language/SQL/SimpleSQL/Parser.lhs +++ b/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 -> *> queryExpr <* eof) f src +> $ parse (setPos p *> whiteSpace *> 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 -> *> queryExprs <* eof) f src +> $ parse (setPos p *> whiteSpace *> 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 -> *> 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 +> $ parse (setPos p *> whiteSpace *> scalarExpr <* eof) f src > 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,39 +179,34 @@ to be. > extract :: P ScalarExpr > extract = try (keyword_ "extract") >> > parens (makeOp <$> identifierString -> <*> (keyword_ "from" -> *> scalarExpr')) +> <*> (keyword_ "from" *> scalarExpr')) > where makeOp n e = SpecialOp "extract" [Iden n, e] > substring :: P ScalarExpr > substring = try (keyword_ "substring") >> > parens (makeOp <$> scalarExpr' -> <*> (keyword_ "from" -> *> scalarExpr') -> <*> (keyword_ "for" -> *> scalarExpr') +> <*> (keyword_ "from" *> scalarExpr') +> <*> (keyword_ "for" *> scalarExpr') > ) > where makeOp a b c = SpecialOp "substring" [a,b,c] > inSuffix :: ScalarExpr -> P ScalarExpr > inSuffix e = -> In -> <$> inty -> <*> return e -> <*> parens (choice -> [InQueryExpr <$> queryExpr -> ,InList <$> commaSep1 scalarExpr']) +> In <$> inty +> <*> return e +> <*> parens (choice +> [InQueryExpr <$> queryExpr +> ,InList <$> commaSep1 scalarExpr']) > where > inty = try $ choice [True <$ keyword_ "in" > ,False <$ keyword_ "not" <* keyword_ "in"] > betweenSuffix :: ScalarExpr -> P ScalarExpr > betweenSuffix e = -> makeOp -> <$> opName -> <*> return e -> <*> scalarExpr'' True -> <*> (keyword_ "and" *> scalarExpr') +> makeOp <$> opName +> <*> return e +> <*> scalarExpr'' True +> <*> (keyword_ "and" *> scalarExpr') > where > opName = try $ choice > ["between" <$ keyword_ "between" @@ -277,14 +234,13 @@ to be. > ,TypeName <$> identifierString] > binOpSymbolNames :: [String] -> binOpSymbolNames = ["=", "<=", ">=" -> ,"!=", "<>", "<", ">" -> ,"*", "/", "+", "-" -> ,"||"] +> binOpSymbolNames = +> ["=", "<=", ">=", "!=", "<>", "<", ">" +> ,"*", "/", "+", "-" +> ,"||"] > binOpKeywordNames :: [String] -> binOpKeywordNames = ["and", "or", "like" -> ,"overlaps"] +> binOpKeywordNames = ["and", "or", "like", "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) = -> try $ PostfixOp o e <$ keywords_ ws +> makeOp (o,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") -> *> keyword_ "by" -> *> commaSep1 ob +> orderBy = try (keyword_ "order") *> keyword_ "by" *> commaSep1 ob > where > ob = (,) <$> scalarExpr > <*> option Asc (choice [Asc <$ keyword_ "asc" @@ -543,12 +496,11 @@ attempt to fix the precedence and associativity. Doesn't work > with :: P QueryExpr > with = try (keyword_ "with") >> -> With <$> commaSep1 withQuery -> <*> queryExpr +> With <$> commaSep1 withQuery <*> queryExpr > where -> withQuery = (,) <$> (identifierString -> <* optional (try $ keyword_ "as")) -> <*> parens queryExpr +> withQuery = +> (,) <$> (identifierString <* optional (try $ keyword_ "as")) +> <*> parens queryExpr > queryExpr :: P QueryExpr > queryExpr = @@ -574,9 +526,9 @@ attempt to fix the precedence and associativity. Doesn't work > ,Intersect <$ keyword_ "intersect" > ,Except <$ keyword_ "except"]) > <*> (fromMaybe All <$> duplicates) -> <*> (option Respectively -> $ try (Corresponding -> <$ keyword_ "corresponding")) +> <*> option Respectively +> (try (Corresponding +> <$ keyword_ "corresponding")) > <*> queryExpr) > >>= queryExprSuffix > ,return qe] @@ -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 diff --git a/Language/SQL/SimpleSQL/Pretty.lhs b/Language/SQL/SimpleSQL/Pretty.lhs index 0d3a20e..ffb4b9e 100644 --- a/Language/SQL/SimpleSQL/Pretty.lhs +++ b/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) = diff --git a/PrettyIt.lhs b/PrettyIt.lhs index d114eb8..6a96c99 100644 --- a/PrettyIt.lhs +++ b/PrettyIt.lhs @@ -1,3 +1,4 @@ + > import System.Environment > import Language.SQL.SimpleSQL.Pretty