From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 27 Feb 2016 21:24:25 +0000 (+0000)
Subject: sketch some actual shell internal modules
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9eedd677ffd0e237a55a0d77498d0b76671b4da0;p=scpubgit%2FDX.git

sketch some actual shell internal modules
---

diff --git a/bin/dx b/bin/dx
new file mode 100644
index 0000000..fac99ee
--- /dev/null
+++ b/bin/dx
@@ -0,0 +1,13 @@
+use strictures 2;
+use Module::Runtime qw(use_module);
+BEGIN { *u = \&use_module }
+
+use_module('DX::ShellFrontend')->new(
+  session_mode => 'shell',
+  session => use_module('DX::ShellSession')->new(
+    shell_state => use_module('DX::ShellState')->new(
+      mode => 'shell',
+      template_query_state => use_module('DX::QueryState')->new
+    )
+  ),
+)->repl
diff --git a/lib/DX/PropositionSequence.pm b/lib/DX/PropositionSequence.pm
new file mode 100644
index 0000000..2becac1
--- /dev/null
+++ b/lib/DX/PropositionSequence.pm
@@ -0,0 +1,17 @@
+package DX::PropositionSequence;
+
+use Types::Standard qw(ArrayRef);
+use DX::Class;
+
+has members => (is => 'ro', isa => ArrayRef[Proposition], required => 1);
+
+sub new_empty {
+  shift->new(members => []);
+}
+
+sub but_append_proposition {
+  my ($self, $prop) = @_;
+  $self->but(members => [ @{$self->members}, $prop ];
+}
+
+1;
diff --git a/lib/DX/QueryState.pm b/lib/DX/QueryState.pm
new file mode 100644
index 0000000..90d72bc
--- /dev/null
+++ b/lib/DX/QueryState.pm
@@ -0,0 +1,9 @@
+package DX::QueryState;
+
+use DX::Class;
+
+#has proposition_sequence => (
+#  is => 'ro', isa => PropositionSequence, required => 1
+#);
+
+1;
diff --git a/lib/DX/ShellFrontend.pm b/lib/DX/ShellFrontend.pm
new file mode 100644
index 0000000..1b91bf6
--- /dev/null
+++ b/lib/DX/ShellFrontend.pm
@@ -0,0 +1,63 @@
+package DX::ShellFrontend;
+
+use IO::Handle;
+use Caroline;
+use DX::Class;
+
+has session => (
+  is => 'ro', required => 1,
+  handles => [ qw(is_complete_command_string eval_command_string) ]
+);
+
+has session_mode => (is => 'rwp', required => 1);
+
+has readline => (is => 'lazy', builder => sub { Caroline->new });
+
+sub BUILD { STDOUT->autoflush(1) }
+
+sub repl {
+  my ($self) = @_;
+  while (1) {
+    last unless $self->rep
+  }
+}
+
+sub rep {
+  my ($self) = @_;
+  return unless defined(my $command = $self->read_command);
+  my @result = $self->eval_command_string($command);
+  $self->process_result(@result);
+  return 1;
+}
+
+sub read_command {
+  my ($self) = @_;
+  my $base_prompt = $self->session_mode eq 'shell' ? '$ ' : '? ';
+  my $rl = $self->readline;
+  return unless defined(my $command = $rl->readline($base_prompt));
+  while (not $self->is_complete_command_string($command)) {
+    $command .= $rl->readline('> ');
+  }
+  $rl->history_add($command);
+  return $command;
+}
+
+sub process_result {
+  my ($self, @result) = @_;
+  foreach my $res (@result) {
+    my ($type, $payload) = @$res;
+    $self->${\($self->can("process_${type}_result")||die)}($payload);
+  }
+}
+
+sub process_mode_result {
+  my ($self, $mode) = @_;
+  $self->_set_session_mode($mode);
+}
+
+sub process_output_result {
+  my ($self, $output) = @_;
+  print $output;
+}
+
+1;
diff --git a/lib/DX/ShellSession.pm b/lib/DX/ShellSession.pm
new file mode 100644
index 0000000..dd4c2a9
--- /dev/null
+++ b/lib/DX/ShellSession.pm
@@ -0,0 +1,50 @@
+package DX::ShellSession;
+
+use Tcl;
+use Scalar::Util qw(weaken);
+use DX::Class;
+
+has shell_state => (is => 'rwp', required => 1, isa => ShellState);
+
+has tcl => (is => 'lazy', builder => sub {
+  my ($self) = @_;
+  weaken $self;
+  my $tcl = Tcl->new;
+  $tcl->CreateCommand('?' => sub {
+    $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ])
+  });
+  $tcl->CreateCommand('?+' => sub {
+    $self->apply_to_state([ mode => 'query' ])
+  });
+  $tcl->CreateCommand('.' => sub {
+    $self->apply_to_state([ mode => 'shell' ])
+  });
+  return $tcl;
+});
+
+sub apply_to_state {
+  my ($self, @to_apply) = @_;
+  my $state = $self->shell_state;
+  our @Result;
+  foreach my $to_apply (@to_apply) {
+    my ($change, @args) = @$to_apply;
+    ($state, my @this_result) = $state->${\"with_${change}"}(@args);
+    push @Result, @this_result;
+  }
+  $self->_set_shell_state($state);
+  return;
+}
+
+sub is_complete_command_string {
+  my ($self, $string) = @_;
+  return !!$self->tcl->icall(info => complete => $string);
+}
+
+sub eval_command_string {
+  my ($self, $string) = @_;
+  local our @Result;
+  $self->tcl->Eval($string);
+  return @Result;
+}
+
+1;
diff --git a/lib/DX/ShellState.pm b/lib/DX/ShellState.pm
new file mode 100644
index 0000000..665d9bc
--- /dev/null
+++ b/lib/DX/ShellState.pm
@@ -0,0 +1,32 @@
+package DX::ShellState;
+
+use DX::Class;
+
+has template_query_state => (
+  is => 'ro', required => 1, isa => QueryState
+);
+
+has current_query_state => (
+  is => 'ro', predicate => 1, isa => QueryState
+);
+
+has mode => (is => 'ro', required => 1);
+
+sub new_query_state { $_[0]->template_query_state }
+
+sub with_new_query_state {
+  my ($self) = @_;
+  $self->but(
+    current_query_state => $self->new_query_state
+  );
+}
+
+sub with_mode {
+  my ($self, $new_mode) = @_;
+  return (
+    $self->but(mode => $new_mode),
+    [ mode => $new_mode ],
+  );
+}
+
+1;
diff --git a/lib/DX/Types.pm b/lib/DX/Types.pm
index 729fa60..47a307b 100644
--- a/lib/DX/Types.pm
+++ b/lib/DX/Types.pm
@@ -6,6 +6,7 @@ use Type::Library
   -declare => (
     (our @CLASSES = qw(
       Hypothesis Scope ResolvedPropositionSet Proposition DependencyMap
+      PropositionSequence QueryState ShellState ShellSession
     )),
     (our @ROLES = qw(
       Step Action ActionPolicy Predicate Value