> 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
~~~~