Conversion of SQL to JSON using Marpa

ddl.marpa

:default ::= action => dump_and_exit
lexeme default = latm => 1

ddl ::=
    <create table>+ action => ddl

<create table> ::=
    (CREATE TABLE) identifier ('(') <table element list> (')' ';')
    action => create_table

<table element list> ::=
    <table element>+ separator => comma
    action => [values]

<table element> ::=
    <column definition> action => ::first
  | <table constraint definition> action => ::first

<column definition> ::=
    identifier <data type> <column constrain list>
    action => column_definition

<column constrain list> ::=
    <column constrain>* action => join_hashes

<column constrain> ::=
    NOT NULL
  | <unique specification> action => ::first
  | AUTOINCREMENT action => autoincrement

<table constraint definition> ::=
    <unique specification> ('(') <column name list> (')') action => table_unique_constrain
  | <referential constraint definition> action => ::first

<referential constraint definition> ::=
    (FOREIGN KEY '(') <reference column list> (')') <references specification>
    action => referential_constraint_definition

<references specification> ::=
    (REFERENCES) identifier ('(') <reference column list> (')') <referential triggered action>
    action => reference_specification

<referential triggered action> ::= action => ::undef
<referential triggered action> ::=
    <update rule> <delete rule>
  | <delete rule> <update rule>

<update rule> ::=
<update rule> ::=
    ON UPDATE <referential action>

<delete rule> ::=
<delete rule> ::=
    ON DELETE <referential action>

<reference column list> ::=
    identifier+ separator => comma action => [values]

<column name list> ::=
    identifier+ separator => comma action => [values]

<referential action> ::=
    CASCADE
  | SET NULL
  | SET DEFAULT
  | RESTRICT
  | NO ACTION

<unique specification> ::=
    UNIQUE
  | PRIMARY KEY action => primary_key

<data type> ::=
    INTEGER action => ::first
  | TEXT action => ::first
  | BLOB action => ::first

identifier ::=
    (double_quote) non_double_quotes (double_quote) action => ::first
  | limited_identifier action => ::first

limited_identifier ~ alphabetic alphanumeric

:discard ~ whitespace

:discard ~ comment
comment ~ '--' non_newline

# Keywords

ACTION        ~ 'action':i
AUTOINCREMENT ~ 'autoincrement':i
BLOB          ~ 'blob':i
CASCADE       ~ 'cascade':i
CREATE        ~ 'create':i
DEFAULT       ~ 'default':i
DELETE        ~ 'delete':i
FOREIGN       ~ 'foreign':i
INTEGER       ~ 'integer':i
KEY           ~ 'key':i
NO            ~ 'no':i
NOT           ~ 'not':i
NULL          ~ 'null':i
ON            ~ 'on':i
PRIMARY       ~ 'primary':i
REFERENCES    ~ 'references':i
RESTRICT      ~ 'restrict':i
SET           ~ 'set':i
TABLE         ~ 'table':i
TEXT          ~ 'text':i
UNIQUE        ~ 'unique':i
UPDATE        ~ 'update':i

# Character classes

