replace error messages tool with golden test approach

tests/Language/SQL/SimpleSQL/ErrorMessages.hs

@@ -1,12 +1,10 @@
 
 {-
-See the file examples/ErrorMessagesTool.hs for some work on this
 
-TODO:
-
-add simple test to check the error and quoting on later line in multi
-line input for lexing and parsing; had a regression here that made it
-to a release
+Quick tests for error messages, all the tests use the entire formatted
+output of parse failures to compare, it's slightly fragile. Most of
+the tests use a huge golden file which contains tons of parse error
+examples.
 
 -}
 
@@ -28,8 +26,14 @@ import Debug.Trace
 
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Test.Hspec.Golden
+    (Golden(..)
+    )
 
 import qualified Text.RawString.QQ as R
+import System.FilePath ((</>))
+import Text.Show.Pretty (ppShow)
 
 errorMessageTests :: TestItem
 errorMessageTests = Group "error messages"
@@ -65,9 +69,11 @@ order by 1,2,3 $@
   |                ^
 unexpected '$'
 |]
+   ,let fn = "expected-parse-errors"
+        got = generateParseResults parseErrorData
+    in GoldenErrorTest fn parseErrorData $ it "parse error regressions" $ myGolden (T.unpack fn) got
         ]
   where
-    
     gp :: (Show a, HasCallStack) => (Text -> Either e a) -> (e -> Text) -> Text -> Text -> TestItem
     gp parse pret src err =
         GeneralParseFailTest src err $
@@ -80,3 +86,612 @@ unexpected '$'
                             trace (T.unpack ("check\n[" <> pret f <>"]\n["<> err <> "]\n"))
                        _ -> id
            in quickTrace (f1 `ex` err)
+
+------------------------------------------------------------------------------
+
+-- golden parse error tests
+    
+myGolden :: String -> Text -> Golden Text
+myGolden name actualOutput =
+  Golden {
+    output = actualOutput,
+    encodePretty = show,
+    writeToFile = T.writeFile,
+    readFromFile = T.readFile,
+    goldenFile = name </> "golden",
+    actualFile = Just (name </> "actual"),
+    failFirstTime = False
+  }
+
+parseErrorData :: [(Text,Text,Text)]
+parseErrorData =
+    concat
+    [simpleExpressions1
+    ,pgExprs
+    ,sqlServerIden
+    ,mysqliden
+    ,paramvariations
+    ,odbcexpr
+    ,odbcqexpr
+    ,queryExprExamples
+    ,statementParseErrorExamples]
+
+generateParseResults :: [(Text,Text,Text)] -> Text
+generateParseResults dat =
+    let 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
+                        "statement" ->
+                            either prettyError (T.pack . ppShow)
+                            $ parseStatement 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 T.unlines [parser, dialect, src, resadj]
+    in T.unlines $ map testLine dat
+
+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
+;
+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[
+;
+(a
+;
+(
+;
+a >*
+;
+a >* b
+;
+( ( a
+;
+( ( a )
+;
+( ( a  + )
+|]
+
+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
+
+|]
+
+
+    
+queryExprExamples :: [(Text,Text,Text)]
+queryExprExamples = 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
+'
+;
+select a as
+;
+select a as from t
+;
+select a as, 
+;
+select a,
+;
+select a, from t
+;
+select a as from
+;
+select a as from from
+;
+select a as from2 from
+;
+select a fromt
+;
+select a b fromt
+
+;
+select a from t u v
+;
+select a from t as
+;
+select a from t, 
+;
+select a from group by b
+;
+select a from t join group by a
+;
+select a from t join
+;
+select a from (@
+;
+select a from ()
+;
+select a from t left join u on
+;
+select a from t left join u on group by a
+;
+select a from t left join u using
+;
+select a from t left join u using (
+;
+select a from t left join u using (a
+;
+select a from t left join u using (a,
+;
+select a from (select a from)
+;
+select a from (select a
+
+;
+select a from t where
+;
+select a from t group by a having b where
+;
+select a from t where (a
+;
+select a from t where group by b
+
+;
+select a from t group by
+;
+select a from t group
+;
+select a from t group by a as
+;
+select a from t group by a,
+;
+select a from t group by order by
+;
+select a <<== b from t
+;
+/*
+;
+select * as a
+;
+select t.* as a
+;
+select 3 + *
+;
+select case when * then 1 end
+;
+select (*)
+;
+select * from (select a
+        from t
+;
+select * from (select a(stuff)
+        from t
+
+;
+select *
+     from (select a,b
+           from t
+           where a = 1
+                 and b > a
+
+;
+select *
+     from (select a,b
+           from t
+           where a = 1
+                 and b > a
+           from t)
+
+|]
+
+
+statementParseErrorExamples :: [(Text,Text,Text)]
+statementParseErrorExamples = flip map (parseExampleStrings src) $ \e ->
+    ("statement", "ansi2011", e)
+  where src = [R.r|
+create
+;
+drop
+;
+delete this
+;
+delete where 7
+;
+delete from where t
+;
+truncate nothing
+;
+truncate nothing nothing
+;
+truncate table from
+;
+truncate table t u
+;
+insert t select u
+;
+insert into t insert
+;
+insert into t (1,2)
+;
+insert into t(
+;
+insert into t(1
+;
+insert into t(a
+;
+insert into t(a,
+;
+insert into t(a,b)
+;
+insert into t(a,b) values
+;
+insert into t(a,b) values (
+;
+insert into t(a,b) values (1
+;
+insert into t(a,b) values (1,
+;
+insert into t(a,b) values (1,2) and stuff
+;
+update set 1
+;
+update t u
+;
+update t u v
+;
+update t set a
+;
+update t set a=
+;
+update t set a=1,
+;
+update t set a=1 where
+;
+update t set a=1 where 1 also
+;
+create table
+;
+create table t (
+  a
+)
+;
+create table t (
+  a
+;
+create table t (
+  a,
+)
+;
+create table t (
+)
+;
+create table t (
+;
+create table t
+;
+create table t. (
+;
+truncate table t.
+;
+drop table t. where
+;
+update t. set
+;
+delete from t. where
+;
+insert into t. values
+;
+with a as (select * from t
+select 1
+;
+with a as (select * from t
+;
+with a as (
+;
+with a (
+;
+with as (select * from t)
+select 1
+;
+with (select * from t) as a
+select 1
+
+
+|]
+

tests/Language/SQL/SimpleSQL/TestTypes.hs

@@ -52,4 +52,5 @@ should all be TODO to convert to a testqueryexpr test.
               | LexTest Dialect Text [Token] (SpecWith ())
               | LexFails Dialect Text (SpecWith ())
               | GeneralParseFailTest Text Text (SpecWith ())
+              | GoldenErrorTest Text [(Text,Text,Text)] (SpecWith ())
 

tests/Language/SQL/SimpleSQL/Tests.hs

@@ -93,3 +93,4 @@ itemToTest (ParseScalarExprFails _ _ t) = t
 itemToTest (LexTest _ _ _ t) = t
 itemToTest (LexFails _ _ t) = t
 itemToTest (GeneralParseFailTest _ _ t) = t
+itemToTest (GoldenErrorTest _ _ t) = t