pretty printer, minor clean ups

clean up some warnings update the cabal file add pretty printer add pretty printing tests
2013-12-13 15:05:32 +02:00 · 2013-12-13 15:05:32 +02:00 · e3be820dfb
parent 52b9f3f4f4
commit e3be820dfb
5 changed files with 157 additions and 76 deletions
--- a/Parser.lhs
+++ b/Parser.lhs
@ -2,15 +2,12 @@

 > module Parser (parseQueryExpr
 >               ,parseScalarExpr
->               ,ParseError(..)) where
+>               ,ParseError) where

 > import Text.Groom
 > import Text.Parsec
 > import Control.Monad.Identity
 > import Control.Applicative hiding (many, (<|>), optional)
-> import Debug.Trace
-> import Data.List
-> import Text.Parsec.Expr
 > import qualified Language.Haskell.Exts.Syntax as HSE
 > import qualified Language.Haskell.Exts.Fixity as HSE
 > import Data.Maybe
@ -200,9 +197,9 @@ to be.
 >     tref = choice [try (JoinQueryExpr <$> parens queryExpr)
 >                   ,JoinParens <$> parens tref
 >                   ,SimpleTableRef <$> identifierString]
->            >>= optionSuffix join
+>            >>= optionSuffix pjoin
 >            >>= optionSuffix alias
->     join tref0 =
+>     pjoin tref0 =
 >         choice
 >         [try (keyword_ "natural") *> keyword_ "inner"
 >          *> conditionlessSuffix tref0 Inner (Just JoinNatural)
@ -217,7 +214,7 @@ to be.
 >         ,try (keyword_ "cross")
 >          *> conditionlessSuffix tref0 Cross Nothing
 >         ]
->         >>= optionSuffix join
+>         >>= optionSuffix pjoin
 >     outerJoinSuffix tref0 jt =
 >         optional (keyword_ "outer") *> conditionSuffix tref0 jt
 >     conditionSuffix tref0 jt =
--- a/Pretty.lhs
+++ b/Pretty.lhs
@ -2,12 +2,118 @@
 This is the pretty printer code which takes AST values and turns them
 back into SQL source text. It attempts to format the output nicely.

-> module Pretty (pretty, prettyScalarExpr) where
+> module Pretty (prettyQueryExpr, prettyScalarExpr) where

 > import Syntax
+> import Text.PrettyPrint
+> import Data.Maybe

-> pretty :: QueryExpr -> String
-> pretty = undefined
+> prettyQueryExpr :: QueryExpr -> String
+> prettyQueryExpr = render . queryExpr

 > prettyScalarExpr :: ScalarExpr -> String
-> prettyScalarExpr = undefined
+> prettyScalarExpr = render . scalarExpr
+
+
+= scalar expressions
+
+> scalarExpr :: ScalarExpr -> Doc
+> scalarExpr (Literal s) = quotes $ text s
+> scalarExpr (Identifier i) = text i
+> scalarExpr (Identifier2 q i) = text q <> text "." <> text i
+> scalarExpr Star = text "*"
+> scalarExpr (Star2 q) = text q <> text "." <> text "*"
+
+> scalarExpr (App f es) = text f <> parens (commaSep (map scalarExpr es))
+> scalarExpr (Op f [e]) = text f <+> scalarExpr e
+> scalarExpr (Op f [e0,e1]) =
+>     sep [scalarExpr e0, text f, scalarExpr e1]
+
+> scalarExpr (Op f es) =
+>     -- TODO: how to handle this? error or either seems poor
+>     text f <> parens (commaSep (map scalarExpr es))
+
+> scalarExpr (Case t ws els) =
+>     sep [text "case" <+> (maybe empty scalarExpr t)
+>         ,nest 4 (sep ((map w ws)
+>                       ++ maybeToList (fmap e els)))
+>         ,text "end"]
+>   where
+>     w (t0,t1) = sep [text "when" <+> scalarExpr t0
+>                     ,text "then" <+> scalarExpr t1]
+>     e el = text "else" <+> scalarExpr el
+> scalarExpr (Parens e) = parens $ scalarExpr e
+
+= query expressions
+
+> queryExpr :: QueryExpr -> Doc
+> queryExpr (Select sl fr wh gb hv od) =
+>   sep [text "select"
+>       ,nest 4 $ sep [selectList sl]
+>       ,from fr
+>       ,whr wh
+>       ,grpBy gb
+>       ,having hv
+>       ,orderBy od]
+
+> selectList :: [(Maybe String, ScalarExpr)] -> Doc
+> selectList is = commaSep $ map si is
+>   where
+>     si (al,e) = scalarExpr e <+> maybe empty alias al
+>     alias al = text "as" <+> text al
+
+> from :: [TableRef] -> Doc
+> from [] = empty
+> from ts =
+>     sep [text "from"
+>         ,nest 4 $ commaSep $ map tr ts]
+>   where
+>     tr (SimpleTableRef t) = text t
+>     tr (JoinAlias t a) = tr t <+> text "as" <+> text a
+>     tr (JoinParens t) = parens $ tr t
+>     tr (JoinQueryExpr q) = parens $ queryExpr q
+>     tr (JoinTableRef jt t0 t1 jc) =
+>        sep [tr t0
+>            ,joinText jt jc
+>            ,tr t1
+>            ,joinCond jc]
+>     joinText jt jc =
+>       sep [case jc of
+>               Just JoinNatural -> text "natural"
+>               _ -> empty
+>           ,case jt of
+>               Inner -> text "inner"
+>               JLeft -> text "left"
+>               JRight -> text "right"
+>               Full -> text "full"
+>               Cross -> text "cross"
+>           ,text "join"]
+>     joinCond (Just (JoinOn e)) = text "on" <+> scalarExpr e
+>     joinCond (Just (JoinUsing es)) = text "using" <+> parens (commaSep $ map text es)
+>     joinCond Nothing = empty
+>     joinCond (Just JoinNatural) = empty
+
+> whr :: Maybe ScalarExpr -> Doc
+> whr = maybe empty
+>       (\w -> sep [text "where"
+>                  ,nest 4 $ scalarExpr w])
+
+> grpBy :: [ScalarExpr] -> Doc
+> grpBy [] = empty
+> grpBy gs = sep [text "group by"
+>                ,nest 4 $ commaSep $ map scalarExpr gs]
+
+> having :: Maybe ScalarExpr -> Doc
+> having = maybe empty
+>          (\w -> sep [text "having"
+>                     ,nest 4 $ scalarExpr w])
+> orderBy :: [ScalarExpr] -> Doc
+> orderBy [] = empty
+> orderBy os = sep [text "order by"
+>                  ,nest 4 $ commaSep $ map scalarExpr os]
+
+
+= utils
+
+> commaSep :: [Doc] -> Doc
+> commaSep ds = sep $ punctuate comma ds
--- a/19
+++ b/19
@ -1,24 +1,24 @@
-add tests

-left factor parsing code
+add tests to cabal

-implement pretty printer
-
-reimplement the fixity thing natively
+haddock

 dialect switching

-fix lexing wrt suffixes
+
+left factor parsing code
+
+reimplement the fixity thing natively
+
+fix lexing wrt suffixes 1/2 done

 position annotation

 emacs parse error formatting

-haddock

 = sql support

-count(*)
 decimal literals, split string and number literals
 order by directions
 distinct/all
@ -59,12 +59,13 @@ group by (), grouping sets(), cube, rollup
 lateral
 corresponding
 named windows
+table, values
 cte
 apply, pivot
 full tableref aliases
 collate
-
 within group aggregate syntax
+
 try to do full review of sql2003 query syntax

 maybe later: other dml
--- a/Tests.lhs
+++ b/Tests.lhs
@ -1,5 +1,5 @@

-> module Tests (testData) where
+> module Tests (testData, runTests) where

 > import Syntax
 > import Pretty
@ -239,12 +239,24 @@
 > itemToTest (Group nm ts) =
 >     H.TestLabel nm $ H.TestList $ map itemToTest ts
 > itemToTest (TestScalarExpr str expected) =