whitespace        ~ [\s]+
comma             ~ [,]
double_quote      ~ ["]
non_double_quotes ~ [^"]+
alphabetic        ~ [a-zA-Z_]
alphanumeric      ~ [a-zA-Z0-9_]*
non_newline       ~ [^\n]*

ddl2json.pl

#! /usr/bin/perl

use strict;
use warnings;
use Marpa::R2;
use Data::Dumper;
use File::Map qw(map_file);
use JSON;

sub lhs {
  my ($lhs) = map {
    $Marpa::R2::Context::slg->symbol_display_form($_)
  } $Marpa::R2::Context::slg->rule_expand($Marpa::R2::Context::rule);
  return $lhs;
}

sub dump_and_exit
{
  my ($self, @args) = @_;
  print lhs, "\n", Dumper (@args);
  exit;
}

sub make_hash_by_name_of
{
  my ($child, @args) = @_;
  my $hash = {};
  for my $element (@args) {
    if (ref $element eq 'HASH') {
      $element = $element->{$child};
      my $name = $element->{name};
      delete $element->{name};
      $hash->{$name} = $element;
    }
  }
  return $hash;
}

sub join_hashes
{
  my ($self, @args) = @_;
  my $jh = {};
  for my $h (@args) {
    @$jh{keys %$h} = values %$h;
  }
  return $jh;
}

sub ddl
{
  my ($self, @args) = @_;
  return make_hash_by_name_of ('table', @args);
}

sub create_table
{
  my ($self, @args) = @_;
  my @columns = grep {exists $_->{column}} @{$args[1]};
  my $columns = make_hash_by_name_of ('column', @columns);
  my @primary_key = grep {exists $_->{primary_key}} @{$args[1]};
  @primary_key = @{$primary_key[0]->{primary_key}} if scalar @primary_key > 0;
  # Normalize primary key constrain.
  for my $c (keys %$columns) {
    if (defined $columns->{$c}->{constrains} &&
        exists $columns->{$c}->{constrains}->{primary_key} &&
        $columns->{$c}->{constrains}->{primary_key}) {
      push @primary_key, $c;
      delete $columns->{$c}->{constrains}->{primary_key};
      undef $columns->{$c}->{constrains} if scalar (keys %{$columns->{$c}->{constrains}}) == 0;
    }
  }
  my @unique = grep {exists $_->{unique}} @{$args[1]};
  my $unique;
  $unique = "TODO" if scalar (@unique) > 0;
  my @references = grep {exists $_->{reference}} @{$args[1]};
  my $references;
  $references = [ map {$_->{reference}} @references ] if scalar (@references) > 0;
  return {table => {name => $args[0],
                    columns => $columns,
                    primary_key => \@primary_key,
                    unique => $unique,
                    references => $references}};
}

sub table_unique_constrain
{
  my ($self, @args) = @_;
  return {(keys %{$args[0]})[0] => $args[1]};
}

sub referential_constraint_definition
{
  my ($self, @args) = @_;
  my $ref = $args[1];
  $ref->{source} = $args[0];
  return {reference => $ref};
}

sub reference_specification
{
  my ($self, @args) = @_;
  return {destination => {$args[0] => $args[1]}};
}

sub column_definition
{
  my ($self, @args) = @_;
  my $constrains = $args[2];
  undef $constrains if scalar(keys %$constrains) == 0;
  return {column => {name => $args[0],
                     type => $args[1],
                     constrains => $constrains}};
}

sub primary_key
{
  my ($self, @args) = @_;
  return {primary_key => JSON::true};
}

sub autoincrement
{
  my ($self, @args) = @_;
  return {autoincrement => JSON::true};
}

map_file my $bnf, 'ddl.marpa';
map_file my $input, 'demo.ddl';

my $grammar = Marpa::R2::Scanless::G->new ({
  bless_package => 'main',
  source => \$bnf});

#print Dumper($grammar->parse (\$input));

my $recce = Marpa::R2::Scanless::R->new ({ grammar => $grammar });
my $self = bless { grammar => $grammar };
$self->{recce} = $recce;

if (not defined eval { $recce->read(\$input); 1 })
{
  my $eval_error = $@;
  chomp $eval_error;
  die $self->show_last_expression(), "\n", $eval_error, "\n";
}

my $value_ref = $recce->value ($self);
if (not defined $value_ref) {
  die $self->show_last_expression(), "\n",
  "No parse was found, after reading the entire input\n";
}

my $JSON = JSON->new->utf8->pretty->allow_nonref;
print $JSON->encode ($$value_ref);

demo.ddl

-- -*- sql -*-

CREATE TABLE "ID"
(
  "num" integer PRIMARY KEY AUTOINCREMENT,
  "uuid" blob
);

CREATE TABLE "Address"
(
  "id"       integer,
  "street"   text,
  "locality" text,
  "country"  text,
  FOREIGN KEY ("id") REFERENCES "ID" ("num"),
  PRIMARY KEY ("id")
);

CREATE TABLE "Address :L"
(
  "id" integer,
  FOREIGN KEY ("id") REFERENCES "ID" ("num"),
  PRIMARY KEY ("id")
);

CREATE TABLE "Address :E"
(
  "list"    integer,
  "address" integer,
  FOREIGN KEY ("list")    REFERENCES "Address :L" ("id"),
  FOREIGN KEY ("address") REFERENCES "Address" ("id"),
  PRIMARY KEY ("list", "address")
);

CREATE TABLE "Person"
(
  "id"                   integer,
  "first name"           text,
  "last name"            text,
  "main residence"       integer,
  "secundary residences" integer,
  FOREIGN KEY ("main residence") REFERENCES "Address" ("id"),
  FOREIGN KEY ("secundary residences") REFERENCES "Address :L" ("id"),
  FOREIGN KEY ("id") REFERENCES "ID" ("num"),
  PRIMARY KEY ("id")
);

demo.json

{
   "Address" : {
      "columns" : {
         "country" : {
            "constrains" : null,
            "type" : "text"
         },
         "street" : {
            "constrains" : null,
            "type" : "text"
         },
         "locality" : {
            "type" : "text",
            "constrains" : null
         },
         "id" : {
            "type" : "integer",
            "constrains" : null
         }
      },
      "unique" : null,
      "references" : [
         {
            "destination" : {
               "ID" : [
                  "num"
               ]
            },
            "source" : [
               "id"
            ]
         }
      ],
      "primary_key" : [
         "id"
      ]
   },
   "Person" : {
      "columns" : {
         "last name" : {
            "constrains" : null,
            "type" : "text"
         },
         "secundary residences" : {
            "type" : "integer",
            "constrains" : null
         },
         "main residence" : {
            "type" : "integer",
            "constrains" : null
         },
         "id" : {
            "type" : "integer",
            "constrains" : null
         },
         "first name" : {
            "type" : "text",
            "constrains" : null
         }
      },
      "references" : [
         {
            "source" : [
               "main residence"
            ],
            "destination" : {
               "Address" : [
                  "id"
               ]
            }
         },
         {
            "source" : [
               "secundary residences"
            ],
            "destination" : {
               "Address :L" : [
                  "id"
               ]
            }
         },
         {
            "source" : [
               "id"
            ],
            "destination" : {
               "ID" : [
                  "num"
               ]
            }
         }
      ],
      "primary_key" : [
         "id"
      ],
      "unique" : null
   },
   "Address :E" : {
      "unique" : null,
      "references" : [
         {
            "source" : [
               "list"
            ],
            "destination" : {
               "Address :L" : [
                  "id"
               ]
            }
         },
         {
            "destination" : {
               "Address" : [
                  "id"
               ]
            },
            "source" : [
               "address"
            ]
         }
      ],
      "primary_key" : [
         "list",
         "address"
      ],
      "columns" : {
         "address" : {
            "type" : "integer",
            "constrains" : null
         },
         "list" : {
            "type" : "integer",
            "constrains" : null
         }
      }
   },
   "Address :L" : {
      "columns" : {
         "id" : {
            "constrains" : null,
            "type" : "integer"
         }
      },
      "references" : [
         {
            "source" : [
               "id"
            ],
            "destination" : {
               "ID" : [
                  "num"
               ]
            }
         }
      ],
      "primary_key" : [
         "id"
      ],
      "unique" : null
   },
   "ID" : {
      "columns" : {
         "uuid" : {
            "constrains" : null,
            "type" : "blob"
         },
         "num" : {
            "constrains" : {
               "autoincrement" : true
            },
            "type" : "integer"
         }
      },
      "unique" : null,
      "primary_key" : [
         "num"
      ],
      "references" : null
   }
}