/src-extra/tosort/examples/util/Database/HsSqlPpp/Utils/RoundTripTester.lhs
Haskell | 293 lines | 192 code | 35 blank | 66 comment | 4 complexity | 8748df32ae90429ead606e9255fef50a MD5 | raw file
Possible License(s): BSD-3-Clause
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