plpgsql/core.sql

   1 CREATE SCHEMA core;
   2
   3 -- general functions
   4
   5 CREATE FUNCTION core.equal(args integer[]) RETURNS integer AS $$
   6 BEGIN
   7     RETURN types._wraptf(types._equal_Q(args[1], args[2]));
   8 END; $$ LANGUAGE plpgsql;
   9
  10 CREATE FUNCTION core.throw(args integer[]) RETURNS integer AS $$
  11 BEGIN
  12     -- TODO: Only throws strings. Without subtransactions, all changes
  13     -- to DB up to this point get rolled back so the object being
  14     -- thrown dissapears.
  15     RAISE EXCEPTION '%', printer.pr_str(args[1], false);
  16 END; $$ LANGUAGE plpgsql;
  17
  18
  19 -- scalar functions
  20
  21 CREATE FUNCTION core.nil_Q(args integer[]) RETURNS integer AS $$
  22 BEGIN
  23     RETURN types._wraptf(types._nil_Q(args[1]));
  24 END; $$ LANGUAGE plpgsql;
  25
  26 CREATE FUNCTION core.true_Q(args integer[]) RETURNS integer AS $$
  27 BEGIN
  28     RETURN types._wraptf(types._true_Q(args[1]));
  29 END; $$ LANGUAGE plpgsql;
  30
  31 CREATE FUNCTION core.false_Q(args integer[]) RETURNS integer AS $$
  32 BEGIN
  33     RETURN types._wraptf(types._false_Q(args[1]));
  34 END; $$ LANGUAGE plpgsql;
  35
  36 CREATE FUNCTION core.number_Q(args integer[]) RETURNS integer AS $$
  37 BEGIN
  38     RETURN types._wraptf(types._number_Q(args[1]));
  39 END; $$ LANGUAGE plpgsql;
  40
  41 CREATE FUNCTION core.string_Q(args integer[]) RETURNS integer AS $$
  42 BEGIN
  43     RETURN types._wraptf(types._string_Q(args[1]));
  44 END; $$ LANGUAGE plpgsql;
  45
  46 CREATE FUNCTION core.symbol(args integer[]) RETURNS integer AS $$
  47 BEGIN
  48     RETURN types._symbolv(types._valueToString(args[1]));
  49 END; $$ LANGUAGE plpgsql;
  50
  51 CREATE FUNCTION core.symbol_Q(args integer[]) RETURNS integer AS $$
  52 BEGIN
  53     RETURN types._wraptf(types._symbol_Q(args[1]));
  54 END; $$ LANGUAGE plpgsql;
  55
  56 CREATE FUNCTION core.keyword(args integer[]) RETURNS integer AS $$
  57 BEGIN
  58     IF types._keyword_Q(args[1]) THEN
  59         RETURN args[1];
  60     ELSE
  61         RETURN types._keywordv(types._valueToString(args[1]));
  62     END IF;
  63 END; $$ LANGUAGE plpgsql;
  64
  65 CREATE FUNCTION core.keyword_Q(args integer[]) RETURNS integer AS $$
  66 BEGIN
  67     RETURN types._wraptf(types._keyword_Q(args[1]));
  68 END; $$ LANGUAGE plpgsql;
  69
  70 CREATE FUNCTION core.fn_Q(args integer[]) RETURNS integer AS $$
  71 BEGIN
  72     RETURN types._wraptf(types._fn_Q(args[1]));
  73 END; $$ LANGUAGE plpgsql;
  74
  75 CREATE FUNCTION core.macro_Q(args integer[]) RETURNS integer AS $$
  76 BEGIN
  77     RETURN types._wraptf(types._macro_Q(args[1]));
  78 END; $$ LANGUAGE plpgsql;
  79
  80
  81 -- string functions
  82
  83 CREATE FUNCTION core.pr_str(args integer[]) RETURNS integer AS $$
  84 BEGIN
  85     RETURN types._stringv(printer.pr_str_array(args, ' ', true));
  86 END; $$ LANGUAGE plpgsql;
  87
  88 CREATE FUNCTION core.str(args integer[]) RETURNS integer AS $$
  89 BEGIN
  90     RETURN types._stringv(printer.pr_str_array(args, '', false));
  91 END; $$ LANGUAGE plpgsql;
  92
  93 CREATE FUNCTION core.prn(args integer[]) RETURNS integer AS $$
  94 BEGIN
  95     PERFORM io.writeline(printer.pr_str_array(args, ' ', true));
  96     RETURN 0; -- nil
  97 END; $$ LANGUAGE plpgsql;
  98
  99 CREATE FUNCTION core.println(args integer[]) RETURNS integer AS $$
 100 BEGIN
 101     PERFORM io.writeline(printer.pr_str_array(args, ' ', false));
 102     RETURN 0; -- nil
 103 END; $$ LANGUAGE plpgsql;
 104
 105 CREATE FUNCTION core.read_string(args integer[]) RETURNS integer AS $$
 106 BEGIN
 107     RETURN reader.read_str(types._valueToString(args[1]));
 108 END; $$ LANGUAGE plpgsql;
 109
 110 CREATE FUNCTION core.readline(args integer[]) RETURNS integer AS $$
 111 DECLARE
 112     input  varchar;
 113 BEGIN
 114     input := io.readline(types._valueToString(args[1]));
 115     IF input IS NULL THEN
 116         RETURN 0;  -- nil
 117     END IF;
 118     RETURN types._stringv(rtrim(input, E'\n'));
 119 END; $$ LANGUAGE plpgsql;
 120
 121
 122 -- See:
 123 -- http://shuber.io/reading-from-the-filesystem-with-postgres/
 124 CREATE FUNCTION core.slurp(args integer[]) RETURNS integer AS $$
 125 DECLARE
 126     fname    varchar;
 127     tmp      varchar;
 128     cmd      varchar;
 129     lines    varchar[];
 130     content  varchar;
 131 BEGIN
 132     fname := types._valueToString(args[1]);
 133     IF fname NOT LIKE '/%' THEN
 134         fname := types._valueToString(envs.vget(0, '*PWD*')) || '/' || fname;
 135     END IF;
 136
 137     tmp := CAST(round(random()*1000000) AS varchar);
 138
 139     EXECUTE format('CREATE TEMP TABLE %I (content text)', tmp);
 140     cmd := format('sed ''s/\\/\\\\/g'' %L', fname);
 141     EXECUTE format('COPY %I FROM PROGRAM %L', tmp, cmd);
 142     EXECUTE format('SELECT ARRAY(SELECT content FROM %I)', tmp) INTO lines;
 143     EXECUTE format('DROP TABLE %I', tmp);
 144
 145     content := array_to_string(lines, E'\n') || E'\n';
 146     RETURN types._stringv(content);
 147 END; $$ LANGUAGE plpgsql;
 148
 149
 150 -- number functions
 151
 152 -- integer comparison
 153 CREATE FUNCTION core.intcmp(op varchar, args integer[]) RETURNS integer AS $$
 154 DECLARE a bigint; b bigint; result boolean;
 155 BEGIN
 156     SELECT val_int INTO a FROM types.value WHERE value_id = args[1];
 157     SELECT val_int INTO b FROM types.value WHERE value_id = args[2];
 158     EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b;
 159     RETURN types._wraptf(result);
 160 END; $$ LANGUAGE plpgsql;
 161
 162 -- integer operation
 163 CREATE FUNCTION core.intop(op varchar, args integer[]) RETURNS integer AS $$
 164 DECLARE a bigint; b bigint; result bigint;
 165 BEGIN
 166     SELECT val_int INTO a FROM types.value WHERE value_id = args[1];
 167     SELECT val_int INTO b FROM types.value WHERE value_id = args[2];
 168     EXECUTE format('SELECT $1 %s $2;', op) INTO result USING a, b;
 169     RETURN types._numToValue(result);
 170 END; $$ LANGUAGE plpgsql;
 171
 172 CREATE FUNCTION core.lt(args integer[]) RETURNS integer AS $$
 173 BEGIN
 174     RETURN core.intcmp('<', args);
 175 END; $$ LANGUAGE plpgsql;
 176
 177 CREATE FUNCTION core.lte(args integer[]) RETURNS integer AS $$
 178 BEGIN
 179     RETURN core.intcmp('<=', args);
 180 END; $$ LANGUAGE plpgsql;
 181
 182 CREATE FUNCTION core.gt(args integer[]) RETURNS integer AS $$
 183 BEGIN
 184     RETURN core.intcmp('>', args);
 185 END; $$ LANGUAGE plpgsql;
 186
 187 CREATE FUNCTION core.gte(args integer[]) RETURNS integer AS $$
 188 BEGIN
 189     RETURN core.intcmp('>=', args);
 190 END; $$ LANGUAGE plpgsql;
 191
 192 CREATE FUNCTION core.add(args integer[]) RETURNS integer AS $$
 193 BEGIN
 194     RETURN core.intop('+', args);
 195 END; $$ LANGUAGE plpgsql;
 196
 197 CREATE FUNCTION core.subtract(args integer[]) RETURNS integer AS $$
 198 BEGIN
 199     RETURN core.intop('-', args);
 200 END; $$ LANGUAGE plpgsql;
 201
 202 CREATE FUNCTION core.multiply(args integer[]) RETURNS integer AS $$
 203 BEGIN
 204     RETURN core.intop('*', args);
 205 END; $$ LANGUAGE plpgsql;
 206
 207 CREATE FUNCTION core.divide(args integer[]) RETURNS integer AS $$
 208 BEGIN
 209     RETURN core.intop('/', args);
 210 END; $$ LANGUAGE plpgsql;
 211
 212 CREATE FUNCTION core.time_ms(args integer[]) RETURNS integer AS $$
 213 BEGIN
 214     RETURN types._numToValue(
 215         CAST(date_part('epoch', clock_timestamp()) * 1000 AS bigint));
 216 END; $$ LANGUAGE plpgsql;
 217
 218
 219 -- collection functions
 220
 221 CREATE FUNCTION core.list(args integer[]) RETURNS integer AS $$
 222 BEGIN
 223     RETURN types._list(args);
 224 END; $$ LANGUAGE plpgsql;
 225
 226 CREATE FUNCTION core.list_Q(args integer[]) RETURNS integer AS $$
 227 BEGIN
 228     RETURN types._wraptf(types._list_Q(args[1]));
 229 END; $$ LANGUAGE plpgsql;
 230
 231 CREATE FUNCTION core.vector(args integer[]) RETURNS integer AS $$
 232 BEGIN
 233     RETURN types._vector(args);
 234 END; $$ LANGUAGE plpgsql;
 235
 236 CREATE FUNCTION core.vector_Q(args integer[]) RETURNS integer AS $$
 237 BEGIN
 238     RETURN types._wraptf(types._vector_Q(args[1]));
 239 END; $$ LANGUAGE plpgsql;
 240
 241 CREATE FUNCTION core.hash_map(args integer[]) RETURNS integer AS $$
 242 BEGIN
 243     RETURN types._hash_map(args);
 244 END; $$ LANGUAGE plpgsql;
 245
 246 CREATE FUNCTION core.map_Q(args integer[]) RETURNS integer AS $$
 247 BEGIN
 248     RETURN types._wraptf(types._hash_map_Q(args[1]));
 249 END; $$ LANGUAGE plpgsql;
 250
 251 CREATE FUNCTION core.assoc(args integer[]) RETURNS integer AS $$
 252 BEGIN
 253     RETURN types._assoc_BANG(types._clone(args[1]),
 254                              args[2:array_length(args, 1)]);
 255 END; $$ LANGUAGE plpgsql;
 256
 257 CREATE FUNCTION core.dissoc(args integer[]) RETURNS integer AS $$
 258 BEGIN
 259     RETURN types._dissoc_BANG(types._clone(args[1]),
 260                               args[2:array_length(args, 1)]);
 261 END; $$ LANGUAGE plpgsql;
 262
 263 CREATE FUNCTION core.get(args integer[]) RETURNS integer AS $$
 264 DECLARE
 265     result  integer;
 266 BEGIN
 267     IF types._type(args[1]) = 0 THEN  -- nil
 268         RETURN 0;
 269     ELSE
 270         result := types._get(args[1], types._valueToString(args[2]));
 271         IF result IS NULL THEN RETURN 0; END IF;
 272         RETURN result;
 273     END IF;
 274 END; $$ LANGUAGE plpgsql;
 275
 276 CREATE FUNCTION core.contains_Q(args integer[]) RETURNS integer AS $$
 277 BEGIN
 278     RETURN types._wraptf(types._contains_Q(args[1],
 279                                            types._valueToString(args[2])));
 280 END; $$ LANGUAGE plpgsql;
 281
 282 CREATE FUNCTION core.keys(args integer[]) RETURNS integer AS $$
 283 BEGIN
 284     RETURN types._list(types._keys(args[1]));
 285 END; $$ LANGUAGE plpgsql;
 286
 287 CREATE FUNCTION core.vals(args integer[]) RETURNS integer AS $$
 288 BEGIN
 289     RETURN types._list(types._vals(args[1]));
 290 END; $$ LANGUAGE plpgsql;
 291
 292
 293
 294 -- sequence functions
 295
 296 CREATE FUNCTION core.sequential_Q(args integer[]) RETURNS integer AS $$
 297 BEGIN
 298     RETURN types._wraptf(types._sequential_Q(args[1]));
 299 END; $$ LANGUAGE plpgsql;
 300
 301 CREATE FUNCTION core.cons(args integer[]) RETURNS integer AS $$
 302 DECLARE
 303     lst   integer[];
 304 BEGIN
 305     lst := array_prepend(args[1], types._valueToArray(args[2]));
 306     RETURN types._list(lst);
 307 END; $$ LANGUAGE plpgsql;
 308
 309 CREATE FUNCTION core.concat(args integer[]) RETURNS integer AS $$
 310 DECLARE
 311     lst     integer;
 312     result  integer[] = ARRAY[]::integer[];
 313 BEGIN
 314     FOREACH lst IN ARRAY args LOOP
 315         result := array_cat(result, types._valueToArray(lst));
 316     END LOOP;
 317     RETURN types._list(result);
 318 END; $$ LANGUAGE plpgsql;
 319
 320 CREATE FUNCTION core.nth(args integer[]) RETURNS integer AS $$
 321 DECLARE
 322     idx  integer;
 323 BEGIN
 324     SELECT val_int INTO idx FROM types.value WHERE value_id = args[2];
 325     IF idx >= types._count(args[1]) THEN
 326         RAISE EXCEPTION 'nth: index out of range';
 327     END IF;
 328     RETURN types._nth(args[1], idx);
 329 END; $$ LANGUAGE plpgsql;
 330
 331 CREATE FUNCTION core.first(args integer[]) RETURNS integer AS $$
 332 BEGIN
 333     IF types._nil_Q(args[1]) THEN
 334         RETURN 0; -- nil
 335     ELSIF types._count(args[1]) = 0 THEN
 336         RETURN 0; -- nil
 337     ELSE
 338         RETURN types._first(args[1]);
 339     END IF;
 340 END; $$ LANGUAGE plpgsql;
 341
 342 CREATE FUNCTION core.rest(args integer[]) RETURNS integer AS $$
 343 BEGIN
 344     RETURN types._rest(args[1]);
 345 END; $$ LANGUAGE plpgsql;
 346
 347 CREATE FUNCTION core.empty_Q(args integer[]) RETURNS integer AS $$
 348 BEGIN
 349     IF types._sequential_Q(args[1]) AND types._count(args[1]) = 0 THEN
 350         RETURN 2;
 351     ELSE
 352         RETURN 1;
 353     END IF;
 354 END; $$ LANGUAGE plpgsql;
 355
 356 CREATE FUNCTION core.count(args integer[]) RETURNS integer AS $$
 357 BEGIN
 358     IF types._sequential_Q(args[1]) THEN
 359         RETURN types._numToValue(types._count(args[1]));
 360     ELSIF types._nil_Q(args[1]) THEN
 361         RETURN types._numToValue(0);
 362     ELSE
 363         RAISE EXCEPTION 'count called on non-sequence';
 364     END IF;
 365 END; $$ LANGUAGE plpgsql;
 366
 367 CREATE FUNCTION core.apply(args integer[]) RETURNS integer AS $$
 368 DECLARE
 369     alen   integer;
 370     fargs  integer[];
 371 BEGIN
 372     alen := array_length(args, 1);
 373     fargs := array_cat(args[2:alen-1], types._valueToArray(args[alen]));
 374     RETURN types._apply(args[1], fargs);
 375 END; $$ LANGUAGE plpgsql;
 376
 377 CREATE FUNCTION core.map(args integer[]) RETURNS integer AS $$
 378 DECLARE
 379     x       integer;
 380     result  integer[];
 381 BEGIN
 382     FOREACH x IN ARRAY types._valueToArray(args[2])
 383     LOOP
 384         result := array_append(result, types._apply(args[1], ARRAY[x]));
 385     END LOOP;
 386     return types._list(result);
 387 END; $$ LANGUAGE plpgsql;
 388
 389 CREATE FUNCTION core.conj(args integer[]) RETURNS integer AS $$
 390 DECLARE
 391     type  integer;
 392 BEGIN
 393     type := types._type(args[1]);
 394     CASE
 395     WHEN type = 8 THEN -- list
 396         RETURN types._list(array_cat(
 397                 types.array_reverse(args[2:array_length(args, 1)]),
 398                 types._valueToArray(args[1])));
 399     WHEN type = 9 THEN -- vector
 400         RETURN types._vector(array_cat(
 401                 types._valueToArray(args[1]),
 402                 args[2:array_length(args, 1)]));
 403     ELSE
 404         RAISE EXCEPTION 'conj: called on non-sequence';
 405     END CASE;
 406 END; $$ LANGUAGE plpgsql;
 407
 408 CREATE FUNCTION core.seq(args integer[]) RETURNS integer AS $$
 409 DECLARE
 410     type  integer;
 411     vid   integer;
 412     str   varchar;
 413     chr   varchar;
 414     seq   integer[];
 415 BEGIN
 416     type := types._type(args[1]);
 417     CASE
 418     WHEN type = 8 THEN -- list
 419         IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil
 420         RETURN args[1];
 421     WHEN type = 9 THEN -- vector
 422         IF types._count(args[1]) = 0 THEN RETURN 0; END IF; -- nil
 423         -- clone and modify to a list
 424         vid := types._clone(args[1]);
 425         UPDATE types.value SET type_id = 8 WHERE value_id = vid;
 426         RETURN vid;
 427     WHEN type = 5 THEN -- string
 428         str := types._valueToString(args[1]);
 429         IF char_length(str) = 0 THEN RETURN 0; END IF; -- nil
 430         FOREACH chr IN ARRAY regexp_split_to_array(str, '') LOOP
 431             seq := array_append(seq, types._stringv(chr));
 432         END LOOP;
 433         RETURN types._list(seq);
 434     WHEN type = 0 THEN -- nil
 435         RETURN 0; -- nil
 436     ELSE
 437         RAISE EXCEPTION 'seq: called on non-sequence';
 438     END CASE;
 439 END; $$ LANGUAGE plpgsql;
 440
 441
 442 -- meta functions
 443
 444 CREATE FUNCTION core.meta(args integer[]) RETURNS integer AS $$
 445 DECLARE
 446     m  integer;
 447 BEGIN
 448     SELECT meta_id INTO m FROM types.value WHERE value_id = args[1];
 449     IF m IS NULL THEN
 450         RETURN 0;
 451     ELSE
 452         RETURN m;
 453     END IF;
 454 END; $$ LANGUAGE plpgsql;
 455
 456 CREATE FUNCTION core.with_meta(args integer[]) RETURNS integer AS $$
 457 DECLARE
 458     vid  integer;
 459 BEGIN
 460     vid := types._clone(args[1]);
 461     UPDATE types.value SET meta_id = args[2]
 462         WHERE value_id = vid;
 463     RETURN vid;
 464 END; $$ LANGUAGE plpgsql;
 465
 466
 467
 468 -- atom functions
 469
 470 CREATE FUNCTION core.atom(args integer[]) RETURNS integer AS $$
 471 BEGIN
 472     RETURN types._atom(args[1]);
 473 END; $$ LANGUAGE plpgsql;
 474
 475 CREATE FUNCTION core.atom_Q(args integer[]) RETURNS integer AS $$
 476 BEGIN
 477     RETURN types._wraptf(types._atom_Q(args[1]));
 478 END; $$ LANGUAGE plpgsql;
 479
 480
 481 CREATE FUNCTION core.deref(args integer[]) RETURNS integer AS $$
 482 BEGIN
 483     RETURN types._deref(args[1]);
 484 END; $$ LANGUAGE plpgsql;
 485
 486 CREATE FUNCTION core.reset_BANG(args integer[]) RETURNS integer AS $$
 487 BEGIN
 488     RETURN types._reset_BANG(args[1], args[2]);
 489 END; $$ LANGUAGE plpgsql;
 490
 491 CREATE FUNCTION core.swap_BANG(args integer[]) RETURNS integer AS $$
 492 DECLARE
 493     atm    integer;
 494     fargs  integer[];
 495 BEGIN
 496     atm := args[1];
 497     fargs := array_cat(ARRAY[types._deref(atm)], args[3:array_length(args, 1)]);
 498     RETURN types._reset_BANG(atm, types._apply(args[2], fargs));
 499 END; $$ LANGUAGE plpgsql;
 500
 501 -- ---------------------------------------------------------
 502
 503 -- repl_env is environment 0
 504
 505 INSERT INTO envs.env (env_id, outer_id, data)
 506     VALUES (0, NULL, hstore(ARRAY[
 507         '=',           types._function('core.equal'),
 508         'throw',       types._function('core.throw'),
 509
 510         'nil?',        types._function('core.nil_Q'),
 511         'true?',       types._function('core.true_Q'),
 512         'false?',      types._function('core.false_Q'),
 513         'number?',     types._function('core.number_Q'),
 514         'string?',     types._function('core.string_Q'),
 515         'symbol',      types._function('core.symbol'),
 516         'symbol?',     types._function('core.symbol_Q'),
 517         'keyword',     types._function('core.keyword'),
 518         'keyword?',    types._function('core.keyword_Q'),
 519         'fn?',         types._function('core.fn_Q'),
 520         'macro?',      types._function('core.macro_Q'),
 521
 522         'pr-str',      types._function('core.pr_str'),
 523         'str',         types._function('core.str'),
 524         'prn',         types._function('core.prn'),
 525         'println',     types._function('core.println'),
 526         'read-string', types._function('core.read_string'),
 527         'readline',    types._function('core.readline'),
 528         'slurp',       types._function('core.slurp'),
 529
 530         '<',           types._function('core.lt'),
 531         '<=',          types._function('core.lte'),
 532         '>',           types._function('core.gt'),
 533         '>=',          types._function('core.gte'),
 534         '+',           types._function('core.add'),
 535         '-',           types._function('core.subtract'),
 536         '*',           types._function('core.multiply'),
 537         '/',           types._function('core.divide'),
 538         'time-ms',     types._function('core.time_ms'),
 539
 540         'list',        types._function('core.list'),
 541         'list?',       types._function('core.list_Q'),
 542         'vector',      types._function('core.vector'),
 543         'vector?',     types._function('core.vector_Q'),
 544         'hash-map',    types._function('core.hash_map'),
 545         'map?',        types._function('core.map_Q'),
 546         'assoc',       types._function('core.assoc'),
 547         'dissoc',      types._function('core.dissoc'),
 548         'get',         types._function('core.get'),
 549         'contains?',   types._function('core.contains_Q'),
 550         'keys',        types._function('core.keys'),
 551         'vals',        types._function('core.vals'),
 552
 553         'sequential?', types._function('core.sequential_Q'),
 554         'cons',        types._function('core.cons'),
 555         'concat',      types._function('core.concat'),
 556         'nth',         types._function('core.nth'),
 557         'first',       types._function('core.first'),
 558         'rest',        types._function('core.rest'),
 559         'empty?',      types._function('core.empty_Q'),
 560         'count',       types._function('core.count'),
 561         'apply',       types._function('core.apply'),
 562         'map',         types._function('core.map'),
 563
 564         'conj',        types._function('core.conj'),
 565         'seq',         types._function('core.seq'),
 566
 567         'meta',        types._function('core.meta'),
 568         'with-meta',   types._function('core.with_meta'),
 569         'atom',        types._function('core.atom'),
 570         'atom?',       types._function('core.atom_Q'),
 571         'deref',       types._function('core.deref'),
 572         'reset!',      types._function('core.reset_BANG'),
 573         'swap!',       types._function('core.swap_BANG')
 574         ]));