hssqlppp-0.6.2: tests/Database/HsSqlPpp/Tests/TestUtils.lhs
> module Database.HsSqlPpp.Tests.TestUtils
> (assertTrace,itemToTft) where
>
> import qualified Test.Tasty as T
> import qualified Test.Tasty.HUnit as H
> --import Data.List
> import Data.Generics.Uniplate.Data
> import Data.Data
> import Debug.Trace
> import Control.Monad
> --import Database.HsSqlPpp.Utils.Here
> import Database.HsSqlPpp.Parse
> import Database.HsSqlPpp.Syntax
> import Database.HsSqlPpp.Pretty
> import Database.HsSqlPpp.TypeCheck
> import Database.HsSqlPpp.Annotation
> import Database.HsSqlPpp.Catalog
> import Database.HsSqlPpp.Utils.GroomUtils
> import Database.HsSqlPpp.Utility
> --import Database.HsSqlPpp.SqlTypes
> --import Database.HsSqlPpp.Utils.PPExpr
> --import Data.Text.Lazy (Text)
> import qualified Data.Text.Lazy as L
> --import qualified Data.Text as T
> import Database.HsSqlPpp.Lex (lexTokens,prettyToken,Token)
> --import Text.Parsec.Text (runParser)
> --import Control.Applicative
> --import Data.Generics.Uniplate.Data
> import Database.HsSqlPpp.Tests.TestTypes
> import Database.HsSqlPpp.Internals.TypeChecking.TypeConversion.TypeConversion2
> --import Test.HUnit
> --import Test.Framework.Providers.HUnit
> --import Test.Framework
> --import Data.List
> --import Data.Generics.Uniplate.Data
> --import Database.HsSqlPpp.Parser
> --import Database.HsSqlPpp.TypeChecker
> --import Database.HsSqlPpp.Annotation
> --import Database.HsSqlPpp.Catalog
> --import Database.HsSqlPpp.Ast hiding (App)
> import Database.HsSqlPpp.Types
> --import Database.HsSqlPpp.Pretty
> --import Database.HsSqlPpp.Utility
> --import Database.HsSqlPpp.Internals.TypeChecking.Environment
> --import Text.Show.Pretty
> --import Debug.Trace
> --import Database.HsSqlPpp.Tests.TestUtils
> --import Control.Monad
> --import Database.HsSqlPpp.Utils.GroomUtils
> --import qualified Data.Text.Lazy as L
> import Database.HsSqlPpp.Dialect
> assertTrace :: (Show a,Eq a) => String -> String -> a -> a -> IO ()
> assertTrace nem s a1 a2 = do
> when (a1 /= a2) $ trace nem $ return ()
> H.assertEqual s a1 a2
> itemToTft :: Item -> T.TestTree
> itemToTft (ParseScalarExpr f a b) = testParseScalarExpr f a b
> itemToTft (ParseQueryExpr f a b) = testParseQueryExpr f a b
> --itemToTft (ParseProcSql f a b) = testParseProcSql f a b
> itemToTft (ParseStmts f a b) = testParseStatements f a b
> itemToTft (ParseProcSql f a b) = testParseProcSql f a b
> {-itemToTft (TSQL a b) =
> testParsePlpgsqlStatements (if True
> then SQLServer
> else PostgreSQL) a b-}
> {-itemToTft (OracleX a b) =
> testParsePlpgsqlStatements Oracle a b -}
> --itemToTft (MSStmt a b) = testParseStatements a b
> itemToTft (Group s is) = T.testGroup s $ map itemToTft is
> itemToTft (Lex d a b) = testLex d a b
> itemToTft (TCScalExpr c e f s r) = testTCScalarExpr c e f s r
> itemToTft (TCQueryExpr cat f s r) = testQueryExprType cat f s r
> itemToTft (TCStatements cat f s r) = testStatementsTypecheck cat f s r
> itemToTft (InsertQueryExpr cus s r) = testInsertQueryExprType sqlServerDialect {-PostgreSQL-} cus s r
> --itemToTft (TSQLQueryExpr cus s r) = undefined --testQueryExprType SQLServer cus s r
> --itemToTft (OracleQueryExpr cus s r) = undefined --testQueryExprType Oracle cus s r
> itemToTft (RewriteQueryExpr f cus s s') = testRewrite f cus s s'
> itemToTft (ImpCastsScalar f s s') = testImpCastsScalar f s s'
> itemToTft (ScalarExprExtra d cat env s r) = testScalarExprTypeExtra d cat env s r
> itemToTft (MatchApp d cat f as r) = testMatchApp d cat f as r
> itemToTft (Custom nm f) = H.testCase nm f
> testParseScalarExpr :: ParseFlags -> L.Text -> ScalarExpr -> T.TestTree
> testParseScalarExpr f src ast =
> parseUtil src ast (parseScalarExpr f "" Nothing)
> (parseScalarExpr f "" Nothing)
> (prettyScalarExpr
> defaultPrettyFlags {ppDialect = pfDialect f} )
> testParseQueryExpr :: ParseFlags -> L.Text -> QueryExpr -> T.TestTree
> testParseQueryExpr f src ast =
> parseUtil src ast (parseQueryExpr f "" Nothing)
> (parseQueryExpr f "" Nothing)
> (prettyQueryExpr defaultPrettyFlags {ppDialect = pfDialect f})
>
> testParseStatements :: ParseFlags -> L.Text -> [Statement] -> T.TestTree
> testParseStatements flg src ast =
> let parse = parseStatements flg "" Nothing
> pp = prettyStatements defaultPrettyFlags {ppDialect=pfDialect flg}
> in parseUtil src ast parse parse pp
> testParseProcSql :: ParseFlags -> L.Text -> [Statement] -> T.TestTree
> testParseProcSql flg src ast =
> let parse = parseProcSQL flg "" Nothing
> pp = prettyStatements defaultPrettyFlags {ppDialect=pfDialect flg}
> in parseUtil src ast parse parse pp
>
>
> parseUtil :: (Show t, Eq b, Show b, Data b) =>
> L.Text
> -> b
> -> (L.Text -> Either t b)
> -> (L.Text -> Either t b)
> -> (b -> L.Text)
> -> T.TestTree
> parseUtil src ast parser reparser printer = H.testCase ("parse " ++ L.unpack src) $
> case parser src of
> Left er -> H.assertFailure $ show er
> Right ast' -> do
> when (ast /= resetAnnotations ast') $ do
> putStrLn $ groomNoAnns ast
> putStrLn $ groomNoAnns $ resetAnnotations ast'
> H.assertEqual ("parse " ++ L.unpack src) ast $ resetAnnotations ast'
> case reparser (printer ast) of
> Left er -> H.assertFailure $ "reparse\n" ++ (L.unpack $ printer ast) ++ "\n" ++ show er ++ "\n" -- ++ pp ++ "\n"
> Right ast'' -> H.assertEqual ("reparse: " ++ L.unpack (printer ast)) ast $ resetAnnotations ast''
> testLex :: Dialect -> L.Text -> [Token] -> T.TestTree
> testLex d t r = H.testCase ("lex "++ L.unpack t) $ do
> let x = lexTokens d "" Nothing t
> y = either (error . show) id x
> H.assertEqual "lex" r (map snd y)
> let t' = L.concat $ map (L.pack . prettyToken d) r
> H.assertEqual "lex . pretty" t t'
> testTCScalarExpr :: Catalog -> Environment -> TypeCheckFlags
> -> L.Text -> Either [TypeError] Type -> T.TestTree
> testTCScalarExpr cat env f src et =
> H.testCase ("typecheck " ++ L.unpack src) $ do
> let ast = case parseScalarExpr defaultParseFlags {pfDialect = tcfDialect f} "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> aast = typeCheckScalarExpr f cat
> (canonicalizeEnvTypes (tcfDialect f) env)
> $ canonicalizeTypes (tcfDialect f) ast
> (ty,errs,noTypeQEs,noTypeSEs) = tcTreeInfo aast
> er = concatMap fst errs
> got = case () of
> _ | null er -> maybe (Left []) (Right . teType) ty
> | otherwise -> Left er
> allTyped = case et of
> Left _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Right _ -> null noTypeSEs && null noTypeQEs
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes aast)
> $ H.assertBool "" allTyped
> unless (et == got) $ trace (groomTypes aast) $ return ()
> H.assertEqual "" et got
> testScalarExprTypeExtra:: Dialect -> Catalog -> Environment -> L.Text
> -> Either [TypeError] TypeExtra
> -> T.TestTree
> testScalarExprTypeExtra d cat env src ete = H.testCase ("typecheck " ++ L.unpack src) $ do
> let ast = case parseScalarExpr defaultParseFlags {pfDialect = d} "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> aast = typeCheckScalarExpr defaultTypeCheckFlags {tcfDialect = d} cat
> (canonicalizeEnvTypes d env)
> $ canonicalizeTypes d ast
> (ty,errs,noTypeQEs,noTypeSEs) = tcTreeInfo aast
> er = concatMap fst errs
> got = case () of
> _ | null er -> maybe (Left []) Right ty
> | otherwise -> Left er
> allTyped = case ete of
> Left _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Right _ -> null noTypeSEs && null noTypeQEs
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes aast)
> $ H.assertBool "" allTyped
> unless (ete == got) $ trace (groomTypes aast) $ return ()
> H.assertEqual "" ete got
> testImpCastsScalar :: TypeCheckFlags -> L.Text -> L.Text -> T.TestTree
> testImpCastsScalar f src wsrc = H.testCase ("typecheck " ++ L.unpack src) $
> let ast = case parseScalarExpr defaultParseFlags {pfDialect = tcfDialect f} "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> aast = typeCheckScalarExpr f (diDefaultCatalog postgresDialect) emptyEnvironment
> $ canonicalizeTypes (tcfDialect f) ast
> aast' = addExplicitCasts aast
> wast = case parseScalarExpr defaultParseFlags {pfDialect = tcfDialect f} "" Nothing wsrc of
> Left e -> error $ show e
> Right l -> l
> in (if (resetAnnotations aast') /= (resetAnnotations wast)
> then trace ("\n***************** got: \n"
> ++ L.unpack (prettyScalarExpr defaultPrettyFlags aast')
> ++ "\nwanted:\n" ++ L.unpack (prettyScalarExpr defaultPrettyFlags wast)
> ++ "\n*****************\n"
> ++ "\n***************** got: \n"
> ++ groomNoAnns aast'
> ++ "\nwanted:\n" ++ groomNoAnns wast
> ++ "\n*****************\n"
> )
> else id) $ H.assertEqual "" (resetAnnotations aast') (resetAnnotations wast)
> testQueryExprType :: Catalog -> TypeCheckFlags
> -> L.Text -> Either [TypeError] Type -> T.TestTree
> testQueryExprType cat f src et =
> H.testCase ("typecheck " ++ L.unpack src) $ do
> let ast = case parseQueryExpr
> defaultParseFlags {pfDialect = tcfDialect f}
> "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> {-Right cat = updateCatalog cus $ case dl of
> PostgreSQL -> defaultTemplate1Catalog
> SQLServer -> defaultTSQLCatalog
> Oracle -> defaultTSQLCatalog-}
> {-flg = case dl of
> PostgreSQL -> defaultTypeCheckFlags
> SQLServer -> defaultTypeCheckFlags {tcfDialect = SQLServer}
> Oracle -> defaultTypeCheckFlags {tcfDialect = Oracle}-}
> aast = typeCheckQueryExpr f cat
> $ canonicalizeTypes (tcfDialect f) ast
> (ty,errs,noTypeQEs,noTypeSEs) = tcTreeInfo aast
> er = concatMap fst errs
> got :: Either [TypeError] Type
> got = case () of
> _ | null er -> maybe (Left []) (Right . teType) ty
> | otherwise -> Left er
> allTyped = case et of
> Left _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Right _ -> null noTypeSEs && null noTypeQEs
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes aast)
> $ H.assertBool "" allTyped
> unless (et == got) $ trace (groomTypes aast) $ return ()
> H.assertEqual "" et got
> --queryExprRewrites cus src et
> testStatementsTypecheck :: Catalog -> TypeCheckFlags -> L.Text -> Maybe [TypeError] -> T.TestTree
> testStatementsTypecheck cat f src et =
> H.testCase ("typecheck " ++ L.unpack src) $ do
> let ast = case parseStatements defaultParseFlags {pfDialect = tcfDialect f} "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> {-Right cat = updateCatalog cus $ case dl of
> PostgreSQL -> defaultTemplate1Catalog
> SQLServer -> defaultTSQLCatalog
> Oracle -> defaultTSQLCatalog
> flg = case dl of
> PostgreSQL -> defaultTypeCheckFlags
> SQLServer -> defaultTypeCheckFlags {tcfDialect = SQLServer}
> Oracle -> defaultTypeCheckFlags {tcfDialect = Oracle}-}
> (_,aast) = typeCheckStatements f cat
> $ canonicalizeTypes (tcfDialect f) ast
> (_,errs,noTypeQEs,noTypeSEs) = tcTreeInfo aast
> er = concatMap fst errs
> got :: Maybe [TypeError]
> got = case () of
> _ | null er -> Nothing
> | otherwise -> Just er
> allTyped = case et of
> Just _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Nothing -> null noTypeSEs && null noTypeQEs
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes aast)
> $ H.assertBool "" allTyped
> unless (et == got) $ trace (groomTypes aast) $ return ()
> H.assertEqual "" et got
> --queryExprRewrites cus src et
> testInsertQueryExprType :: Dialect -> [CatalogUpdate] -> L.Text -> Either [TypeError] Type -> T.TestTree
> testInsertQueryExprType dl cus src et = H.testCase ("typecheck " ++ L.unpack src) $ do
> let cat = makeCatalog dl cus
> flg = defaultTypeCheckFlags {tcfDialect = dl}
> asts = either (error . show) id $ parseStatements defaultParseFlags "" Nothing src
> Insert _ _ _ q _ = extractInsert $ snd $ typeCheckStatements flg cat
> $ canonicalizeTypes (tcfDialect flg) asts
> q' = addImplicitCasts cat q
> q'' = typeCheckQueryExpr flg cat q'
> (ty,errs,noTypeQEs,noTypeSEs) = tcTreeInfo q''
> er = concatMap fst errs
> got :: Either [TypeError] Type
> got = case () of
> _ | null er -> maybe (Left []) (Right . teType) ty
> | otherwise -> Left er
> allTyped = case et of
> Left _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Right _ -> null noTypeSEs && null noTypeQEs
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes q'')
> $ H.assertBool "" allTyped
> unless (et == got) $ trace (groomTypes q'') $ return ()
> H.assertEqual "" et got
> where
> extractInsert [i@Insert{}] = i
> extractInsert x = error $ "expected a single insert statement, got " ++ groomTypes x
rewrite the queryexpr with all the options true
pretty print, then check that the resultant sql parses the same, and
type checks properly and produces the same type
> _queryExprRewrites :: [CatalogUpdate] -> L.Text -> Either [TypeError] Type -> IO () --Test.Framework.Test
> _queryExprRewrites cus src et = {-testCase ("rewrite expanded " ++ src) $-} do
> let ast = case parseQueryExpr defaultParseFlags "" Nothing src of
> Left e -> error $ "parse: " ++ L.unpack src ++ "\n" ++ show e
> Right l -> l
> let cat = makeCatalog postgresDialect cus
> aast = typeCheckQueryExpr
> defaultTypeCheckFlags {tcfAddQualifiers = True
> ,tcfAddSelectItemAliases = True
> ,tcfExpandStars = True
> ,tcfAddFullTablerefAliases = True}
> cat $ canonicalizeTypes
> (tcfDialect defaultTypeCheckFlags) ast
> ty = anType $ getAnnotation aast
> -- print with rewritten tree
> pp = prettyQueryExpr defaultPrettyFlags aast
> astrw = case parseQueryExpr defaultParseFlags "" Nothing pp of
> Left e -> error $ "parse: " ++ L.unpack pp ++ "\n" ++ show e
> Right l -> l
> aastrw = typeCheckQueryExpr
> defaultTypeCheckFlags
> cat $ canonicalizeTypes
> (tcfDialect defaultTypeCheckFlags) astrw
> tyrw = anType $ getAnnotation aast
> H.assertEqual "rewrite pp . parse" (resetAnnotations aast) (resetAnnotations aastrw)
> H.assertEqual "rewrite ty" ty tyrw
> let (_,errs,noTypeQEs,noTypeSEs) = tcTreeInfo aast
> er = concatMap fst errs
> allTyped = case et of
> Left _ -> True -- don't check if everything is typed
> -- if expecting a type error
> Right _ -> null noTypeSEs && null noTypeQEs
> unless (null er) $
> trace ("errors in tree: " ++ groomTypes aastrw)
> $ H.assertBool "" (null er)
> unless allTyped $
> trace ("MISSING TYPES: " ++ groomTypes aastrw)
> $ H.assertBool "" allTyped
> testRewrite :: TypeCheckFlags -> [CatalogUpdate] -> L.Text -> L.Text
> -> T.TestTree
> testRewrite f cus src src' = H.testCase ("rewrite " ++ L.unpack src) $ do
> let ast = case parseQueryExpr defaultParseFlags {pfDialect = tcfDialect f}
> "" Nothing src of
> Left e -> error $ show e
> Right l -> l
> cat = makeCatalog (tcfDialect f) cus
> aast = typeCheckQueryExpr f cat ast
> astrw = resetAnnotations aast
> ast' = case parseQueryExpr defaultParseFlags "" Nothing src' of
> Left e -> error $ show e
> Right l -> resetAnnotations l
> (if astrw /= ast'
> then trace ("\n***************** expected\n" ++
> L.unpack (prettyQueryExpr defaultPrettyFlags ast')
> ++ "\n" ++ L.unpack (prettyQueryExpr defaultPrettyFlags astrw)
> ++ "\n\n" ++ groomTypes ast'
> ++ "\n\n" ++ groomTypes astrw
> ++ "\n***************** got\n")
> else id) $ H.assertEqual "" ast' astrw
> -- check second rewrite is idempotent
> {-let astrw2 = resetAnnotations $ typeCheckQueryExpr f cat astrw
> (if astrw /= astrw2
> then trace ("\nSECOND REWRITE\n***************** expected\n" ++
> prettyQueryExpr defaultPrettyFlags astrw
> ++ "\n" ++ prettyQueryExpr defaultPrettyFlags astrw2
> ++ "\n\n" ++ groomTypes astrw
> ++ "\n\n" ++ groomTypes astrw2
> ++ "\n***************** got\n")
> else id) $ assertEqual "second rewrite" astrw astrw2-}
> testMatchApp :: Dialect -> Catalog -> [NameComponent]
> -> [(TypeExtra, Maybe LitArg)]
> -> (Either [TypeError] ([TypeExtra],TypeExtra))
> -> T.TestTree
> testMatchApp d cat f as r = H.testCase (show f ++ show as) $
> H.assertEqual "" r $ matchApp d cat f as
> canonicalizeTypes :: Data a => Dialect -> a -> a
> canonicalizeTypes d = transformBi $ \x -> case x of
> ScalarType t -> ScalarType $ canonicalizeTypeName d t
> _ -> x
> canonicalizeEnvTypes :: Data a => Dialect -> a -> a
> canonicalizeEnvTypes d = transformBi $ \x -> case x of
> TypeExtra (ScalarType t) p s n ->
> TypeExtra (ScalarType $ canonicalizeTypeName d t) p s n
> _ -> x
~~~~
TODO
new idea for testing:
parsesql -> ast1
parse, pretty print, parse -> ast2
load into pg, pg_dump, parse -> ast3
parse, pretty print, load into pg, pg_dump, parse -> ast4
check all these asts are the same
~~~~