/src-extra/tests/Database/HsSqlPpp/Tests/junk/ExtensionTests.lhs
http://github.com/JakeWheat/hssqlppp · Haskell · 178 lines · 175 code · 3 blank · 0 comment · 11 complexity · 3d54011529b800187a93e07bb973b6ae MD5 · raw file
- Set of tests for the old chaosextensions, in the process of being
- replaced
- > module Database.HsSqlPpp.Tests.ExtensionTests (extensionTests) where
- >
- > import Test.HUnit
- > import Test.Framework
- > import Test.Framework.Providers.HUnit
- > --import Debug.Trace
- >
- > import Database.HsSqlPpp.Parser
- > import Database.HsSqlPpp.Annotation
- > import ChaosExtensions
- > import Database.HsSqlPpp.Ast
- > --import Database.HsSqlPpp.PrettyPrinter.PrettyPrinter
- >
- > extensionTests :: Test.Framework.Test
- > extensionTests =
- > testGroup "extensionTests" (mapCheckExtension [
- > t rewriteCreateVars
- > "select create_var('varname','vartype');"
- > "create table varname_table (\n\
- > \ varname vartype);\n\
- > \create function get_varname() returns vartype as $a$\n\
- > \ select * from varname_table;\n\
- > \$a$ language sql stable;\n\
- > \create function check_con_varname_table_varname_key() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \/*drop function if exists varname_table_constraint_trigger_operator();\n\
- > \create function varname_table_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;*/\n\
- > \create function check_con_varname_table_01_tuple() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \drop function if exists varname_table_constraint_trigger_operator();\n\
- > \create function varname_table_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- >
- > ,t addReadonlyTriggers
- > "select set_relvar_type('stuff','readonly');"
- > "create function check_stuff_d_readonly() returns trigger as $a$\n\
- > \begin\n\
- > \ if (not (false)) then\n\
- > \ raise exception 'delete on base_relvar_metadata violates transition constraint base_relvar_metadata_d_readonly';\n\
- > \ end if;\n\
- > \return null;\n\
- > \end;\n\
- > \$a$ language plpgsql volatile;\n\
- > \create function check_stuff_i_readonly() returns trigger as $a$\n\
- > \begin\n\
- > \ if (not (false)) then\n\
- > \ raise exception 'delete on base_relvar_metadata violates transition constraint base_relvar_metadata_d_readonly';\n\
- > \ end if;\n\
- > \ return null;\n\
- > \end;\n\
- > \$a$ language plpgsql volatile;\n\
- > \create function check_stuff_u_readonly() returns trigger as $a$\n\
- > \begin\n\
- > \ if (not (false)) then\n\
- > \ raise exception 'delete on base_relvar_metadata violates transition constraint base_relvar_metadata_d_readonly';\n\
- > \ end if;\n\
- > \ return null;\n\
- > \end;\n\
- > \$a$ language plpgsql volatile;"
- >
- > ,t createClientActionWrapper
- > "select create_client_action_wrapper('actname', $$actcall()$$);"
- > "create function action_actname() returns void as $a$\n\
- > \begin\n\
- > \ perform action_actcall();\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- > ,t createClientActionWrapper
- > "select create_client_action_wrapper('actname', $$actcall('test')$$);"
- > "create function action_actname() returns void as $a$\n\
- > \begin\n\
- > \ perform action_actcall('test');\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- > ,t addNotifyTriggers
- > "select set_relvar_type('stuff','data');"
- > "create function stuff_changed() returns trigger as $a$\n\
- > \begin\n\
- > \ notify stuff;\n\
- > \ return null;\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- > ,t addConstraint
- > "select add_constraint('name', 'true', array['t1', 't2']);"
- > "create function check_con_name() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \drop function if exists t1_constraint_trigger_operator();\n\
- > \create function t1_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;\n\
- > \drop function if exists t2_constraint_trigger_operator();\n\
- > \create function t2_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- > ,t addKey
- > "select add_key('tbl', 'attr');"
- > "create function check_con_tbl_attr_key() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \/*drop function if exists tbl_constraint_trigger_operator();\n\
- > \create function tbl_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;*/"
- > ,t addKey
- > "select add_key('tbl', array['attr1','attr2']);"
- > "create function check_con_tbl_attr1_attr2_key() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \/*drop function if exists tbl_constraint_trigger_operator();\n\
- > \create function tbl_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;*/"
- > ,t zeroOneTuple
- > "select constrain_to_zero_or_one_tuple('tbl');"
- > "create function check_con_tbl_01_tuple() returns boolean as $a$\n\
- > \begin\n\
- > \ return true;\n\
- > \end;\n\
- > \$a$ language plpgsql stable;\n\
- > \drop function if exists tbl_constraint_trigger_operator();\n\
- > \create function tbl_constraint_trigger_operator() returns trigger as $a$\n\
- > \begin\n\
- > \ null;\n\
- > \end;\n\
- > \$a$ language plpgsql;"
- >
- > -- add_foreign_key
- > -- constrain zero one
- > -- add constraint
- >
- > ])
- >
- > where
- > t a b c = (a,b,c)
- > mapCheckExtension = map (\(a,b,c) -> checkExtension a b c)
- > checkExtension :: (StatementList -> StatementList) -> String -> String -> Test.Framework.Test
- > checkExtension f stxt ttxt = testCase ("check " ++ stxt) $
- > case (do
- > sast <- parseSql "" stxt
- > let esast = f sast
- > --trace (printSql esast) $ return ()
- > tast <- parseSql "" ttxt
- > return (tast,esast)) of
- > Left e -> assertFailure $ show e
- > Right (ts,es) -> assertEqual "" (stripAnnotations ts) (stripAnnotations es)