switch tests to hspec, improve error messages
This commit is contained in:
Jake Wheat
parent
fadd010942
commit
c11bee4a9c
36 changed files with 2570 additions and 1809 deletions
514
examples/ErrorMessagesTool.hs
Normal file
514
examples/ErrorMessagesTool.hs
Normal file
|
|
@ -0,0 +1,514 @@
|
|||
{-
|
||||
|
||||
tool to compare before and after on error messages, suggested use:
|
||||
add any extra parse error examples below
|
||||
run it on baseline code
|
||||
run it on the modified code
|
||||
use meld on the two resulting csvs
|
||||
bear in mind that " will appear as "" because of csv escaping
|
||||
|
||||
this is how to generate a csv of errors:
|
||||
|
||||
cabal -ftestexe build error-messages-tool && cabal -ftestexe run error-messages-tool -- generate | cabal -ftestexe run error-messages-tool -- test > res.csv
|
||||
|
||||
TODO:
|
||||
think about making a regression test with this
|
||||
can add some more tools:
|
||||
there's a join mode to join two sets of results, could add a filter
|
||||
to remove rows that are the same
|
||||
but finding the different rows in meld seems to work well enough
|
||||
figure out if you can display visual diffs between pairs of cells in localc
|
||||
implement the tagging feature, one idea for working with it:
|
||||
you generate a bunch of error messages
|
||||
you eyeball the list, and mark some as good, some as bad
|
||||
then when you update, you can do a compare which filters
|
||||
to keep any errors that have changed, and any that haven't
|
||||
changed but are not marked as good
|
||||
etc.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Text.Show.Pretty (ppShow)
|
||||
import qualified Text.RawString.QQ as R
|
||||
|
||||
import Language.SQL.SimpleSQL.Parse
|
||||
(prettyError
|
||||
,parseQueryExpr
|
||||
,parseScalarExpr
|
||||
-- ,parseStatement
|
||||
-- ,parseStatements
|
||||
,ansi2011
|
||||
-- ,ParseError(..)
|
||||
)
|
||||
--import qualified Language.SQL.SimpleSQL.Lex as L
|
||||
|
||||
import Language.SQL.SimpleSQL.Dialect
|
||||
(postgres
|
||||
,Dialect(..)
|
||||
,sqlserver
|
||||
,mysql
|
||||
)
|
||||
|
||||
import System.Environment (getArgs)
|
||||
import Data.Csv
|
||||
(encode
|
||||
,decode
|
||||
,HasHeader(..))
|
||||
|
||||
import qualified Data.ByteString.Lazy as B hiding (pack)
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import qualified Data.ByteString.Lazy.Char8 as B (putStrLn)
|
||||
import qualified Data.Vector as V
|
||||
import Data.Vector (Vector)
|
||||
|
||||
import Database.SQLite.Simple
|
||||
(open
|
||||
,execute_
|
||||
,executeMany
|
||||
,query_
|
||||
)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
as <- getArgs
|
||||
case as of
|
||||
["generate"] -> B.putStrLn generateData
|
||||
["test"] -> do
|
||||
txt <- B.getContents
|
||||
B.putStrLn $ runTests txt
|
||||
["compare", f1, f2] -> do
|
||||
c1 <- B.readFile f1
|
||||
c2 <- B.readFile f2
|
||||
B.putStrLn =<< compareFiles c1 c2
|
||||
_ -> error $ "unsupported arguments: " <> show as
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- compare two files
|
||||
{-
|
||||
|
||||
take two inputs
|
||||
assume they have (testrunid, parser, dialect, src, res,tags) lines
|
||||
do a full outer join between them, on
|
||||
parser,dialect,src
|
||||
so you have
|
||||
parser,dialect,src,res a, tags a, res b, tags b
|
||||
|
||||
then output this as the result
|
||||
|
||||
see what happens if you highlight the differences in localc, edit some
|
||||
tags, then save as csv - does the highlighting just disappear leaving
|
||||
the interesting data only?
|
||||
|
||||
-}
|
||||
|
||||
|
||||
compareFiles :: ByteString -> ByteString -> IO ByteString
|
||||
compareFiles csva csvb = do
|
||||
let data1 :: [(Text,Text,Text,Text,Text,Text)]
|
||||
data1 = either (error . show) V.toList $ decode NoHeader csva
|
||||
data2 :: [(Text,Text,Text,Text,Text,Text)]
|
||||
data2 = either (error . show) V.toList $ decode NoHeader csvb
|
||||
conn <- open ":memory:"
|
||||
execute_ conn [R.r|
|
||||
create table data1 (
|
||||
testrunida text,
|
||||
parser text,
|
||||
dialect text,
|
||||
source text,
|
||||
result_a text,
|
||||
tags_a text)|]
|
||||
execute_ conn [R.r|
|
||||
create table data2 (
|
||||
testrunidb text,
|
||||
parser text,
|
||||
dialect text,
|
||||
source text,
|
||||
result_b text,
|
||||
tags_b text)|]
|
||||
|
||||
executeMany conn "insert into data1 values (?,?,?,?,?,?)" data1
|
||||
executeMany conn "insert into data2 values (?,?,?,?,?,?)" data2
|
||||
r <- query_ conn [R.r|
|
||||
select
|
||||
parser, dialect, source, result_a, tags_a, result_b, tags_b
|
||||
from data1 natural full outer join data2|] :: IO [(Text,Text,Text,Text,Text,Text,Text)]
|
||||
|
||||
pure $ encode r
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- running tests
|
||||
|
||||
runTests :: ByteString -> ByteString
|
||||
runTests csvsrc =
|
||||
let csv :: Vector (Text,Text,Text)
|
||||
csv = either (error . show) id $ decode NoHeader csvsrc
|
||||
|
||||
testrunid = ("0" :: Text)
|
||||
|
||||
testLine (parser,dialect,src) =
|
||||
let d = case dialect of
|
||||
"ansi2011" -> ansi2011
|
||||
"postgres" -> postgres
|
||||
"sqlserver" -> sqlserver
|
||||
"mysql" -> mysql
|
||||
"params" -> ansi2011{diAtIdentifier=True, diHashIdentifier= True}
|
||||
"odbc" -> ansi2011{diOdbc=True}
|
||||
_ -> error $ "unknown dialect: " <> T.unpack dialect
|
||||
res = case parser of
|
||||
"queryExpr" ->
|
||||
either prettyError (T.pack . ppShow)
|
||||
$ parseQueryExpr d "" Nothing src
|
||||
"scalarExpr" ->
|
||||
either prettyError (T.pack . ppShow)
|
||||
$ parseScalarExpr d "" Nothing src
|
||||
_ -> error $ "unknown parser: " <> T.unpack parser
|
||||
-- prepend a newline to multi line fields, so they show
|
||||
-- nice in a diff in meld or similar
|
||||
resadj = if '\n' `T.elem` res
|
||||
then T.cons '\n' res
|
||||
else res
|
||||
in (testrunid, parser, dialect, src, resadj,"" :: Text)
|
||||
|
||||
allres = V.map testLine csv
|
||||
in encode $ V.toList allres
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- generating data
|
||||
|
||||
generateData :: ByteString
|
||||
generateData =
|
||||
encode $ concat
|
||||
[simpleExpressions1
|
||||
,pgExprs
|
||||
,sqlServerIden
|
||||
,mysqliden
|
||||
,paramvariations
|
||||
,odbcexpr
|
||||
,odbcqexpr
|
||||
,otherParseErrorExamples]
|
||||
|
||||
--------------------------------------
|
||||
|
||||
-- example data
|
||||
|
||||
parseExampleStrings :: Text -> [Text]
|
||||
parseExampleStrings = filter (not . T.null) . map T.strip . T.splitOn ";"
|
||||
|
||||
simpleExpressions1 :: [(Text,Text,Text)]
|
||||
simpleExpressions1 =
|
||||
concat $ flip map (parseExampleStrings simpleExprData) $ \e ->
|
||||
[("scalarExpr", "ansi2011", e)
|
||||
,("queryExpr", "ansi2011", "select " <> e)
|
||||
,("queryExpr", "ansi2011", "select " <> e <> ",")
|
||||
,("queryExpr", "ansi2011", "select " <> e <> " from")]
|
||||
where
|
||||
simpleExprData = [R.r|
|
||||
'test
|
||||
;
|
||||
'test''t
|
||||
;
|
||||
'test''
|
||||
;
|
||||
3.23e-
|
||||
;
|
||||
.
|
||||
;
|
||||
3.23e
|
||||
;
|
||||
a.3
|
||||
;
|
||||
3.a
|
||||
;
|
||||
3.2a
|
||||
;
|
||||
4iden
|
||||
;
|
||||
4iden.
|
||||
;
|
||||
iden.4iden
|
||||
;
|
||||
4iden.*
|
||||
;
|
||||
from
|
||||
;
|
||||
from.a
|
||||
;
|
||||
a.from
|
||||
;
|
||||
not
|
||||
;
|
||||
4 +
|
||||
;
|
||||
4 + from
|
||||
;
|
||||
(5
|
||||
;
|
||||
(5 +
|
||||
;
|
||||
(5 + 6
|
||||
;
|
||||
(5 + from)
|
||||
;
|
||||
case
|
||||
;
|
||||
case a
|
||||
;
|
||||
case a when b c end
|
||||
;
|
||||
case a when b then c
|
||||
;
|
||||
case a else d end
|
||||
;
|
||||
case a from c end
|
||||
;
|
||||
case a when from then to end
|
||||
;
|
||||
/* blah
|
||||
;
|
||||
/* blah /* stuff */
|
||||
;
|
||||
/* *
|
||||
;
|
||||
/* /
|
||||
;
|
||||
$$something$
|
||||
;
|
||||
$$something
|
||||
;
|
||||
$$something
|
||||
x
|
||||
;
|
||||
$a$something$b$
|
||||
;
|
||||
$a$
|
||||
;
|
||||
'''
|
||||
;
|
||||
'''''
|
||||
;
|
||||
"a
|
||||
;
|
||||
"a""
|
||||
;
|
||||
"""
|
||||
;
|
||||
"""""
|
||||
;
|
||||
""
|
||||
;
|
||||
*/
|
||||
;
|
||||
:3
|
||||
;
|
||||
@3
|
||||
;
|
||||
#3
|
||||
;
|
||||
:::
|
||||
;
|
||||
|||
|
||||
;
|
||||
...
|
||||
;
|
||||
"
|
||||
;
|
||||
]
|
||||
;
|
||||
)
|
||||
;
|
||||
[test
|
||||
;
|
||||
[]
|
||||
;
|
||||
[[test]]
|
||||
;
|
||||
`open
|
||||
;
|
||||
```
|
||||
;
|
||||
``
|
||||
;
|
||||
}
|
||||
;
|
||||
mytype(4 '4';
|
||||
;
|
||||
app(3
|
||||
;
|
||||
app(
|
||||
;
|
||||
app(something
|
||||
;
|
||||
count(*
|
||||
;
|
||||
count(* filter (where something > 5)
|
||||
;
|
||||
count(*) filter (where something > 5
|
||||
;
|
||||
count(*) filter (
|
||||
;
|
||||
sum(a over (order by b)
|
||||
;
|
||||
sum(a) over (order by b
|
||||
;
|
||||
sum(a) over (
|
||||
;
|
||||
rank(a,c within group (order by b)
|
||||
;
|
||||
rank(a,c) within group (order by b
|
||||
;
|
||||
rank(a,c) within group (
|
||||
;
|
||||
array[
|
||||
;
|
||||
|]
|
||||
|
||||
pgExprs :: [(Text,Text,Text)]
|
||||
pgExprs = flip map (parseExampleStrings src) $ \e ->
|
||||
("scalarExpr", "postgres", e)
|
||||
where src = [R.r|
|
||||
$$something$
|
||||
;
|
||||
$$something
|
||||
;
|
||||
$$something
|
||||
x
|
||||
;
|
||||
$a$something$b$
|
||||
;
|
||||
$a$
|
||||
;
|
||||
:::
|
||||
;
|
||||
|||
|
||||
;
|
||||
...
|
||||
;
|
||||
|
||||
|]
|
||||
|
||||
sqlServerIden :: [(Text,Text,Text)]
|
||||
sqlServerIden = flip map (parseExampleStrings src) $ \e ->
|
||||
("scalarExpr", "sqlserver", e)
|
||||
where src = [R.r|
|
||||
]
|
||||
;
|
||||
[test
|
||||
;
|
||||
[]
|
||||
;
|
||||
[[test]]
|
||||
|
||||
|]
|
||||
|
||||
mysqliden :: [(Text,Text,Text)]
|
||||
mysqliden = flip map (parseExampleStrings src) $ \e ->
|
||||
("scalarExpr", "mysql", e)
|
||||
where src = [R.r|
|
||||
`open
|
||||
;
|
||||
```
|
||||
;
|
||||
``
|
||||
|
||||
|]
|
||||
|
||||
paramvariations :: [(Text,Text,Text)]
|
||||
paramvariations = flip map (parseExampleStrings src) $ \e ->
|
||||
("scalarExpr", "params", e)
|
||||
where src = [R.r|
|
||||
:3
|
||||
;
|
||||
@3
|
||||
;
|
||||
#3
|
||||
|
||||
|]
|
||||
|
||||
|
||||
odbcexpr :: [(Text,Text,Text)]
|
||||
odbcexpr = flip map (parseExampleStrings src) $ \e ->
|
||||
("scalarExpr", "odbc", e)
|
||||
where src = [R.r|
|
||||
{d '2000-01-01'
|
||||
;
|
||||
{fn CHARACTER_LENGTH(string_exp)
|
||||
|
||||
|]
|
||||
|
||||
odbcqexpr :: [(Text,Text,Text)]
|
||||
odbcqexpr = flip map (parseExampleStrings src) $ \e ->
|
||||
("queryExpr", "odbc", e)
|
||||
where src = [R.r|
|
||||
select * from {oj t1 left outer join t2 on expr
|
||||
|
||||
|]
|
||||
|
||||
|
||||
|
||||
otherParseErrorExamples :: [(Text,Text,Text)]
|
||||
otherParseErrorExamples = flip map (parseExampleStrings src) $ \e ->
|
||||
("queryExpr", "ansi2011", e)
|
||||
where src = [R.r|
|
||||
select a select
|
||||
;
|
||||
select a from t,
|
||||
;
|
||||
select a from t select
|
||||
;
|
||||
select a from t(a)
|
||||
;
|
||||
select a from (t
|
||||
;
|
||||
select a from (t having
|
||||
;
|
||||
select a from t a b
|
||||
;
|
||||
select a from t as
|
||||
;
|
||||
select a from t as having
|
||||
;
|
||||
select a from (1234)
|
||||
;
|
||||
select a from (1234
|
||||
;
|
||||
select a from a wrong join b
|
||||
;
|
||||
select a from a natural wrong join b
|
||||
;
|
||||
select a from a left wrong join b
|
||||
;
|
||||
select a from a left wrong join b
|
||||
;
|
||||
select a from a join b select
|
||||
;
|
||||
select a from a join b on select
|
||||
;
|
||||
select a from a join b on (1234
|
||||
;
|
||||
select a from a join b using(a
|
||||
;
|
||||
select a from a join b using(a,
|
||||
;
|
||||
select a from a join b using(a,)
|
||||
;
|
||||
select a from a join b using(1234
|
||||
;
|
||||
select a from t order no a
|
||||
;
|
||||
select a from t order by a where c
|
||||
;
|
||||
select 'test
|
||||
'
|
||||
|
||||
|]
|
||||
|
|
@ -89,7 +89,7 @@ lexCommand =
|
|||
(f,src) <- getInput args
|
||||
either (error . T.unpack . L.prettyError)
|
||||
(putStrLn . intercalate ",\n" . map show)
|
||||
$ L.lexSQL ansi2011 (T.pack f) Nothing (T.pack src)
|
||||
$ L.lexSQL ansi2011 False (T.pack f) Nothing (T.pack src)
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue