; a simple line editor for reading lisp expressions.
; colors strings and comments. nested parens get different colors.
;
; needs to do its own raw keyboard/screen management since we need to decide
; how to color each key right as it is printed.
; lots of logic devoted to handling backspace correctly.

; keyboard screen abort continuation -> string
(function read-expression [
  (default-space:space-address <- new space:literal 60:literal)
  (k:keyboard-address <- next-input)
  (screen:terminal-address <- next-input)
  (abort:continuation <- next-input)
  (history:buffer-address <- next-input)  ; buffer of strings
  (history-length:integer <- get history:buffer-address/deref length:offset)
  (current-history-index:integer <- copy history-length:integer)
  (result:buffer-address <- init-buffer 10:literal)  ; string to maybe add to
  (open-parens:integer <- copy 0:literal)  ; for balancing parens and tracking nesting depth
  ; we can change color when backspacing over parens or comments or strings,
  ; but we need to know that they aren't escaped
  (escapes:buffer-address <- init-buffer 5:literal)
  ; to not return after just a comment
  (not-empty?:boolean <- copy nil:literal)
  { begin
    ; repeatedly read keys from the keyboard
    ;   test: 34<enter>
    (done?:boolean <- process-key default-space:space-address k:keyboard-address screen:terminal-address)
    (loop-unless done?:boolean)
  }
  ; trim trailing newline in result (easier history management below)
  { begin
    (l:character <- last result:buffer-address)
    (trailing-newline?:boolean <- equal l:character ((#\newline literal)))
    (break-unless trailing-newline?:boolean)
    (len:integer-address <- get-address result:buffer-address/deref length:offset)
    (len:integer-address/deref <- subtract len:integer-address/deref 1:literal)
  }
  ; test: 3<enter> => size of s is 2
  (s:string-address <- to-array result:buffer-address)
  (reply s:string-address)
])

(function process-key [  ; return t to signal end of expression
  (default-space:space-address <- new space:literal 60:literal)
  (0:space-address/names:read-expression <- next-input)
  (k:keyboard-address <- next-input)
  (screen:terminal-address <- next-input)
  (c:character <- wait-for-key k:keyboard-address silent:literal/terminal)
  (len:integer-address <- get-address result:buffer-address/space:1/deref length:offset)
  (maybe-cancel-this-expression c:character abort:continuation/space:1)
  ; check for ctrl-d and exit
  { begin
    (eof?:boolean <- equal c:character ((ctrl-d literal)))
    (break-unless eof?:boolean)
    ; return empty expression
    (s:string-address-address <- get-address result:buffer-address/space:1/deref data:offset)
    (s:string-address-address/deref <- copy nil:literal)
    (reply t:literal)
  }
  ; check for backspace
  ;   test: 3<backspace>4<enter>
  ;   todo: backspace past newline
  { begin
    (backspace?:boolean <- equal c:character ((#\backspace literal)))
    (break-unless backspace?:boolean)
    (print-character screen:terminal-address c:character/backspace)
    { begin
      ; delete last character if any
      (zero?:boolean <- lesser-or-equal len:integer-address/deref 0:literal)
      (break-if zero?:boolean)
      (len:integer-address/deref <- subtract len:integer-address/deref 1:literal)
      ; switch colors
      ;   test: "a"<backspace>bc"
      ;   test: "a\"<backspace>bc"
      { begin
        (backspaced-over-close-quote?:boolean <- backspaced-over-unescaped? result:buffer-address/space:1 ((#\" literal)) escapes:buffer-address/space:1)  ; "
        (break-unless backspaced-over-close-quote?:boolean)
        (slurp-string result:buffer-address/space:1 escapes:buffer-address/space:1 abort:continuation/space:1 k:keyboard-address screen:terminal-address)
        (reply nil:literal)
      }
      ;   test: (+ 1 (<backspace>2)
      ;   test: (+ 1 #\(<backspace><backspace><backspace>2)
      { begin
        (backspaced-over-open-paren?:boolean <- backspaced-over-unescaped? result:buffer-address/space:1 ((#\( literal)) escapes:buffer-address/space:1)
        (break-unless backspaced-over-open-paren?:boolean)
        (open-parens:integer/space:1 <- subtract open-parens:integer/space:1 1:literal)
        (reply nil:literal)
      }
      ;   test: (+ 1 2)<backspace> 3)
      ;   test: (+ 1 2#\)<backspace><backspace><backspace> 3)
      { begin
        (backspaced-over-close-paren?:boolean <- backspaced-over-unescaped? result:buffer-address/space:1 ((#\) literal)) escapes:buffer-address/space:1)
        (break-unless backspaced-over-close-paren?:boolean)
        (open-parens:integer/space:1 <- add open-parens:integer/space:1 1:literal)
        (reply nil:literal)
      }
    }
    (reply nil:literal)
  }
  ; up arrow; switch to previous item in history
  { begin
    (up-arrow?:boolean <- equal c:character ((up literal)))
    (break-unless up-arrow?:boolean)
    ; if history exists
    ;   test: <up><enter>  up without history has no effect
    { begin
      (empty-history?:boolean <- lesser-or-equal history-length:integer/space:1 0:literal)
      (break-unless empty-history?:boolean)
      (reply nil:literal)
    }
    ; if pointer not already at start of history
    ;   test: 34<enter><up><up><enter>  up past history has no effect
    { begin
      (at-history-start?:boolean <- lesser-or-equal current-history-index:integer/space:1 0:literal)
      (break-unless at-history-start?:boolean)
      (reply nil:literal)
    }
    ; then update history index, copy into current buffer
    ;   test: 34<enter><up><enter>  up restores previous command
    ;   test todo: 34<enter>23<up>34<down><enter>  up doesn't mess up typing on current line
    ;   test todo: 34<enter><up>5<enter><up><up>  commands don't modify history
    ;   test todo: multi-line expressions
    ; identify the history item
    (current-history-index:integer/space:1 <- subtract current-history-index:integer/space:1 1:literal)
    (switch-to-history 0:space-address screen:terminal-address)
    ; <enter> is trimmed in the history expression, so wait for the human to
    ; hit <enter> again or backspace to make edits
    (reply nil:literal)
  }
  ; down arrow; switch to next item in history
  { begin
    (down-arrow?:boolean <- equal c:character ((down literal)))
    (break-unless down-arrow?:boolean)
    ; if history exists
    ;   test: <down><enter>  down without history has no effect
    { begin
      (empty-history?:boolean <- lesser-or-equal history-length:integer/space:1 0:literal)
      (break-unless empty-history?:boolean)
      (reply nil:literal)
    }
    ; if pointer not already at end of history
    ;   test: 34<enter><down><down><enter>  up past history has no effect
    { begin
      (x:integer <- subtract history-length:integer/space:1 1:literal)
      (before-history-end?:boolean <- greater-or-equal current-history-index:integer/space:1 x:integer)
      (break-unless before-history-end?:boolean)
      (reply nil:literal)
    }
    ; then update history index, copy into current buffer
    ;   test: 34<enter><up><enter>  up restores previous command
    ;   test todo: 34<enter>23<up>34<down><enter>  up doesn't mess up typing on current line
    ;   test todo: 34<enter><up>5<enter><up><up>  commands don't modify history
    ;   test todo: multi-line expressions
    ; identify the history item
    (current-history-index:integer/space:1 <- add current-history-index:integer/space:1 1:literal)
    (switch-to-history 0:space-address screen:terminal-address)
    ; <enter> is trimmed in the history expression, so wait for the human to
    ; hit <enter> again or backspace to make edits
    (reply nil:literal)
  }
  ; if it's a newline, decide whether to return
  ;   test: <enter>34<enter>
  { begin
    (newline?:boolean <- equal c:character ((#\newline literal)))
    (break-unless newline?:boolean)
    (print-character screen:terminal-address c:character/newline)
    (at-top-level?:boolean <- lesser-or-equal open-parens:integer/space:1 0:literal)
    (end-expression?:boolean <- and at-top-level?:boolean not-empty?:boolean/space:1)
    (reply end-expression?:boolean)
  }
  ; printable character; save
;?   ($print (("append\n" literal))) ;? 2
  (result:buffer-address/space:1 <- append result:buffer-address/space:1 c:character)
;?   ($print (("done\n" literal))) ;? 2
  ; if it's backslash, read, save and print one additional character
  ;   test: (prn #\()
  { begin
    (backslash?:boolean <- equal c:character ((#\\ literal)))
    (break-unless backslash?:boolean)
    (print-character screen:terminal-address c:character/backslash 7:literal/white)
    (result:buffer-address/space:1 escapes:buffer-address/space:1 <- slurp-escaped-character result:buffer-address/space:1 7:literal/white escapes:buffer-address/space:1 abort:continuation/space:1 k:keyboard-address screen:terminal-address)
    (reply nil:literal)
  }
  ; if it's a semi-colon, parse a comment
  { begin
    (comment?:boolean <- equal c:character ((#\; literal)))
    (break-unless comment?:boolean)
    (print-character screen:terminal-address c:character/semi-colon 4:literal/fg/blue)
    (comment-read?:boolean <- slurp-comment result:buffer-address/space:1 escapes:buffer-address/space:1 abort:continuation/space:1 k:keyboard-address screen:terminal-address)
    ; return if comment was read (i.e. consumed a newline)
    ; test: ;a<backspace><backspace> (shouldn't end command until <enter>)
    { begin
      (break-if comment-read?:boolean)
      (reply nil:literal)
    }
    ; and we're not within parens
    ;   test: (+ 1 2)  ; comment<enter>
    ;   test: (+ 1<enter>; abc<enter>2)<enter>
    ;   test: ; comment<enter>(+ 1 2)<enter>
    ;   too expensive to build: 3<backspace>; comment<enter>(+ 1 2)<ent<style>pre { line-height: 125%; }
td.linenos .normal { color: inherit; background-color: transparent; padding-left: 5px; padding-right: 5px; }
span.linenos { color: inherit; background-color: transparent; padding-left: 5px; padding-right: 5px; }
td.linenos .special { color: #000000; background-color: #ffffc0; padding-left: 5px; padding-right: 5px; }
span.linenos.special { color: #000000; background-color: #ffffc0; padding-left: 5px; padding-right: 5px; }
.highlight .hll { background-color: #ffffcc }
.highlight .c { color: #888888 } /* Comment */
.highlight .err { color: #a61717; background-color: #e3d2d2 } /* Error */
.highlight .k { color: #008800; font-weight: bold } /* Keyword */
.highlight .ch { color: #888888 } /* Comment.Hashbang */
.highlight .cm { color: #888888 } /* Comment.Multiline */
.highlight .cp { color: #cc0000; font-weight: bold } /* Comment.Preproc */
.highlight .cpf { color: #888888 } /* Comment.PreprocFile */
.highlight .c1 { color: #888888 } /* Comment.Single */
.highlight .cs { color: #cc0000; font-weight: bold; background-color: #fff0f0 } /* Comment.Special */
.highlight .gd { color: #000000; background-color: #ffdddd } /* Generic.Deleted */
.highlight .ge { font-style: italic } /* Generic.Emph */
.highlight .ges { font-weight: bold; font-style: italic } /* Generic.EmphStrong */
.highlight .gr { color: #aa0000 } /* Generic.Error */
.highlight .gh { color: #333333 } /* Generic.Heading */
.highlight .gi { color: #000000; background-color: #ddffdd } /* Generic.Inserted */
.highlight .go { color: #888888 } /* Generic.Output */
.highlight .gp { color: #555555 } /* Generic.Prompt */
.highlight .gs { font-weight: bold } /* Generic.Strong */
.highlight .gu { color: #666666 } /* Generic.Subheading */
.highlight .gt { color: #aa0000 } /* Generic.Traceback */
.highlight .kc { color: #008800; font-weight: bold } /* Keyword.Constant */
.highlight .kd { color: #008800; font-weight: bold } /* Keyword.Declaration */
.highlight .kn { color: #008800; font-weight: bold } /* Keyword.Namespace */
.highlight .kp { color: #008800 } /* Keyword.Pseudo */
.highlight .kr { color: #008800; font-weight: bold } /* Keyword.Reserved */
.highlight .kt { color: #888888; font-weight: bold } /* Keyword.Type */
.highlight .m { color: #0000DD; font-weight: bold } /* Literal.Number */
.highlight .s { color: #dd2200; background-color: #fff0f0 } /* Literal.String */
.highlight .na { color: #336699 } /* Name.Attribute */
.highlight .nb { color: #003388 } /* Name.Builtin */
.highlight .nc { color: #bb0066; font-weight: bold } /* Name.Class */
.highlight .no { color: #003366; font-weight: bold } /* Name.Constant */
.highlight .nd { color: #555555 } /* Name.Decorator */
.highlight .ne { color: #bb0066; font-weight: bold } /* Name.Exception */
.highlight .nf { color: #0066bb; font-weight: bold } /* Name.Function */
.highlight .nl { color: #336699; font-style: italic } /* Name.Label */
.highlight .nn { color: #bb0066; font-weight: bold } /* Name.Namespace */
.highlight .py { color: #336699; font-weight: bold } /* Name.Property */
.highlight .nt { color: #bb0066; font-weight: bold } /* Name.Tag */
.highlight .nv { color: #336699 } /* Name.Variable */
.highlight .ow { color: #008800 } /* Operator.Word */
.highlight .w { color: #bbbbbb } /* Text.Whitespace */
.highlight .mb { color: #0000DD; font-weight: bold } /* Literal.Number.Bin */
.highlight .mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */
.highlight .mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */
.highlight .mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */
.highlight .mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */
.highlight .sa { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Affix */
.highlight .sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */
.highlight .sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */
.highlight .dl { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Delimiter */
.highlight .sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */
.highlight .s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */
.highlight .se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */
.highlight .sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */
.highlight .si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */
.highlight .sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */
.highlight .sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */
.highlight .s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */
.highlight .ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */
.highlight .bp { color: #003388 } /* Name.Builtin.Pseudo */
.highlight .fm { color: #0066bb; font-weight: bold } /* Name.Function.Magic */
.highlight .vc { color: #336699 } /* Name.Variable.Class */
.highlight .vg { color: #dd7700 } /* Name.Variable.Global */
.highlight .vi { color: #3333bb } /* Name.Variable.Instance */
.highlight .vm { color: #336699 } /* Name.Variable.Magic */
.highlight .il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */</style><div class="highlight"><pre><span></span><span class="c">#</span>
<span class="c">#</span>
<span class="c">#            Nimrod&#39;s Runtime Library</span>
<span class="c">#        (c) Copyright 2012 Andreas Rumpf</span>
<span class="c">#</span>
<span class="c">#    See the file &quot;copying.txt&quot;, included in this</span>
<span class="c">#    distribution, for details about the copyright.</span>
<span class="c">#</span>

<span class="sd">## A higher level `PostgreSQL`:idx: database wrapper. This interface </span>
<span class="sd">## is implemented for other databases too.</span>

<span class="kn">import</span><span class="w"> </span><span class="n">strutils</span><span class="p">,</span><span class="w"> </span><span class="n">postgres</span>

<span class="k">type</span>
<span class="w">  </span><span class="n">TDbConn</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="n">PPGconn</span><span class="w">   </span><span class="sd">## encapsulates a database connection</span>
<span class="w">  </span><span class="n">TRow</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="nb">seq</span><span class="o">[</span><span class="nb">string</span><span class="o">]</span><span class="w">  </span><span class="sd">## a row of a dataset. NULL database values will be</span>
<span class="w">                       </span><span class="sd">## transformed always to the empty string.</span>
<span class="w">  </span><span class="n">EDb</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="k">object</span><span class="w"> </span><span class="k">of</span><span class="w"> </span><span class="n">EIO</span><span class="w"> </span><span class="sd">## exception that is raised if a database error occurs</span>
<span class="w">  </span>
<span class="w">  </span><span class="n">TSqlQuery</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="k">distinct</span><span class="w"> </span><span class="nb">string</span><span class="w"> </span><span class="sd">## an SQL query string</span>

<span class="w">  </span><span class="n">FDb</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="k">object</span><span class="w"> </span><span class="k">of</span><span class="w"> </span><span class="n">FIO</span><span class="w"> </span><span class="sd">## effect that denotes a database operation</span>
<span class="w">  </span><span class="n">FReadDb</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="k">object</span><span class="w"> </span><span class="k">of</span><span class="w"> </span><span class="n">FDB</span><span class="w">   </span><span class="sd">## effect that denotes a read operation</span>
<span class="w">  </span><span class="n">FWriteDb</span><span class="o">*</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="k">object</span><span class="w"> </span><span class="k">of</span><span class="w"> </span><span class="n">FDB</span><span class="w">  </span><span class="sd">## effect that denotes a write operation</span>
<span class="w">  </span>
<span class="k">proc</span><span class="w"> </span><span class="nf">sql</span><span class="o">*</span><span class="p">(</span><span class="n">query</span><span class="p">:</span><span class="w"> </span><span class="nb">string</span><span class="p">):</span><span class="w"> </span><span class="n">TSqlQuery</span><span class="w"> </span><span class="sx">{.noSideEffect</span>,<span class="w"> </span><span class="sx">inline.}</span><span class="w"> </span><span class="o">=</span><span class="w">  </span>
<span class="w">  </span><span class="sd">## constructs a TSqlQuery from the string `query`. This is supposed to be </span>
<span class="w">  </span><span class="sd">## used as a raw-string-literal modifier:</span>
<span class="w">  </span><span class="sd">## ``sql&quot;update user set counter = counter + 1&quot;``</span>
<span class="w">  </span><span class="sd">##</span>
<span class="w">  </span><span class="sd">## If assertions are turned off, it does nothing. If assertions are turned </span>
<span class="w">  </span><span class="sd">## on, later versions will check the string for valid syntax.</span>
<span class="w">  </span><span class="n">result</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="n">TSqlQuery</span><span class="p">(</span><span class="n">query</span><span class="p">)</span>
<span class="w"> </span>
<span class="k">proc</span><span class="w"> </span><span class="nf">dbError</span><span class="p">(</span><span class="n">db</span><span class="p">:</span><span class="w"> </span><span class="n">TDbConn</span><span class="p">)</span><span class="w"> </span><span class="sx">{.noreturn.}</span><span class="w"> </span><span class="o">=</span><span class="w"> </span>
<span class="w">  </span><span class="sd">## raises an EDb exception.</span>
<span class="w">  </span><span class="kd">var</span><span class="w"> </span><span class="n">e</span><span class="p">:</span><span class="w"> </span><span class="k">ref</span><span class="w"> </span><span class="n">EDb</span>
<span class="w">  </span><span class="n">new</span><span class="p">(</span><span class="n">e</span><span class="p">)</span>
<span class="w">  </span><span class="n">e</span><span class="p">.</span><span class="n">msg</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="o">$</span><span class="n">PQerrorMessage</span><span class="p">(</span><span class="n">db</span><span class="p">)</span>
<span class="w">  </span><span class="k">raise</span><span class="w"> </span><span class="n">e</span>

<span class="k">proc</span><span class="w"> </span><span class="nf">dbError</span><span class="o">*</span><span class="p">(</span><span class="n">msg</span><span class="p">:</span><span class="w"> </span><span class="nb">string</span><span class="p">)</span><span class="w"> </span><span class="sx">{.noreturn.}</span><span class="w"> </span><span class="o">=</span><span class="w"> </span>
<span class="w">  </span><span class="sd">## raises an EDb exception with message `msg`.</span>
<span class="w">  </span><span class="kd">var</span><span class="w"> </span><span class="n">e</span><span class="p">:</span><span class="w"> </span><span class="k">ref</span><span class="w"> </span><span class="n">EDb</span>
<span class="w">  </span><span class="n">new</span><span class="p">(</span><span class="n">e</span><span class="p">)</span>
<span class="w">  </span><span class="n">e</span><span class="p">.</span><span class="n">msg</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="n">msg</span>
<span class="w">  </span><span class="k">raise</span><span class="w"> </span><span class="n">e</span>

<span class="k">proc</span><span class="w"> </span><span class="nf">dbQuote</span><span class="p">(</span><span class="n">s</span><span class="p">:</span><span class="w"> </span><span class="nb">string</span><span class="p">):</span><span class="w"> </span><span class="nb">string</span><span class="w"> </span><span class="o">=</span>
<span class="w">  </span><span class="n">result</span><span class="w"> </span><span class="o">=</span><span class="w"> </span><span class="s">&quot;&#39;&quot;</span>
<span class="w">  </span><span class="k">for</span><span class="w"> </span><span class="n">c</span><span class="w"> </span><span class="ow">in</span><span class="w"> </span><span class="n">items</span><span class="p">(</span><span class="n">s</span><span class="p">):</span>
<span class="w">    </span><span class="k">if</span><span class="w"> </span><span class="n">c</span><span class="w"> </span><span class="o">==</span><span class="w"> </span><span class="sc">&#39;</span><span class="se">\&#39;</span><span class="sc">&#39;</span><span class="p">:</span><span class="w"> </span><span class="n">add</span><span class="p">(</span><span class="n">res