Chicken Web REPL

Há algum tempo eu e o Vilson estávamos discutindo sobre REPLs na Web (não lembro o que desencadeou esse tópico -- também é possível que o tópico não tenha sido esse -- tá feio o caso da minha memória). Bem, o fato é que desta conversa surgiu a idéia de fazer um REPL via Web para Chicken. Lembrei do egg sandbox, do Chicken Playground (um ambiente chroot com uma instalação de Debian, Chicken e um monte de eggs) e fiz um Web REPL simples para Chicken.

Em seguida, o Vilson descobriu o EditArea (um editor de código em Javascript) e modificou para adicionar um suporte básico a Common Lisp. Enviou o código para mim e eu, com base nele, adicionei suporte básico a Scheme.

O resultado está em http://repl.ucpel.tche.br:8080.



Uma das funcionalidades interessantes do Web REPL é o uso de sessões HTTP para manter coisas como histórico de trechos de código submetidos ao avaliador e definições feitas na sessão. A implementação de sessões é feita com o egg http-session.

O Web REPL também usa os eggs web-scheme, ajax, spiffy-utils e spiffy (servidor web).

REPL de Chicken para acesso a bases de dados do Postgres

A seguir está uma forma de usar o REPL de Chicken (csi) como um REPL para bases de dados do Postgres.

Com isso, tem-se um REPL que possibilita a execução de consultas SQL e código Scheme. A implementação usa o próprio REPL do sistema Chicken e alguns eggs como: postgresql (para acesso so Postgres), readline (para edição de linhas de comando, histórico) e stty (para configuração do terminal na leitura de senhas).

O programa db-repl.scm usa como argumentos não interativos (opcionais) o usuário do banco de dados, o nome do host e a base de dados, os quais devem ser fornecidos no seguinte formato:

<usuario>@<host>/<base de dados>

Quando executado, o programa pede para o usuário digitar a senha.

A associação do REPL de Chicken com a base de dados é feita através da definição de comandos do REPL (toplevel-command). Na implementação mostrada abaixo, são definidos três comandos:

• tables: mostras as tabelas da base de dados.


• table: mostra estrutura da tabela dada como argumento (nome e tipo das colunas e se podem ou não ser nulas).


• -: executa a consulta SQL dada como argumento.

Exemplos:

csi -s db-repl.scm mario@localhost/sgpc
Senha: *****

#;1> ,tables
perms
news
users_sites
ticket_comments
ticket_attachments
obj_type
acervos
autores
videos
audios
images
objects
texts
scanners
users
wiki
sites
tickets

#;1> ,table news
news_id                       integer                       NO
user_id                       integer                       NO
site_id                       integer                       NO
timestamp                     timestamp without time zone   YES
title                         character varying(100)        NO
news                          text                          YES

#;1> ,- select * from news
(#(2
   1
   1
   #(2008 7 30 19 37 54 271625)
   "Teste."
   "teste

   === titulo")
 #(3
   1
   1
   #(2008 7 30 19 40 27 180765)
   "Outra notícia!"
   "Aqui vai o texto da notícia.

[[image:http://subversion.tigris.org/branding/images/logo.gif|Logo]]"))

Obviamente, os comandos para acesso ao banco de dados disponibilizados através do REPL podem ser estendidos. O texto PostgreSQL INFORMATION_SCHEMA fornece várias dicas de como extrair informações de bases de dados do Postgres.

Nesta implementação, o parâmetro pg-repl:conn armazena o objeto que representa a conexão com o banco de dados, de forma que ele pode ser usado pelos procedimentos do egg postgresql para a execução de consultas:

#;1> (define query  "select * from news")
#;2> (vector-ref (car (pg:query-tuples query (pg-repl:conn))) 3)
#(2008 7 30 19 37 54 271625)

O código do programa (db-repl.scm) está a seguir:

(use utils postgresql readline stty regex (srfi 13))

(define pg-repl:conn (make-parameter #f))

(define (pg-repl:query . query)
  (pg:query-tuples
   (string-intersperse (map ->string query) "")
   (pg-repl:conn)))

(toplevel-command
 '-
 (lambda ()
   (pp (pg-repl:query
        (with-output-to-string
          (cut print (read-line)))))))

(toplevel-command
 'table
 (lambda ()
   (let* ((table (string-trim-both (read-line)))
          (cols
           (pg-repl:query
            "select column_name,data_type,"
            "character_maximum_length,is_nullable "
            "from information_schema.columns "
            "where table_name = '" table "'")))
     (if (null? cols)
         (print "Tabela \"" table "\" nao existe.")
         (for-each
          (lambda (f)
            (let ((colname (vector-ref f 0))
                  (type (vector-ref f 1))
                  (size (let ((size (vector-ref f 2)))
                          (if (pg:sql-null-object? size)
                              ""
                              (conc "(" size ")"))))
                  (nullable (vector-ref f 3)))
              (print
               colname
               (make-string
                (- 30 (string-length colname)))
               type size
               (make-string
                (- 30 (string-length (conc type size))))
               nullable)))
          cols)))))

(toplevel-command
 'tables
 (lambda ()
   (for-each
    (lambda (item)
      (print (vector-ref item 0)))
    (pg-repl:query
     "select table_name from information_schema.tables "
     "where table_type = 'BASE TABLE' "
     "and table_schema not in "
     "('pg_catalog', 'information_schema')"))))

(define (pg-repl:usage #!optional exit-code)
  (print (program-name) " [<user>@<server>/<database>]")
  (when exit-code (exit exit-code)))

(let ((args (command-line-arguments))
      (user "postgres")
      (host "localhost")
      (db "template")
      (passwd #f))

  ;; Restaura o terminal em caso de termino via C-c
  (set-signal-handler! signal/int
                       (lambda (_) (stty '(echo))))

  (unless (or (null? args) (equal? "\"\"" (car args)))
    (let* ((cred (string-trim-both
                  (car args)
                  (cut memq <> '(#\space #\newline #\")))) ;"
           (@tokens (string-split cred "@"))
           (/tokens (if (null? @tokens)
                        '()
                        (string-split (cadr @tokens) "/"))))
      (if (and (null? @tokens) (null? /tokens))
          (pg-repl:usage 1)
          (begin
            (unless (null? @tokens)
              (set! user (car @tokens)))
            (unless (null? /tokens)
              (set! host (car /tokens))
              (set! db (cadr /tokens)))))))
  (display "Senha: ")
  (pg-repl:conn
   (pg:connect
    `((user . ,user)
      (dbname . ,db)
      (host . ,host)
      (password . ,(with-stty '(not echo) read-line)))))
  (current-input-port (make-gnu-readline-port))
  (gnu-history-install-file-manager
   (string-append (or (getenv "HOME") ".")
                  "/.csi.history"))
  (newline)
  (repl))

Copy & comment

Para quem seguidamente, como eu:

1. tem preguiça de criar uma revisão no VCS para alterar algo pequeno no código (só para ver se dá certo -- se não der, volta atrás rapidinho);

2. acha muito trabalhoso usar o editor de texto para duplicar um trecho de código (i.e., copiar & colar) e comentar uma das partes.

A função a seguir (em Elisp, para Emacs) faz as tarefas do item 2 para quem se enquadra no perfil do item 1:

(defun copy&comment (begin end)
  (interactive "r")
  (save-excursion
    (copy-region-as-kill begin end)
    (goto-char end)
    (yank)
    (comment-region begin end)))

Interpretador de assembly em Scheme

Dando continuidade à série de programas inúteis que só servem para alimentar a procrastinação, a seguir estão a descrição e implementação (em Chicken Scheme) de um pequeno interpretador de uma linguagem assembly bem simples.

A linguagem possui apenas seis instruções e opera somente com números:

• add <reg> <number | reg>: Soma um número ou o conteúdo do registrador usado como segundo argumento com o conteúdo do registrador usado como primeiro argumento. O resultado é armazenado no registrador usado como primeiro argumento.


• mov <reg> <number | reg>: Armazena o número ou o conteúdo do registrador usado como segundo argumento no registrador usado como primeiro argumento.


• lbl <label>: Associa um endereço de memória a um rótulo, o qual pode ser referenciado no programa pelas instruções jmp e jnz.


• jmp <label>: Desvia o fluxo de execução para <label> (uma marca determinada através da instrução lbl).


• jnz <reg> <label>: Desvia o fluxo de execução para <label> se o conteúdo do registrador usado como primeiro argumento for diferente de zero.


• out <number | reg>: Imprime o número ou conteúdo do registrador usado como argumento.

A arquitetura hipotética considerada possui 8 registradores para leitura e escrita (r1 a r8), nenhum deles com função específica. Há também um registrador somente para leitura (ip) que armazena o endereço de memória da última instrução executada.

Por simplicidade, a sintaxe das instruções é semelhante à sintaxe de Scheme, ou seja, usa parênteses. Por exemplo:

(mov r1 3)

O código do interpretador está a seguir (tiny-assembly.scm):

;; Instrucoes:
;;     add <reg> <number | reg>
;;     mov <reg> <number | reg>
;;     jmp <label>
;;     jnz <reg> <label>
;;     lbl <label>
;;     out <number | reg>
;;
;; Registradores: r1..r8
;; Registrador "read-only": ip

(use srfi-1)

(define (run code)
  (define memory (map cons (iota (length code)) code))
  (define labels '())
  (define registers
    '((r1 . 0) (r2 . 0) (r3 . 0) (r4 . 0)
      (r5 . 0) (r6 . 0) (r7 . 0) (r8 . 0)))
  (define ip 0)
  (define code-len (length code))

  (define (die . msg)
    (print "Error: "
           (string-intersperse (map ->string msg) ""))
    (exit 1))

  (define (next-ip)
    (set! ip (add1 ip)))

  (define (reg-get register)
    (alist-ref register registers))

  (define (val-get thing)
    (if (eq? thing 'ip)
        ip
        (if (number? thing)
            thing
            (reg-get thing))))

  (define (reg-set! reg val)
    (set! registers
          (alist-update! reg (val-get val) registers)))

  (define (label-address label)
    (alist-ref label labels))

  (define (add reg val)
    (reg-set! reg (+ (reg-get reg) (val-get val))))

  (define (mov reg val)
    (reg-set! reg (val-get val)))

  (define (jmp label)
    (let ((address (or (reg-get label)
                       (label-address label))))
      (if address
          (set! ip address)
          (die "label " label " not found."))))

  (define (jnz reg label)
    (if (zero? (reg-get reg))
        (next-ip)
        (jmp label)))

  (define (lbl label)
    (set! labels (alist-update! label ip labels)))

  (define (finished? ip) (>= ip code-len))

  (set! labels
        (map (lambda (label)
               (cons (caddr label) (car label)))
             (filter (lambda (expr)
                       (eq? (cadr expr) 'lbl))
                     memory)))
  (let loop ()
    (if (finished? ip)
        (exit)
        (begin
          (let* ((expr (alist-ref ip memory))
                 (op (car expr))
                 (arg1 (cadr expr))
                 (arg2 (and (not (null? (cddr expr)))
                            (caddr expr))))
            (case op
              ((mov) (mov arg1 arg2))
              ((add) (add arg1 arg2))
              ((jmp) (jmp arg1))
              ((jnz) (jnz arg1 arg2))
              ((lbl) (noop))
              ((out) (print
                      (or (reg-get arg1)
                          (if (eq? arg1 'ip)
                              ip
                              arg1))))
              (else (die op ": unknown command.")))
            (unless (memq op '(jmp jnz))
              (next-ip)))
          (loop)))))

;;; Command line parser
(let ((args (command-line-arguments)))
  (when (null? args)
    (print "Usage: " (program-name) " <input-file>")
    (exit 1))
  (let ((file (car args)))
    (unless (file-exists? file)
      (print "Could not open " file)
      (exit 1))
    (run (handle-exceptions
          exn
          (die "parse error.")
          (with-input-from-file file read-file)))))

A seguir estão alguns exemplos de código assembly e uso com o interpretador:

Multiplicação

A linguagem não possui uma instrução para multiplicação. Abaixo está a implementação de uma rotina para multiplicar dois números (7 x 4):

(mov r1 7)
(mov r2 4)
(mov r4 ip)
(jmp mul)
(jmp end)

;; Multiplicacao (x * y)
;; x -> r1
;; y -> r2
;; produto -> r3
;; endereco de retorno -> r4
(lbl mul)
(jnz r1 not-zero)
(jmp end)
(lbl not-zero)
(mov r3 0)
(lbl loopmul)
(add r3 r2)
(add r1 -1)
(jnz r1 loopmul)
(add r4 2)
(jmp r4)

(lbl end)
(out r3)

$ csi -s tiny-assembly.scm multiplicacao.asm
28

Fatorial

Toda e qualquer implementação de linguagem inútil deve mostrar uma implementação de fatorial como exemplo. Abaixo está a implementação usando o assembly descrito neste texto (where's your god now?!):

(mov r5 7) ;; entrada de dados

;; Fatorial
;;     entrada -> r5
;;     resultado -> r6
(lbl fatorial)
(mov r6 1)
(lbl fat-loop)
(jnz r5 fat-not-0)
(jmp end)
(lbl fat-not-0)
(add r5 -1)
(jnz r5 fat-not-1)
(jmp end)
(lbl fat-not-1)
(add r5 1)
(mov r1 r6)
(mov r2 r5)
(mov r4 ip)
(jmp mul)
(mov r6 r3)
(add r5 -1)
(jmp fat-loop)

;; Multiplicacao (x * y)
;;     x -> r1
;;     y -> r2
;;     produto -> r3
;;     endereco de retorno -> r4
(lbl mul)
(jnz r1 mul-not-0)
(jmp end)
(lbl mul-not-0)
(mov r3 0)
(lbl loopmul)
(add r3 r2)
(add r1 -1)
(jnz r1 loopmul)
(add r4 2)
(jmp r4)

(lbl end)
(out r6) ;; imprime o resultado

$ csi -s tiny-assembly.scm fatorial.asm
5040

Contagem de definições no toplevel

Dando início a uma série de programas para geração de estatísticas inúteis, abaixo está um pequeno código para contagem de definições feitas no toplevel (em Chicken Scheme).

(use srfi-1)

(define count-defines
  (let* ((definers '(define define-macro define-constant
                     define-inline define-syntax))
         (count-defines
          (lambda (file)
            (cons file
                  (length
                   (filter
                    (lambda (form)
                      (and (pair? form)
                           (memq (car form) definers)))
                    (with-input-from-file
                        file read-file)))))))
    (lambda (files)
      (let ((defines-count (map count-defines files)))
        (for-each (lambda (file/defcount)
                    (print (car file/defcount) ": "
                           (cdr file/defcount)))
                  defines-count)
        (print "Total: "
               (reduce + 0 (map cdr defines-count)))))))

(let ((files (command-line-arguments)))
  (if (null? files)
      (exit 0)
      (count-defines files)))

Exemplos de uso:

$ csi -s count-defines.scm count-defines.scm
count-defines.scm: 1
Total: 1

$ csi -s count-defines.scm spiffy/trunk/*.scm
spiffy/trunk/cgi-handler.scm: 5
spiffy/trunk/simple-directory-handler.scm: 4
spiffy/trunk/spiffy-base.scm: 70
spiffy/trunk/spiffy.scm: 1
spiffy/trunk/ssp-handler.scm: 10
spiffy/trunk/web-scheme-handler.scm: 4
Total: 94

Embora este programa não diga muita coisa de útil sobre o código que analisa, serve para mostrar um dos aspectos mais interessantes de Lisp: a possibilidade de se tratar, naturalmente, código como dados. Basicamente, a contagem de definições no toplevel consiste em ler todas as expressões de um arquivo e verificar se o car de cada expressão é um dos símbolos define, define-macro, define-constant, define-inline ou define-syntax (se a expressão for um par).

Este tipo de análise não é muito útil porque, pelo menos em Chicken, é possível especificar o que deve ser "visível" ou não no código compilado. Isto pode ser feito com as declarações export e hide. Outros motivos são que este programa não consegue inferir as definições de toplevel que serão geradas através da expansão de macros (web-scheme, por exemplo, usa esta estratégia) e que não computa definições feitas dentro de blocos cond-expand.

Acessando base de dados SQL com Scheme

Em alguns projetos em que estou trabalhando seguidamente tenho que acessar tabelas de bases de dados. Costumo usar o Postgres através do egg postgresql do sistema Chicken.

Para evitar de esquecer de fechar as conexões com o banco, normalmente uso um procedimento que recebe uma query como argumento. Este procedimento abre a conexão com o banco, executa a query e fecha a conexão automaticamente (o desempenho que se dane :-)). As credenciais do banco mantenho em um parâmetro (definido com make-parameter). O procedimento é algo como:

(define db-credentials (make-parameter '()))

(define (db-query query)
  (let* ((db (pg:connect (db-credentials)))
         (output (pg:query-tuples query db)))
    (pg:close db)
    output))

Mesmo com o uso do procedimento db-query, o acesso a colunas do banco não é das tarefas mais simples. Abaixo está um exemplo em que quero acessar as colunas username e email de uma tabela e associar o valor delas à variáveis em Scheme:

(db-credentials '((host . "localhost")
                  (user . "usuario")
                  (password . "****")
                  (dbname . "nome-da-base")))

(let* ((results
        (let ((results
               (db-query
                "select username,email from users where user_id=1")))
          (if (null? results)
              #f
              (car results))))
       (username (and results (vector-ref results 0)))
       (email (and results (vector-ref results 1))))
  (print username)
  (print email))

Como pode ser visto no exemplo, associar valores de colunas da base de dados a variáveis em Scheme é uma certa novela. Para facilitar esta tarefa, fiz o esquema mostrado abaixo:

(use postgresql)

(define db-map:credentials (make-parameter '()))

(define db-map:create-object
  (let ()
    (define (db-query query)
      (let* ((db (pg:connect (db-map:credentials)))
             (output (pg:query-tuples query db)))
        (pg:close db)
        output))
    (lambda (query fields)
      (let* ((query-results (let ((results (db-query query)))
                              (if (null? results)
                                  #f
                                  (car results)))))
        (lambda (field)
          (and query-results
               (let ((pos (list-index (cut eq? <> field)
                                      fields)))
                 (vector-ref query-results pos))))))))

O procedimento db-map:create-object recebe uma query SQL e uma lista de símbolos a serem associados com os valores das colunas obtidos como resultado da execução da query. db-map:create-object retorna um procedimento que recebe como argumento um símbolo representando uma coluna da base de dados e que retorna o valor associado ao símbolo.

Assim, para acessar o valor das colunas username e email, faço o seguinte:

(let ((obj (db-map:create-object
            "select username,email from users where user_id=1"
            '(username email))))
  (print (obj 'username))
  (print (obj 'email)))

A ordem dos símbolos da lista passada como segundo argumento deve ser a mesma dos valores das colunas resultantes da query SQL.

Persistência de dados (e código!) em Scheme

Hoje eu e o Vilson estávamos conversando sobre persistência de dados (e código!) em Lisp. Fiz um exemplo simples e estou colocando abaixo para não perder a viagem. :-)

O exemplo implementa um objeto mem (criado com o procedimento make-mem) e procedimentos para manipulação desse tipo de objeto: mem-get (para leitura de dados) e mem-set! (para escrita em memória e em disco).

A leitura de dados é sempre feita da memória (exceto na criação do objeto, que pode aproveitar dados do arquivo passado como argumento). As escritas são feitas em memória e em disco.

Os dados são armazenados em uma hash-table e indexados por símbolos.

Abaixo está a implementação simplificada (em Chicken Scheme), que usa o egg s11n:

(use s11n)

(define (make-mem file)
  (cons file (if (file-exists? file)
                 (with-input-from-file
                     file
                   (cut deserialize))
                 (make-hash-table))))

(define (mem-get mem key #!optional default)
  (hash-table-ref/default (cdr mem) key default))

(define (mem-set! mem key val)
  (let ((file (car mem))
        (data (cdr mem)))
    (hash-table-set! data key val)
    (with-output-to-file file (cut serialize data))))

A seguir está um exemplo que armazena uma lista e um procedimento (código!):

(let ((mem (make-mem "teste.data")))
  (print  (mem-get mem 'a))
  (mem-set! mem 'a '(1 2 3))
  (print  (mem-get mem 'a))
  (mem-set! mem 'soma (lambda (a b) (+ a b)))
  (print ((mem-get mem 'soma) 2 2)))

O resultado da execução do código do exemplo é (caso em que teste.data inicialmente não existe):

#f
(1 2 3)
4