->     toTest parseScalarExpr str expected
+>     toTest parseScalarExpr prettyScalarExpr str expected
 > itemToTest (TestQueryExpr str expected) =
->     toTest parseQueryExpr str expected
+>     toTest parseQueryExpr prettyQueryExpr str expected

-> toTest parser str expected = H.TestLabel str $ H.TestCase $ do
+> toTest :: (Eq a, Show a, Show e) =>
+>           (String -> Maybe (Int,Int) -> String -> Either e a)
+>        -> (a -> String)
+>        -> String
+>        -> a
+>        -> H.Test
+> toTest parser pp str expected = H.TestLabel str $ H.TestCase $ do
 >         let egot = parser "" Nothing str
 >         case egot of
 >             Left e -> H.assertFailure $ show e
->             Right got -> H.assertEqual "" expected got
+>             Right got -> do
+>                 H.assertEqual "" expected got
+>                 let str' = pp got
+>                 let egot' = parser "" Nothing str'
+>                 case egot' of
+>                     Left e' -> H.assertFailure $ "pp roundtrip " ++ show e'
+>                     Right got' -> H.assertEqual "pp roundtrip" expected got'
--- a/simple-sql-parser.cabal
+++ b/simple-sql-parser.cabal
@ -1,70 +1,35 @@
-- Initial simple-sql-parser.cabal generated by cabal init.  For further 
-- documentation, see http://haskell.org/cabal/users-guide/
-
-- The name of the package.
 name:                simple-sql-parser
-
-- The package version.  See the Haskell package versioning policy (PVP) 
-- for standards guiding when and how versions should be incremented.
-- http://www.haskell.org/haskellwiki/Package_versioning_policy
-- PVP summary:      +-+------- breaking API changes
--                   | | +----- non-breaking API additions
--                   | | | +--- code changes with no API change
 version:             0.1.0.0
-
-- A short (one-line) description of the package.
 synopsis:            A parser for SQL queries

-- A longer description of the package.
-- description:         
+description:         A parser for SQL queries, using Parsec. Also includes pretty printer. Aims to support most of SQL2003 queries.

-- URL for the project homepage or repository.
-homepage:            xx
-
-- The license under which the package is released.
+homepage:            https://github.com/JakeWheat/simple_sql_parser
 license:             BSD3
-
-- The file containing the license text.
 license-file:        LICENSE
-
-- The package author(s).
 author:              Jake Wheat
-
-- An email address to which users can send suggestions, bug reports, and 
-- patches.
 maintainer:          jakewheatmail@gmail.com
-
-- A copyright notice.
-- copyright:           
-
-category:            Database
-
+copyright:           Copyright Jake Wheat 2013
+category:            Database,Language
 build-type:          Simple
-
-- Extra files to be distributed with the package, such as examples or a 
-- README.
-- extra-source-files:  
-
-- Constraint on the version of Cabal needed to build this package.
+extra-source-files:  README,LICENSE
 cabal-version:       >=1.10
+bug-reports:         https://github.com/JakeWheat/simple_sql_parser/issues

+source-repository head
+  type:     git
+  location: https://github.com/JakeWheat/simple_sql_parser.git

 library
-  -- Modules exported by the library.
  exposed-modules:     Pretty, Parser, Syntax
-  
-  -- Modules included in this library but not exported.
  -- other-modules:       
-  
-  -- LANGUAGE extensions used by modules in this package.
  -- other-extensions:    
-  
-  -- Other library packages from which modules are imported.
-  build-depends:       base >=4.6 && <4.7, groom >=0.1 && <0.2, parsec >=3.1 && <3.2, mtl >=2.1 && <2.2, haskell-src-exts >=1.14 && <1.15
-  
-  -- Directories containing source files.
+  build-depends:       base >=4.6 && <4.7,
+                       groom >=0.1 && <0.2,
+                       parsec >=3.1 && <3.2,
+                       mtl >=2.1 && <2.2,
+                       haskell-src-exts >=1.14 && <1.15,
+                       pretty >= 1.1 && < 1.2
  -- hs-source-dirs:      
-  
-  -- Base language which the package is written in.
  default-language:    Haskell2010
-  
+  ghc-options: -Wall