/src-extra/tosort/examples/util/Database/HsSqlPpp/Utils/RoundTripTester.lhs

  1
  2This file is a confused mess. The plan is to completely start again,
  3to produce a big multi function routine which analyzes sql:
  4
  5* check it parses
  6* lists type errors
  7* produces documentation
  8* catalog reference docs - so we can search an index, then click to go
  9  to definition in the rendered docs
 10* check the roundtripping, etc.
 11
 12This will be mostly based on the runtestbattery function below.
 13
 14> {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables,FlexibleContexts,QuasiQuotes #-}
 15> module Database.HsSqlPpp.Utils.RoundTripTester
 16>     (roundTripTest
 17>     ,RoundTripResults(..)
 18>     ,TypeErrorList
 19>     ,rtShowBrief) where
 20>
 21> import System.Console.CmdArgs
 22> --import System.IO
 23> import Control.Monad.Error
 24> import Data.List
 25
 26> --import Debug.Trace
 27> import Data.Maybe
 28> import Data.Generics.Uniplate.Data
 29>
 30> --import Database.HsSqlPpp.Tests.Tests
 31> import Database.HsSqlPpp.Utils.Utils
 32> --import Database.HsSqlPpp.Utils.Here
 33>
 34> import Database.HsSqlPpp.Ast
 35> import Database.HsSqlPpp.Catalog
 36> import Database.HsSqlPpp.TypeChecker
 37> import Database.HsSqlPpp.Annotation
 38> import Database.HsSqlPpp.SqlTypes
 39>
 40> import Database.HsSqlPpp.Parser
 41> --import Database.HsSqlPpp.Parsing.Lexer
 42>
 43> import Database.HsSqlPpp.PrettyPrinter
 44>
 45> --import Database.HsSqlPpp.Examples.AnnotateSource
 46>
 47> --import Database.HsSqlPpp.DatabaseLoader.DatabaseLoader
 48> --import Database.HsSqlPpp.Examples.WrapperGen
 49> import Database.HsSqlPpp.Utils.DBUtils
 50>
 51> --import Database.HsSqlPpp.DevelTools.MakeWebsite
 52> --import Database.HsSqlPpp.DevelTools.MakeAntiNodes
 53> --import Database.HsSqlPpp.Examples.Extensions.TransitionConstraints
 54> --import Database.HsSqlPpp.Examples.Extensions.ChaosExtensions
 55> --import Database.HsSqlPpp.Examples.Chaos2010
 56
 57> type TypeErrorList = [(Maybe (String,Int,Int), [TypeError])]
 58
 59> data RoundTripResults = RoundTripResults
 60>     {rtDatabaseName :: String
 61>     ,rtFiles :: [FilePath]
 62>     ,rtEmptyCat :: Catalog
 63>     ,rtOrigCat :: Catalog
 64>     ,rtOrigAst :: [Statement]
 65>     ,rtOrigTypeErrors :: TypeErrorList
 66>     ,rtPgCat :: Catalog
 67>     ,rtOrigPgCatDiff :: CatalogDiff
 68>     ,rtDumpAst :: [Statement]
 69>     ,rtDumpCat :: Catalog
 70>     ,rtDumpTypeErrors :: TypeErrorList
 71>     ,rtOrigDumpCatDiff :: CatalogDiff
 72>     }
 73
 74> rtShowBrief :: RoundTripResults -> String
 75> rtShowBrief rtt =
 76>   header "initial type errors"
 77>   ++ intercalate "\n" (ppTypeErrors (rtOrigTypeErrors rtt))
 78>   ++ header "cat diff: orig to pg"
 79>   ++ ppCatDiff (rtOrigPgCatDiff rtt)
 80>   ++ header "dump type errors"
 81>   ++ intercalate "\n" (ppTypeErrors (rtDumpTypeErrors rtt))
 82>   ++ header "cat diff: orig to dump"
 83>   ++ ppCatDiff (rtOrigDumpCatDiff rtt)
 84>   where
 85>     header x = "-------------" ++ x ++ "\n"
 86
 87> {-ppCatalogA = mode $ PPCatalog {database = def
 88>                               ,files = def &= typ "FILES" & args}
 89>              &= text "reads each file, parses, type checks, then outputs the \
 90>                      \changes to the catalog that the sql makes"
 91>
 92> ppCatalog :: String -> [FilePath] -> IO ()
 93> ppCatalog db fns = wrapETs $ do
 94>   scat <- liftIO (readCatalog db) >>= tsl
 95>   (ncat, _) <- mapM (\f -> (liftIO . readInput) f >>=
 96>                            tsl . P.parseSql f) fns >>=
 97>                  return . (concat |>
 98>                            astTransformer |>
 99>                            A.typeCheck scat)
100>   liftIO $ putStrLn $ ppCatDiff $ compareCatalogs scat emptyCatalog ncat
101
102-------------------------------------------------------------------------------
103
104load
105====
106
107load sql files into a database via parsing and pretty printing them
108
109>
110> loadSql :: String -> [String] -> IO ()
111> loadSql db fns = wrapETs $
112>      liftIO (hSetBuffering stdout NoBuffering) >>
113>      mapM (\f -> (liftIO . readInput) f >>=
114>                  tsl . P.parseSql f) fns >>=
115>      return . (concat |>
116>                astTransformer) >>=
117>      liftIO . loadAst db
118
119-------------------------------------------------------------------------------
120
121loadPsql
122========
123
124load sql files into a database via psql
125
126> loadPsqlA = mode $ LoadPsql {database = def
127>                             ,files = def &= typ "FILES" & args}
128>             &= text "loads sql into a database using psql."
129>
130> loadSqlPsql :: String -> [String] -> IO ()
131> loadSqlPsql db = wrapETs .
132>   mapM_ (\s -> liftIO (loadSqlUsingPsqlFromFile db s) >>=
133>                tsl >>=
134>                liftIO . putStrLn)
135
136
137-------------------------------------------------------------------------------
138
139clearLoad
140=========
141
142like load above, but runs the clear command first
143
144might try to work out a way of running multiple commands in one invoc
145of this exe, then this command will disappear
146
147> clearLoadA = mode $ ClearLoad {database = def
148>                               ,files = def &= typ "FILES" & args}
149>              &= text "cleardb then loadsql"
150>
151> clearAndLoadSql :: String -> [String] -> IO ()
152> clearAndLoadSql db fns = cleardb db >> loadSql db fns -}
153
154
155-------------------------------------------------------------------------------
156
157testBattery
158===========
159
160run test battery: run a bunch of tests including consistency on the
161database and sql files given
162
163The idea is to typecheck the sql, load it into pg and dump it via psql
164and via database loader, can then compare asts, catalogs, etc. in a
165lot of different ways
166
167currently:
168parse and type check sql, save the catalog
169load the sql into the db using psql, compare the catalog read from pg
170with the catalog from typechecking
171dump the sql and typecheck the dump, compare the catalog from this
172check with the catalog from the original typecheck
173
174todo: compare asts from initial parse with parsed dump - this is going
175to be a lot of work to get passing since the statements are
176re-ordered, and sometimes changed/ split up by pg
177
178also: load the sql using the extension system and database loader,
179then compare pg catalog with initial catalog, and dump and compare ast
180with original ast
181
182want to run a similar set of tests starting with the dump sql:
183get ast,cat from dump sql, load using psql and using databaseloader
184and check cats and subsequent dump asts.
185
186getting the dump ast comparing with the original ast:
187
188step one: convert tests in parser test to also roundtrip through
189database, see parsertests for details
190
191step two: write an ast conversion routine: assume that the pgdump ast
192is like the ast fed into pg but with a few statements split into
193components (e.g. create table with serial is split into create
194sequence and create table), and then the statements are reordered, so
195write a routine to mirror this - will then have
196(anyast -> rearrange and reorder) == (anyast -> pg->pgdump)
197
198
199rough new plan:
200
201combine this with the planned report generator
202
203have new annotation routine used in website, in annotatesource2
204first part is to run this and produce html report of the source,
205then add the catalog summary page, and list of type errors as with the website generator
206
207then we do the round trip tests:
208load into database, then compare catalogs
209dump from database, reparse and compare catalogs
210then parse, typecheck the dumped code, list type errors and catalog differences
211when the code is up to it, compare the original ast to the dumped ast.
212
213make different stages optional:
214
215run as a check tool, just want the catalog differences and type errors
216on the command line. would be nice to try and link the catalog
217differences to source positions.
218
219do website generation, without the pg roundtrips
220
221> parseFiles :: [String] -> IO [StatementList]
222> parseFiles fns = do
223>   as <- mapM (\f -> fmap (parseStatements f) $ readFile f) fns
224>   return $ either (error . show) id $ sequence as
225
226> roundTripTest :: ([Statement] -> [Statement]) -> String -> [FilePath] -> IO RoundTripResults
227> roundTripTest astTransformer dbName fns = wrapETs $ do
228>     -- clear target database
229>     liftIO $ clearDBN dbName
230>     -- get the catalog of the empty database
231>     emptyCat <- readCat dbName
232>     -- get the ast and catalog of the sql to test with the catalog
233>     -- determined by the hssqlppp typechecker
234>     (origAst :: [Statement]) <- (astTransformer . concat) `fmap` liftIO (parseFiles fns)
235>     let (origCat :: Catalog, origAast :: [Statement]) = typeCheckStatements emptyCat origAst
236>     let origTypeErrors = getTypeErrors origAast
237>     -- load the test sql into postgresql using psql and get the
238>     -- new catalog from postgresql
239>     _ <- liftIO $ loadSqlUsingPsql dbName $ printStatements origAst
240>     pgCat <- readCat dbName
241>     -- show the differences between the catalog as determined by the
242>     -- hssqlppp type checker and by loading into postgresql and reading
243>     -- the catalog from the loaded database
244>     let origPgCatDiff = compareCatalogs emptyCat origCat pgCat
245>     -- dump the database from postgresql, parse and run the dump sql through the
246>     -- hssqlppp type checker
247>     dumpSql <- liftIO $ pgDump dbName
248>     dumpSqlAst <- etsr $ parseStatements "" dumpSql
249>     let (dumpCat,dumpAast) = typeCheckStatements emptyCat dumpSqlAst
250>     let dumpTypeErrors = getTypeErrors dumpAast
251>     let origDumpCatDiff = compareCatalogs emptyCat origCat dumpCat
252>
253>     return $ RoundTripResults
254>                {rtDatabaseName = dbName
255>                ,rtFiles = fns
256>                ,rtEmptyCat = emptyCat
257>                ,rtOrigCat = origCat
258>                ,rtOrigAst = origAast
259>                ,rtOrigTypeErrors = origTypeErrors
260>                ,rtPgCat = pgCat
261>                ,rtOrigPgCatDiff = origPgCatDiff
262>                ,rtDumpAst = dumpAast
263>                ,rtDumpCat = dumpCat
264>                ,rtDumpTypeErrors = dumpTypeErrors
265>                ,rtOrigDumpCatDiff = origDumpCatDiff
266>                }
267>     where
268>       readCat d = liftIO (readCatalog d) >>= etsr
269
270> -- | Pretty print list of type errors with optional source position
271> --   in emacs readable format.
272> ppTypeErrors :: [(Maybe (String,Int,Int), [TypeError])] -> [String]
273> ppTypeErrors tes =
274>   map showSpTe tes
275>   where
276>     showSpTe (Just (fn,l,c), e) =
277>         fn ++ ":" ++ show l ++ ":" ++ show c ++ ":\n" ++ show e
278>     showSpTe (_,e) = "unknown:0:0:\n" ++ show e
279
280> getTypeErrors :: Data a => a -> [(Maybe (String,Int,Int), [TypeError])]
281> getTypeErrors es =
282>   let as = [(a::Annotation) | a <- universeBi es]
283>   in mapMaybe getTes as
284>   where
285>     getTes as = let tes = errs as
286>                 in if null tes
287>                    then Nothing
288>                    else Just (asrc as, tes)
289
290> type ErrorIO e a = ErrorT e IO a
291
292> etsr :: Show e => Either e a -> ErrorIO String a
293> etsr = either (throwError . show) return