switch in megaparsec with stub lexing code

tools/Language/SQL/SimpleSQL/LexerTests.hs

@@ -2,23 +2,89 @@
 
 -- Test for the lexer
 
+
+{-
+TODO:
+figure out a way to do quickcheck testing:
+1. generate valid tokens and check they parse
+
+2. combine two generated tokens together for the combo testing
+
+this especially will work much better for the postgresql extensible
+operator tests which doing exhaustively takes ages and doesn't bring
+much benefit over testing a few using quickcheck.
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
 module Language.SQL.SimpleSQL.LexerTests (lexerTests) where
 
 import Language.SQL.SimpleSQL.TestTypes
-import Language.SQL.SimpleSQL.Lex (Token(..),tokenListWillPrintAndLex)
+import Language.SQL.SimpleSQL.Lex
+    (Token(..)
+    ,tokenListWillPrintAndLex
+    )
+
+import Language.SQL.SimpleSQL.Dialect
+    (ansi2011)
+
+import qualified Data.Text as T
+    
 --import Debug.Trace
 --import Data.Char (isAlpha)
-import Data.List
+-- import Data.List
 
 lexerTests :: TestItem
 lexerTests = Group "lexerTests" $
-    [Group "lexer token tests" [ansiLexerTests
+    [bootstrapTests{-Group "lexer token tests" [ansiLexerTests
                                ,postgresLexerTests
                                ,sqlServerLexerTests
                                ,oracleLexerTests
                                ,mySqlLexerTests
-                               ,odbcLexerTests]]
+                               ,odbcLexerTests]-}]
 
+-- quick sanity tests to see something working
+bootstrapTests :: TestItem
+bootstrapTests = Group "bootstrap tests" $
+    map (uncurry (LexTest ansi2011)) (
+    [("iden", [Identifier Nothing "iden"])
+    ,("'string'", [SqlString "'" "'" "string"])
+
+    ,("  ", [Whitespace "  "])
+    ,("\t  ", [Whitespace "\t  "])
+    ,("  \n  ", [Whitespace "  \n  "])
+
+    ,("--", [LineComment "--"])
+    ,("--\n", [LineComment "--\n"])
+    ,("--stuff", [LineComment "--stuff"])
+    ,("-- stuff", [LineComment "-- stuff"])
+    ,("-- stuff\n", [LineComment "-- stuff\n"])
+    ,("--\nstuff", [LineComment "--\n", Identifier Nothing "stuff"])
+    ,("-- com \nstuff", [LineComment "-- com \n", Identifier Nothing "stuff"])
+
+    ,("/*test1*/", [BlockComment "/*test1*/"])
+    ,("/**/", [BlockComment "/**/"])
+    ,("/***/", [BlockComment "/***/"])
+    ,("/* * */", [BlockComment "/* * */"])
+    ,("/*test*/", [BlockComment "/*test*/"])
+    ,("/*te/*st*/", [BlockComment "/*te/*st*/"])
+    ,("/*te*st*/", [BlockComment "/*te*st*/"])
+    ,("/*lines\nmore lines*/", [BlockComment "/*lines\nmore lines*/"])
+    ,("/*test1*/\n", [BlockComment "/*test1*/", Whitespace "\n"])
+    ,("/*test1*/stuff", [BlockComment "/*test1*/", Identifier Nothing "stuff"])
+
+    ,("1", [SqlNumber "1"])
+    ,("42", [SqlNumber "42"])
+
+    ,("$1", [PositionalArg 1])
+    ,("$200", [PositionalArg 200])
+
+    ,(":test", [PrefixedVariable ':' "test"])
+
+    ] ++ map (\a -> (a, [Symbol a])) (
+     ["!=", "<>", ">=", "<=", "||"]
+     ++ map T.singleton ("(),-+*/<>=." :: String)))
+
+{-
 ansiLexerTable :: [(String,[Token])]
 ansiLexerTable =
     -- single char symbols
@@ -331,13 +397,4 @@ combos :: [a] -> Int -> [[a]]
 combos _ 0 = [[]]
 combos l n = [ x:tl | x <- l, tl <- combos l (n - 1) ]
 
-{-
-figure out a way to do quickcheck testing:
-1. generate valid tokens and check they parse
-
-2. combine two generated tokens together for the combo testing
-
-this especially will work much better for the postgresql extensible
-operator tests which doing exhaustively takes ages and doesn't bring
-much benefit over testing a few using quickcheck.
 -}

tools/Language/SQL/SimpleSQL/TestTypes.hs

@@ -13,6 +13,8 @@ import Language.SQL.SimpleSQL.Syntax
 import Language.SQL.SimpleSQL.Lex (Token)
 import Language.SQL.SimpleSQL.Dialect
 
+import Data.Text (Text)
+
 {-
 TODO: maybe make the dialect args into [dialect], then each test
 checks all the dialects mentioned work, and all the dialects not
@@ -38,6 +40,6 @@ should all be TODO to convert to a testqueryexpr test.
 
               | ParseQueryExprFails Dialect String
               | ParseScalarExprFails Dialect String
-              | LexTest Dialect String [Token]
+              | LexTest Dialect Text [Token]
               | LexFails Dialect String
                 deriving (Eq,Show)

tools/Language/SQL/SimpleSQL/Tests.hs

@@ -5,6 +5,7 @@ Test.Framework tests. It also contains the code which converts the
 test data to the Test.Framework tests.
 -}
 
+{-# LANGUAGE OverloadedStrings #-}
 module Language.SQL.SimpleSQL.Tests
     (testData
     ,tests
@@ -17,7 +18,7 @@ import qualified Test.Tasty.HUnit as H
 --import Language.SQL.SimpleSQL.Syntax
 import Language.SQL.SimpleSQL.Pretty
 import Language.SQL.SimpleSQL.Parse
-import Language.SQL.SimpleSQL.Lex
+import qualified Language.SQL.SimpleSQL.Lex as Lex
 
 import Language.SQL.SimpleSQL.TestTypes
 
@@ -44,6 +45,9 @@ import Language.SQL.SimpleSQL.MySQL
 import Language.SQL.SimpleSQL.Oracle
 import Language.SQL.SimpleSQL.CustomDialect
 
+import Data.Text (Text)
+import qualified Data.Text as T
+
 
 {-
 Order the tests to start from the simplest first. This is also the
@@ -54,7 +58,7 @@ testData :: TestItem
 testData =
     Group "parserTest"
     [lexerTests
-    ,scalarExprTests
+    {-,scalarExprTests
     ,odbcTests
     ,queryExprComponentTests
     ,queryExprsTests
@@ -72,7 +76,7 @@ testData =
     ,oracleTests
     ,customDialectTests
     ,emptyStatementTests
-    ,createIndexTests
+    ,createIndexTests-}
     ]
 
 tests :: T.TestTree
@@ -104,18 +108,19 @@ itemToTest (ParseScalarExprFails d str) =
 itemToTest (LexTest d s ts) = makeLexerTest d s ts
 itemToTest (LexFails d s) = makeLexingFailsTest d s
 
-makeLexerTest :: Dialect -> String -> [Token] -> T.TestTree
-makeLexerTest d s ts = H.testCase s $ do
-    let lx = either (error . show) id $ lexSQL d "" Nothing s
-    H.assertEqual "" ts $ map snd lx
-    let s' = prettyTokens d $ map snd lx
+makeLexerTest :: Dialect -> Text -> [Lex.Token] -> T.TestTree
+makeLexerTest d s ts = H.testCase (T.unpack s) $ do
+    let lx = either (error . T.unpack . Lex.prettyError) id $ Lex.lexSQL d "" Nothing s
+        ts1 = map Lex.tokenVal lx
+    H.assertEqual "" ts ts1
+    let s' = Lex.prettyTokens d $ ts1
     H.assertEqual "pretty print" s s'
 
 makeLexingFailsTest :: Dialect -> String -> T.TestTree
 makeLexingFailsTest d s = H.testCase s $ do
-    case lexSQL d "" Nothing s of
+    undefined {-case lexSQL d "" Nothing s of
          Right x -> H.assertFailure $ "lexing should have failed: " ++ s ++ "\ngot: " ++ show x
-         Left _ -> return ()
+         Left _ -> return ()-}
 
 
 toTest :: (Eq a, Show a) =>