diff --git a/hssqlppp.cabal b/hssqlppp.cabal --- a/hssqlppp.cabal +++ b/hssqlppp.cabal @@ -1,13 +1,13 @@ Name: hssqlppp -Version: 0.4.1 +Version: 0.4.2 Synopsis: SQL parser and type checker License: BSD3 License-file: LICENSE Author: Jake Wheat Maintainer: jakewheatmail@gmail.com Build-Type: Simple -Cabal-Version: >=1.6 -copyright: Copyright 2009-2011 Jake Wheat +Cabal-Version: >=1.10 +copyright: Copyright 2009-2014 Jake Wheat stability: pre-alpha homepage: http://jakewheat.github.com/hssqlppp/ bug-reports: https://github.com/JakeWheat/hssqlppp/issues @@ -31,15 +31,16 @@ Library Build-Depends: base >= 4 && < 5, - mtl >= 2.0.1.0 && < 2.2, + mtl >= 2.2 && < 2.3, containers >= 0.3.0.0 && < 0.6, parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2, - syb >= 0.1.0.2 && < 0.5, + syb >= 0.4 && < 0.5, uniplate >= 1.6 && < 1.7, - transformers >= 0.2.2.0 && < 0.4, + transformers >= 0.4 && < 0.5, template-haskell + default-language: Haskell2010 hs-source-dirs: src Exposed-modules: Database.HsSqlPpp.Ast Database.HsSqlPpp.Annotation @@ -68,9 +69,74 @@ Database.HsSqlPpp.Internals.AstInternal Database.HsSqlPpp.Internals.TypeType - extensions: TupleSections - DeriveDataTypeable, - ScopedTypeVariables, - PatternGuards, - FlexibleContexts, - TemplateHaskell +Test-Suite Tests + type: exitcode-stdio-1.0 + main-is: Tests.lhs + hs-source-dirs: src, + src-extra/tests, + src-extra/util + Build-Depends: base >=4.6 && <4.8, + mtl >= 2.2 && < 2.3, + containers >= 0.3.0.0 && < 0.6, + parsec >= 3.1 && < 3.2, + pretty >= 1.1 && < 1.2, + syb >= 0.4 && < 0.5, + uniplate >= 1.6 && < 1.7, + transformers >= 0.4 && < 0.5, + template-haskell, + HUnit >= 1.2 && < 1.3, + test-framework >= 0.8 && < 0.9, + test-framework-hunit >= 0.3 && < 0.4, + groom >= 0.1 && < 0.2 + Other-Modules: Database.HsSqlPpp.Tests.TypeChecking.Insert + Database.HsSqlPpp.Tests.TypeChecking.Misc + Database.HsSqlPpp.Tests.TypeChecking.Into + Database.HsSqlPpp.Tests.TypeChecking.Literals + Database.HsSqlPpp.Tests.TypeChecking.RowCtors + Database.HsSqlPpp.Tests.TypeChecking.SpecialFunctions + Database.HsSqlPpp.Tests.TypeChecking.Plpgsql + Database.HsSqlPpp.Tests.TypeChecking.SimpleExpressions + Database.HsSqlPpp.Tests.TypeChecking.MiscExpressions + Database.HsSqlPpp.Tests.TypeChecking.Joins + Database.HsSqlPpp.Tests.TypeChecking.Qualification + Database.HsSqlPpp.Tests.TypeChecking.TableRefTests + Database.HsSqlPpp.Tests.TypeChecking.Update + Database.HsSqlPpp.Tests.TypeChecking.CombineSelects + Database.HsSqlPpp.Tests.TypeChecking.MiscSelects + Database.HsSqlPpp.Tests.TypeChecking.Drops + Database.HsSqlPpp.Tests.TypeChecking.CatalogChaining + Database.HsSqlPpp.Tests.TypeChecking.Delete + Database.HsSqlPpp.Tests.TypeChecking.SelectFrom + Database.HsSqlPpp.Tests.TypeChecking.Creates + Database.HsSqlPpp.Tests.TypeChecking.CaseExpressions + Database.HsSqlPpp.Tests.TypeChecking.TypeCheckTests + Database.HsSqlPpp.Tests.TypeChecking.Utils + Database.HsSqlPpp.Tests.TypeChecking.TypeInferenceTests + Database.HsSqlPpp.Tests.TypeChecking.SimpleSelects + Database.HsSqlPpp.Tests.TypeChecking.TpchTests + Database.HsSqlPpp.Tests.TypeChecking.Triggers + Database.HsSqlPpp.Tests.FixTree.FixUpIdentifiersTests + Database.HsSqlPpp.Tests.FixTree.ExplicitCasts + Database.HsSqlPpp.Tests.Tests + Database.HsSqlPpp.Tests.TestUtils + Database.HsSqlPpp.Tests.QuasiQuoteTests + Database.HsSqlPpp.Tests.Parsing.Dml + Database.HsSqlPpp.Tests.Parsing.Misc + Database.HsSqlPpp.Tests.Parsing.Plpgsql + Database.HsSqlPpp.Tests.Parsing.CreateTable + Database.HsSqlPpp.Tests.Parsing.FunctionsDdl + Database.HsSqlPpp.Tests.Parsing.Selects + Database.HsSqlPpp.Tests.Parsing.ParserTests + Database.HsSqlPpp.Tests.Parsing.Expressions + Database.HsSqlPpp.Tests.Parsing.MiscDdl + Database.HsSqlPpp.Tests.Parsing.Utils + Database.HsSqlPpp.Tests.ParameterizedStatementTests + Database.HsSqlPpp.Tests.TpchData + Database.HsSqlPpp.Utils.Here + Database.HsSqlPpp.Utils.PgUtils + Database.HsSqlPpp.Utils.CatalogReader + + + other-extensions: TupleSections,DeriveDataTypeable + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/ExplicitCasts.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/ExplicitCasts.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/ExplicitCasts.lhs @@ -0,0 +1,85 @@ + +Tests using the tpch queries. Just tests the result type at the +moment. + +> module Database.HsSqlPpp.Tests.FixTree.ExplicitCasts +> (explicitCastTests) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Data.List +> import Control.Monad +> +> --import Database.HsSqlPpp.Utils.Here +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> --import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> --import Database.HsSqlPpp.Utils.PPExpr +> --import Database.HsSqlPpp.Tests.TestUtils +> import Database.HsSqlPpp.Pretty +> --import Database.HsSqlPpp.Tests.TpchData +> import Text.Groom +> import Database.HsSqlPpp.Tests.TestUtils + + +> --import Data.Data +> --import Data.Generics.Uniplate.Data +> --import Database.HsSqlPpp.Ast + +> +> data Item = Group String [Item] +> | Query String String +> +> explicitCastTests :: Test.Framework.Test +> explicitCastTests = itemToTft explicitCastTestData +> +> explicitCastTestData :: Item +> explicitCastTestData = +> Group "explicitcasts" [ +> Query "select a+b from t;" "select (a::float8) + (b::float8) from t;" +> ,Query "select case true when true then 1::int else 1::float4 end;" +> "select case true when true then (1::int)::float4 else 1::float4 end;" +> ,Query "select case when true then 1::int else 1::float4 end;" +> "select case when true then (1::int)::float4 else 1::float4 end;" +> ,Query "select 3::int between 1::float8 and 4::numeric;" +> "select (3::int)::float8 between 1::float8 and (4::numeric)::float8;" +> ,Query "select a from t where c between 1.0 and 1.2" +> "select a from t where c between 1.0::numeric and 1.2::numeric" +> ,Query "select a from t where d in ('a', 'bc')" +> "select a from t where d in ('a'::char, 'bc'::char)" +> ] + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> itemToTft (Query sql sql1) = testCase ("ec " ++ sql) $ do +> --putStrLn $ ppExpr $ ptc sql +> let ast = {-resetAnnotations $-} addExplicitCasts $ ptc sql +> ast1 = {-resetAnnotations $-} canonicalizeTypeNames $ ptc sql1 +> when (resetAnnotations ast /= resetAnnotations ast1) +> $ putStrLn $ printQueryExpr ast +> ++ "\n" ++ printQueryExpr ast1 +> ++ "\n\n" ++ groom ast +> ++ "\n\n" ++ groom ast1 +> ++ "\n\n" +> assertEqual "" (resetAnnotations ast) (resetAnnotations ast1) +> where +> ptc s = typeCheckQueryExpr cat +> $ case parseQueryExpr "" s of +> Left e -> error $ show e +> Right l -> l + +> cat :: Catalog +> cat = case updateCatalog defaultTemplate1Catalog testCatalog of +> Left x -> error $ show x +> Right e -> e + + + +> testCatalog :: [CatalogUpdate] +> testCatalog = [CatCreateTable "t" [("a", typeFloat4) +> ,("b", typeInt) +> ,("c", typeNumeric) +> ,("d", typeChar)] []] diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/FixUpIdentifiersTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/FixUpIdentifiersTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/FixTree/FixUpIdentifiersTests.lhs @@ -0,0 +1,229 @@ + +cd /home/jake/wd/hssqlppp/trunk/src/lib/Database/HsSqlPpp/Internals && uuagc --genlinepragmas -dcfwsp AstInternal.ag && cd /home/jake/wd/hssqlppp/trunk/ && cabal build + +> module Database.HsSqlPpp.Tests.FixTree.FixUpIdentifiersTests +> (fixUpIdentifiersTests) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Data.Generics.Uniplate.Data +> import Control.Monad + +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Ast +> --import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> --import Database.HsSqlPpp.Utils.PPExpr +> --import Database.HsSqlPpp.Tests.TestUtils +> import Database.HsSqlPpp.Pretty +> --import Database.HsSqlPpp.Tests.TpchData +> --import Database.HsSqlPpp.Utils.Here +> import Database.HsSqlPpp.Tests.TestUtils + +> data Item = Group String [Item] +> | Item [CatalogUpdate] String String +> | SItem [CatalogUpdate] String String +> +> fixUpIdentifiersTests :: Test.Framework.Test +> fixUpIdentifiersTests = itemToTft fixUpIdentifiersTestsData +> +> fixUpIdentifiersTestsData :: Item +> fixUpIdentifiersTestsData = Group "cantests" +> [Group "select lists" +> [Item db1 "select a,b from t;" "select t.a as a, t.b as b from t as t(a,b);" +> ,Item db1 "select * from t;" "select t.a as a, t.b as b from t as t(a,b);" +> ,Item db1 "select * from (select a from t) t;" +> "select t.a as a from (select t.a as a from t as t(a,b)) as t(a);" +> ,Item db1 "select * from generate_series(1,5);" +> "select generate_series.generate_series as generate_series\n\ +> \from generate_series(1,5) as generate_series(generate_series);" +> ,Item db1 "select a,c from t,u;" +> "select t.a as a, u.c as c from t as t(a,b),u as u(c,d);" +> ,Item db1 "select * from t,u;" +> "select t.a as a,t.b as b,u.c as c,u.d as d \n\ +> \from t as t(a,b),u as u(c,d);" +> ,Item db1 "select t.* from t,u;" +> "select t.a as a, t.b as b from t as t(a,b),u as u(c,d);" +> ,Item db1 "select u.* from t,u;" +> "select u.c as c,u.d as d from t as t(a,b),u as u(c,d);" +> ,Item db1 "select t.*,u.*,* from t,u;" +> "select t.a as a, t.b as b,\n\ +> \ u.c as c, u.d as d,\n\ +> \ t.a as a, t.b as b, u.c as c, u.d as d\n\ +> \ from t as t(a,b),u as u(c,d);" +> ,Item db1 "select v from v;" "select v.v as v from v as v(v);" +> ,Item db1 "select count(*) from t;" +> "select count(true) as count from t as t(a,b);" +> ] +> ,Group "trefs" +> [Item db1 "select * from generate_series(1,5) g;" +> "select g.g as g\n\ +> \from generate_series(1,5) as g(g);" +> ,Item db1 "select a from t as x;" +> "select x.a as a from t as x(a,b);" +> ,Item db1 "select * from t as x(f,g);" +> "select x.f as f ,x.g as g from t as x(f,g);" +> ] +> ,Group "where" +> [Item db1 "select a,b from t where a > b;" +> "select t.a as a, t.b as b from t as t(a,b) where t.a > t.b;" +> ,Item db1 "select a,c from t,u where b = d;" +> "select t.a as a,u.c as c\n\ +> \ from t as t(a,b),u as u(c,d)\n\ +> \ where t.b = u.d;" +> ] +> ,Group "groupby" +> [Item db1 "select a,sum(b) from t group by a;" +> "select t.a as a,sum(t.b) as sum\n\ +> \from t as t(a,b) group by t.a;" +> ] +> ,Group "having" +> [Item db1 "select a,sum(b) from t group by a having a > b;" +> "select t.a as a,sum(t.b) as sum from t as t(a,b)\n\ +> \group by t.a having t.a > t.b;" +> ] +> ,Group "orderby" +> [Item db1 "select a from t order by b;" +> "select t.a as a from t as t(a,b) order by t.b;" +> ] +> -- fixme: needs some work before these pass +> {-,Group "ctes" +> [Item [] "with ta as (select 1 as a, 2 as b)\n\ +> \select * from ta;" +> +> "with ta(a,b) as (select 1 as a, 2 as b)\n\ +> \select ta.a as a, ta.b as b from ta as ta(a,b);" +> ,Item db1 "/*66642*/with ta as (select 1 as a, 2 as b),\n\ +> \ tb as (select * from t)\n\ +> \select * from ta\n\ +> \union select * from tb;" +> +> "with ta(a,b) as (select 1 as a, 2 as b),\n\ +> \ tb(a,b) as (select t.a as a, t.b as b from t as t(a,b))\n\ +> \select ta.a as a, ta.b as b from ta as ta(a,b)\n\ +> \union select tb.a as a, tb.b as tb from tb as tb(a,b);" + +> ]-} +> ,Group "correlated subqueries" +> [Item db1 +> "select a,b,c,d from t,u where a = c and d =\n\ +> \ (select min(d) from u where a = c);" +> "select t.a as a,t.b as b,\n\ +> \ u.c as c, u.d as d\n\ +> \ from t as t(a,b),u as u(c,d)\n\ +> \ where t.a = u.c and u.d =\n\ +> \ (select min(u.d) as min from u as u(c,d) where t.a = u.c);" + +> ] +> ,Group "funtrefs" +> [Item [] "select * from generate_series(1,7) g\n\ +> \where g not in (select * from generate_series(3,5));" +> "select g.g as g from generate_series(1,7) g(g)\n\ +> \where g.g not in (select generate_series.generate_series as generate_series\n\ +> \ from generate_series(3,5) as generate_series(generate_series));" +> ,Item [] "select g from generate_series(1,7) g\n\ +> \where g not in (select * from generate_series(3,5));" +> "select g.g as g from generate_series(1,7) g(g)\n\ +> \where g.g not in (select generate_series.generate_series as generate_series\n\ +> \ from generate_series(3,5) as generate_series(generate_series));" +> ,Item [] "select g.* from generate_series(1,7) g\n\ +> \where g not in (select * from generate_series(3,5));" +> "select g.g as g from generate_series(1,7) g(g)\n\ +> \where g.g not in (select generate_series.generate_series as generate_series\n\ +> \ from generate_series(3,5) as generate_series(generate_series));" + +> ] +> ,Group "select lists" +> [Item db1 "select a,b,f(a),a::int,a+b,row_number() over (order by a), a as c from t;" +> "select t.a as a,t.b as b,f(t.a) as f,t.a::int as \"int\",t.a+t.b as \"?column?\",row_number() over (order by t.a) as row_number, t.a as c from t as t(a,b);" +> ] +> ,Group "joins" +> [Item db1 "select * from t natural inner join t1;" +> "select t.a as a,t.b as b,t1.c as c \ +> \from t as t(a,b) natural inner join t1 as t1(a,c);" +> ,Item db1 "select * from t inner join t1 using (a);" +> "select t.a as a,t.b as b,t1.c as c \ +> \from t as t(a,b) inner join t1 as t1(a,c) using (a);" +> ,Item db1 "select * from t cross join t1;" +> "select t.a as a,t.b as b,t1.a as a,t1.c as c \ +> \from t as t(a,b) cross join t1 as t1(a,c);" +> ,Item db1 "select t.* from t natural inner join t1;" +> "select t.a as a,t.b as b \ +> \from t as t(a,b) natural inner join t1 as t1(a,c);" +> ,Item db1 "select t1.* from t natural inner join t1;" +> "select t1.a as a,t1.c as c \ +> \from t as t(a,b) natural inner join t1 as t1(a,c);" +> ] +> ,Group "dml" +> [SItem db1 "update t set a = b where a = 5;" +> "update t set a = t.b where t.a = 5;" +> ,SItem db1 "delete from t where a = 0;" +> "delete from t where t.a = 0;"] +> ,Group "returning" +> [SItem db1 "update t set a = 1 returning a;" +> "update t set a = 1 returning t.a as a;" +> ,SItem db1 "insert into t (a,b) values (1,2) returning a,b;" +> "insert into t (a,b) values (1,2) returning t.a as a,t.b as b;" +> ,SItem db1 "delete from t returning a;" +> "delete from t returning t.a as a;"] +> ] + +qualifier and column name the same + + +> db1 :: [CatalogUpdate] +> db1 = [CatCreateTable "t" [("a",typeInt) +> ,("b", typeInt)] [] +> ,CatCreateTable "u" [("c",typeInt) +> ,("d", typeInt)] [] +> ,CatCreateTable "v" [("v",typeInt)] [] +> ,CatCreateTable "t1" [("a",typeInt) +> ,("c", typeInt)] [] +> ] + + +------------------------ + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> itemToTft (Item eu sql esql) = +> itemToTft' parseStatement eu sql esql +> --itemToTft (MSItem eu sql esql) = itemToTft' parseSqlServerQueryExpr eu sql esql +> itemToTft (SItem eu sql esql) = itemToTft' parseStatement eu sql esql + +> parseStatement :: String -> String -> Either ParseErrorExtra Statement +> parseStatement f s = +> let p = parseStatements f s +> in case p of +> Left e -> Left e +> Right [a] -> Right a +> Right _ -> error "wrong number of statements parsed" + +> type P = String -> String -> Either ParseErrorExtra Statement + +> itemToTft' :: P -> [CatalogUpdate] -> String -> String -> Test.Framework.Test +> itemToTft' p eu sql esql = testCase sql $ do +> let eAst = [case p "" esql of +> Left e -> error $ show e +> Right l -> resetAnnotations l] +> ast = [case p "" sql of +> Left e -> error $ show e +> Right l -> resetAnnotations l] +> cAst = fixUpIdentifiers makeCat ast +> c2Ast = fixUpIdentifiers makeCat cAst +> --putStrLn $ printStatements cAst ++ "\n" ++ printStatements c2Ast +> when (eAst /= cAst) $ do +> putStrLn $ "\nExpected:\n\n" ++ printStatements eAst +> putStrLn $ "\nGot:\n\n" ++ printStatements cAst ++ "\n\n" +> when (cAst /= c2Ast) $ do +> putStrLn $ "\nREDO, Expected:\n\n" ++ printStatements cAst +> putStrLn $ "\nGot:\n\n" ++ printStatements c2Ast ++ "\n\n" +> assertEqual "" eAst cAst +> assertEqual "redo" cAst c2Ast +> where +> makeCat = case updateCatalog defaultTemplate1Catalog eu of +> Left x -> error $ show x +> Right e -> e diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/ParameterizedStatementTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/ParameterizedStatementTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/ParameterizedStatementTests.lhs @@ -0,0 +1,153 @@ + +Tests for the infrastructure to create type safe access to databases - +the information needed is gathered during typechecking and exposed in +the StatementType annotation, so these are really just a subset of the +type checking tests. + +> module Database.HsSqlPpp.Tests.ParameterizedStatementTests (parameterizedStatementTests) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Debug.Trace +> import Data.Generics +> import Data.Generics.Uniplate.Data +> +> +> import Database.HsSqlPpp.Types +> import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Catalog +> +> data Item = Group String [Item] +> | Statements [(String, [CatalogUpdate], Maybe ParameterizedStatementType)] +> +> parameterizedStatementTests :: Test.Framework.Test +> parameterizedStatementTests = +> testGroup "parameterized statement tests" $ itemToTft testData +> +> testData :: Item +> testData = +> Group "parameterized statement tests" [ +> Group "simple selects" [ Statements [ +> ("select test();" +> ,[CatCreateFunction FunName "test" [] (Pseudo Void) False] +> ,Just ([],[])) +> ,("select adnum,adbin from pg_attrdef;" +> ,[] +> ,Just ([],[("adnum", ScalarType "int2") +> ,("adbin", ScalarType "pg_node_tree")])) +> ,("select adnum,adbin from pg_attrdef where adnum= ?;" +> ,[] +> ,Just ([ScalarType "int2"],[("adnum", ScalarType "int2") +> ,("adbin", ScalarType "pg_node_tree")])) +> ,("select count(1) from pg_attrdef;" +> ,[] +> ,Just ([],[("count", ScalarType "int8")])) +> {-,("select test($1);" +> ,[CatCreateFunction FunName "test" [ScalarType "int4"] (ScalarType "text") False] +> ,StatementType [ScalarType "int4"] [("test",ScalarType "text")]) +> ,-} +> ,("select test(?);" +> ,[CatCreateFunction FunName "test" [ScalarType "int4"] (ScalarType "text") False] +> ,Just ([ScalarType "int4"],[("test",ScalarType "text")])) +> ] +> ] +> ,Group "simple dml" [ Statements [ +> ("insert into testt values (1, 'test');" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([],[])) +> ,("insert into testt (c1,c2) values (?, ?);" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([typeInt, ScalarType "text"],[])) +> ,("insert into testt (c1,c2) values (1, 'test') returning c1;" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([],[("c1",typeInt)])) +> ,("insert into testt (c1,c2) values (?, ?) returning c1 as d1, c2;" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([typeInt, ScalarType "text"],[("d1", typeInt) +> ,("c2", ScalarType "text")])) +> {-,("insert into testt (c1,c2) values (?, ?) returning *;" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,StatementType [typeInt, ScalarType "text"] [("c1", typeInt) +> ,("c2", ScalarType "text")])-} +> ,("update testt set c1= ?,c2= ? where c1= ? returning c2;" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([typeInt, ScalarType "text", typeInt],[("c2", ScalarType "text")])) +> ,("update testt set (c1,c2) = (?,?);" +> ,[CatCreateTable "testt" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([typeInt, ScalarType "text"],[])) +> ,("delete from blah where c1= ? returning c2;" +> ,[CatCreateTable "blah" [("c1", typeInt) +> ,("c2", ScalarType "text")] []] +> ,Just ([typeInt],[("c2", ScalarType "text")])) +> ] +> ] +> ] + +~~~~ + +select a,b from c where d=e group by f having g=h orderby i limit j offset k; +select function(a,b); +insert into a (b,c) values (d,e) returning f,g +update a set b=c,d=e where f=g returning h,i +delete from t where a=b returning c,d + +rough list of grammar elements to possibly add inference support to: + +where top level - >maybeboolexpr +having +limit, offset +values for table literal or insert +set clause +rowsetclause +onexpr, joinon? +windowfn +liftoperator +selectitem? +castexpression +caseexpression +funcall +inpredicate + + TODO: add support in each of these places for position args only when + doing typecheckPS + do typecheck error if come across ? when not doing typecheckPS + make sure ? fails type check if not in a valid place in the ast +~~~~ + +------------------------------------------------------------------------------- + +> testStatementType :: String -> [CatalogUpdate] -> Maybe ParameterizedStatementType -> Test.Framework.Test +> testStatementType src eu st = testCase ("typecheck " ++ src) $ +> let ast = case parseStatements "" src of +> Left e -> error $ show e +> Right l -> l +> in case typeCheckParameterizedStatement makeCat (head ast) of +> Left e -> error $ show e +> Right aast -> --trace (ppShow aast) $ +> let is = getTopLevelInfo aast +> er = getTypeErrors aast +> in case is of +> _ | not (null er) -> assertFailure $ show er +> is1 -> assertEqual ("typecheck " ++ src) st is1 +> -- _ -> assertFailure ("expected onne statementinfo, got " ++ show is) +> where +> getTypeErrors :: Data a => a -> [TypeError] +> getTypeErrors = universeBi +> getTopLevelInfo a = stType $ getAnnotation a +> makeCat = case updateCatalog defaultTemplate1Catalog eu of +> Left x -> error $ show x +> Right e -> e +> +> itemToTft :: Item -> [Test.Framework.Test] +> itemToTft (Statements es) = map (\(a,b,c) -> testStatementType a b c) es +> itemToTft (Group s is) = [testGroup s $ concatMap itemToTft is] diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/CreateTable.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/CreateTable.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/CreateTable.lhs @@ -0,0 +1,223 @@ + +> {-# LANGUAGE OverloadedStrings #-} +> module Database.HsSqlPpp.Tests.Parsing.CreateTable (createTableParsingTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> createTableParsingTestData:: Item +> createTableParsingTestData = +> Group "create table" [ +> Group "simple tables" [ +> s "create table test (\n\ +> \ fielda text,\n\ +> \ fieldb int\n\ +> \);" +> [CreateTable ea +> (dqi "test") +> [att "fielda" "text" +> ,att "fieldb" "int" +> ] +> []] +> ,s "create table tbl (\n\ +> \ fld boolean default false);" +> [CreateTable ea (dqi "tbl") +> [AttributeDef ea (Nmc "fld") (SimpleTypeName ea "boolean") +> (Just $ BooleanLit ea False) []][]] +> +> ,s "create table tbl as select 1;" +> [CreateTableAs ea (dqi "tbl") +> (selectE (SelectList ea [SelExp ea (NumberLit ea "1")]))] +> +> ,s "alter table a alter column b set default 1;" +> [AlterTable ea (dqi "a") [AlterColumnDefault ea (Nmc "b") (NumberLit ea "1")]] +> +> ,s "alter table a add constraint unique(b);" +> [AlterTable ea (dqi "a") [AddConstraint ea (UniqueConstraint ea "" [Nmc "b"])]] +> ] +> ,Group "constraints" [ +> Group "nulls" [ +> s "create table t1 (\n\ +> \ a text null\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "a") (SimpleTypeName ea "text") +> Nothing [NullConstraint ea ""]] +> []] +> ,s "create table t1 (\n\ +> \ a text not null\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "a") (SimpleTypeName ea "text") +> Nothing [NotNullConstraint ea ""]] +> []] +> ] +> +> ,Group "unique" [ +> s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ unique (x,y)\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [UniqueConstraint ea "" [Nmc "x",Nmc "y"]]] + +test arbitrary ordering + +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ unique (x),\n\ +> \ y int\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [UniqueConstraint ea "" [Nmc "x"]]] + +unique row + +> ,s "create table t1 (\n\ +> \ x int unique\n\ +> \);" +> [CreateTable ea (dqi "t1") +> [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowUniqueConstraint ea ""]][]] +> +> ,s "create table t1 (\n\ +> \ x int unique not null\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowUniqueConstraint ea "" +> ,NotNullConstraint ea ""]][]] + +quick sanity check + +> ,s "create table t1 (\n\ +> \ x int not null unique\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [NotNullConstraint ea "" +> ,RowUniqueConstraint ea ""]][]] +> ] +> +> ,Group "primary key" [ +> s "create table t1 (\n\ +> \ x int primary key\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowPrimaryKeyConstraint ea ""]][]] +> +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ primary key (x,y)\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [PrimaryKeyConstraint ea "" [Nmc "x", Nmc "y"]]] +> ] +> +> ,Group "check" [ +> s "create table t (\n\ +> \f text check (f in('a', 'b'))\n\ +> \);" +> [CreateTable ea (dqi "t") +> [AttributeDef ea (Nmc "f") (SimpleTypeName ea "text") Nothing +> [RowCheckConstraint ea "" (InPredicate ea +> (Identifier ea "f") True +> (InList ea [stringQ "a", stringQ "b"]))]] []] +> +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ check (x>y)\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [CheckConstraint ea "" (FunCall ea (name ">") [Identifier ea "x", Identifier ea "y"])]] +> ] +> +> ,Group "misc" [ +> s "create table t (\n\ +> \f text not null unique check (f in('a', 'b'))\n\ +> \);" +> [CreateTable ea (dqi "t") +> [AttributeDef ea (Nmc "f") (SimpleTypeName ea "text") Nothing +> [NotNullConstraint ea "" +> ,RowUniqueConstraint ea "" +> ,RowCheckConstraint ea "" (InPredicate ea +> (Identifier ea "f") True +> (InList ea [stringQ "a" +> ,stringQ "b"]))]] []] +> ] + +> ,Group "references" [ +> s "create table t1 (\n\ +> \ x int references t2\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowReferenceConstraint ea "" (dqi "t2") Nothing +> Restrict Restrict]][]] +> +> ,s "create table t1 (\n\ +> \ x int references t2(y)\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowReferenceConstraint ea "" (dqi "t2") (Just $ Nmc "y") +> Restrict Restrict]][]] +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ foreign key (x,y) references t2\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [ReferenceConstraint ea "" [Nmc "x", Nmc "y"] (dqi "t2") [] +> Restrict Restrict]] +> +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ foreign key (x,y) references t2(z,w)\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [ReferenceConstraint ea "" [Nmc "x", Nmc "y"] (dqi "t2") [Nmc "z", Nmc "w"] +> Restrict Restrict]] +> +> ,s "create table t1 (\n\ +> \ x int references t2 on delete cascade\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowReferenceConstraint ea "" (dqi "t2") Nothing +> Cascade Restrict]][]] +> +> ,s "create table t1 (\n\ +> \ x int references t2 on update cascade\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowReferenceConstraint ea "" (dqi "t2") Nothing +> Restrict Cascade]][]] +> +> ,s "create table t1 (\n\ +> \ x int references t2 on delete cascade on update cascade\n\ +> \);" +> [CreateTable ea (dqi "t1") [AttributeDef ea (Nmc "x") (SimpleTypeName ea "int") Nothing +> [RowReferenceConstraint ea "" (dqi "t2") Nothing +> Cascade Cascade]][]] +> +> ,s "create table t1 (\n\ +> \ x int,\n\ +> \ y int,\n\ +> \ foreign key (x,y) references t2 on update cascade on delete cascade\n\ +> \);" +> [CreateTable ea (dqi "t1") [att "x" "int" +> ,att "y" "int"] +> [ReferenceConstraint ea "" [Nmc "x", Nmc "y"] (dqi "t2") [] +> Cascade Cascade]] +> +> ] +> ] +> ] + +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Dml.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Dml.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Dml.lhs @@ -0,0 +1,126 @@ + +> {-# LANGUAGE OverloadedStrings #-} +> module Database.HsSqlPpp.Tests.Parsing.Dml (dmlParsingTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +TODO: + +from in update, using in delete (+ type check these) + +> dmlParsingTestData:: Item +> dmlParsingTestData = +> Group "dml" [ +> Group "insert" [ +> s "insert into testtable\n\ +> \(columna,columnb)\n\ +> \values (1,2);\n" +> [Insert ea +> (dqi "testtable") +> [Nmc "columna", Nmc "columnb"] +> (Values ea [[NumberLit ea "1", NumberLit ea "2"]]) +> Nothing] + +multi row insert, test the stand alone values statement first, maybe +that should be in the select section? + +> ,s "values (1,2), (3,4);" +> [QueryStatement ea $ Values ea [[NumberLit ea "1", NumberLit ea "2"] +> ,[NumberLit ea "3", NumberLit ea "4"]]] +> +> ,s "insert into testtable\n\ +> \(columna,columnb)\n\ +> \values (1,2), (3,4);\n" +> [Insert ea +> (dqi "testtable") +> [Nmc "columna", Nmc "columnb"] +> (Values ea [[NumberLit ea "1", NumberLit ea "2"] +> ,[NumberLit ea "3", NumberLit ea "4"]]) +> Nothing] + +insert from select + +> ,s "insert into a\n\ +> \ select b from c;" +> [Insert ea (dqi "a") [] +> (selectFrom [selI "b"] (Tref ea (i "c") (NoAlias ea))) +> Nothing] +> +> ,s "insert into testtable\n\ +> \(columna,columnb)\n\ +> \values (1,2) returning id;\n" +> [Insert ea +> (dqi "testtable") +> [Nmc "columna", Nmc "columnb"] +> (Values ea [[NumberLit ea "1", NumberLit ea "2"]]) +> (Just $ sl [selI "id"])] +> ] +> +> ,Group "update" [ +> s "update tb\n\ +> \ set x = 1, y = 2;" +> [Update ea (dqi "tb") [SetClause ea (Nmc "x") $ NumberLit ea "1" +> ,SetClause ea (Nmc "y") $ NumberLit ea "2"] +> [] Nothing Nothing] +> ,s "update tb\n\ +> \ set x = 1, y = 2 where z = true;" +> [Update ea (dqi "tb") [SetClause ea (Nmc "x") $ NumberLit ea "1" +> ,SetClause ea (Nmc "y") $ NumberLit ea "2"] +> [] +> (Just $ FunCall ea (name "=") +> [Identifier ea "z", BooleanLit ea True]) +> Nothing] +> ,s "update tb\n\ +> \ set x = 1, y = 2 returning id;" +> [Update ea (dqi "tb") [SetClause ea (Nmc "x") $ NumberLit ea "1" +> ,SetClause ea (Nmc "y") $ NumberLit ea "2"] +> [] Nothing (Just $ sl [selI "id"])] +> ,s "update tb\n\ +> \ set (x,y) = (1,2);" +> [Update ea (dqi "tb") +> [MultiSetClause ea [Nmc "x",Nmc "y"] +> $ FunCall ea (name "!rowctor") [NumberLit ea "1" +> ,NumberLit ea "2"]] +> [] +> Nothing Nothing] +> ] + +FunCall ea "=" [FunCall ea "!rowctor" [Identifier ea "x",Identifier ea "y"],FunCall ea "!rowctor" [NumberLit ea "1",NumberLit ea "2"]]) + + +> +> ,Group "delete" [ +> s "delete from tbl1 where x = true;" +> [Delete ea (dqi "tbl1") [] (Just $ FunCall ea (name "=") +> [Identifier ea "x", BooleanLit ea True]) +> Nothing] +> ,s "delete from tbl1 where x = true returning id;" +> [Delete ea (dqi "tbl1") [] (Just $ FunCall ea (name "=") +> [Identifier ea "x", BooleanLit ea True]) +> (Just $ sl [selI "id"])] +> ] +> +> ,Group "truncate" [ +> s "truncate test;" +> [Truncate ea [dqi "test"] ContinueIdentity Restrict] +> +> ,s "truncate table test, test2 restart identity cascade;" +> [Truncate ea [dqi "test",dqi "test2"] RestartIdentity Cascade] +> ] + +copy, bit crap at the moment + +> ,Group "copy" [ +> s "copy tbl(a,b) from stdin;\n\ +> \bat\tt\n\ +> \bear\tf\n\ +> \\\.\n" +> [Copy ea (dqi "tbl") [Nmc "a", Nmc "b"] Stdin +> ,CopyData ea "\ +> \bat\tt\n\ +> \bear\tf\n"] +> ]] +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Expressions.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Expressions.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Expressions.lhs @@ -0,0 +1,224 @@ + +> {-# LANGUAGE QuasiQuotes,OverloadedStrings #-} +> +> module Database.HsSqlPpp.Tests.Parsing.Expressions (expressionParsingTestData) where +> +> import Database.HsSqlPpp.Utils.Here +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> expressionParsingTestData:: Item +> expressionParsingTestData = +> Group "parse expressions" [ +> Group "numbers" [ +> e "42" (num "42") +> ,e "3.5" (num "3.5") +> ,e "4." (num "4.") +> ,e ".001" (num ".001") +> ,e "5e2" (num "5e2") +> ,e "1.925e-3" (num "1.925e-3") + +> ] +> ,Group "basic expressions" [ +> e "1" (num "1") +> ,e "-1" (funCall "u-" [num "1"]) +> ,e "1.1" (num "1.1") +> ,e "-1.1" (funCall "u-" [num "1.1"]) +> ,e " 1 + 1 " (funCall "+" [num "1" +> ,num "1"]) +> ,e "1+1+1" (funCall "+" [funCall "+" [num "1" +> ,num "1"] +> ,num "1"]) +> ] +> ,Group "parens" [ + +check some basic parens use wrt naked values and row constructors +these tests reflect how pg seems to interpret the variants. + +> e "(1)" (num "1") +> ,e "row ()" (funCall "!rowctor" []) +> ,e "row (1)" (funCall "!rowctor" [num "1"]) +> ,e "row (1,2)" (funCall "!rowctor" [num "1",num "2"]) +> ,e "(1,2)" (funCall "!rowctor" [num "1",num "2"]) +> ] +> ,Group "more basic expressions" [ + +test some more really basic expressions + +> e "'test'" (stringQ "test") +> ,e "''" (stringQ "") +> ,e "hello" (ei "hello") +> ,e "helloTest" (ei "helloTest") +> ,e "hello_test" (ei "hello_test") +> ,e "\"this is an identifier\"" +> (Identifier ea (QNmc "this is an identifier")) +> ,e "hello1234" (ei "hello1234") +> ,e "true" lTrue +> ,e "false" lFalse +> ,e "null" lNull +> ] +> ,Group "array ctor and selector" [ +> e "array[1,2]" (funCall "!arrayctor" [num "1", num "2"]) +> ,e "a[1]" (funCall "!arraysub" [ei "a", num "1"]) +> ] +> ,Group "simple operators" [ +> e "1 + tst1" (funCall "+" [num "1" +> ,ei "tst1"]) +> ,e "tst1 + 1" (funCall "+" [ei "tst1" +> ,num "1"]) +> ,e "tst + tst1" (funCall "+" [ei "tst" +> ,ei "tst1"]) +> ,e "'a' || 'b'" (funCall "||" [stringQ "a" +> ,stringQ "b"]) +> ,e "'stuff'::text" +> (Cast ea (stringQ "stuff") (SimpleTypeName ea "text")) +> ,e "245::float(24)" (Cast ea (num "245") (PrecTypeName ea "float" 24)) +> ,e "245.1::numeric(5,3)" +> (Cast ea (num "245.1") (Prec2TypeName ea "numeric" 5 3)) +> ,e "245::double precision" +> (Cast ea (num "245") (SimpleTypeName ea "double precision")) +> ,e "date '1998-12-01'" +> (TypedStringLit ea (SimpleTypeName ea "date") "1998-12-01") +> ,e "interval '63' day" (Interval ea "63" IntervalDay Nothing) +> ,e "interval '63' day (3)" (Interval ea "63" IntervalDay $ Just 3) +> ,e "extract(year from a)" (Extract ea ExtractYear $ ei "a") +> ,e "a between 1 and 3" +> (funCall "!between" [ei "a", num "1", num "3"]) +> ,e "a between 7 - 1 and 7 + 1" +> (funCall "!between" [ei "a" +> ,funCall "-" [num "7" +> ,num "1"] +> ,funCall "+" [num "7" +> ,num "1"]]) +> ,e "cast(a as text)" +> (Cast ea (ei "a") (SimpleTypeName ea "text")) +> ,e "@ a" +> (funCall "@" [ei "a"]) +> ,e "substring(a from 0 for 3)" +> (funCall "!substring" [ei "a", num "0", num "3"]) +> ,e "substring(a from 0 for (5 - 3))" +> (funCall "!substring" [ei "a" +> ,num "0" +> ,funCall "-" [num "5",num "3"]]) +> ,e "substring(a,b,c)" +> (funCall "substring" [ei "a" +> ,ei "b" +> ,ei "c"]) +> ,e "a like b" +> (funCall "!like" [ei "a", ei "b"]) +> ,e "a not like b" +> (funCall "!notlike" [ei "a", ei "b"]) +> , e "a and b and c and d" +> (funCall "!and" +> [funCall "!and" +> [funCall "!and" [ei "a" +> ,ei "b"] +> ,ei "c"] +> ,ei "d"]) +> ] +> ,Group "function calls" [ +> e "fn()" (funCall "fn" []) +> ,e "fn(1)" (funCall "fn" [num "1"]) +> ,e "fn('test')" (funCall "fn" [stringQ "test"]) +> ,e "fn(1,'test')" (funCall "fn" [num "1", stringQ "test"]) +> ,e "fn('test')" (funCall "fn" [stringQ "test"]) +> ] +> ,Group "simple whitespace sanity checks" [ +> e "fn (1)" (funCall "fn" [num "1"]) +> ,e "fn( 1)" (funCall "fn" [num "1"]) +> ,e "fn(1 )" (funCall "fn" [num "1"]) +> ,e "fn(1) " (funCall "fn" [num "1"]) +> ] +> ,Group "null stuff" [ +> e "not null" (funCall "!not" [lNull]) +> ,e "a is null" (funCall "!isnull" [ei "a"]) +> ,e "a is not null" (funCall "!isnotnull" [ei "a"]) +> ,e "not not true" (funCall "!not" +> [funCall "!not" +> [lTrue]]) +> ] + +> ,Group "case expressions" [ +> e [here| +> case when a,b then 3 +> when c then 4 +> else 5 +> end +> |] +> (Case ea [([ei "a", ei "b"], num "3") +> ,([ei "c"], num "4")] +> (Just $ num "5")) +> ,e "case 1 when 2 then 3 else 4 end" +> (CaseSimple ea (num "1") +> [([num "2"], num "3")] +> (Just $ num "4")) +> ] +> ,Group "positional args" [ +> e "$1" (PositionalArg ea 1) +> ,e "?" (Placeholder ea) +> ,e "a = ?" (funCall "=" [ei "a",Placeholder ea]) +> ] +> ,Group "exists" [ +> e "exists (select 1 from a)" +> (Exists ea (selectFrom [SelExp ea (num "1")] +> (Tref ea (i "a") (NoAlias ea)))) +> ] +> ,Group "in variants" [ +> e "t in (1,2)" +> (InPredicate ea (ei "t") True (InList ea [num "1",num "2"])) +> ,e "t not in (1,2)" +> (InPredicate ea (ei "t") False (InList ea [num "1",num "2"])) +> ,e "(t,u) in (1,2)" +> (InPredicate ea (funCall "!rowctor" [ei "t",ei "u"]) True +> (InList ea [num "1",num "2"])) +> ,e "3 = any (array[1,2])" +> (LiftOperator ea "=" LiftAny [num "3" +> ,funCall "!arrayctor" [num "1" +> ,num "2"]]) +> ,e "3 = all (array[1,2,4])" +> (LiftOperator ea "=" LiftAll [num "3" +> ,funCall "!arrayctor" [num "1" +> ,num "2" +> ,num "4"]]) +> ] +> ,Group "comparison operators" [ +> e "a < b" +> (funCall "<" [ei "a", ei "b"]) +> ,e "a <> b" +> (funCall "<>" [ei "a", ei "b"]) +> ,e "a != b" +> (funCall "<>" [ei "a", ei "b"]) +> ] + +test some string parsing, want to check single quote behaviour, +and dollar quoting, including nesting. + +> ,Group "string parsing" [ +> e "''" (stringQ "") +> ,e "''''" (stringQ "'") +> ,e "'test'''" (stringQ "test'") +> ,e "'''test'" (stringQ "'test") +> ,e "'te''st'" (stringQ "te'st") +> ,e "$$test$$" (StringLit ea "test") +> ,e "$$te'st$$" (StringLit ea "te'st") +> ,e "$st$test$st$" (StringLit ea "test") +> ,e "$outer$te$$yup$$st$outer$" (StringLit ea "te$$yup$$st") +> ,e "'spl$$it'" (stringQ "spl$$it") +> ] +> ,Group "bracketed things" [ +> e "(p).x" (eqi "p" "x") +> ,e "(select f(((a).x, y)::z))" +> (ScalarSubQuery ea +> (selectE (sl +> [SelExp ea +> (funCall "f" [Cast ea +> (funCall "!rowctor" +> [eqi "a" "x" +> ,ei "y"]) +> (SimpleTypeName ea "z")])]))) +> ] +> ] +> where +> e = Expr diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/FunctionsDdl.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/FunctionsDdl.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/FunctionsDdl.lhs @@ -0,0 +1,146 @@ + + +> {-# LANGUAGE OverloadedStrings #-} +> module Database.HsSqlPpp.Tests.Parsing.FunctionsDdl (functionsDdlParsingTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> functionsDdlParsingTestData:: Item +> functionsDdlParsingTestData = +> Group "functionsddl" [ +> Group "basics" [ +> s "create function t1(text) returns text as $$\n\ +> \select a from t1 where b = $1;\n\ +> \$$ language sql stable;" +> [CreateFunction ea (dqi "t1") [ParamDefTp ea $ SimpleTypeName ea "text"] +> (SimpleTypeName ea "text") NoReplace Sql +> (SqlFnBody ea +> [QueryStatement ea $ selectFromWhere [SelExp ea (Identifier ea "a")] (Tref ea (i "t1") (NoAlias ea)) +> (FunCall ea (name "=") +> [Identifier ea "b", PositionalArg ea 1])]) +> Stable] +> ,s "create function fn() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql volatile;" +> [CreateFunction ea (dqi "fn") [] (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea (Block ea Nothing [VarDef ea (Nmc "a") (SimpleTypeName ea "int") Nothing +> ,VarDef ea (Nmc "b") (SimpleTypeName ea "text") Nothing] +> [NullStatement ea])) +> Volatile] +> ,s "create function fn() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql volatile;" +> [CreateFunction ea (dqi "fn") [] (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea +> (Block ea Nothing [VarDef ea (Nmc "a") (SimpleTypeName ea "int") Nothing +> ,VarDef ea (Nmc "b") (SimpleTypeName ea "text") Nothing] +> [NullStatement ea])) +> Volatile] +> ,s "create function fn(a text[]) returns int[] as $$\n\ +> \declare\n\ +> \ b xtype[] := '{}';\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql immutable;" +> [CreateFunction ea (dqi "fn") +> [ParamDef ea (Nmc "a") $ ArrayTypeName ea $ SimpleTypeName ea "text"] +> (ArrayTypeName ea $ SimpleTypeName ea "int") NoReplace Plpgsql +> (PlpgsqlFnBody ea +> (Block ea Nothing +> [VarDef ea (Nmc "b") (ArrayTypeName ea $ SimpleTypeName ea "xtype") (Just $ stringQ "{}")] +> [NullStatement ea])) +> Immutable] +> ,s "create function fn() returns void as '\n\ +> \declare\n\ +> \ a int := 3;\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \' language plpgsql stable;" +> [CreateFunction ea (dqi "fn") [] (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea +> (Block ea Nothing +> [VarDef ea (Nmc "a") (SimpleTypeName ea "int") (Just $ NumberLit ea "3")] +> [NullStatement ea])) +> Stable] +> ,s "create function fn(int) returns void as '\n\ +> \declare\n\ +> \ a alias for $1;\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \' language plpgsql stable;" +> [CreateFunction ea (dqi "fn") +> [ParamDefTp ea $ SimpleTypeName ea "int"] +> (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea +> (Block ea Nothing +> [ParamAlias ea (Nmc "a") 1] +> [NullStatement ea])) +> Stable] +> ,s "create function fn(b int) returns void as '\n\ +> \declare\n\ +> \ a alias for b;\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \' language plpgsql stable;" +> [CreateFunction ea (dqi "fn") +> [ParamDef ea (Nmc "b") $ SimpleTypeName ea "int"] +> (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea +> (Block ea Nothing +> [VarAlias ea (Nmc "a") (dqi "b")] +> [NullStatement ea])) +> Stable] +> ,s "create function fn() returns setof int as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> [CreateFunction ea (dqi "fn") [] +> (SetOfTypeName ea $ SimpleTypeName ea "int") NoReplace Plpgsql +> (PlpgsqlFnBody ea (Block ea Nothing [] [NullStatement ea])) +> Stable] +> ,s "create function fn() returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end\n\ +> \$$ language plpgsql stable;" +> [CreateFunction ea (dqi "fn") [] +> (SimpleTypeName ea "void") NoReplace Plpgsql +> (PlpgsqlFnBody ea (Block ea Nothing [] [NullStatement ea])) +> Stable] +> ,s "create or replace function fn() returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end\n\ +> \$$ language plpgsql stable;" +> [CreateFunction ea (dqi "fn") [] +> (SimpleTypeName ea "void") Replace Plpgsql +> (PlpgsqlFnBody ea (Block ea Nothing [] [NullStatement ea])) +> Stable] +> ,s "drop function test(text);" +> [DropFunction ea Require [(dqi "test",[SimpleTypeName ea "text"])] Restrict] +> ,s "drop function test(int,int);" +> [DropFunction ea Require [(dqi "test",[SimpleTypeName ea "int" +> ,SimpleTypeName ea "int"])] Restrict] +> ,s "drop function if exists a(),test(text) cascade;" +> [DropFunction ea IfExists [(dqi "a",[]) +> ,(dqi "test",[SimpleTypeName ea "text"])] Cascade] +> ]] +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Misc.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Misc.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Misc.lhs @@ -0,0 +1,63 @@ + +The automated tests, uses hunit to check a bunch of text expressions +and sql statements parse to the correct tree, and then checks pretty +printing and then reparsing gives the same tree. The code was mostly +written almost in tdd style, which the order/ coverage of these tests +reflects. + +There are no tests for invalid syntax at the moment. + +> module Database.HsSqlPpp.Tests.Parsing.Misc (miscParserTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils +> +> miscParserTestData :: Item +> miscParserTestData = +> Group "miscParserTests" [ + +> Group "multiple statements" [ +> s "select 1;\nselect 2;" [QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "1")] +> ,QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "2")]] +> ] +> ,Group "comments" [ +> s "" [] +> ,s "-- this is a test" [] +> ,s "/* this is\n\ +> \a test*/" [] +> ,s "select 1;\n\ +> \-- this is a test\n\ +> \select -- this is a test\n\ +> \2;" [QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "1")] +> ,QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "2")] +> ] +> ,s "select 1;\n\ +> \/* this is\n\ +> \a test*/\n\ +> \select /* this is a test*/2;" +> [QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "1")] +> ,QueryStatement ea $ selectE $ sl [SelExp ea (NumberLit ea "2")] +> ] +> ] + +-------------------------------------------------------------------------------- + +ddl statements + + +> ,Group "misc" [ +> s "SET search_path TO my_schema, public;" +> [Set ea "search_path" [SetId ea "my_schema" +> ,SetId ea "public"]] +> ,s "SET t1 = 3;" +> [Set ea "t1" [SetNum ea 3]] +> ,s "SET t1 = 'stuff';" +> [Set ea "t1" [SetStr ea "stuff"]] +> ,s "create language plpgsql;" +> [CreateLanguage ea "plpgsql"] +> +> ] +> ] +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/MiscDdl.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/MiscDdl.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/MiscDdl.lhs @@ -0,0 +1,63 @@ + +> {-# LANGUAGE OverloadedStrings #-} +> module Database.HsSqlPpp.Tests.Parsing.MiscDdl (miscDdlParsingTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> miscDdlParsingTestData:: Item +> miscDdlParsingTestData = +> Group "misc ddl" [ +> Group "misc create" [ +> s "create view v1 as\n\ +> \select a,b from t;" +> [CreateView ea +> (dqi "v1") Nothing +> (selectFrom [selI "a", selI "b"] (Tref ea (i "t") (NoAlias ea)))] +> ,s "create view v1(c,d) as\n\ +> \select a,b from t;" +> [CreateView ea +> (dqi "v1") (Just [Nmc "c",Nmc "d"]) +> (selectFrom [selI "a", selI "b"] (Tref ea (i "t") (NoAlias ea)))] +> ,s "create domain td as text check (value in ('t1', 't2'));" +> [CreateDomain ea (dqi "td") (SimpleTypeName ea "text") "" +> (Just (InPredicate ea (Identifier ea "value") True +> (InList ea [stringQ "t1" ,stringQ "t2"])))] +> ,s "create type tp1 as (\n\ +> \ f1 text,\n\ +> \ f2 text\n\ +> \);" +> [CreateType ea (dqi "tp1") [TypeAttDef ea (Nmc "f1") (SimpleTypeName ea "text") +> ,TypeAttDef ea (Nmc "f2") (SimpleTypeName ea "text")]] +> +> ,s "create sequence s start with 5 increment by 4 no maxvalue no minvalue cache 1;" +> [CreateSequence ea (dqi "s") 4 1 ((2::Integer) ^ (63::Integer) - 1) 5 1] +> +> ,s "alter sequence s owned by a.b;" +> [AlterSequence ea (dqi "s") $ qi "a" "b"] +> +> ,s "create trigger tr\n\ +> \after insert or delete on tb\n\ +> \for each statement\n\ +> \execute procedure fb();" +> [CreateTrigger ea (Nmc "tr") TriggerAfter [TInsert,TDelete] (dqi "tb") EachStatement (dqi "fb") []] +> ] +> +> ,Group "drops" [ +> s "drop domain t;" +> [DropSomething ea Domain Require [dqi "t"] Restrict] +> ,s "drop domain if exists t,u cascade;" +> [DropSomething ea Domain IfExists [dqi "t", dqi "u"] Cascade] +> ,s "drop domain t restrict;" +> [DropSomething ea Domain Require [dqi "t"] Restrict] +> +> ,s "drop type t;" +> [DropSomething ea Type Require [dqi "t"] Restrict] +> ,s "drop table t;" +> [DropSomething ea Table Require [dqi "t"] Restrict] +> ,s "drop view t;" +> [DropSomething ea View Require [dqi "t"] Restrict] +> ]] +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/ParserTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/ParserTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/ParserTests.lhs @@ -0,0 +1,112 @@ + +The automated tests, uses hunit to check a bunch of text expressions +and sql statements parse to the correct tree, and then checks pretty +printing and then reparsing gives the same tree. The code was mostly +written almost in tdd style, which the order/ coverage of these tests +reflects. + +There are no tests for invalid syntax at the moment. + +> module Database.HsSqlPpp.Tests.Parsing.ParserTests +> (parserTests +> ,parserTestData +> ,Item(..) +> ) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> import Data.Generics +> +> import Database.HsSqlPpp.Ast +> --import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.Pretty +> + +> import Database.HsSqlPpp.Tests.Parsing.Utils +> import Database.HsSqlPpp.Tests.Parsing.Expressions +> import Database.HsSqlPpp.Tests.Parsing.Selects +> import Database.HsSqlPpp.Tests.Parsing.Dml +> import Database.HsSqlPpp.Tests.Parsing.CreateTable +> import Database.HsSqlPpp.Tests.Parsing.MiscDdl +> import Database.HsSqlPpp.Tests.Parsing.FunctionsDdl +> import Database.HsSqlPpp.Tests.Parsing.Plpgsql +> import Database.HsSqlPpp.Tests.Parsing.Misc + +> import Database.HsSqlPpp.Tests.TestUtils + +> parserTests :: Test.Framework.Test +> parserTests = itemToTft parserTestData +> +> parserTestData :: Item +> parserTestData = +> Group "parserTests" [ +> expressionParsingTestData +> ,selectParsingTestData +> ,dmlParsingTestData +> ,Group "ddl" [createTableParsingTestData +> ,miscDdlParsingTestData +> ,functionsDdlParsingTestData] +> ,pgplsqlParsingTestData +> ,miscParserTestData +> ] + +-------------------------------------------------------------------------------- + +Unit test helpers + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Expr a b) = testParseScalarExpr a b +> itemToTft (PgSqlStmt a b) = testParsePlpgsqlStatements a b +> itemToTft (Stmt a b) = testParseStatements a b +> --itemToTft (MSStmt a b) = testParseStatements a b +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> +> testParseScalarExpr :: String -> ScalarExpr -> Test.Framework.Test +> testParseScalarExpr src ast = +> parseUtil src ast (parseScalarExpr "") (parseScalarExpr "") printScalarExpr +> +> testParseStatements :: String -> [Statement] -> Test.Framework.Test +> testParseStatements src ast = +> parseUtil src ast (parseStatements "") (parseStatements "") printStatements +> +> {-testParseMSStatements :: String -> [Statement] -> Test.Framework.Test +> testParseMSStatements src ast = +> parseUtil src ast parseMsQuery (parseStatements "") printStatements +> where +> parseMsQuery :: String -> Either ParseErrorExtra [Statement] +> parseMsQuery s = +> (\p' -> [QueryStatement ea p']) +> `fmap` parseSqlServerQueryExpr "" s-} + +> +> testParsePlpgsqlStatements :: String -> [Statement] -> Test.Framework.Test +> testParsePlpgsqlStatements src ast = +> parseUtil src ast (parsePlpgsql "") (parsePlpgsql "") printStatements +> +> parseUtil :: (Show t, Eq b, Show b, Data b) => +> String +> -> b +> -> (String -> Either t b) +> -> (String -> Either t b) +> -> (b -> String) +> -> Test.Framework.Test +> parseUtil src ast parser reparser printer = testCase ("parse " ++ src) $ +> case parser src of +> Left er -> assertFailure $ show er +> Right ast' -> do +> assertEqual ("parse " ++ src) ast $ resetAnnotations ast' +> case reparser (printer ast) of +> Left er -> assertFailure $ "reparse\n" ++ show er ++ "\n" -- ++ pp ++ "\n" +> Right ast'' -> assertEqual ("reparse " ++ printer ast) ast $ resetAnnotations ast'' + +~~~~ +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 +~~~~ diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Plpgsql.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Plpgsql.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Plpgsql.lhs @@ -0,0 +1,152 @@ + + +> {-# LANGUAGE OverloadedStrings #-} +> module Database.HsSqlPpp.Tests.Parsing.Plpgsql (pgplsqlParsingTestData) where +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> pgplsqlParsingTestData:: Item +> pgplsqlParsingTestData = +> Group "plpgsql" [ +> Group "simple plpgsql statements" [ +> f "success := true;" +> [Assignment ea (Name ea ["success"]) (BooleanLit ea True)] +> ,f "success = true;" +> [Assignment ea (Name ea ["success"]) (BooleanLit ea True)] +> ,f "return true;" +> [Return ea $ Just (BooleanLit ea True)] +> ,f "return;" +> [Return ea Nothing] +> ,f "return next 1;" +> [ReturnNext ea $ NumberLit ea "1"] +> ,f "return query select a from b;" +> [ReturnQuery ea $ selectFrom [selI "a"] (Tref ea (i "b") (NoAlias ea))] +> ,f "raise notice 'stuff %', 1;" +> [Raise ea RNotice "stuff %" [NumberLit ea "1"]] +> ,f "perform test();" +> [Perform ea $ FunCall ea (name "test") []] +> ,f "perform test(a,b);" +> [Perform ea $ FunCall ea (name "test") [Identifier ea "a", Identifier ea "b"]] +> ,f "perform test(r.relvar_name || '_and_stuff');" +> [Perform ea $ FunCall ea (name "test") [ +> FunCall ea (name "||") [eqi "r" "relvar_name" +> ,stringQ "_and_stuff"]]] +> ,f "select into a,b c,d from e;" +> [Into ea False [name "a", name "b"] +> $ QueryStatement ea $ Select ea Dupes (SelectList ea [selI "c", selI "d"]) +> [Tref ea (i "e") (NoAlias ea)] Nothing [] Nothing [] Nothing Nothing] +> ,f "select c,d into a,b from e;" +> [Into ea False [name "a", name "b"] +> $ QueryStatement ea $ Select ea Dupes (SelectList ea [selI "c", selI "d"]) +> [Tref ea (i "e") (NoAlias ea)] Nothing [] Nothing [] Nothing Nothing] +> ,f "delete from pieces where x = 1 and y = 1 returning tag into r.tag;" +> [Into ea False [Name ea [Nmc "r",Nmc "tag"]] +> $ Delete ea (dqi "pieces") [] +> (Just $ funCall "!and" [funCall "=" [ei "x",num "1"] +> ,funCall "=" [ei "y",num "1"]]) +> (Just $ sl [selI "tag"])] +> ,f "update pieces\n\ +> \set a=b returning tag into r.tag;" +> [Into ea False [Name ea [Nmc "r",Nmc "tag"]] +> $ Update ea (dqi "pieces") +> [SetClause ea (Nmc "a") $ Identifier ea "b"] +> [] +> Nothing (Just (SelectList ea +> [SelExp ea (Identifier ea "tag")]))] +> ,f "insert into t(a) values (1) returning id into x;" +> [Into ea False [Name ea [Nmc "x"]] +> $ Insert ea +> (dqi "t") +> [Nmc "a"] +> (Values ea [[NumberLit ea "1"]]) +> (Just $ sl [selI "id"])] + +> ,f "update t\n\ +> \ set x = 1 returning id into z;" +> [Into ea False [Name ea [Nmc "z"]] +> $ Update ea (dqi "t") [SetClause ea (Nmc "x") $ NumberLit ea "1"] +> [] Nothing (Just $ sl [selI "id"])] + +> ,f "execute s;" +> [Execute ea (Identifier ea "s")] +> ,f "execute s into r;" +> [Into ea False [Name ea [Nmc "r"]] (Execute ea (Identifier ea "s"))] +> ,f "continue;" [ContinueStatement ea Nothing] +> ] +> +> ,Group "other plpgsql statements" [ +> f "for r in select a from tbl loop\n\ +> \null;\n\ +> \end loop;" +> [ForQueryStatement ea Nothing (Nmc "r") (selectFrom [selI "a"] (Tref ea (i "tbl") (NoAlias ea))) +> [NullStatement ea]] +> ,f "for r in select a from tbl where true loop\n\ +> \null;\n\ +> \end loop;" +> [ForQueryStatement ea Nothing (Nmc "r") +> (selectFromWhere [selI "a"] (Tref ea (i "tbl") (NoAlias ea)) (BooleanLit ea True)) +> [NullStatement ea]] +> ,f "for r in 1 .. 10 loop\n\ +> \null;\n\ +> \end loop;" +> [ForIntegerStatement ea Nothing (Nmc "r") +> (NumberLit ea "1") (NumberLit ea "10") +> [NullStatement ea]] +> -- catch a bug in lexing where 1..10 is parsed as +> -- num "1.", num ".10", instead of num 1, symbol "..", num 10 +> ,f "for r in 1..10 loop\n\ +> \null;\n\ +> \end loop;" +> [ForIntegerStatement ea Nothing (Nmc "r") +> (NumberLit ea "1") (NumberLit ea "10") +> [NullStatement ea]] +> +> ,f "if a=b then\n\ +> \ update c set d = e;\n\ +> \end if;" +> [If ea [(FunCall ea (name "=") [ei "a", ei "b"] +> ,[Update ea (dqi "c") [SetClause ea (Nmc "d") +> $ ei "e"] [] Nothing Nothing])] +> []] +> ,f "if true then\n\ +> \ null;\n\ +> \else\n\ +> \ null;\n\ +> \end if;" +> [If ea [(BooleanLit ea True,[NullStatement ea])] +> [NullStatement ea]] +> ,f "if true then\n\ +> \ null;\n\ +> \elseif false then\n\ +> \ return;\n\ +> \end if;" +> [If ea [(BooleanLit ea True, [NullStatement ea]) +> ,(BooleanLit ea False, [Return ea Nothing])] +> []] +> ,f "if true then\n\ +> \ null;\n\ +> \elseif false then\n\ +> \ return;\n\ +> \elsif false then\n\ +> \ return;\n\ +> \else\n\ +> \ return;\n\ +> \end if;" +> [If ea [(BooleanLit ea True, [NullStatement ea]) +> ,(BooleanLit ea False, [Return ea Nothing]) +> ,(BooleanLit ea False, [Return ea Nothing])] +> [Return ea Nothing]] +> ,f "case a\n\ +> \ when b then null;\n\ +> \ when c,d then null;\n\ +> \ else null;\n\ +> \end case;" +> [CaseStatementSimple ea (Identifier ea "a") +> [([Identifier ea "b"], [NullStatement ea]) +> ,([Identifier ea "c", Identifier ea "d"], [NullStatement ea])] +> [NullStatement ea]] +> ]] +> where +> f = PgSqlStmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Selects.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Selects.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Selects.lhs @@ -0,0 +1,434 @@ + +> {-# LANGUAGE QuasiQuotes,OverloadedStrings #-} +> +> module Database.HsSqlPpp.Tests.Parsing.Selects (selectParsingTestData) where +> +> import Database.HsSqlPpp.Utils.Here +> +> import Database.HsSqlPpp.Ast + +> import Database.HsSqlPpp.Tests.Parsing.Utils + +> selectParsingTestData:: Item +> selectParsingTestData = +> Group "parse selects" [ +> Group "simple select statements" [ +> Group "select no table" [ +> s "select 1;" [QueryStatement ea $ selectE (SelectList ea [SelExp ea (NumberLit ea "1")])] +> ] +> ,Group "select from table" [ +> s "select * from tbl;" +> [QueryStatement ea $ selectFrom (selEL [Star ea]) (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select a,b from tbl;" +> [QueryStatement ea $ selectFrom (selIL ["a", "b"]) (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select a,b from inf.tbl;" +> [QueryStatement ea $ selectFrom (selIL ["a", "b"]) (Tref ea (qi "inf" "tbl") (NoAlias ea))] +> ,s "select distinct * from tbl;" +> [QueryStatement ea $ Select ea Distinct (SelectList ea (selEL [Star ea])) [Tref ea (i "tbl") (NoAlias ea)] +> Nothing [] Nothing [] Nothing Nothing] +> ,s "select a from tbl where b=2;" +> [QueryStatement ea $ selectFromWhere +> (selIL ["a"]) +> (Tref ea (i "tbl") (NoAlias ea)) +> (FunCall ea (name "=") +> [Identifier ea "b", NumberLit ea "2"])] +> ,s "select a from tbl where b=2 and c=3;" +> [QueryStatement ea $ selectFromWhere +> (selIL ["a"]) +> (Tref ea (i "tbl") (NoAlias ea)) +> (FunCall ea (name "!and") +> [FunCall ea (name "=") [Identifier ea "b", NumberLit ea "2"] +> ,FunCall ea (name "=") [Identifier ea "c", NumberLit ea "3"]])] +> {-,MSStmt "select a from t;\ngo" +> [QueryStatement ea $ selectFrom (selIL ["a"]) (Tref ea (i "t") (NoAlias ea))] +> ,MSStmt "select a from t;\nset rowcount -1\ngo" +> [QueryStatement ea $ selectFrom (selIL ["a"]) (Tref ea (i "t") (NoAlias ea))] +> ,MSStmt "select a from t;\nset rowcount 10\ngo" +> [QueryStatement ea $ Select ea Dupes +> (sl (selIL ["a"])) +> [Tref ea (i "t") (NoAlias ea)] +> Nothing [] Nothing [] (Just (NumberLit ea "10")) Nothing]-} +> ,s "SELECT T.A::INT FROM TABLE AS T;" +> [QueryStatement ea +> (Select ea Dupes +> (SelectList ea +> [SelExp ea (Cast ea (QIdentifier ea [Nmc "T",Nmc "A"]) +> (SimpleTypeName ea "int"))]) +> [Tref ea (Name ea [Nmc "TABLE"]) (TableAlias ea (Nmc "T"))] +> Nothing [] Nothing [] Nothing Nothing)] +> ] +> + +> ,Group "more select statements" [ +> s "select a from tbl\n\ +> \except\n\ +> \select a from tbl1;" +> [QueryStatement ea $ CombineQueryExpr ea Except +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl") (NoAlias ea))) +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl1") (NoAlias ea)))] +> ,s "select a from tbl where true\n\ +> \except\n\ +> \select a from tbl1 where true;" +> [QueryStatement ea $ CombineQueryExpr ea Except +> (selectFromWhere (selIL ["a"]) (Tref ea (i "tbl") (NoAlias ea)) (BooleanLit ea True)) +> (selectFromWhere (selIL ["a"]) (Tref ea (i "tbl1") (NoAlias ea)) (BooleanLit ea True))] +> ,s "select a from tbl\n\ +> \union\n\ +> \select a from tbl1;" +> [QueryStatement ea $ CombineQueryExpr ea Union +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl") (NoAlias ea))) +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl1") (NoAlias ea)))] +> ,s "select a from tbl\n\ +> \union all\n\ +> \select a from tbl1;" +> [QueryStatement ea $ CombineQueryExpr ea UnionAll +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl") (NoAlias ea))) +> (selectFrom (selIL ["a"]) (Tref ea (i "tbl1") (NoAlias ea)))] +> ,s "(select 1 union select 2) union select 3;" +> [QueryStatement ea +> (CombineQueryExpr ea Union +> (CombineQueryExpr ea Union +> (selectE (SelectList ea [SelExp ea (NumberLit ea "1")])) +> (selectE (SelectList ea [SelExp ea (NumberLit ea "2")]))) +> (selectE (SelectList ea [SelExp ea (NumberLit ea "3")])))] +> ,s "select 1 union (select 2 union select 3);" +> [QueryStatement ea +> (CombineQueryExpr ea Union +> (selectE (SelectList ea [SelExp ea (NumberLit ea "1")])) +> (CombineQueryExpr ea Union +> (selectE (SelectList ea [SelExp ea (NumberLit ea "2")])) +> (selectE (SelectList ea [SelExp ea (NumberLit ea "3")]))))] +> ,s [here| +> with a as (select 1 as a1), +> b as (select * from a) +> select * from b; |] +> [QueryStatement ea +> (WithQueryExpr ea +> [WithQuery ea (Nmc "a") Nothing (selectE $ SelectList ea +> [SelectItem ea (NumberLit ea "1") (Nmc "a1")]) +> ,WithQuery ea (Nmc "b") Nothing (selectFrom (selEL [Star ea]) (Tref ea (i "a") (NoAlias ea)))] +> (selectFrom (selEL [Star ea]) (Tref ea (i "b") (NoAlias ea))))] +> ,s [here| +> with a as (select 1 as a1), +> b as (select * from a) +> select * from a +> union select * from b; |] +> [QueryStatement ea +> (WithQueryExpr ea +> [WithQuery ea (Nmc "a") Nothing (selectE $ SelectList ea +> [SelectItem ea (NumberLit ea "1") (Nmc "a1")]) +> ,WithQuery ea (Nmc "b") Nothing (selectFrom (selEL [Star ea]) (Tref ea (i "a") (NoAlias ea)))] +> (CombineQueryExpr ea Union +> (selectFrom (selEL [Star ea]) (Tref ea (i "a") (NoAlias ea))) +> (selectFrom (selEL [Star ea]) (Tref ea (i "b") (NoAlias ea)))))] +> ,s "select a as b from tbl;" +> [QueryStatement ea $ selectFrom [SelectItem ea (Identifier ea "a") (Nmc "b")] (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select a + b as b from tbl;" +> [QueryStatement ea $ selectFrom +> [SelectItem ea +> (FunCall ea (name "+") +> [Identifier ea "a", Identifier ea "b"]) (Nmc "b")] +> (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select a.* from tbl a;" +> [QueryStatement ea $ selectFrom (selEL [QStar ea (Nmc "a")]) (Tref ea (i "tbl") (TableAlias ea (Nmc "a")))] +> ,s "select a.* from tbl a(b,c);" +> [QueryStatement ea $ selectFrom (selEL [QStar ea (Nmc "a")]) (Tref ea (i "tbl") (FullAlias ea (Nmc "a") [Nmc "b",Nmc "c"]))] + +> ,s "select * from t1 a, t2 b;" +> [QueryStatement ea +> (Select ea Dupes +> (SelectList ea +> [SelExp ea (Star ea)]) +> [Tref ea (i "t1") (TableAlias ea (Nmc "a")),Tref ea (i "t2") (TableAlias ea (Nmc "b"))] +> Nothing [] Nothing [] Nothing Nothing)] +> ,s "select a from b inner join c on b.a=c.a;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural Inner (Tref ea (i "c") (NoAlias ea)) +> (Just (JoinOn ea +> (FunCall ea (name "=") [eqi "b" "a", eqi "c" "a"]))) (NoAlias ea))] +> ,s "select a from b inner join c as d on b.a=d.a;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural Inner (Tref ea (i "c") (TableAlias ea (Nmc "d"))) +> (Just (JoinOn ea +> (FunCall ea (name "=") [eqi "b" "a", eqi "d" "a"]))) (NoAlias ea))] +> ,s "select a from b inner join c using(d,e);" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural Inner (Tref ea (i "c") (NoAlias ea)) +> (Just (JoinUsing ea [Nmc "d",Nmc "e"])) (NoAlias ea))] +> ,s "select a from b natural inner join c;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Natural Inner (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select a from b left outer join c;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural LeftOuter (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select a from b full outer join c;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural FullOuter (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select a from b right outer join c;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural RightOuter (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select a from b cross join c;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural Cross (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select a from (b natural join c);" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Natural Inner (Tref ea (i "c") (NoAlias ea)) Nothing (NoAlias ea))] +> ,s "select x from a cross join b cross join c;" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "b") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)))] +> ,s "select x from ((a cross join b) cross join c);" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "b") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)))] +> ,s "select x from (a cross join (b cross join c));" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (JoinTref ea +> (Tref ea (i "b") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Nothing (NoAlias ea)))] + +> ,s "select x from ((a cross join b) cross join c);" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "b") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)))] +> ,s "select x from (a cross join b) cross join c;" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "b") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)))] +> ,s "select x from ((a cross join b) cross join c) cross join d;" +> [QueryStatement ea +> (selectFrom (selIL ["x"]) +> (JoinTref ea +> (JoinTref ea +> (JoinTref ea +> (Tref ea (i "a") (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "b") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "c") (NoAlias ea)) +> Nothing (NoAlias ea)) +> Unnatural Cross +> (Tref ea (i "d") (NoAlias ea)) +> Nothing (NoAlias ea)))] +> ,s "select a from b\n\ +> \ inner join c\n\ +> \ on true\n\ +> \ inner join d\n\ +> \ on 1=1;" +> [QueryStatement ea $ selectFrom +> [SelExp ea (Identifier ea "a")] +> (JoinTref ea +> (JoinTref ea (Tref ea (i "b") (NoAlias ea)) Unnatural Inner (Tref ea (i "c") (NoAlias ea)) +> (Just $ JoinOn ea (BooleanLit ea True)) (NoAlias ea)) +> Unnatural Inner (Tref ea (i "d") (NoAlias ea)) +> (Just $ JoinOn ea (FunCall ea (name "=") +> [NumberLit ea "1", NumberLit ea "1"])) (NoAlias ea))] + +> ,s "select row_number() over(order by a) as place from tbl;" +> [QueryStatement ea $ selectFrom [SelectItem ea +> (WindowFn ea +> (FunCall ea (name "row_number") []) +> [] +> [(Identifier ea "a", Asc)] FrameUnboundedPreceding) +> (Nmc "place")] +> (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select row_number() over(order by a asc) as place from tbl;" +> [QueryStatement ea $ selectFrom [SelectItem ea +> (WindowFn ea +> (FunCall ea (name "row_number") []) +> [] +> [(Identifier ea "a",Asc)] FrameUnboundedPreceding) +> (Nmc "place")] +> (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select row_number() over(order by a desc) as place from tbl;" +> [QueryStatement ea $ selectFrom [SelectItem ea +> (WindowFn ea +> (FunCall ea (name "row_number") []) +> [] +> [(Identifier ea "a", Desc)] FrameUnboundedPreceding) +> (Nmc "place")] +> (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select row_number()\n\ +> \over(partition by (a,b) order by c) as place\n\ +> \from tbl;" +> [QueryStatement ea $ selectFrom [SelectItem ea +> (WindowFn ea +> (FunCall ea (name "row_number") []) +> [FunCall ea (name "!rowctor") [Identifier ea "a",Identifier ea "b"]] +> [(Identifier ea "c", Asc)] FrameUnboundedPreceding) +> (Nmc "place")] +> (Tref ea (i "tbl") (NoAlias ea))] +> ,s "select * from a natural inner join (select * from b) as a;" +> [QueryStatement ea $ selectFrom +> (selEL [Star ea]) +> (JoinTref ea (Tref ea (i "a") (NoAlias ea)) Natural +> Inner (SubTref ea (selectFrom +> (selEL [Star ea]) +> (Tref ea (i "b") (NoAlias ea))) (TableAlias ea $ Nmc "a")) +> Nothing (NoAlias ea))] +> ,s "select * from a order by c;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c",Asc)] Nothing Nothing] +> ,s "select *\n\ +> \from Adventure\n\ +> \order by Clicks desc, AdventureID;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "Adventure") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "Clicks",Desc) +> ,(Identifier ea "AdventureID",Asc)] Nothing Nothing] +> ,s "select * from a order by c,d asc;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c", Asc) +> ,(Identifier ea "d", Asc)] Nothing Nothing] +> ,s "select * from a order by c,d desc;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c", Asc) +> ,(Identifier ea "d", Desc)] Nothing Nothing] +> ,s "select * from a order by c limit 1;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c",Asc)] (Just (NumberLit ea "1")) Nothing] +> ,s "select top 3 * from a order by c;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c",Asc)] (Just (NumberLit ea "3")) Nothing] +> ,s "select * from a order by c offset 3;" +> [QueryStatement ea $ Select ea Dupes +> (sl (selEL [Star ea])) +> [Tref ea (i "a") (NoAlias ea)] +> Nothing [] Nothing [(Identifier ea "c",Asc)] Nothing (Just $ NumberLit ea "3")] +> ,s "select a from (select b from c) as d;" +> [QueryStatement ea $ selectFrom +> (selIL ["a"]) +> (SubTref ea (selectFrom +> (selIL ["b"]) +> (Tref ea (i "c") (NoAlias ea))) +> (TableAlias ea $ Nmc "d"))] +> ,s "select * from gen();" +> [QueryStatement ea $ selectFrom (selEL [Star ea]) (FunTref ea (FunCall ea (name "gen") []) (NoAlias ea))] +> ,s "select * from gen() as t;" +> [QueryStatement ea $ selectFrom +> (selEL [Star ea]) +> (FunTref ea (FunCall ea (name "gen") [])(TableAlias ea $ Nmc "t"))] +> ,s "select count(distinct b) from c;" +> [QueryStatement ea $ Select ea Dupes +> (sl [SelExp ea (AggregateFn ea Distinct +> (FunCall ea (name "count") [Identifier ea "b"]) +> [])]) +> [Tref ea (i "c") (NoAlias ea)] Nothing [] +> Nothing [] Nothing Nothing] +> ,s "select count(all b) from c;" +> [QueryStatement ea $ Select ea Dupes +> (sl [SelExp ea (AggregateFn ea Dupes +> (FunCall ea (name "count") [Identifier ea "b"]) +> [])]) +> [Tref ea (i "c") (NoAlias ea)] Nothing [] +> Nothing [] Nothing Nothing] +> ,s "select string_agg(distinct relname,',' order by relname1) from pg_class;" +> [QueryStatement ea $ Select ea Dupes +> (sl [SelExp ea (AggregateFn ea Distinct +> (FunCall ea (name "string_agg") [Identifier ea "relname" +> ,StringLit ea ","]) +> [(Identifier ea "relname1", Asc)])]) +> [Tref ea (i "pg_class") (NoAlias ea)] Nothing [] +> Nothing [] Nothing Nothing] +> ,s "select a, count(b) from c group by a;" +> [QueryStatement ea $ Select ea Dupes +> (sl [selI "a", SelExp ea (FunCall ea (name "count") [Identifier ea "b"])]) +> [Tref ea (i "c") (NoAlias ea)] Nothing [Identifier ea "a"] +> Nothing [] Nothing Nothing] +> ,s "select a, count(b) as cnt from c group by a having cnt > 4;" +> [QueryStatement ea $ Select ea Dupes +> (sl [selI "a", SelectItem ea (FunCall ea (name "count") [Identifier ea "b"]) $ Nmc "cnt"]) +> [Tref ea (i "c") (NoAlias ea)] Nothing [Identifier ea "a"] +> (Just $ FunCall ea (name ">") [Identifier ea "cnt", NumberLit ea "4"]) +> [] Nothing Nothing] +> ,s "select a from (select 1 as a, 2 as b) x;" +> [QueryStatement ea $ selectFrom +> [selI "a"] +> (SubTref ea (selectE $ SelectList ea +> [SelectItem ea (NumberLit ea "1") $ Nmc "a" +> ,SelectItem ea (NumberLit ea "2") $ Nmc "b"]) +> (TableAlias ea $ Nmc "x"))] +> ] +> ] +> ,Group "some misc stuff" [ +> s "select (p).x, (p).y from pos;" +> [QueryStatement ea $ selectFrom (selEL [eqi "p" "x" +> ,eqi "p" "y"]) +> (Tref ea (i "pos") (NoAlias ea))] +> ,s "select ($1).x, ($1).y from pos;" +> [QueryStatement ea $ selectFrom +> (selEL [member (PositionalArg ea 1) (Identifier ea "x") +> ,member (PositionalArg ea 1) (Identifier ea "y")]) +> (Tref ea (i "pos") (NoAlias ea))] +> ,s "select row_number() over(), x from tb;" +> [QueryStatement ea $ selectFrom +> [SelExp ea +> (WindowFn ea +> (FunCall ea (name "row_number") []) +> [] +> [] FrameUnboundedPreceding) +> , selI "x"] +> (Tref ea (i "tb") (NoAlias ea))] +> ]] +> where +> s = Stmt diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Utils.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Utils.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Parsing/Utils.lhs @@ -0,0 +1,90 @@ + +> module Database.HsSqlPpp.Tests.Parsing.Utils where + +> import Database.HsSqlPpp.Ast +> import Database.HsSqlPpp.Annotation +> import GHC.Exts (IsString(..)) + +> data Item = Expr String ScalarExpr +> | Stmt String [Statement] +> | PgSqlStmt String [Statement] +> | Group String [Item] + +------------------------------------------------------------------------------- + +shortcuts for constructing test data and asts + +> stringQ :: String -> ScalarExpr +> stringQ = StringLit ea +> +> selectFrom :: SelectItemList +> -> TableRef +> -> QueryExpr +> selectFrom selList frm = Select ea Dupes (SelectList ea selList) +> [frm] Nothing [] Nothing [] Nothing Nothing +> +> selectE :: SelectList -> QueryExpr +> selectE selList = Select ea Dupes selList +> [] Nothing [] Nothing [] Nothing Nothing +> +> selIL :: [String] -> [SelectItem] +> selIL = map selI +> selEL :: [ScalarExpr] -> [SelectItem] +> selEL = map (SelExp ea) +> +> i :: String -> Name +> i x = Name ea [Nmc x] + +> dqi :: String -> Name +> dqi x = Name ea [Nmc x] + +> eqi :: String -> String -> ScalarExpr +> eqi c x = QIdentifier ea [Nmc c, Nmc x] + +> ei :: String -> ScalarExpr +> ei = Identifier ea . Nmc +> +> qi :: String -> String -> Name +> qi c n = Name ea [Nmc c, Nmc n] +> +> selI :: String -> SelectItem +> selI = SelExp ea . Identifier ea . Nmc +> +> sl :: SelectItemList -> SelectList +> sl = SelectList ea +> +> selectFromWhere :: SelectItemList +> -> TableRef +> -> ScalarExpr +> -> QueryExpr +> selectFromWhere selList frm whr = +> Select ea Dupes (SelectList ea selList) +> [frm] (Just whr) [] Nothing [] Nothing Nothing +> +> att :: String -> String -> AttributeDef +> att n t = AttributeDef ea (Nmc n) (SimpleTypeName ea t) Nothing [] + +> ea :: Annotation +> ea = emptyAnnotation + +> name :: String -> Name +> name n = Name ea [Nmc n] + +> instance IsString NameComponent where +> fromString = Nmc + +> member :: ScalarExpr -> ScalarExpr -> ScalarExpr +> member a b = FunCall ea (name ".") [a,b] + + + +> num :: String -> ScalarExpr +> num n = NumberLit ea n + +> funCall :: String -> [ScalarExpr] -> ScalarExpr +> funCall n as = FunCall ea (name n) as + +> lTrue,lFalse,lNull :: ScalarExpr +> lTrue = BooleanLit ea True +> lFalse = BooleanLit ea False +> lNull = NullLit ea diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/QuasiQuoteTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/QuasiQuoteTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/QuasiQuoteTests.lhs @@ -0,0 +1,180 @@ + +Tests mainly for antiquotation, plus examples of where antiquotes work. + +> {-# LANGUAGE QuasiQuotes,ScopedTypeVariables #-} +> +> module Database.HsSqlPpp.Tests.QuasiQuoteTests (quasiQuoteTests, quasiQuoteTestData, Item(..)) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> import Data.Data +> +> import Database.HsSqlPpp.Ast +> import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Pretty +> import Database.HsSqlPpp.Quote +> import Database.HsSqlPpp.Tests.TestUtils +> +> data Item = Expr ScalarExpr ScalarExpr +> | Stmts [Statement] [Statement] +> | PgSqlStmts [Statement] [Statement] +> | Stmt Statement Statement +> | PgSqlStmt Statement Statement +> | Group String [Item] +> quasiQuoteTests :: Test.Framework.Test +> quasiQuoteTests = itemToTft quasiQuoteTestData +> +> quasiQuoteTestData :: Item +> quasiQuoteTestData = +> Group "quasiQuoteTests" [ + +-------------------------------------------------------------------------------- + +expressions + +> Group "stuff" [ +> let tablename = "my_table" +> varname = "my_field" +> typename = "text" +> in Stmt [sqlStmt| +> +> create table $(tablename) ( +> $(varname) $(typename) +> ); +> +> |] +> [sqlStmt| +> create table my_table ( +> my_field text +> ); +> |] +> +> ,let fnname = "my_function" +> tablename = "my_table" +> typename = "int" +> in Stmt [sqlStmt| +> +> create function $(fnname)() returns $(typename) as $a$ +> select * from $(tablename); +> $a$ language sql stable; +> +> |] +> [sqlStmt| +> create function my_function() returns int as $a$ +> select * from my_table; +> $a$ language sql stable; +> |] +> +> ,let fnname = "my_function" +> in Stmt [sqlStmt| drop function $(fnname)();|] +> [sqlStmt| drop function my_function();|] +> +> ,let expr = StringLit ea "testing" +> in PgSqlStmt [pgsqlStmt| return $(expr); |] +> [pgsqlStmt| return 'testing'; |] +> +> ,let expr = (FunCall ea (Name ea [Nmc "+"]) [NumberLit ea "3",NumberLit ea "4"]) +> in PgSqlStmt [pgsqlStmt| return $(expr); |] +> [pgsqlStmt| return 3 + 4; |] +> +> ,let errMsg = "this splice is slighty dodgy" +> in PgSqlStmt [pgsqlStmt| +> if true then +> raise exception '$(errMsg)'; +> end if;|] +> [pgsqlStmt| +> if true then +> raise exception 'this splice is slighty dodgy'; +> end if;|] +> +> ,let triggername = "my_trigger" +> tablename = "my_table" +> opname = "my_function" +> in Stmt [sqlStmt| +> create trigger $(triggername) +> after insert or update or delete on $(tablename) +> for each statement +> execute procedure $(opname)(); +> |] +> [sqlStmt| +> create trigger my_trigger +> after insert or update or delete on my_table +> for each statement +> execute procedure my_function(); +> |] +> ,let tablename = "lotsastuff" +> in Expr [sqlExpr|(select count(*) from $(tablename))|] +> [sqlExpr|(select count(*) from lotsastuff)|] +> +> ,let trigname = "tbl_trig1" +> tablename = "tbl" +> tevent = TUpdate +> fn = "checkit" +> in Stmt [sqlStmt| +> create trigger $(trigname) +> after $(tevent) on $(tablename) +> for each row +> execute procedure $(fn)(); +> |] [sqlStmt| +> create trigger tbl_trig1 +> after update on tbl +> for each row +> execute procedure checkit(); +> |] +> ,let x = "fnname" +> in Expr [sqlExpr| $(x)('a') |] +> [sqlExpr| fnname('a') |] +> ,let x = "splicedstring" +> in Expr [sqlExpr| $s(x) |] +> (StringLit ea "splicedstring") +> ,let x = "splicedIdentifier" +> in Expr [sqlExpr| $i(x) |] +> (Identifier ea $ Nmc "splicedIdentifier") +> ,let errMsg = "this splice isn't too dodgy" +> in PgSqlStmt [pgsqlStmt| raise exception $s(errMsg); |] +> [pgsqlStmt| raise exception 'this splice isn''t too dodgy'; |] + +> {-,let s1 = [sqlStmts| select * from tbl; |] +> in Stmts [sqlStmts| +> select 1; +> $(s1); +> select 2;|] +> [sqlStmts| +> select 1; +> select * from tbl; +> select 2;|] + +> ,let s1 = [sqlStmt| select * from tbl; |] +> s2 = [s1,s2] +> in Stmts [sqlStmts| +> select 1; +> $(s2); +> select 2;|] +> [sqlStmts| +> select 1; +> select * from tbl; +> select * from tbl; +> select 2;|]-} + + +> ]] + + +================================================================================ + +Unit test helpers + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Expr a b) = testCase (printScalarExpr b) $ stripEqual a b +> itemToTft (PgSqlStmt a b) = testCase (printStatements [b]) $ stripEqual a b +> itemToTft (Stmt a b) = testCase (printStatements [b]) $ stripEqual a b +> itemToTft (PgSqlStmts a b) = testCase (printStatements b) $ stripEqual a b +> itemToTft (Stmts a b) = testCase (printStatements b) $ stripEqual a b +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> stripEqual :: (Data a, Eq a, Show a) => +> a -> a -> Assertion +> stripEqual a b = assertEqual "" (resetAnnotations a) (resetAnnotations b) + +> ea :: Annotation +> ea = emptyAnnotation diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TestUtils.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TestUtils.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TestUtils.lhs @@ -0,0 +1,30 @@ + +> module Database.HsSqlPpp.Tests.TestUtils +> (assertTrace,resetAnnotations) where +> +> import Test.HUnit +> --import Test.Framework +> --import Test.Framework.Providers.HUnit +> --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.Parser +> --import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Annotation +> --import Database.HsSqlPpp.Catalog +> --import Database.HsSqlPpp.SqlTypes +> --import Database.HsSqlPpp.Utils.PPExpr + + +> assertTrace :: (Show a,Eq a) => String -> String -> a -> a -> IO () +> assertTrace nem s a1 a2 = do +> when (a1 /= a2) $ trace nem $ return () +> assertEqual s a1 a2 + +> resetAnnotations :: Data a => a -> a +> resetAnnotations = transformBi (const emptyAnnotation) diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/Tests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/Tests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/Tests.lhs @@ -0,0 +1,28 @@ + +> module Database.HsSqlPpp.Tests.Tests (allTests) where +> +> import Test.Framework +> +> import Database.HsSqlPpp.Tests.Parsing.ParserTests + +> import Database.HsSqlPpp.Tests.FixTree.FixUpIdentifiersTests +> import Database.HsSqlPpp.Tests.FixTree.ExplicitCasts + +> import Database.HsSqlPpp.Tests.TypeChecking.TypeCheckTests + +> import Database.HsSqlPpp.Tests.QuasiQuoteTests + +> --import Database.HsSqlPpp.Tests.ExtensionTests +> import Database.HsSqlPpp.Tests.ParameterizedStatementTests +> +> allTests :: [Test] +> allTests = +> parserTests +> : fixUpIdentifiersTests +> : explicitCastTests +> : quasiQuoteTests +> : typeCheckTests +> : parameterizedStatementTests +> -- : extensionTests +> : [] + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TpchData.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TpchData.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TpchData.lhs @@ -0,0 +1,974 @@ + +> {-# LANGUAGE QuasiQuotes #-} +> module Database.HsSqlPpp.Tests.TpchData +> (tpchQueries +> ,tpchCatalog) where +> + +> import Database.HsSqlPpp.Utils.Here +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types + +> tpchQueries :: [(String,String)] +> tpchQueries = +> [("Q1",[here| +\begin{code} +select + l_returnflag, + l_linestatus, + sum(l_quantity) as sum_qty, + sum(l_extendedprice) as sum_base_price, + sum(l_extendedprice * (1 - l_discount)) as sum_disc_price, + sum(l_extendedprice * (1 - l_discount) * (1 + l_tax)) as sum_charge, + avg(l_quantity) as avg_qty, + avg(l_extendedprice) as avg_price, + avg(l_discount) as avg_disc, + count(*) as count_order +from + lineitem +where + l_shipdate <= date '1998-12-01' - interval '63' day (3) +group by + l_returnflag, + l_linestatus +order by + l_returnflag, + l_linestatus; +--set rowcount -1 +--go +\end{code} +> |]) +> ,("Q2",[here| +\begin{code} + +select + s_acctbal, + s_name, + n_name, + p_partkey, + p_mfgr, + s_address, + s_phone, + s_comment +from + part, + supplier, + partsupp, + nation, + region +where + p_partkey = ps_partkey + and s_suppkey = ps_suppkey + and p_size = 15 + and p_type like '%BRASS' + and s_nationkey = n_nationkey + and n_regionkey = r_regionkey + and r_name = 'EUROPE' + and ps_supplycost = ( + select + min(ps_supplycost) + from + partsupp, + supplier, + nation, + region + where + p_partkey = ps_partkey + and s_suppkey = ps_suppkey + and s_nationkey = n_nationkey + and n_regionkey = r_regionkey + and r_name = 'EUROPE' + ) +order by + s_acctbal desc, + n_name, + s_name, + p_partkey; +--set rowcount 100 +--go +\end{code} +> |]) +> ,("Q3",[here| +\begin{code} +select + l_orderkey, + sum(l_extendedprice * (1 - l_discount)) as revenue, + o_orderdate, + o_shippriority +from + customer, + orders, + lineitem +where + c_mktsegment = 'MACHINERY' + and c_custkey = o_custkey + and l_orderkey = o_orderkey + and o_orderdate < date '1995-03-21' + and l_shipdate > date '1995-03-21' +group by + l_orderkey, + o_orderdate, + o_shippriority +order by + revenue desc, + o_orderdate; +--set rowcount 10 +--go +\end{code} +> |]) +> ,("Q4",[here| +\begin{code} +select + o_orderpriority, + count(*) as order_count +from + orders +where + o_orderdate >= date '1996-03-01' + and o_orderdate < date '1996-03-01' + interval '3' month + and exists ( + select + * + from + lineitem + where + l_orderkey = o_orderkey + and l_commitdate < l_receiptdate + ) +group by + o_orderpriority +order by + o_orderpriority; +--set rowcount -1 +--go +\end{code} +> |]) +> ,("Q5",[here| +\begin{code} +select + n_name, + sum(l_extendedprice * (1 - l_discount)) as revenue +from + customer, + orders, + lineitem, + supplier, + nation, + region +where + c_custkey = o_custkey + and l_orderkey = o_orderkey + and l_suppkey = s_suppkey + and c_nationkey = s_nationkey + and s_nationkey = n_nationkey + and n_regionkey = r_regionkey + and r_name = 'EUROPE' + and o_orderdate >= date '1997-01-01' + and o_orderdate < date '1997-01-01' + interval '1' year +group by + n_name +order by + revenue desc; +--set rowcount -1 +--go +\end{code} +> |]) +> ,("Q6",[here| +\begin{code} +select + sum(l_extendedprice * l_discount) as revenue +from + lineitem +where + l_shipdate >= date '1997-01-01' + and l_shipdate < date '1997-01-01' + interval '1' year + and l_discount between 0.07 - 0.01 and 0.07 + 0.01 + and l_quantity < 24; +--set rowcount -1 +--go +\end{code} +> |]) +> ,("Q7",[here| +\begin{code} +select + supp_nation, + cust_nation, + l_year, + sum(volume) as revenue +from + ( + select + n1.n_name as supp_nation, + n2.n_name as cust_nation, + extract(year from l_shipdate) as l_year, + l_extendedprice * (1 - l_discount) as volume + from + supplier, + lineitem, + orders, + customer, + nation n1, + nation n2 + where + s_suppkey = l_suppkey + and o_orderkey = l_orderkey + and c_custkey = o_custkey + and s_nationkey = n1.n_nationkey + and c_nationkey = n2.n_nationkey + and ( + (n1.n_name = 'PERU' and n2.n_name = 'IRAQ') + or (n1.n_name = 'IRAQ' and n2.n_name = 'PERU') + ) + and l_shipdate between date '1995-01-01' and date '1996-12-31' + ) as shipping +group by + supp_nation, + cust_nation, + l_year +order by + supp_nation, + cust_nation, + l_year; +--set rowcount -1 +--go +\end{code} +> |]) +> ,("Q8",[here| +\begin{code} +select + o_year, + sum(case + when nation = 'IRAQ' then volume + else 0 + end) / sum(volume) as mkt_share +from + ( + select + extract(year from o_orderdate) as o_year, + l_extendedprice * (1 - l_discount) as volume, + n2.n_name as nation + from + part, + supplier, + lineitem, + orders, + customer, + nation n1, + nation n2, + region + where + p_partkey = l_partkey + and s_suppkey = l_suppkey + and l_orderkey = o_orderkey + and o_custkey = c_custkey + and c_nationkey = n1.n_nationkey + and n1.n_regionkey = r_regionkey + and r_name = 'MIDDLE EAST' + and s_nationkey = n2.n_nationkey + and o_orderdate between date '1995-01-01' and date '1996-12-31' + and p_type = 'STANDARD ANODIZED BRASS' + ) as all_nations +group by + o_year +order by + o_year; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q9",[here| +\begin{code} + + +select + nation, + o_year, + sum(amount) as sum_profit +from + ( + select + n_name as nation, + extract(year from o_orderdate) as o_year, + l_extendedprice * (1 - l_discount) - ps_supplycost * l_quantity as amount + from + part, + supplier, + lineitem, + partsupp, + orders, + nation + where + s_suppkey = l_suppkey + and ps_suppkey = l_suppkey + and ps_partkey = l_partkey + and p_partkey = l_partkey + and o_orderkey = l_orderkey + and s_nationkey = n_nationkey + and p_name like '%antique%' + ) as profit +group by + nation, + o_year +order by + nation, + o_year desc; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q10",[here| +\begin{code} + + +select + c_custkey, + c_name, + sum(l_extendedprice * (1 - l_discount)) as revenue, + c_acctbal, + n_name, + c_address, + c_phone, + c_comment +from + customer, + orders, + lineitem, + nation +where + c_custkey = o_custkey + and l_orderkey = o_orderkey + and o_orderdate >= date '1993-12-01' + and o_orderdate < date '1993-12-01' + interval '3' month + and l_returnflag = 'R' + and c_nationkey = n_nationkey +group by + c_custkey, + c_name, + c_acctbal, + c_phone, + n_name, + c_address, + c_comment +order by + revenue desc; +--set rowcount 20 +--go + +\end{code} +> |]) +> ,("Q11",[here| +\begin{code} + + +select + ps_partkey, + sum(ps_supplycost * ps_availqty) as value +from + partsupp, + supplier, + nation +where + ps_suppkey = s_suppkey + and s_nationkey = n_nationkey + and n_name = 'CHINA' +group by + ps_partkey having + sum(ps_supplycost * ps_availqty) > ( + select + sum(ps_supplycost * ps_availqty) * 0.0001000000 + from + partsupp, + supplier, + nation + where + ps_suppkey = s_suppkey + and s_nationkey = n_nationkey + and n_name = 'CHINA' + ) +order by + value desc; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q12",[here| +\begin{code} + + +select + l_shipmode, + sum(case + when o_orderpriority = '1-URGENT' + or o_orderpriority = '2-HIGH' + then 1 + else 0 + end) as high_line_count, + sum(case + when o_orderpriority <> '1-URGENT' + and o_orderpriority <> '2-HIGH' + then 1 + else 0 + end) as low_line_count +from + orders, + lineitem +where + o_orderkey = l_orderkey + and l_shipmode in ('AIR', 'RAIL') + and l_commitdate < l_receiptdate + and l_shipdate < l_commitdate + and l_receiptdate >= date '1994-01-01' + and l_receiptdate < date '1994-01-01' + interval '1' year +group by + l_shipmode +order by + l_shipmode; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q13",[here| +\begin{code} + + +select + c_count, + count(*) as custdist +from + ( + select + c_custkey, + count(o_orderkey) + from + customer left outer join orders on + c_custkey = o_custkey + and o_comment not like '%pending%requests%' + group by + c_custkey + ) as c_orders (c_custkey, c_count) +group by + c_count +order by + custdist desc, + c_count desc; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q14",[here| +\begin{code} + +select + 100.00 * sum(case + when p_type like 'PROMO%' + then l_extendedprice * (1 - l_discount) + else 0 + end) / sum(l_extendedprice * (1 - l_discount)) as promo_revenue +from + lineitem, + part +where + l_partkey = p_partkey + and l_shipdate >= date '1994-12-01' + and l_shipdate < date '1994-12-01' + interval '1' month; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q15",[here| +\begin{code} + +/*create view revenue0 (supplier_no, total_revenue) as + select + l_suppkey, + sum(l_extendedprice * (1 - l_discount)) + from + lineitem + where + l_shipdate >= date '1995-06-01' + and l_shipdate < date '1995-06-01' + interval '3' month + group by + l_suppkey;*/ + +with +revenue0 as + (select + l_suppkey as supplier_no, + sum(l_extendedprice * (1 - l_discount)) as total_revenue + from + lineitem + where + l_shipdate >= date '1995-06-01' + and l_shipdate < date '1995-06-01' + interval '3' month + group by + l_suppkey) +select + s_suppkey, + s_name, + s_address, + s_phone, + total_revenue +from + supplier, + revenue0 +where + s_suppkey = supplier_no + and total_revenue = ( + select + max(total_revenue) + from + revenue0 + ) +order by + s_suppkey; + +--drop view revenue0; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q16",[here| +\begin{code} + + +select + p_brand, + p_type, + p_size, + count(distinct ps_suppkey) as supplier_cnt +from + partsupp, + part +where + p_partkey = ps_partkey + and p_brand <> 'Brand#15' + and p_type not like 'MEDIUM BURNISHED%' + and p_size in (39, 26, 18, 45, 19, 1, 3, 9) + and ps_suppkey not in ( + select + s_suppkey + from + supplier + where + s_comment like '%Customer%Complaints%' + ) +group by + p_brand, + p_type, + p_size +order by + supplier_cnt desc, + p_brand, + p_type, + p_size; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q17",[here| +\begin{code} + + +select + sum(l_extendedprice) / 7.0 as avg_yearly +from + lineitem, + part +where + p_partkey = l_partkey + and p_brand = 'Brand#52' + and p_container = 'JUMBO CAN' + and l_quantity < ( + select + 0.2 * avg(l_quantity) + from + lineitem + where + l_partkey = p_partkey + ); +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q18",[here| +\begin{code} + + +select + c_name, + c_custkey, + o_orderkey, + o_orderdate, + o_totalprice, + sum(l_quantity) +from + customer, + orders, + lineitem +where + o_orderkey in ( + select + l_orderkey + from + lineitem + group by + l_orderkey having + sum(l_quantity) > 313 + ) + and c_custkey = o_custkey + and o_orderkey = l_orderkey +group by + c_name, + c_custkey, + o_orderkey, + o_orderdate, + o_totalprice +order by + o_totalprice desc, + o_orderdate; +--set rowcount 100 +--go + +\end{code} +> |]) +> ,("Q19",[here| +\begin{code} + + +select + sum(l_extendedprice* (1 - l_discount)) as revenue +from + lineitem, + part +where + ( + p_partkey = l_partkey + and p_brand = 'Brand#43' + and p_container in ('SM CASE', 'SM BOX', 'SM PACK', 'SM PKG') + and l_quantity >= 3 and l_quantity <= 3 + 10 + and p_size between 1 and 5 + and l_shipmode in ('AIR', 'AIR REG') + and l_shipinstruct = 'DELIVER IN PERSON' + ) + or + ( + p_partkey = l_partkey + and p_brand = 'Brand#25' + and p_container in ('MED BAG', 'MED BOX', 'MED PKG', 'MED PACK') + and l_quantity >= 10 and l_quantity <= 10 + 10 + and p_size between 1 and 10 + and l_shipmode in ('AIR', 'AIR REG') + and l_shipinstruct = 'DELIVER IN PERSON' + ) + or + ( + p_partkey = l_partkey + and p_brand = 'Brand#24' + and p_container in ('LG CASE', 'LG BOX', 'LG PACK', 'LG PKG') + and l_quantity >= 22 and l_quantity <= 22 + 10 + and p_size between 1 and 15 + and l_shipmode in ('AIR', 'AIR REG') + and l_shipinstruct = 'DELIVER IN PERSON' + ); +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q20",[here| +\begin{code} + + +select + s_name, + s_address +from + supplier, + nation +where + s_suppkey in ( + select + ps_suppkey + from + partsupp + where + ps_partkey in ( + select + p_partkey + from + part + where + p_name like 'lime%' + ) + and ps_availqty > ( + select + 0.5 * sum(l_quantity) + from + lineitem + where + l_partkey = ps_partkey + and l_suppkey = ps_suppkey + and l_shipdate >= date '1994-01-01' + and l_shipdate < date '1994-01-01' + interval '1' year + ) + ) + and s_nationkey = n_nationkey + and n_name = 'VIETNAM' +order by + s_name; +--set rowcount -1 +--go + +\end{code} +> |]) +> ,("Q21",[here| +\begin{code} + + +select + s_name, + count(*) as numwait +from + supplier, + lineitem l1, + orders, + nation +where + s_suppkey = l1.l_suppkey + and o_orderkey = l1.l_orderkey + and o_orderstatus = 'F' + and l1.l_receiptdate > l1.l_commitdate + and exists ( + select + * + from + lineitem l2 + where + l2.l_orderkey = l1.l_orderkey + and l2.l_suppkey <> l1.l_suppkey + ) + and not exists ( + select + * + from + lineitem l3 + where + l3.l_orderkey = l1.l_orderkey + and l3.l_suppkey <> l1.l_suppkey + and l3.l_receiptdate > l3.l_commitdate + ) + and s_nationkey = n_nationkey + and n_name = 'INDIA' +group by + s_name +order by + numwait desc, + s_name; +--set rowcount 100 +--go + +\end{code} +> |]) +> ,("Q22",[here| +\begin{code} + + +select + cntrycode, + count(*) as numcust, + sum(c_acctbal) as totacctbal +from + ( + select + substring(c_phone from 1 for 2) as cntrycode, + c_acctbal + from + customer + where + substring(c_phone from 1 for 2) in + ('41', '28', '39', '21', '24', '29', '44') + and c_acctbal > ( + select + avg(c_acctbal) + from + customer + where + c_acctbal > 0.00 + and substring(c_phone from 1 for 2) in + ('41', '28', '39', '21', '24', '29', '44') + ) + and not exists ( + select + * + from + orders + where + o_custkey = c_custkey + ) + ) as custsale +group by + cntrycode +order by + cntrycode; +--set rowcount -1 +--go + +\end{code} +> |]) +> ] + + +> tpchCatalog :: [CatalogUpdate] +> tpchCatalog = + +CREATE TABLE NATION ( N_NATIONKEY INTEGER NOT NULL, + N_NAME CHAR(25) NOT NULL, + N_REGIONKEY INTEGER NOT NULL, + N_COMMENT VARCHAR(152)); + +> [CatCreateTable "nation" [("n_nationkey", typeInt) +> ,("n_name", typeChar) +> ,("n_regionkey", typeInt) +> ,("n_comment", typeVarChar)] [] + +CREATE TABLE REGION ( R_REGIONKEY INTEGER NOT NULL, + R_NAME CHAR(25) NOT NULL, + R_COMMENT VARCHAR(152)); + +> ,CatCreateTable "region" [("r_regionkey", typeInt) +> ,("r_name", typeChar) +> ,("r_comment", typeVarChar)] [] + +CREATE TABLE PART ( P_PARTKEY INTEGER NOT NULL, + P_NAME VARCHAR(55) NOT NULL, + P_MFGR CHAR(25) NOT NULL, + P_BRAND CHAR(10) NOT NULL, + P_TYPE VARCHAR(25) NOT NULL, + P_SIZE INTEGER NOT NULL, + P_CONTAINER CHAR(10) NOT NULL, + P_RETAILPRICE DECIMAL(15,2) NOT NULL, + P_COMMENT VARCHAR(23) NOT NULL ); + +> ,CatCreateTable "part" [("p_partkey", typeInt) +> ,("p_name", typeVarChar) +> ,("p_mfgr", typeChar) +> ,("p_brand", typeChar) +> ,("p_type", typeVarChar) +> ,("p_size", typeInt) +> ,("p_container", typeChar) +> ,("p_retailprice", typeNumeric) +> ,("p_comment", typeVarChar)] [] + +CREATE TABLE SUPPLIER ( S_SUPPKEY INTEGER NOT NULL, + S_NAME CHAR(25) NOT NULL, + S_ADDRESS VARCHAR(40) NOT NULL, + S_NATIONKEY INTEGER NOT NULL, + S_PHONE CHAR(15) NOT NULL, + S_ACCTBAL DECIMAL(15,2) NOT NULL, + S_COMMENT VARCHAR(101) NOT NULL); + +> ,CatCreateTable "supplier" [("s_suppkey", typeInt) +> ,("s_name", typeChar) +> ,("s_address", typeVarChar) +> ,("s_nationkey", typeInt) +> ,("s_phone", typeChar) +> ,("s_acctbal", typeNumeric) +> ,("s_comment", typeVarChar)] [] + + +CREATE TABLE PARTSUPP ( PS_PARTKEY INTEGER NOT NULL, + PS_SUPPKEY INTEGER NOT NULL, + PS_AVAILQTY INTEGER NOT NULL, + PS_SUPPLYCOST DECIMAL(15,2) NOT NULL, + PS_COMMENT VARCHAR(199) NOT NULL ); + +> ,CatCreateTable "partsupp" [("ps_partkey", typeInt) +> ,("ps_suppkey", typeInt) +> ,("ps_availqty", typeInt) +> ,("ps_supplycost", typeNumeric) +> ,("ps_comment", typeVarChar)] [] + +CREATE TABLE CUSTOMER ( C_CUSTKEY INTEGER NOT NULL, + C_NAME VARCHAR(25) NOT NULL, + C_ADDRESS VARCHAR(40) NOT NULL, + C_NATIONKEY INTEGER NOT NULL, + C_PHONE CHAR(15) NOT NULL, + C_ACCTBAL DECIMAL(15,2) NOT NULL, + C_MKTSEGMENT CHAR(10) NOT NULL, + C_COMMENT VARCHAR(117) NOT NULL); + +> ,CatCreateTable "customer" [("c_custkey", typeInt) +> ,("c_name", typeChar) +> ,("c_address", typeVarChar) +> ,("c_nationkey", typeInt) +> ,("c_phone", typeChar) +> ,("c_acctbal", typeNumeric) +> ,("c_mktsegment", typeChar) +> ,("c_comment", typeVarChar)] [] + + +CREATE TABLE ORDERS ( O_ORDERKEY INTEGER NOT NULL, + O_CUSTKEY INTEGER NOT NULL, + O_ORDERSTATUS CHAR(1) NOT NULL, + O_TOTALPRICE DECIMAL(15,2) NOT NULL, + O_ORDERDATE DATE NOT NULL, + O_ORDERPRIORITY CHAR(15) NOT NULL, + O_CLERK CHAR(15) NOT NULL, + O_SHIPPRIORITY INTEGER NOT NULL, + O_COMMENT VARCHAR(79) NOT NULL); + +> ,CatCreateTable "orders" [("o_orderkey", typeInt) +> ,("o_custkey", typeInt) +> ,("o_orderstatus", typeChar) +> ,("o_totalprice", typeNumeric) +> ,("o_orderdate", typeDate) +> ,("o_orderpriority", typeChar) +> ,("o_clerk", typeChar) +> ,("o_shippriority", typeInt) +> ,("o_comment", typeVarChar)] [] + + +CREATE TABLE LINEITEM ( L_ORDERKEY INTEGER NOT NULL, + L_PARTKEY INTEGER NOT NULL, + L_SUPPKEY INTEGER NOT NULL, + L_LINENUMBER INTEGER NOT NULL, + L_QUANTITY DECIMAL(15,2) NOT NULL, + L_EXTENDEDPRICE DECIMAL(15,2) NOT NULL, + L_DISCOUNT DECIMAL(15,2) NOT NULL, + L_TAX DECIMAL(15,2) NOT NULL, + L_RETURNFLAG CHAR(1) NOT NULL, + L_LINESTATUS CHAR(1) NOT NULL, + L_SHIPDATE DATE NOT NULL, + L_COMMITDATE DATE NOT NULL, + L_RECEIPTDATE DATE NOT NULL, + L_SHIPINSTRUCT CHAR(25) NOT NULL, + L_SHIPMODE CHAR(10) NOT NULL, + L_COMMENT VARCHAR(44) NOT NULL); + +> ,CatCreateTable "lineitem" [("l_orderkey", typeInt) +> ,("l_partkey", typeInt) +> ,("l_suppkey", typeInt) +> ,("l_linenumber", typeInt) +> ,("l_quantity", typeNumeric) +> ,("l_extendedprice", typeNumeric) +> ,("l_discount", typeNumeric) +> ,("l_tax", typeNumeric) +> ,("l_returnflag", typeChar) +> ,("l_linestatus", typeChar) +> ,("l_shipdate", typeDate) +> ,("l_commitdate", typeDate) +> ,("l_receiptdate", typeDate) +> ,("l_shipinstruct", typeChar) +> ,("l_shipmode", typeChar) +> ,("l_comment", typeVarChar)] [] + +> ] diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CaseExpressions.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CaseExpressions.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CaseExpressions.lhs @@ -0,0 +1,56 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.CaseExpressions +> (caseExpressionsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> caseExpressionsTestData :: Item +> caseExpressionsTestData = +> Group "case expressions" [ +> e "case\n\ +> \ when true then 1\n\ +> \end" $ Right typeInt +> ,e "case\n\ +> \ when 1=2 then 'stuff'\n\ +> \ when 2=3 then 'blah'\n\ +> \ else 'test'\n\ +> \end" $ Right UnknownType +> ,e "case\n\ +> \ when 1=2 then 'stuff'\n\ +> \ when 2=3 then 'blah'\n\ +> \ else 'test'::text\n\ +> \end" $ Right $ ScalarType "text" +> ,e "case\n\ +> \ when 1=2 then 'stuff'\n\ +> \ when true=3 then 'blah'\n\ +> \ else 'test'\n\ +> \end" $ Left [NoMatchingOperator "=" [typeBool,typeInt]] +> ,e "case\n\ +> \ when 1=2 then true\n\ +> \ when 2=3 then false\n\ +> \ else 1\n\ +> \end" $ Left [IncompatibleTypeSet [typeBool +> ,typeBool +> ,typeInt]] +> ,e "case\n\ +> \ when 1=2 then false\n\ +> \ when 2=3 then 1\n\ +> \ else true\n\ +> \end" $ Left [IncompatibleTypeSet [typeBool +> ,typeInt +> ,typeBool]] +> ,e "case 1 when 2 then 3 else 4 end" $ Right typeInt +> ,e "case 1 when true then 3 else 4 end" +> $ Left [IncompatibleTypeSet [ScalarType "int4" +> ,ScalarType "bool"]] +> ,e "case 1 when 2 then true else false end" $ Right typeBool +> ,e "case 1 when 2 then 3 else false end" +> $ Left [IncompatibleTypeSet [ScalarType "int4" +> ,ScalarType "bool"]] +> ] +> where +> e = Expr + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CatalogChaining.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CatalogChaining.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CatalogChaining.lhs @@ -0,0 +1,34 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.CatalogChaining +> (tcCatalogChainingTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> + +> tcCatalogChainingTestData :: Item +> tcCatalogChainingTestData = +> Group "check catalog chaining" [ +> +> -- create function then select +> -- select then create function +> -- then in two separate chained asts +> +> s "create function t1() returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql stable;\n\ +> \select t1();" +> (Right [Nothing,Just ([], [])]) +> ,s "select t1();\n\ +> \create function t1() returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Left [NoMatchingOperator "t1" []]) +> ] +> where +> s = StmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CombineSelects.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CombineSelects.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/CombineSelects.lhs @@ -0,0 +1,42 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.CombineSelects +> (tcCombineSelectsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> tcCombineSelectsTestData :: Item +> tcCombineSelectsTestData = +> Group "combine selects" [ +> s "select 1,2 union select '3', '4';" $ Right [Just ([], +> [("?column?", typeInt) +> ,("?column?", typeInt)])] +> ,s "select 1,2 intersect select 'a', true;" $ Left [IncompatibleTypeSet [typeInt +> ,typeBool]] +> ,s "select '3', '4' except select 1,2;" $ Right [Just ([], +> [("?column?", typeInt) +> ,("?column?", typeInt)])] +> ,s "select 'a', true union select 1,2;" +> $ Left [IncompatibleTypeSet [typeBool +> ,typeInt]] +> ,s "select 'a'::text, '2'::int2 intersect select '1','2';" $ Right [Just ([], +> [("text", ScalarType "text") +> ,("int2", typeSmallInt)])] +> ,s "select 1,2,3 except select 1,2;" $ Left [ValuesListsMustBeSameLength] +> ,s "select '3' as a, '4' as b except select 1,2;" $ Right [Just ([], +> [("a", typeInt) +> ,("b", typeInt)])] +> --FIXME: withs not working +> {-,s [here| +> with a as (select 1 as a1), +> b as (select * from a) +> select * from a +> union select * from b; |] +> $ Right [Just $ ([], +> [("a1", typeInt)])]-} +> ] + +> where +> s = StmtType + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Creates.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Creates.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Creates.lhs @@ -0,0 +1,60 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Creates +> (tcCreateTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> import Database.HsSqlPpp.Catalog + +> tcCreateTestData :: Item +> tcCreateTestData = +> Group "creates" [ +> d "create table t1 (\n\ +> \ a int,\n\ +> \ b text\n\ +> \);" +> [CatCreateTable "t1" [("a",ScalarType "int4") +> ,("b",ScalarType "text")] +> [("tableoid", ScalarType "oid") +> ,("cmax", ScalarType "cid") +> ,("xmax", ScalarType "xid") +> ,("cmin", ScalarType "cid") +> ,("xmin", ScalarType "xid") +> ,("ctid", ScalarType "tid")]] +> ,d "create type t1 as (\n\ +> \ a int,\n\ +> \ b text\n\ +> \);" +> [CatCreateComposite "t1" [("a",ScalarType "int4") +> ,("b",ScalarType "text")]] +> +> ,d "create domain t1 as text;" +> [CatCreateDomain (DomainType "t1") (ScalarType "text")] + +> --fixme: check in domain constraint +> {-,d "create domain t1 as text check (value in ('a', 'b'));\n\ +> \select 'text'::t1;" +> [CatCreateDomain (DomainType "t1") (ScalarType "text")]-} +> +> +> ,d "create view v1 as select * from pg_attrdef;" +> [CatCreateView "v1" [("adrelid",ScalarType "oid") +> ,("adnum",ScalarType "int2") +> ,("adbin",ScalarType "pg_node_tree") +> ,("adsrc",ScalarType "text")]] +> +> ,d "create function t1(text) returns text as $$\n\ +> \null;\n\ +> \$$ language sql stable;" +> [CatCreateFunction FunName "t1" [ScalarType "text"] +> (ScalarType "text") False] +> ,d "create language plpgsql;" +> [CatCreateFunction FunName "plpgsql_call_handler" [] (Pseudo LanguageHandler) False +> ,CatCreateFunction FunName "plpgsql_validator" [ScalarType "oid"] (Pseudo Void) False] +> ] +> +> where +> d = Ddl + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Delete.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Delete.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Delete.lhs @@ -0,0 +1,23 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Delete +> (tcDeleteTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +> tcDeleteTestData :: Item +> tcDeleteTestData = +> Group "delete" [ +> s "delete from nope;" +> $ Left [UnrecognisedRelation "nope"] +> ,s "delete from pg_attrdef where 1=2;" +> $ Right [Just ([], [])] +> ,s "delete from pg_attrdef where 1;" +> $ Left [ExpressionMustBeBool] +> ,s "delete from pg_attrdef where adsrc='';" +> $ Right [Just ([], [])] +> ] + +> where +> s = StmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Drops.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Drops.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Drops.lhs @@ -0,0 +1,39 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Drops +> (tcDropsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> import Database.HsSqlPpp.Catalog + +-------------------------------------------------------------------------------- + + +> tcDropsTestData :: Item +> tcDropsTestData = +> Group "drop stuff" [ +> d "create function test(a int) returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end\n\ +> \$$ language plpgsql;" +> [CatCreateFunction FunName "test" [typeInt] (Pseudo Void) False] +> ,d "create function test(a int) returns void as $$\n\ +> \begin\n\ +> \ null;\n\ +> \end\n\ +> \$$ language plpgsql;\n\ +> \drop function test(int);" +> [] +> -- FIXME: this should fail but doesn't +> ,d "drop function test(int);" +> [] +> ,d "drop function if exists test(int);" +> [] +> ] + +> where +> d = Ddl + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Insert.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Insert.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Insert.lhs @@ -0,0 +1,34 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Insert +> (tcInsertTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +> tcInsertTestData :: Item +> tcInsertTestData = +> Group "insert" [ +> s "insert into nope (a,b) values (c,d);" +> $ Left [UnrecognisedRelation "nope" +> ,UnrecognisedIdentifier "c" +> ,UnrecognisedIdentifier "d"] +> ,s "insert into pg_attrdef (adrelid,adnum,adbin,adsrc)\n\ +> \values (1,2, 'a', 'b');" +> $ Right [Just ([], [])] +> ,s "insert into pg_attrdef\n\ +> \values (1,2, 'a', 'c');" +> $ Right [Just ([], [])] +> ,s "insert into pg_attrdef (hello,adnum,adbin,adsrc)\n\ +> \values (1,2, 'a', 'b');" +> $ Left [UnrecognisedIdentifier "hello"] +> ,s "insert into pg_attrdef (adrelid,adnum,adbin,adsrc)\n\ +> \values (1,true, 'a', 'b');" +> $ Left [IncompatibleTypes (ScalarType "int2") (ScalarType "bool")] +> ,s "insert into pg_attrdef (adrelid,adnum,adbin,adsrc)\n\ +> \values (1,true, 'a', 'b','c');" +> $ Left [WrongNumberOfColumns] +> ] + +> where +> s = StmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Into.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Into.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Into.lhs @@ -0,0 +1,113 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Into +> (tcIntoTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +-------------------------------------------------------------------------------- + + +> tcIntoTestData :: Item +> tcIntoTestData = --fixme: intos need fixing +> Group "select into" $ drop 1000 [ +> s "insert into pg_attrdef (adrelid,adnum,adbin,adsrc)\n\ +> \values (1,2, 'a', 'b') returning adnum,adbin;" +> $ Right [Just ([], [("adnum", ScalarType "int2") +> ,("adbin", ScalarType "pg_node_tree")])] +> ,s "update pg_attrdef set adnum = adnum + 1 returning adnum;" +> $ Right [Just ([], [("adnum", ScalarType "int2")])] +> ,s "delete from pg_attrdef returning adnum,adbin;" +> $ Right [Just ([], [("adnum", ScalarType "int2") +> ,("adbin", ScalarType "pg_node_tree")])] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into a,b from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Right [Nothing] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into b,a from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Left [IncompatibleTypes (ScalarType "text") (ScalarType "int2") +> ,IncompatibleTypes (ScalarType "int4") (ScalarType "text")] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into a,c from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Left [UnrecognisedIdentifier "c"] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into a from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Left [WrongNumberOfColumns] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r record;\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into r from pg_attrdef;\n\ +> \ a := r.adnum;\n\ +> \ b := r.adbin;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Right [Nothing] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r record;\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ select adnum,adbin into r from pg_attrdef;\n\ +> \ a := r.adnum;\n\ +> \ b := r.adsrc;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Left [UnrecognisedIdentifier "adsrc"] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r pg_attrdef;\n\ +> \begin\n\ +> \ select * into r from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Right [Nothing] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r pg_class;\n\ +> \begin\n\ +> \ select adnum,adbin into r from pg_attrdef;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Left [IncompatibleTypes (NamedCompositeType "pg_class") (AnonymousRecordType [ScalarType "int2",ScalarType "text"])] +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r record;\n\ +> \begin\n\ +> \ select adnum,adbin into r from pg_attrdef;\n\ +> \ select relname into r from pg_class;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Right [Nothing] +> ] +> where +> s = StmtType + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Joins.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Joins.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Joins.lhs @@ -0,0 +1,66 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Joins +> (tcJoinsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +> tcJoinsTestData :: Item +> tcJoinsTestData = +> Group "simple join selects" [ +> s "select * from (select 1 as a, 2 as b) a\n\ +> \ cross join (select true as c, 4.5 as d) b;" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt) +> ,("c", typeBool) +> ,("d", typeNumeric)])] +> ,s "select * from (select 1 as a, 2 as b) a\n\ +> \ inner join (select true as c, 4.5 as d) b on true;" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt) +> ,("c", typeBool) +> ,("d", typeNumeric)])] +> ,s "select * from (select 1 as a, 2 as b) a\n\ +> \ inner join (select 1 as a, 4.5 as d) b using(a);" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt) +> ,("d", typeNumeric)])] +> ,s "select * from (select 1 as a, 2 as b) a\n\ +> \ natural inner join (select 1 as a, 4.5 as d) b;" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt) +> ,("d", typeNumeric)])] +> --check the attribute order +> ,s "select * from (select 2 as b, 1 as a) a\n\ +> \ natural inner join (select 4.5 as d, 1 as a) b;" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt) +> ,("d", typeNumeric)])] +> --fixme: result set compatilibity check +> {-,s "select * from (select 1 as a1, 2 as b) a\n\ +> \ natural inner join (select true as a1, 4.5 as d) b;" +> $ Left [UnrecognisedCorrelationName "" +> ,IncompatibleTypeSet [ScalarType "int4" +> ,ScalarType "bool"]]-} +> --fixme: result set compatilibity check +> {-,s "select * from (select 1 as a1, 2 as b) a\n\ +> \ natural inner join (select true as a1, 4.5 as d) b;" +> $ Left [UnrecognisedCorrelationName "" +> ,IncompatibleTypeSet [ScalarType "int4" +> ,ScalarType "bool"]]-} +> ,s "select * from (select 1 as a1) a, (select 2 as a2) b;" +> $ Right [Just ([], [("a1", typeInt) +> ,("a2", typeInt)])] +> +> ,s "select * from (select 1 as a1) a, (select 2 as a1) b;" +> $ Right [Just ([], [("a1", typeInt) +> ,("a1", typeInt)])] +> --fixme: error detection (fixupids?) +> {-,s "select a1 from (select 1 as a1) a, (select 2 as a1) b;" +> $ Left [AmbiguousIdentifier "a1"]-} +> ] + +> where +> s = StmtType + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Literals.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Literals.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Literals.lhs @@ -0,0 +1,25 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Literals +> (tcLiteralTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> tcLiteralTestData :: Item +> tcLiteralTestData = +> Group "basic literal types" [ +> e "1" $ Right typeInt +> ,e "1.0" $ Right typeNumeric +> ,e "'test'" $ Right UnknownType +> ,e "true" $ Right typeBool +> ,e "array[1,2,3]" $ Right (ArrayType typeInt) +> ,e "array['a','b']" $ Right (ArrayType UnknownType) +> ,e "array['a'::text,'b']" $ Right (ArrayType (ScalarType "text")) +> ,e "array['a','b'::text]" $ Right (ArrayType (ScalarType "text")) +> ,e "array[1,'b']" $ Right (ArrayType typeInt) +> ,e "array[1,true]" $ Left [NoMatchingOperator "!arrayctor" [ScalarType "int4",ScalarType "bool"]] +> ] +> where +> e = Expr + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Misc.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Misc.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Misc.lhs @@ -0,0 +1,62 @@ + +Set of tests to check the type checking code. Includes tests for the +errors for sql which doesn't type check. + +> module Database.HsSqlPpp.Tests.TypeChecking.Misc +> (tcMiscTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> --import Database.HsSqlPpp.Catalog + +-------------------------------------------------------------------------------- + + +> tcMiscTestData :: Item +> tcMiscTestData = --fixme +> Group "misc" [ +> {-Group "composite elements" [ +> s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r pg_attrdef;\n\ +> \ a int;\n\ +> \ b text;\n\ +> \begin\n\ +> \ b = r.adsrc;\n\ +> \ r.adnum := a;\n\ +> \ b = r.adsrc;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> $ Right [Nothing] +> ]-} + +> {-,Group "positional args" [ +> s "create function distance(int, int, int, int) returns float(24) as $$\n\ +> \ select (point($1, $2) <-> point($3, $4))::float(24) as result;\n\ +> \$$ language sql immutable;" +> $ Right [Nothing] +> ,s "create function distance(int, int, int, int) returns float(24) as $$\n\ +> \ select (point($1, $2) <-> point($3, $5))::float(24) as result;\n\ +> \$$ language sql immutable;" +> $ Left [UnrecognisedIdentifier "$5"] +> ] + +> ,-}Group "window fns" [ +> s "select *, row_number() over () from pg_attrdef;" +> $ Right [Just ([], +> [("adrelid",ScalarType "oid") +> ,("adnum",ScalarType "int2") +> ,("adbin",ScalarType "pg_node_tree") +> ,("adsrc",ScalarType "text") +> ,("row_number",ScalarType "int8")])] +> ] +> ] + +> where +> --e = Expr +> s = StmtType +> --c = CatStmtType +> --d = Ddl + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscExpressions.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscExpressions.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscExpressions.lhs @@ -0,0 +1,63 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.MiscExpressions +> (miscExpressionsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> miscExpressionsTestData :: Item +> miscExpressionsTestData = +> Group "misc expressions" [ + +~~~~ +implicit casting and function/operator choice tests: +check when multiple implicit and one exact match on num args +check multiple matches with num args, only one with implicit conversions +check multiple implicit matches with one preferred +check multiple implicit matches with one preferred highest count +check casts from unknown string lits +~~~~ + +> Group "some expressions" [ +> e "3 + '4'" $ Right typeInt +> ,e "3.0 + '4'" $ Right typeNumeric +> ,e "'3' + '4'" $ Left [NoMatchingOperator "+" [UnknownType +> ,UnknownType]] +> ] +> ,Group "exists expressions" [ +> e "exists (select 1 from pg_type)" $ Right typeBool +> ,e "exists (select testit from pg_type)" +> $ Left [UnrecognisedIdentifier "testit"] +> ] + +> ,Group "polymorphic functions" [ +> e "array_append(ARRAY[1,2], 3)" +> $ Right (ArrayType typeInt) +> ,e "array_append(ARRAY['a','b'], 'c')" +> $ Right (ArrayType UnknownType) +> ,e "array_append(ARRAY['a','b'], 'c'::text)" +> $ Right (ArrayType $ ScalarType "text") +> ,e "array_append(ARRAY['a','b'::text], 'c')" +> $ Right (ArrayType $ ScalarType "text") +> ,e "array_append(ARRAY['a'::int,'b'], 'c')" +> $ Right (ArrayType typeInt) +> ] + +> ,Group "cast expressions" [ +> e "cast ('1' as integer)" +> $ Right typeInt +> ,e "cast ('1' as baz)" +> $ Left [UnknownTypeName "baz"] +> ,e "array[]" -- FIXME: this isn't quite right but not sure how to do it atm +> -- no point fixing this case since need a load of other +> -- test cases where the behaviour is different +> $ Right (Pseudo AnyArray) -- Left [TypelessEmptyArray] +> ,e "array[] :: text[]" +> $ Right (ArrayType (ScalarType "text")) +> ] + +> ] +> where +> e = Expr diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscSelects.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscSelects.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/MiscSelects.lhs @@ -0,0 +1,83 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.MiscSelects +> (tcMiscSelectTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> import Database.HsSqlPpp.Catalog + +> tcMiscSelectTestData :: Item +> tcMiscSelectTestData = +> Group "misc selects" [ +> Group "aggregates" [ +> s "select max(prorettype::int) from pg_proc;" +> $ Right [Just ([], [("max", typeInt)])] +> ] + +> ,Group "simple wheres" [ +> s "select 1 from pg_type where true;" +> $ Right [Just ([], [("?column?", typeInt)])] +> ,s "select 1 from pg_type where 1;" +> $ Left [ExpressionMustBeBool] +> ,s "select typname from pg_type where typbyval;" +> $ Right [Just ([], [("typname", ScalarType "name")])] +> ,s "select typname from pg_type where typtype = 'b';" +> $ Right [Just ([], [("typname", ScalarType "name")])] +> ,s "select typname from pg_type where what = 'b';" +> $ Left [UnrecognisedIdentifier "what"] +> ] + +> ,Group "unnest" [ +> s "select conname,unnest(conkey) as attnum from pg_constraint;" +> $ Right [Just ([], [("conname",ScalarType "name") +> ,("attnum",typeSmallInt)])] +> ] + +TODO: check identifier stacking working, then remove the pg_namespace +qualifier before oid and this should still work + +> ,Group "subqueries" [ +> s "select relname as relvar_name\n\ +> \ from pg_class\n\ +> \ where ((relnamespace =\n\ +> \ (select oid\n\ +> \ from pg_namespace\n\ +> \ where (nspname = 'public'))) and (relkind = 'r'));" +> $ Right [Just ([], [("relvar_name",ScalarType "name")])] +> ,s "select relname from pg_class where relkind in ('r', 'v');" +> $ Right [Just ([], [("relname",ScalarType "name")])] +> ,s "select * from generate_series(1,7) g\n\ +> \where g not in (select * from generate_series(3,5));" +> $ Right [Just ([], [("g",typeInt)])] +> ,s "select * from generate_series(3,5);" +> $ Right [Just ([], [("generate_series",typeInt)])] +> ,s "select * from generate_series(1,7) g\n\ +> \where g not in (1,2);" +> $ Right [Just ([], [("g",typeInt)])] + +> ,s "select 3 = any(array[1,2,3]);" +> $ Right [Just ([], [("?column?",typeBool)])] +> ,c "select b.t,b.u from a,b where a.t = b.t\n\ +> \ and b.u = (select min(b.u) from b where a.t = b.t);" +> [CatCreateTable "a" [("t", typeInt)] [] +> ,CatCreateTable "b" [("t", typeInt) +> ,("u", typeNumeric)] []] +> $ Right [Just ([], [("t", typeInt) +> ,("u", typeNumeric)])] +> ] +> +> -- identifiers in select parts +> ,Group "select part identifiers" [ +> s "select relname as relvar_name,attname as name from pg_class\n\ +> \inner join pg_attribute\n\ +> \on pg_attribute.attrelid = pg_class.oid;" +> $ Right [Just ([], [("relvar_name",ScalarType "name") +> ,("name",ScalarType "name")])] +> ] +> ] + + +> where +> s = StmtType +> c = CatStmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Plpgsql.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Plpgsql.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Plpgsql.lhs @@ -0,0 +1,179 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Plpgsql +> (tcPlpgsqlTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +-------------------------------------------------------------------------------- + +~~~~ +check the identifier resolution for functions: +parameters +variable declarations +select expressions inside these: +refer to param +refer to variable +override var with var +override var with select iden +todo: override var with param, override select iden with param + +check var defs: +check type exists +check type of initial values + + +> tcPlpgsqlTestData :: Item +> tcPlpgsqlTestData = --fixme: plpgsql ids +> Group "plpgsql" $ drop 1000 [ +> Group "create function param resolution" [ +> s "create function t1(stuff text) returns text as $$\n\ +> \begin\n\ +> \ return stuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> ,s "create function t1(stuff text) returns text as $$\n\ +> \begin\n\ +> \ return badstuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Left [UnrecognisedIdentifier "badstuff"]) +> ,s "create function t1() returns text as $$\n\ +> \declare\n\ +> \ stuff text;\n\ +> \begin\n\ +> \ return stuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> ] + + +-------------------------------------------------------------------------------- + +> ,Group "plpgsqlbits" [ +> s "create function t1(stuff text) returns text as $$\n\ +> \begin\n\ +> \ return stuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> ,s "create function t1(stuff text) returns text as $$\n\ +> \begin\n\ +> \ return badstuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Left [UnrecognisedIdentifier "badstuff"]) +> ,s "create function t1() returns text as $$\n\ +> \declare\n\ +> \ stuff text;\n\ +> \begin\n\ +> \ return stuff || ' and stuff';\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a bool;\n\ +> \begin\n\ +> \ a := 3;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Left [IncompatibleTypes (ScalarType "bool") (ScalarType "int4")]) +> ,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ a boolean;\n\ +> \begin\n\ +> \ a := true;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> ] + +-------------------------------------------------------------------------------- + +> ,Group "for loops" [ +> s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r record;\n\ +> \ t int;\n\ +> \begin\n\ +> \ for r in select * from pg_attrdef loop\n\ +> \ t := r.adnum;\n\ +> \ end loop;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing]) +> +> +> {-,s "create function t1() returns void as $$\n\ +> \declare\n\ +> \ r record;\n\ +> \ t int;\n\ +> \begin\n\ +> \ for r in select adnum from pg_attrdef loop\n\ +> \ t := r;\n\ +> \ end loop;\n\ +> \end;\n\ +> \$$ language plpgsql stable;" +> (Right [Nothing])-} +> +> -- loop var already declared +> +> ,s "create function test() returns void as $$\n\ +> \declare\n\ +> \ i int;\n\ +> \ i1 int;\n\ +> \begin\n\ +> \ for i in 0 .. 10 loop\n\ +> \ i1 := i;\n\ +> \ end loop;\n\ +> \end;\n\ +> \$$ language plpgsql volatile;" +> (Right [Nothing]) +> +> --implicitly created loop var +> +> ,s "create function test() returns void as $$\n\ +> \declare\n\ +> \ i1 int;\n\ +> \begin\n\ +> \ for i in 0 .. 10 loop\n\ +> \ i1 := i;\n\ +> \ end loop;\n\ +> \end;\n\ +> \$$ language plpgsql volatile;" +> (Right [Nothing]) +> +> --loop var already declared, wrong type +> +> ,s "create function test() returns void as $$\n\ +> \declare\n\ +> \ i bool;\n\ +> \begin\n\ +> \ for i in 0 .. 10 loop\n\ +> \ null;\n\ +> \ end loop;\n\ +> \end;\n\ +> \$$ language plpgsql volatile;" +> (Left [IncompatibleTypes (ScalarType "bool") (ScalarType "int4")]) +> +> --loop var implicit check it's type +> +> ,s "create function test() returns void as $$\n\ +> \declare\n\ +> \ t bool;\n\ +> \begin\n\ +> \ for i in 0 .. 10 loop\n\ +> \ t := i;\n\ +> \ end loop;\n\ +> \end;\n\ +> \ $$ language plpgsql volatile;" +> (Left [IncompatibleTypes (ScalarType "bool") (ScalarType "int4")]) +> ] +> ] +> where +> s = StmtType + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Qualification.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Qualification.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Qualification.lhs @@ -0,0 +1,47 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Qualification +> (tcQualificationTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +> tcQualificationTestData :: Item +> tcQualificationTestData = +> Group "simple scalar identifier qualification" [ +> s "select a.* from \n\ +> \(select 1 as a, 2 as b) a \n\ +> \cross join (select 3 as c, 4 as d) b;" +> $ Right [Just ([], [("a", typeInt) +> ,("b", typeInt)])] +> {-,s "select nothere.* from \n\ +> \(select 1 as a, 2 as b) a \n\ +> \cross join (select 3 as c, 4 as d) b;" +> $ Left [UnrecognisedCorrelationName "nothere"]-} +> ,s "select a.b,b.c from \n\ +> \(select 1 as a, 2 as b) a \n\ +> \natural inner join (select 3 as a, 4 as c) b;" +> $ Right [Just ([], [("b", typeInt) +> ,("c", typeInt)])] +> ,s "select a.a,b.a from \n\ +> \(select 1 as a, 2 as b) a \n\ +> \natural inner join (select 3 as a, 4 as c) b;" +> $ Right [Just ([], [("a", typeInt) +> ,("a", typeInt)])] +> ,s "select pg_attrdef.adsrc from pg_attrdef;" +> $ Right [Just ([], [("adsrc", ScalarType "text")])] +> +> ,s "select a.adsrc from pg_attrdef a;" +> $ Right [Just ([], [("adsrc", ScalarType "text")])] +> +> ,s "select pg_attrdef.adsrc from pg_attrdef a;" +> $ Left [UnrecognisedCorrelationName "pg_attrdef"] +> +> ,s "select a from (select 2 as b, 1 as a) a\n\ +> \natural inner join (select 4.5 as d, 1 as a) b;" +> $ Right [Just ([], [("a", typeInt)])] +> +> ] + +> where +> s = StmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/RowCtors.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/RowCtors.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/RowCtors.lhs @@ -0,0 +1,52 @@ + +Set of tests to check the type checking code. Includes tests for the +errors for sql which doesn't type check. + +> module Database.HsSqlPpp.Tests.TypeChecking.RowCtors +> (tcRowCtorsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> tcRowCtorsTestData :: Item +> tcRowCtorsTestData = +> Group "row comparison expressions" [ + +~~~~ +rows different lengths +rows match types pairwise, same and different types +rows implicit cast from unknown +rows don't match types +~~~~ + +> e "row(1)" $ Right (AnonymousRecordType [typeInt]) +> ,e "row(1,2)" $ Right (AnonymousRecordType [typeInt,typeInt]) +> ,e "row('t1','t2')" $ Right (AnonymousRecordType [UnknownType,UnknownType]) +> ,e "row(true,1,'t3')" $ Right (AnonymousRecordType [typeBool, typeInt,UnknownType]) +> ,e "(true,1,'t3',75.3)" $ Right (AnonymousRecordType [typeBool,typeInt +> ,UnknownType,typeNumeric]) +> ,e "row(1) = row(2)" $ Right typeBool +> ,e "row(1,2) = row(2,1)" $ Right typeBool +> ,e "(1,2) = (2,1)" $ Right typeBool +> ,e "(1,2,3) = (2,1)" $ Left [NoMatchingOperator "=" +> [AnonymousRecordType [ScalarType "int4" +> ,ScalarType "int4" +> ,ScalarType "int4"] +> ,AnonymousRecordType [ScalarType "int4" +> ,ScalarType "int4"]]] +> ,e "('1',2) = (2,'1')" $ Right typeBool +> ,e "(1,true) = (2,1)" $ Left [NoMatchingOperator "=" +> [AnonymousRecordType [ScalarType "int4" +> ,ScalarType "bool"] +> ,AnonymousRecordType [ScalarType "int4" +> ,ScalarType "int4"]]] +> ,e "(1,2) <> (2,1)" $ Right typeBool +> ,e "(1,2) >= (2,1)" $ Right typeBool +> ,e "(1,2) <= (2,1)" $ Right typeBool +> ,e "(1,2) > (2,1)" $ Right typeBool +> ,e "(1,2) < (2,1)" $ Right typeBool +> ] +> where +> e = Expr diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SelectFrom.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SelectFrom.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SelectFrom.lhs @@ -0,0 +1,77 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.SelectFrom +> (tcSelectFromTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> import Database.HsSqlPpp.Catalog + +> tcSelectFromTestData :: Item +> tcSelectFromTestData = +> Group "selects from" [ +> Group "simple selects from" [ +> s "select a from (select 1 as a, 2 as b) x;" +> $ Right [Just ([], [("a", typeInt)])] +> ,s "select b from (select 1 as a, 2 as b) x;" +> $ Right [Just ([], [("b", typeInt)])] +> ,s "select c from (select 1 as a, 2 as b) x;" +> $ Left [UnrecognisedIdentifier "c"] +> ,s "select typlen from pg_type;" +> $ Right [Just ([], [("typlen", typeSmallInt)])] +> ,s "select oid from pg_type;" +> $ Right [Just ([], [("oid", ScalarType "oid")])] +> ,s "select p.oid from pg_type p;" +> $ Right [Just ([], [("oid", ScalarType "oid")])] +> ,s "select typlen from nope;" +> $ Left [UnrecognisedRelation "nope"] +> ,s "select generate_series from generate_series(1,7);" +> $ Right [Just ([], [("generate_series", typeInt)])] +> +> -- check aliasing +> ,s "select generate_series.generate_series from generate_series(1,7);" +> $ Right [Just ([], [("generate_series", typeInt)])] +> ,s "select g from generate_series(1,7) g;" +> $ Right [Just ([], [("g", typeInt)])] +> ,s "select g.g from generate_series(1,7) g;" +> $ Right [Just ([], [("g", typeInt)])] +> ,s "select generate_series.g from generate_series(1,7) g;" +> $ Left [UnrecognisedCorrelationName "generate_series"] +> ,s "select g.generate_series from generate_series(1,7) g;" +> $ Left [UnrecognisedIdentifier "generate_series"] +> +> ,s "select * from pg_attrdef;" +> $ Right [Just ([], +> [("adrelid",ScalarType "oid") +> ,("adnum",ScalarType "int2") +> ,("adbin",ScalarType "pg_node_tree") +> ,("adsrc",ScalarType "text")])] +> ,s "select abs from abs(3);" +> $ Right [Just ([], [("abs", typeInt)])] +> --todo: these are both valid, +> --the second one means select 3+generate_series from generate_series(1,7) +> -- select generate_series(1,7); +> -- select 3 + generate_series(1,7); +> ] + +> ,Group "simple selects from 2" [ +> -- fixme: needs compfuntref? +> {-c "select a,b from testfunc();" +> [CatCreateComposite "testType" [("a", ScalarType "text") +> ,("b", typeInt) +> ,("c", typeInt)] +> ,CatCreateFunction FunName "testfunc" [] +> (SetOfType $ NamedCompositeType "testType") False] +> $ Right [Just ([], +> [("a",ScalarType "text"),("b",ScalarType "int4")])] +> +> ,-}c "select testfunc();" +> [CatCreateFunction FunName "testfunc" [] (Pseudo Void) False] +> $ Right [Just ([], [])] +> ] +> ] + +> where +> s = StmtType +> c = CatStmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleExpressions.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleExpressions.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleExpressions.lhs @@ -0,0 +1,73 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.SimpleExpressions +> (tcSimpleExpressionTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> tcSimpleExpressionTestData :: Item +> tcSimpleExpressionTestData = +> Group "simple expressions" [ +> e "1=1" $ Right typeBool +> ,e "1=true" $ Left [NoMatchingOperator "=" [typeInt,typeBool]] +> ,e "substring('aqbc' from 2 for 2)" $ Right (ScalarType "text") +> +> ,e "substring(3 from 2 for 2)" $ Left +> [NoMatchingOperator "!substring" +> [ScalarType "int4" +> ,ScalarType "int4" +> ,ScalarType "int4"]] +> ,e "substring('aqbc' from 2 for true)" $ Left +> [NoMatchingOperator "!substring" +> [UnknownType +> ,ScalarType "int4" +> ,ScalarType "bool"]] +> +> ,e "3 between 2 and 4" $ Right typeBool +> ,e "3 between true and 4" $ Left +> [IncompatibleTypeSet [ScalarType "int4" +> ,ScalarType "bool" +> ,ScalarType "int4"]] +> +> ,e "array[1,2,3][2]" $ Right typeInt +> ,e "array['a','b'][1]" $ Right UnknownType +> ,e "array['a'::text,'b'][1]" $ Right (ScalarType "text") +> -- FIXME? +> {-,p "array['a','b'][true]" (TypeError ("",0,0) +> (WrongType +> typeInt +> UnknownType))-} +> ,e "not true" $ Right typeBool +> ,e "not 1" $ Left +> [NoMatchingOperator "!not" [typeInt]] +> +> ,e "@ 3" $ Right typeInt +> ,e "@ true" $ Left +> [NoMatchingOperator "@" [ScalarType "bool"]] +> +> ,e "-3" $ Right typeInt +> ,e "-'a'" $ Left +> [NoMatchingOperator "-" [UnknownType]] +> +> ,e "4-3" $ Right typeInt +> +> ,e "1 is null" $ Right typeBool +> ,e "1 is not null" $ Right typeBool +> +> ,e "1+1" $ Right typeInt +> ,e "1+1" $ Right typeInt +> ,e "31*511" $ Right typeInt +> ,e "5/2" $ Right typeInt +> ,e "2^10" $ Right typeFloat8 +> ,e "17%5" $ Right typeInt +> ,e "3 and 4" $ Left +> [NoMatchingOperator "!and" [typeInt,typeInt]] +> ,e "True and False" $ Right typeBool +> ,e "false or true" $ Right typeBool +> ,e "lower('TEST')" $ Right (ScalarType "text") +> ,e "lower(1)" $ Left [NoMatchingOperator "lower" [typeInt]] +> ] +> where +> e = Expr diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleSelects.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleSelects.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SimpleSelects.lhs @@ -0,0 +1,44 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.SimpleSelects +> (tcSimpleSelectsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> tcSimpleSelectsTestData :: Item +> tcSimpleSelectsTestData = +> Group "simple selects" [ +> s "select 1;" $ Right [Just ([], [("?column?", typeInt)])] +> ,s "select 1 as a;" $ +> Right [Just ([], [("a", typeInt)])] +> ,s "select 1,2;" $ +> Right [Just ([], [("?column?", typeInt) +> ,("?column?", typeInt)])] +> ,s "select 1 as a, 2 as b;" $ +> Right [Just ([], [("a", typeInt) +> ,("b", typeInt)])] +> ,s "select 1+2 as a, 'a' || 'b';" $ +> Right [Just ([], [("a", typeInt) +> ,("?column?", ScalarType "text")])] +> ,s "values (1,2);" $ Right [Just ([], +> [("column1", typeInt) +> ,("column2", typeInt)])] +> ,s "values (1,2),('3', '4');" $ Right [Just ([], +> [("column1", typeInt) +> ,("column2", typeInt)])] +> ,s "values (1,2),('a', true);" $ Left [IncompatibleTypeSet [typeInt +> ,typeBool]] +> ,s "values ('3', '4'),(1,2);" $ Right [Just ([], +> [("column1", typeInt) +> ,("column2", typeInt)])] +> ,s "values ('a', true),(1,2);" $ Left [IncompatibleTypeSet [typeBool +> ,typeInt]] +> ,s "values ('a'::text, '2'::int2),('1','2');" $ Right [Just ([], +> [("column1", ScalarType "text") +> ,("column2", typeSmallInt)])] +> ,s "values (1,2,3),(1,2);" $ Left [ValuesListsMustBeSameLength] +> ] +> where +> s = StmtType diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SpecialFunctions.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SpecialFunctions.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/SpecialFunctions.lhs @@ -0,0 +1,32 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.SpecialFunctions +> (tcSpecialFunctionsTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types +> +> +> tcSpecialFunctionsTestData :: Item +> tcSpecialFunctionsTestData = +> Group "special functions" [ +> e "coalesce(null,1,2,null)" $ Right typeInt +> ,e "coalesce('3',1,2,null)" $ Right typeInt +> ,e "coalesce('3',1,true,null)" +> $ Left [NoMatchingOperator "coalesce" [UnknownType +> ,ScalarType "int4" +> ,ScalarType "bool" +> ,UnknownType]] +> ,e "nullif('hello','hello')" $ Right UnknownType +> ,e "nullif('hello'::text,'hello')" $ Right (ScalarType "text") +> ,e "nullif(3,4)" $ Right typeInt +> ,e "nullif(true,3)" +> $ Left [NoMatchingOperator "nullif" [ScalarType "bool" +> ,ScalarType "int4"]] +> ,e "greatest(3,5,6,4,3)" $ Right typeInt +> ,e "least(3,5,6,4,3)" $ Right typeInt +> ,e "least(5,true)" +> $ Left [NoMatchingOperator "least" [ScalarType "int4",ScalarType "bool"]] +> ] +> where +> e = Expr diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TableRefTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TableRefTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TableRefTests.lhs @@ -0,0 +1,136 @@ +Test the type checking and errors within tablerefs +and test the produced simple select lists + +> module Database.HsSqlPpp.Tests.TypeChecking.TableRefTests +> (tableRefTests +> --,tableRefTestData +> --,Item(..) +> ) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Data.List +> import Data.Generics.Uniplate.Data +> import Control.Monad +> import Text.Groom +> +> --import Database.HsSqlPpp.Utils.Here +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> --import Database.HsSqlPpp.Utils.PPExpr +> --import Database.HsSqlPpp.Tests.TestUtils +> import Database.HsSqlPpp.Pretty +> +> data Item = Group String [Item] +> | Query [CatalogUpdate] String (Either [TypeError] Type) +> +> tableRefTests :: Test.Framework.Test +> tableRefTests = itemToTft tableRefTestData +> +> tableRefTestData :: Item +> tableRefTestData = Group "tableRefs" +> [Query db1 "select * from t;" +> $ Right $ SetOfType $ CompositeType +> [("a",typeInt) +> ,("b",typeInt)] +> ,Query db1 "select a,b from t;" +> $ Right $ SetOfType $ CompositeType +> [("a",typeInt) +> ,("b",typeInt)] +> ,Query db1 "select t.* from t;" +> $ Right $ SetOfType $ CompositeType +> [("a",typeInt) +> ,("b",typeInt)] +> {-,Query db1 "select u.* from t;" +> $ Left [UnrecognisedCorrelationName "u"]-} +> ,Query db1 "select * from t u;" +> $ Right $ SetOfType $ CompositeType +> [("a",typeInt) +> ,("b",typeInt)] +> ,Query db1 "select * from t u(c,d);" +> $ Right $ SetOfType $ CompositeType +> [("c",typeInt) +> ,("d",typeInt)] +> ,Query db1 "select u.* from t u(c,d);" +> $ Right $ SetOfType $ CompositeType +> [("c",typeInt) +> ,("d",typeInt)] +> ,Query db1 "select c,d from t u(c,d);" +> $ Right $ SetOfType $ CompositeType +> [("c",typeInt) +> ,("d",typeInt)] +> {-,Query db1 "select t.* from t u;" +> $ Left [UnrecognisedCorrelationName "t"]-} +> -- FIXME: disabled because the error comes out twice, and I can't work out why +> -- this problem occurs in the uuagc code so it is probably the ag code which is wrong +> {-,Query db1 "select * from t u(a);" +> $ Left [WrongNumberOfAliasCols 2 1]-} +> ,Query db1 "select c from t;" +> $ Left [UnrecognisedIdentifier "c"] +> ,Query db1 "select a from t u(c,d);" +> $ Left [UnrecognisedIdentifier "a"] +> ,Query db1 "select * from non;" +> $ Left [UnrecognisedRelation "non"] +> ,Query db1 "select a,b,d from t,u where a=c;" +> $ Right $ SetOfType $ CompositeType +> [("a",typeInt) +> ,("b",typeInt) +> ,("d",typeInt)] +> ] + +table ref tests: + +columns in: +tref, subtref, funtref +jointref: aliased, unaliased, 3 way + +select lists: +simple, qualified, *, q.* + + +errors: +unrecognised id +ambiguous id +incompatible join columns +unrecognised relation +missing join attribute + + + + +> db1 :: [CatalogUpdate] +> db1 = [CatCreateTable "t" [("a",typeInt) +> ,("b", typeInt)] [] +> ,CatCreateTable "u" [("c",typeInt) +> ,("d", typeInt)] [] +> ,CatCreateTable "v" [("v",typeInt)] []] + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> itemToTft (Query eu sql t) = testCase ("typecheck " ++ sql) $ do +> let ast = case parseQueryExpr "" sql of +> Left e -> error $ show e +> Right l -> l +> aast = typeCheckQueryExpr cat ast +> ty = atype $ getAnnotation aast +> er :: [TypeError] +> er = universeBi aast +> res = if null er +> then case ty of +> Nothing -> Left [] +> Just ty' -> Right ty' +> else Left er +> when (t /= res) $ putStrLn $ "bad sql: " ++ printQueryExpr aast +> ++ "\n" ++ groom aast +> assertEqual "" t res +> where +> cat = case updateCatalog defaultTemplate1Catalog eu of +> Left x -> error $ show x +> Right e -> e + + + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TpchTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TpchTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TpchTests.lhs @@ -0,0 +1,168 @@ + +Tests using the tpch queries. Just tests the result type at the +moment. + +> module Database.HsSqlPpp.Tests.TypeChecking.TpchTests +> (tpchTests) where +> +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Data.List +> import Data.Generics.Uniplate.Data +> import Control.Monad +> --import Text.Groom +> +> --import Database.HsSqlPpp.Utils.Here +> import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> --import Database.HsSqlPpp.Utils.PPExpr +> --import Database.HsSqlPpp.Tests.TestUtils +> import Database.HsSqlPpp.Pretty +> import Database.HsSqlPpp.Tests.TpchData +> +> data Item = Group String [Item] +> | Query String String Type +> +> tpchTests :: Test.Framework.Test +> tpchTests = itemToTft tpchTestData +> +> tpchTestData :: Item +> tpchTestData = +> Group "tpch" $ +> -- FIXME: 15 has with expression which doesn't quite work atm +> -- (todo with fixup identifiers I think +> let (s,e) = splitAt 14 t +> in s ++ drop 1 e +> where +> t = zipWith (\(n,s) t' -> Query n s (SetOfType $ CompositeType t')) +> tpchQueries +> [-- q1 +> [("l_returnflag", typeChar) +> ,("l_linestatus", typeChar) +> ,("sum_qty", typeNumeric) +> ,("sum_base_price", typeNumeric) +> ,("sum_disc_price", typeNumeric) +> ,("sum_charge", typeNumeric) +> ,("avg_qty", typeNumeric) +> ,("avg_price", typeNumeric) +> ,("avg_disc", typeNumeric) +> ,("count_order", typeBigInt)] +> ,--q2 +> [("s_acctbal", typeNumeric) +> ,("s_name", typeChar) +> ,("n_name", typeChar) +> ,("p_partkey", typeInt) +> ,("p_mfgr", typeChar) +> ,("s_address", typeVarChar) +> ,("s_phone", typeChar) +> ,("s_comment", typeVarChar)] +> ,--q3 +> [("l_orderkey", typeInt) +> ,("revenue", typeNumeric) +> ,("o_orderdate", typeDate) +> ,("o_shippriority", typeInt)] +> ,--q4 +> [("o_orderpriority", typeChar) +> ,("order_count", typeBigInt)] +> ,--q5 +> [("n_name", typeChar) +> ,("revenue", typeNumeric)] +> ,--q6 +> [("revenue", typeNumeric)] +> ,--q7 +> [("supp_nation", typeChar) +> ,("cust_nation", typeChar) +> ,("l_year", typeFloat8) +> ,("revenue", typeNumeric)] +> ,--q8 +> [("o_year", typeFloat8) +> ,("mkt_share", typeNumeric)] +> ,--q9 +> [("nation", typeChar) +> ,("o_year", typeFloat8) +> ,("sum_profit", typeNumeric)] +> ,--q10 +> [("c_custkey",typeInt) +> ,("c_name", typeChar) +> ,("revenue", typeNumeric) +> ,("c_acctbal", typeNumeric) +> ,("n_name", typeChar) +> ,("c_address", typeVarChar) +> ,("c_phone", typeChar) +> ,("c_comment", typeVarChar)] +> ,--q11 +> [("ps_partkey", typeInt) +> ,("value", typeNumeric)] +> ,--q12 +> [("l_shipmode", typeChar) +> ,("high_line_count", typeBigInt) +> ,("low_line_count", typeBigInt)] +> ,--q13 +> [("c_count", typeBigInt) +> ,("custdist", typeBigInt)] +> ,--q14 +> [("promo_revenue", typeNumeric)] +> ,--q15 +> [("s_suppkey", typeInt) +> ,("s_name", typeChar) +> ,("s_address", typeVarChar) +> ,("s_phone", typeChar) +> ,("total_revenue", typeNumeric)] +> ,--q16 +> [("p_brand", typeChar) +> ,("p_type", typeVarChar) +> ,("p_size", typeInt) +> ,("supplier_cnt", typeBigInt)] +> ,--q17 +> [("avg_yearly", typeNumeric)] +> ,--q18 +> [("c_name", typeChar) +> ,("c_custkey", typeInt) +> ,("o_orderkey", typeInt) +> ,("o_orderdate", typeDate) +> ,("o_totalprice", typeNumeric) +> ,("sum", typeNumeric)] +> ,--q19 +> [("revenue", typeNumeric)] +> ,--q20 +> [("s_name", typeChar) +> ,("s_address", typeVarChar)] +> ,--q21 +> [("s_name", typeChar) +> ,("numwait", typeBigInt)] +> ,--q22 +> [("cntrycode", ScalarType "char") +> ,("numcust", typeBigInt) +> ,("totacctbal", typeNumeric)] +> ] + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Group s is) = testGroup s $ map itemToTft is +> itemToTft (Query n sql t) = testCase ("typecheck tpch " ++ n ++ ":") $ do +> let ast = case parseQueryExpr "" sql of +> Left e -> error $ show e +> Right l -> l +> aast = typeCheckQueryExpr cat ast +> ty = atype $ getAnnotation aast +> er :: [TypeError] +> er = universeBi aast +> res = if null er +> then case ty of +> Nothing -> Left [] +> Just ty' -> Right ty' +> else Left er +> ok = Right t == res +> unless ok $ putStrLn $ "bad sql: " ++ printQueryExpr aast +> -- ++ "\n" ++ groom aast +> assertBool "" ok +> where +> cat = case updateCatalog defaultTemplate1Catalog tpchCatalog of +> Left x -> error $ show x +> Right e -> e + + + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Triggers.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Triggers.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Triggers.lhs @@ -0,0 +1,94 @@ + +Set of tests to check the type checking code. Includes tests for the +errors for sql which doesn't type check. + +> module Database.HsSqlPpp.Tests.TypeChecking.Triggers +> (tcTriggersTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> --import Database.HsSqlPpp.Types +> +> --import Database.HsSqlPpp.Catalog + +-------------------------------------------------------------------------------- + + +> tcTriggersTestData :: Item +> tcTriggersTestData = --fixme +> Group "triggers" [ +> {-d [$here| +> create table t1 ( +> a int, +> b int, +> c text +> ); +> create table t2 ( +> a int, +> b int, +> c int +> ); +> create function trig_fn() returns trigger as $a$ +> begin +> if (NEW.a > 100) or (OLD.b < 5) then +> raise exception 'no good'; +> end if; +> return NEW; +> end; +> $a$ language plpgsql volatile; +> create trigger trig +> after update on t1 +> for each row +> execute procedure check_relvar_update(); +> create trigger trig +> after update on t2 +> for each row +> execute procedure check_relvar_update(); +> |] +> [CatCreateTable "t1" [("a",ScalarType "int4") +> ,("b",ScalarType "int4") +> ,("c",ScalarType "text")] +> [("tableoid",ScalarType "oid") +> ,("cmax",ScalarType "cid") +> ,("xmax",ScalarType "xid") +> ,("cmin",ScalarType "cid") +> ,("xmin",ScalarType "xid") +> ,("ctid",ScalarType "tid")] +> ,CatCreateTable "t2" [("a",ScalarType "int4") +> ,("b",ScalarType "int4") +> ,("c",ScalarType "int4")] +> [("tableoid",ScalarType "oid") +> ,("cmax",ScalarType "cid") +> ,("xmax",ScalarType "xid") +> ,("cmin",ScalarType "cid") +> ,("xmin",ScalarType "xid") +> ,("ctid",ScalarType "tid")] +> ,CatCreateFunction FunName "trig_fn" [] (Pseudo Trigger) False]-} +> {-,s [$here| +> create table t1 ( +> a int, +> b int, +> c text +> ); +> create function trig_fn() returns trigger as $a$ +> begin +> if NEW.d = 'bad value' then +> return NEW; +> raise exception 'no good'; +> end if; +> end; +> $a$ language plpgsql volatile; +> create trigger trig +> after update on t1 +> for each row +> execute procedure check_relvar_update(); +> |] +> $ Left []-} +> ] + +> where +> --e = Expr +> --s = StmtType +> --c = CatStmtType +> --d = Ddl + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeCheckTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeCheckTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeCheckTests.lhs @@ -0,0 +1,115 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.TypeCheckTests +> (typeCheckTests +> ,typeCheckTestData +> ,Item(..)) where + +> import Test.Framework + + +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Tests.TypeChecking.TableRefTests +> import Database.HsSqlPpp.Tests.TypeChecking.TpchTests +> import Database.HsSqlPpp.Tests.TypeChecking.TypeInferenceTests +> import Database.HsSqlPpp.Tests.TypeChecking.Literals +> import Database.HsSqlPpp.Tests.TypeChecking.SimpleExpressions +> import Database.HsSqlPpp.Tests.TypeChecking.SpecialFunctions +> import Database.HsSqlPpp.Tests.TypeChecking.RowCtors +> import Database.HsSqlPpp.Tests.TypeChecking.CaseExpressions +> import Database.HsSqlPpp.Tests.TypeChecking.MiscExpressions +> import Database.HsSqlPpp.Tests.TypeChecking.SimpleSelects +> import Database.HsSqlPpp.Tests.TypeChecking.CombineSelects +> import Database.HsSqlPpp.Tests.TypeChecking.SelectFrom +> import Database.HsSqlPpp.Tests.TypeChecking.Joins +> import Database.HsSqlPpp.Tests.TypeChecking.Qualification +> import Database.HsSqlPpp.Tests.TypeChecking.MiscSelects +> import Database.HsSqlPpp.Tests.TypeChecking.Insert +> import Database.HsSqlPpp.Tests.TypeChecking.Update +> import Database.HsSqlPpp.Tests.TypeChecking.Delete +> import Database.HsSqlPpp.Tests.TypeChecking.Creates +> import Database.HsSqlPpp.Tests.TypeChecking.Plpgsql +> import Database.HsSqlPpp.Tests.TypeChecking.CatalogChaining +> import Database.HsSqlPpp.Tests.TypeChecking.Into +> import Database.HsSqlPpp.Tests.TypeChecking.Drops +> import Database.HsSqlPpp.Tests.TypeChecking.Triggers +> import Database.HsSqlPpp.Tests.TypeChecking.Misc + +> typeCheckTestData :: Item +> typeCheckTestData = Group "typeCheckTests" typeCheckTestList + +> typeCheckTestList :: [Item] +> typeCheckTestList = [tcLiteralTestData +> ,tcSimpleExpressionTestData +> ,tcSpecialFunctionsTestData +> ,tcRowCtorsTestData +> ,caseExpressionsTestData +> ,miscExpressionsTestData +> ,tcSimpleSelectsTestData +> ,tcCombineSelectsTestData +> ,tcSelectFromTestData +> ,tcJoinsTestData +> ,tcQualificationTestData +> ,tcMiscSelectTestData +> ,tcInsertTestData +> ,tcUpdateTestData +> ,tcDeleteTestData +> ,tcCreateTestData +> ,tcPlpgsqlTestData +> ,tcCatalogChainingTestData +> ,tcIntoTestData +> ,tcDropsTestData +> ,tcTriggersTestData +> ,tcMiscTestData] + +todo: + +-------------------------------------------------------------------------------- + +~~~~ +test some casts +assign composite to record + then assign record to composite +assign row to composite + : check wrong cols, wrong types +check read and write fields in composite->record +check read and write fields in composite +check domain <-> base assigns +check call function with compatible composite, compatible row ctor +assign comp to comp + +todo for chaos sql +for loop var = scalar, select = setof composite with one scalar + +select into +composite assignment and equality +autocast from rowctor to composite when calling function +assignment to composite fields +read fields of composite + +array_contains -> match anyelement +createtable as cat update +window functions +assign domain <-> base +sql function not working +~~~~ + + +~~~~ +check insert returning, update returning, delete returning, one check each +check select into: multiple vars, record (then access fields to check), + composite var +check errors: select into wrong number of vars, wrong types, and into + composite wrong number and wrong type +~~~~ + + + + +> typeCheckTests :: Test.Framework.Test +> typeCheckTests = +> testGroup "typeChecking" $ +> [tableRefTests +> ,tpchTests +> ,typeInferenceTests] +> ++ map itemToTft typeCheckTestList diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeInferenceTests.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeInferenceTests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/TypeInferenceTests.lhs @@ -0,0 +1,66 @@ + +> {-# LANGUAGE QuasiQuotes #-} +> module Database.HsSqlPpp.Tests.TypeChecking.TypeInferenceTests (typeInferenceTests) where + +> import Test.HUnit +> import Test.Framework +> import Test.Framework.Providers.HUnit +> --import Data.List +> import Data.Generics.Uniplate.Data + +> --import Debug.Trace +> +> --import Database.HsSqlPpp.Utils.Here +> --import Database.HsSqlPpp.Parser +> import Database.HsSqlPpp.TypeChecker +> import Database.HsSqlPpp.Annotation +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> import Database.HsSqlPpp.Quote +> import Database.HsSqlPpp.Ast +> import Database.HsSqlPpp.Pretty + +> data Item = Expr ScalarExpr [Maybe Type] +> | Group String [Item] + +> typeInferenceTests :: Test.Framework.Test +> typeInferenceTests = itemToTft typeInferenceTestData +> +> typeInferenceTestData :: Item +> typeInferenceTestData = +> Group "typeInferenceTests" [ +> e [sqlExpr| 1 = '2'|] [Just typeBool +> ,Just typeInt +> ,Just typeInt] +> ,e [sqlExpr| (3,4) = ('2','3')|] [Just typeBool +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt] +> ,e [sqlExpr| ('2','3') = (3,4)|] [Just typeBool +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt] +> ,e [sqlExpr| ('2',3) = (3,'4')|] [Just typeBool +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt +> ,Just $ AnonymousRecordType [typeInt,typeInt] +> ,Just typeInt +> ,Just typeInt] +> ] +> where +> e = Expr + +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Group s is) = testGroup s $ map itemToTft is + +> itemToTft (Expr e t) = testCase (printScalarExpr e) $ +> let a = typeCheckScalarExpr defaultTemplate1Catalog e +> t1 = filter (/= Nothing) [infType el | el <- universeBi a] +> in assertEqual "" t t1 diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Update.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Update.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Update.lhs @@ -0,0 +1,48 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Update +> (tcUpdateTestData) where +> +> import Database.HsSqlPpp.Tests.TypeChecking.Utils + +> import Database.HsSqlPpp.Types + +> tcUpdateTestData :: Item +> tcUpdateTestData = +> Group "update" [ +> s "update nope set a = 1;" +> $ Left [UnrecognisedRelation "nope"] +> ,s "update pg_attrdef set adsrc = '' where 1;" +> $ Left [ExpressionMustBeBool] +> ,s "update pg_attrdef set (adbin,adsrc) = ('a','b','c');" +> $ Left [IncompatibleTypes +> (AnonymousRecordType [ScalarType "pg_node_tree" +> ,ScalarType "text"]) +> (AnonymousRecordType [UnknownType +> ,UnknownType +> ,UnknownType])] +> ,s "update pg_attrdef set (adrelid,adsrc) = (true,'b');" +> $ Left [IncompatibleTypes +> (AnonymousRecordType [ScalarType "oid" +> ,ScalarType "text"]) +> (AnonymousRecordType [ScalarType "bool" +> ,UnknownType])] +> ,s "update pg_attrdef set (shmadrelid,adsrc) = ('a','b');" +> $ Left [UnrecognisedIdentifier "shmadrelid"] +> ,s "update pg_attrdef set adsrc='';" +> $ Right [Just ([], [])] +> ,s "update pg_attrdef set adsrc='' where 1=2;" +> $ Right [Just ([], [])] +> -- FIXME? +> -- TODO: actually, pg doesn't support this so need to generate error instead +> {-,s "update pg_attrdef set (adbin,adsrc) = ((select 'a','b'));" +> $ Right [Just ([], [])]-} +> --check where ids +> ,s "update pg_attrdef set adsrc='' where adsrc='';" +> $ Right [Just ([], [])] +> ,s "update pg_attrdef set adnum = adnum + 1;" +> $ Right [Just ([], [])] +> ] + +> where +> s = StmtType + diff --git a/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Utils.lhs b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Utils.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Database/HsSqlPpp/Tests/TypeChecking/Utils.lhs @@ -0,0 +1,94 @@ + +> module Database.HsSqlPpp.Tests.TypeChecking.Utils where + +> import Test.Framework + + +> import Test.HUnit +> import Test.Framework.Providers.HUnit +> 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.Types +> import Database.HsSqlPpp.Pretty +> --import Text.Groom +> import Database.HsSqlPpp.Tests.TestUtils + + +> data Item = Group String [Item] +> | Expr String (Either [TypeError] Type) +> | StmtType String (Either [TypeError] [Maybe ParameterizedStatementType]) +> | CatStmtType String [CatalogUpdate] (Either [TypeError] [Maybe ParameterizedStatementType]) +> | Ddl String [CatalogUpdate] + + +> testExpressionType :: String -> Either [TypeError] Type -> Test.Framework.Test +> testExpressionType src et = testCase ("typecheck " ++ src) $ +> let ast = case parseScalarExpr "" src of +> Left e -> error $ show e +> Right l -> l +> aast = typeCheckScalarExpr defaultTemplate1Catalog ast +> ty = atype $ getAnnotation aast +> er :: [TypeError] +> er = universeBi aast +> in if null er +> then assertEqual ("typecheck " ++ src) (Just et) $ fmap Right ty +> else assertEqual ("typecheck " ++ src) et $ Left er +> +> testStatementType :: String -> Either [TypeError] [Maybe ParameterizedStatementType] -> Test.Framework.Test +> testStatementType src sis = testCase ("typecheck " ++ src) $ +> let ast = case parseStatements "" src of +> Left e -> error $ show e +> Right l -> l +> aast = snd $ typeCheckStatements defaultTemplate1Catalog ast +> is = map (stType . getAnnotation) aast +> er :: [TypeError] +> er = universeBi aast +> in case (length er, length is) of +> (0,0) -> assertFailure "didn't get any infos?" +> (0,_) -> assertTrace (printStatements aast) ("typecheck " ++ src) sis $ Right is +> _ -> assertTrace (printStatements aast) ("typecheck " ++ src) sis $ Left er + +> testCatUpStatementType :: String +> -> [CatalogUpdate] +> -> Either [TypeError] [Maybe ParameterizedStatementType] +> -> Test.Framework.Test +> testCatUpStatementType src eu sis = testCase ("typecheck " ++ src) $ +> let ast = case parseStatements "" src of +> Left e -> error $ show e +> Right l -> l +> aast = snd $ typeCheckStatements makeCat ast +> is = map (stType . getAnnotation) aast +> er :: [TypeError] +> er = universeBi aast +> in {-trace (show aast) $-} case (length er, length is) of +> (0,0) -> assertFailure "didn't get any infos?" +> (0,_) -> assertTrace (printStatements aast) ("typecheck " ++ src) sis $ Right is +> _ -> assertTrace (printStatements aast) ("typecheck " ++ src) sis $ Left er +> where +> makeCat = case updateCatalog defaultTemplate1Catalog eu of +> Left x -> error $ show x +> Right e -> e +> +> testCat :: String -> [CatalogUpdate] -> Test.Framework.Test +> testCat src eu = testCase ("check catalog: " ++ src) $ +> let ast = case parseStatements "" src of +> Left e -> error $ show e +> Right l -> l +> (ncat,aast) = typeCheckStatements defaultTemplate1Catalog ast +> er :: [TypeError] +> er = universeBi aast +> neu = deconstructCatalog ncat \\ deconstructCatalog defaultTemplate1Catalog +> in if not (null er) +> then assertFailure $ show er +> else assertEqual "check eus" eu neu +> +> itemToTft :: Item -> Test.Framework.Test +> itemToTft (Expr s r) = testExpressionType s r +> itemToTft (StmtType s r) = testStatementType s r +> itemToTft (CatStmtType s c r) = testCatUpStatementType s c r +> itemToTft (Ddl s c) = testCat s c +> itemToTft (Group s is) = testGroup s $ map itemToTft is diff --git a/src-extra/tests/Tests.lhs b/src-extra/tests/Tests.lhs new file mode 100644 --- /dev/null +++ b/src-extra/tests/Tests.lhs @@ -0,0 +1,28 @@ +test files todo: + +create new test hierarchy, move test code here, add new exe to run + them + +disable failing tests + +get website generating again + +start new test pages + renderer + + +extensions tests + +local bindings tests + +parameterized statement tests +parsertests +quasiquote tests +roundtrip tests +type check tests +type inference tests + +> import Database.HsSqlPpp.Tests.Tests +> import Test.Framework + +> main :: IO () +> main = defaultMain allTests diff --git a/src-extra/util/Database/HsSqlPpp/Utils/CatalogReader.lhs b/src-extra/util/Database/HsSqlPpp/Utils/CatalogReader.lhs new file mode 100644 --- /dev/null +++ b/src-extra/util/Database/HsSqlPpp/Utils/CatalogReader.lhs @@ -0,0 +1,333 @@ + +This module contains the code to read a set of catalog updates +from a database. + +The code here hasn't been tidied up since the Catalog data type +was heavily changed so it's a bit messy. + +> {-# LANGUAGE QuasiQuotes #-} +> +> module Database.HsSqlPpp.Utils.CatalogReader +> (readCatalogFromDatabase) where +> +> import qualified Data.Map as M +> import Data.Maybe +> import Control.Applicative +> --import Debug.Trace +> +> --import Database.HsSqlPpp.Internals.TypeType +> --import Database.HsSqlPpp.Utils.Utils +> import Database.HsSqlPpp.Utils.Here +> --import Database.HsSqlPpp.Internals.Catalog.CatalogInternal +> import Database.HsSqlPpp.Utils.PgUtils +> import Database.HsSqlPpp.Catalog +> import Database.HsSqlPpp.Types +> +> -- | Creates an 'CatalogUpdate' list by reading the database given. +> -- To create an Catalog value from this, use +> -- +> -- @ +> -- cat <- readCatalogFromDatabase 'something' +> -- let newCat = updateCatalog defaultCatalog cat +> -- @ +> readCatalogFromDatabase :: String -- ^ connection string of the database to read +> -> IO [CatalogUpdate] +> readCatalogFromDatabase cs = withConn cs $ \conn -> do +> typeInfo <- selectRelation conn [here| + +\begin{code} + +select t.oid as oid, + t.typtype, + case nspname + when 'public' then t.typname + when 'pg_catalog' then t.typname + else nspname || '.' || t.typname + end as typname, + t.typarray, + coalesce(e.typtype,'0') as atyptype, + e.oid as aoid, + e.typname as atypname + from pg_catalog.pg_type t + left outer join pg_type e + on t.typarray = e.oid + inner join pg_namespace ns + on t.typnamespace = ns.oid + and ns.nspname in ('pg_catalog' + ,'public' + ,'information_schema') + where /*pg_catalog.pg_type_is_visible(t.oid) + and */not exists(select 1 from pg_catalog.pg_type el + where el.typarray = t.oid) + order by t.typname; + +\end{code} + +> |] [] +> let typeStuff = concatMap convTypeInfoRow typeInfo +> typeAssoc = map (\(a,b,_) -> (a,b)) typeStuff +> typeMap = M.fromList typeAssoc +> cts <- map (\(nm:cat:pref:[]) -> +> CatCreateScalar (ScalarType nm) cat ( read pref :: Bool)) <$> +> selectRelation conn [here| + +\begin{code} + +select t.typname,typcategory,typispreferred +from pg_type t + inner join pg_namespace ns + on t.typnamespace = ns.oid + and ns.nspname in ('pg_catalog', 'public', 'information_schema') +where t.typarray<>0 and + typtype='b' /*and + pg_catalog.pg_type_is_visible(t.oid)*/; + +\end{code} + +> |] [] +> domainDefInfo <- selectRelation conn [here| + +\begin{code} + +select pg_type.oid, typbasetype + from pg_type + inner join pg_namespace ns + on pg_type.typnamespace = ns.oid + and ns.nspname in ('pg_catalog', 'public', 'information_schema') + where typtype = 'd' + /*and pg_catalog.pg_type_is_visible(oid)*/; + +\end{code} + +> |] [] +> let jlt k = fromJust $ M.lookup k typeMap +> let domainDefs = map (\l -> (jlt (l!!0), jlt (l!!1))) domainDefInfo +> --let domainCasts = map (\(t,b) ->(t,b,ImplicitCastContext)) domainDefs +> castInfo <- selectRelation conn +> "select castsource,casttarget,castcontext from pg_cast;" [] +> let casts = +> {- domainCasts ++ -} +> flip map castInfo +> (\l -> (jlt (l!!0) +> ,jlt (l!!1) +> ,case (l!!2) of +> "a" -> AssignmentCastContext +> "i" -> ImplicitCastContext +> "e" -> ExplicitCastContext +> _ -> error $ "internal error: unknown \ +> \cast context " ++ (l!!2))) +> operatorInfo <- selectRelation conn [here| + +\begin{code} + +select oprname, + oprleft, + oprright, + oprresult +from pg_operator + where not (oprleft <> 0 and oprright <> 0 + and oprname = '@') --hack for now + order by oprname; + +\end{code} + +> |] [] +> let getOps a b c [] = (a,b,c) +> getOps pref post bin (l:ls) = +> let bit = (\a -> (l!!0, a, jlt(l!!3))) +> in case () of +> _ | l!!1 == "0" +> -> getOps (bit [jlt (l!!2)]:pref) post bin ls +> | l!!2 == "0" +> -> getOps pref (bit [jlt (l!!1)]:post) bin ls +> | otherwise -> getOps pref post (bit [jlt (l!!1) +> ,jlt (l!!2)]:bin) ls +> let (prefixOps, postfixOps, binaryOps) = getOps [] [] [] operatorInfo +> functionInfo <- selectRelation conn [here| + +\begin{code} + +select proname, + array_to_string(proargtypes,','), + proretset, + prorettype +from pg_proc +where pg_catalog.pg_function_is_visible(pg_proc.oid) + and provariadic = 0 + and not proisagg + and not proiswindow +order by proname,proargtypes; +\end{code} + +> |] [] +> let fnProts = map (convFnRow jlt) functionInfo +> aggregateInfo <- selectRelation conn [here| + +\begin{code} + +select proname, + array_to_string(proargtypes,','), + proretset, + prorettype +from pg_proc +where pg_catalog.pg_function_is_visible(pg_proc.oid) + and provariadic = 0 + and proisagg +order by proname,proargtypes; +\end{code} + +> |] [] +> let aggProts = map (convFnRow jlt) aggregateInfo +> windowInfo <- selectRelation conn [here| + +\begin{code} + +select proname, + array_to_string(proargtypes,','), + proretset, + prorettype +from pg_proc +where pg_catalog.pg_function_is_visible(pg_proc.oid) + and provariadic = 0 + and proiswindow +order by proname,proargtypes; + +\end{code} + +> |] [] +> let winProts = map (convFnRow jlt) windowInfo +> comps <- map (\(kind:nm:atts:sysatts:nsp:[]) -> +> let nm1 = case nsp of +> "pg_catalog" -> nm +> "public" -> nm +> n -> n ++ "." ++ nm +> in case kind of +> "c" -> CatCreateComposite nm1 (convertAttString jlt atts) +> "r" -> CatCreateTable nm1 (convertAttString jlt atts) +> (convertAttString jlt sysatts) +> "v" -> CatCreateView nm1 (convertAttString jlt atts) +> _ -> error $ "unrecognised relkind: " ++ kind) <$> +> selectRelation conn [here| + +\begin{code} + +with att1 as ( + select + attrelid, + attname, + attnum, + atttypid + from pg_attribute + inner join pg_class cls + on cls.oid = attrelid + inner join pg_namespace ns + on cls.relnamespace = ns.oid + and ns.nspname in ('pg_catalog', 'public', 'information_schema') + where /*pg_catalog.pg_table_is_visible(cls.oid) + and*/ cls.relkind in ('r','v','c') + and not attisdropped), + sysAtt as ( + select attrelid, + array_to_string( + array_agg(attname || ';' || atttypid) + over (partition by attrelid order by attnum + range between unbounded preceding + and unbounded following) + ,',') as sysAtts + from att1 + where attnum < 0), + att as ( + select attrelid, + array_to_string( + array_agg(attname || ';' || atttypid) + over (partition by attrelid order by attnum + range between unbounded preceding + and unbounded following) + ,',') as atts + from att1 + where attnum > 0) + select distinct + cls.relkind, + cls.relname, + atts, + coalesce(sysAtts,''), + nspname + from att left outer join sysAtt using (attrelid) + inner join pg_class cls + on cls.oid = attrelid + inner join pg_namespace ns + on cls.relnamespace = ns.oid + order by relkind,relname; + +\end{code} + +> |] [] +> return +> $ concat [cts +> ,map (uncurry CatCreateDomain) domainDefs +> ,map (\(a,b,c) -> CatCreateCast a b c) casts +> ,map (\(a,b,c) -> +> CatCreateFunction FunPrefix a b c False) prefixOps +> ,map (\(a,b,c) -> +> CatCreateFunction FunPostfix a b c False) postfixOps +> ,map (\(a,b,c) -> +> CatCreateFunction FunBinary a b c False) binaryOps +> ,map (\(a,b,c) -> +> CatCreateFunction FunName a b c False) fnProts +> ,map (\(a,b,c) -> +> CatCreateFunction FunAgg a b c False) aggProts +> ,map (\(a,b,c) -> +> CatCreateFunction FunWindow a b c False) winProts +> ,comps] +> where +> convertAttString jlt s = +> let ps = split ',' s +> ps1 = map (split ';') ps +> in map (\pl -> (head pl, jlt (pl!!1))) ps1 +> convFnRow jlt l = +> (head l,fnArgs,fnRet) +> where +> fnRet = let rt1 = jlt (l!!3) +> in if read (l!!2)::Bool +> then SetOfType rt1 +> else rt1 +> fnArgs = if (l!!1) == "" +> then [] +> else let a = split ',' (l!!1) +> in map jlt a +> convTypeInfoRow l = +> let name = canonicalizeTypeName (l!!2) +> ctor = case (l!!1) of +> "b" -> ScalarType +> "c" -> NamedCompositeType +> "d" -> DomainType +> "e" -> EnumType +> "p" -> Pseudo . pn +> _ -> error $ "internal error: unknown type type: " +> ++ (l !! 1) +> scType = (head l, ctor name, name) +> in if (l!!4) /= "0" +> then [(l!!5,ArrayType $ ctor name, '_':name), scType] +> else [scType] +> pn t = case t of +> "any" -> Any +> "anyarray" -> AnyArray +> "anyelement" -> AnyElement +> "anyenum" -> AnyEnum +> "anynonarray" -> AnyNonArray +> "cstring" -> Cstring +> "internal" -> Internal +> "language_handler" -> LanguageHandler +> "opaque" -> Opaque +> "record" -> Record +> "trigger" -> Trigger +> "void" -> Void +> "fdw_handler" -> FdwHandler +> _ -> error $ "internal error: unknown pseudo " ++ t + +> split :: Char -> String -> [String] +> split _ "" = [] +> split c s = let (l, s') = break (== c) s +> in l : case s' of +> [] -> [] +> (_:s'') -> split c s'' diff --git a/src-extra/util/Database/HsSqlPpp/Utils/Here.lhs b/src-extra/util/Database/HsSqlPpp/Utils/Here.lhs new file mode 100644 --- /dev/null +++ b/src-extra/util/Database/HsSqlPpp/Utils/Here.lhs @@ -0,0 +1,16 @@ + +Multiline string support, mainly used to enter multiline sql strings + +robbed from http://old.nabble.com/Multi-line-string-literals-are-both-easy--and--elegant-in-Haskell-td19959973.html + +> module Database.HsSqlPpp.Utils.Here where +> +> import Language.Haskell.TH.Quote +> --import Language.Haskell.TH.Syntax +> import Language.Haskell.TH.Lib +> +> here :: QuasiQuoter +> here = QuasiQuoter {quoteExp = litE . stringL +> ,quotePat = litP . stringL +> ,quoteType = undefined +> ,quoteDec = undefined} diff --git a/src-extra/util/Database/HsSqlPpp/Utils/PgUtils.lhs b/src-extra/util/Database/HsSqlPpp/Utils/PgUtils.lhs new file mode 100644 --- /dev/null +++ b/src-extra/util/Database/HsSqlPpp/Utils/PgUtils.lhs @@ -0,0 +1,37 @@ + +Some simple wrappers around HDBC for the code to use. + +> module Database.HsSqlPpp.Utils.PgUtils +> (withConn +> ,selectRelation +> ,runSqlCommand +> ,withTransaction +> ,Pg.Connection +> ,IConnection) where +> +> import qualified Database.HDBC.PostgreSQL as Pg +> import Database.HDBC +> import Control.Exception +> +> withConn :: String -> (Pg.Connection -> IO c) -> IO c +> withConn cs = bracket (Pg.connectPostgreSQL cs) disconnect +> +> selectRelation ::(IConnection conn) => +> conn -> String -> [String] -> IO [[String]] +> selectRelation conn query args = do +> sth <- prepare conn query +> _ <- execute sth $ map sToSql args +> v <- fetchAllRows' sth +> return $ map (map sqlToS) v +> +> runSqlCommand :: (IConnection conn) => +> conn -> String -> IO () +> runSqlCommand conn query = do +> _ <- run conn query [] +> commit conn +> +> sToSql :: String -> SqlValue +> sToSql s = toSql (s::String) +> +> sqlToS :: SqlValue -> String +> sqlToS = fromSql diff --git a/src/Database/HsSqlPpp/Internals/AstInternal.hs b/src/Database/HsSqlPpp/Internals/AstInternal.hs --- a/src/Database/HsSqlPpp/Internals/AstInternal.hs +++ b/src/Database/HsSqlPpp/Internals/AstInternal.hs @@ -1,8 +1,8 @@ -- UUAGC 0.9.39.1 (src/Database/HsSqlPpp/Internals/AstInternal.ag) +{-# LANGUAGE DeriveDataTypeable,ScopedTypeVariables #-} module Database.HsSqlPpp.Internals.AstInternal( - -- {-# LANGUAGE DeriveDataTypeable,ScopedTypeVariables #-} --from the ag files: --ast nodes Statement (..) diff --git a/src/Database/HsSqlPpp/Internals/TypeChecking/IDEnv.lhs b/src/Database/HsSqlPpp/Internals/TypeChecking/IDEnv.lhs --- a/src/Database/HsSqlPpp/Internals/TypeChecking/IDEnv.lhs +++ b/src/Database/HsSqlPpp/Internals/TypeChecking/IDEnv.lhs @@ -5,6 +5,7 @@ this should eventually expand to take over the local identifier bindings code +> {-# LANGUAGE TupleSections #-} > module Database.HsSqlPpp.Internals.TypeChecking.IDEnv > (IDEnv(..) > ,emptyIDEnv diff --git a/src/Database/HsSqlPpp/Internals/TypeChecking/TypeConversion.lhs b/src/Database/HsSqlPpp/Internals/TypeChecking/TypeConversion.lhs --- a/src/Database/HsSqlPpp/Internals/TypeChecking/TypeConversion.lhs +++ b/src/Database/HsSqlPpp/Internals/TypeChecking/TypeConversion.lhs @@ -25,7 +25,7 @@ off. -> {-# LANGUAGE PatternGuards #-} +> {-# LANGUAGE PatternGuards,NondecreasingIndentation #-} > module Database.HsSqlPpp.Internals.TypeChecking.TypeConversion ( > findCallMatch > ,resolveResultSetType diff --git a/src/Database/HsSqlPpp/Parsing/ParserInternal.lhs b/src/Database/HsSqlPpp/Parsing/ParserInternal.lhs --- a/src/Database/HsSqlPpp/Parsing/ParserInternal.lhs +++ b/src/Database/HsSqlPpp/Parsing/ParserInternal.lhs @@ -2,7 +2,7 @@ The main file for parsing sql, uses parsec. Not sure if parsec is the right choice, but it seems to do the job pretty well at the moment. -> {-# LANGUAGE FlexibleContexts,ExplicitForAll #-} +> {-# LANGUAGE FlexibleContexts,ExplicitForAll,TupleSections #-} > -- | Functions to parse SQL. > module Database.HsSqlPpp.Parsing.ParserInternal > (-- * Main