$-expression for gauche

dollar-expr.scm

(define-module $exp-convert
  (use srfi-1)
  (use util.match)
  
  (export
    $exp-list->sexp)

  ;;; port->$exp-listで読まれたものをS式に変換する。
  (define ($exp-list->sexp $exp)
    ($ reverse
       $ (cut match-let1 ((-1 . s)) <> s)
       $ shift-to -1
       $ (cut fold bag <> $exp)
       $ unshift -1 '()))

  (define get-indent-level
    caar)

  (define (bag token stack)
    (match-let1 (indent . elem) token
      (match (cons elem (compare indent (get-indent-level stack)))
        [(('paren . _) . 1)  (unshift indent stack)]
        [(('paren . _) . 0)  (unshift indent (shift stack))]
        [(('paren . _) . -1) (unshift indent (shift-to (- indent 1) stack))]
        [(('token . s) . 1)  (add s stack)]
        [(('token . s) . 0)  (add s (shift stack))]
        [(('token . s) . -1) (add s (shift-to (- indent 1) stack))])))

  (define (shift stack)
    (match-let1 ((_ . list) (l . next) . rest) stack
      `((,l . (,(reverse list) . ,next)) . ,rest)))

  (define (unshift level stack)
    `((,level . ()) . ,stack))

  (define (shift-to level stack)
    (do ([stack stack (shift stack)])
        ((>= level (get-indent-level stack)) stack)))

  (define (add s stack)
    (match-let1 ((l . list) . rest) stack
      `((,l . (,s . ,list)) . ,rest)))
)

(define-module $exp-read
  (use gauche.vport)
  (use text.parse)
  
  (export
    string->$exp-list
    port->$exp-list
    read-$exp)

  ;;; 文字列から$式をすべて読み取る。
  (define (string->$exp-list string)
    (port->$exp-list (open-input-string string)))

  ;;; ポートが終わるまで$式をすべて読み取る。
  (define (port->$exp-list port)
    (port->list read-$exp (make-port-with-caret port)))

  ;;; ポートから$式のトークンをひとつ読み取る。
  (define (read-$exp port)
    (let* ([peek   (skip-while #[\s] port)]
           [column (port-current-column port)]
           [token  (read port)])
      (if (eof-object? token)
        token
        (list* column (token-kind peek token) token))))

  (define (token-kind peek token)
    ; $ opens parentheses. |$| is a symbol.
    (if (and (eq? token '$) (not (eq? peek #\|)))
      'paren
      'token))

  (define-class <port-with-caret> (<virtual-input-port>)
    ([line   :init-value 0]
     [column :init-value 0]))

  (define-method port-current-line ((iport <port-with-caret>))
    (ref iport 'line))

  (define-method port-current-column ((iport <port-with-caret>))
    (ref iport 'column))

  (define (make-port-with-caret input-port)
    (rec self
      (make <port-with-caret>
        :ready
          (^ (kind)
            ((if kind char-ready? byte-ready?) input-port))
        :seek
          (^ (offset from)
            (port-seek input-port offset from))
        :getc
          (^ ()
            (let1 c (read-char input-port) 
              (cond 
                [(eq? #\newline c)
                  (inc! (ref self 'line))
                  (set! (ref self 'column) 0)]
                [(not (eof-object? c))
                  (inc! (ref self 'column))])
              c)))))
)

(import $exp-convert)
(import $exp-read)

(define (usage)
  (format (current-error-port)
          "Usage: ~a {- | file.$cm} [file.$cm ...]\n" *program-name*)
  (exit 2))

(define ($exp-port->source-string port)
  (string-join
    (map write-to-string
      ($exp-list->sexp
        (port->$exp-list port)))))

(define (main args)
  (if (null? (cdr args))
    (usage)
    (for-each
      (^ (source-file)
        (let1 source
              (if (equal? source-file "-")
                  ($exp-port->source-string (current-input-port))
                  (call-with-input-file source-file $exp-port->source-string))
          (call-with-input-string source load-from-port)))
      (cdr args))))

infer.scm

$ define-module infer
  $ use srfi-1
  $ use srfi-27
  $ use srfi-13
  $ use util.match
  $ use text.tr
  $ export
      infer
      generate-expr
      pretty-expr
      <infer-error>
      <infer-internal-error>
      <infer-type-mismatch-error>
      <infer-type-loop-error>
      <infer-syntax-error>

$ select-module infer

$ define-class <infer> $
  $ $ type-count :init-value -1
    $ cxt :init-value '()

$ define-condition-type <infer-error> <error> #f
$ define-condition-type <infer-internal-error> <infer-error> #f
$ define-condition-type <infer-type-mismatch-error> <infer-error> #f
$ define-condition-type <infer-type-loop-error> <infer-error> #f
$ define-condition-type <infer-syntax-error> <infer-error> #f

$ define-method newtype! $ (self <infer>)
  $ inc! $ ref self 'type-count
  $ ref self 'type-count

$ define-method add-substitution! $ (self <infer>) var type
  $ update! $ ref self 'cxt
    $ ^ $ cxt
      $ and-let $ $ entry $ assq var cxt
        $ error <infer-internal-error> "already registered" entry
      $ acons var type cxt

$ define-method infer $ expr env
  $ infer (make <infer>) expr env

$ define-method infer $ (self <infer>) expr env
  $ check-syntax expr
  $ make-typevar-readable $ resolve self $ infer-raw self expr env

$ define-method infer-raw $ (self <infer>) expr env
  $ let1 texpr $ newtype! self
    $ check self texpr expr env
    texpr

$ define $ number->symbol n
  $ unless $ <= 0 n (- (* 26 27) 1)
    $ error <infer-internal-error> #`"n must be between 0..,(- (* 26 27) 1)" n
  $ string->symbol
    $ tr "0-9a-p" "a-z"
      $ (cut string-copy <> 1)
        $ number->string (+ n (* 26 25)) 26

$ define $ memoize value-proc
  $ let1 dict '()
    $ ^ $ key
      $ or $ assq-ref dict key
           $ let1 value $ value-proc key
             $ push! dict $ cons key value
             value

$ define $ make-typevar-readable type
  $ let1 count -1
    $ rewrite-type type
      $ memoize
        $ ^_ $ inc! count
             $ number->name count

$ define $ rewrite-type type lookup
  $ let loop $ $ t type
    $ cond
      $ $ pair? type
        $ map loop type
      $ $ symbol? type
        type
      $ $ number? type
        $ lookup type
      $ else
        $ error <infer-internal-error> "unexpected type:" type

$ define-method resolve $ (self <infer>) n
  $ let1 cxt $ ref self 'cxt
    $ let loop $ $ n n
                 $ history '()
      $ cond
        $ $ memq n history
          $ raise <infer-type-loop-error> "loop detected" history n
        $ $ number? n
          $ let1 d $ assq-ref cxt n
           $ if d
              $ loop d $ cons n prev
              n
        $ $ pair? n
          $ map (cut loop <> (cons n prev)) type
        $ $ symbol? n
          n
        $ $ null? type
          $ error <infer-internal-error> "definition not found" n prev
        $ else
          $ error <infer-internal-error> "unexpected query" n prev

$ define-method unify $ (self <infer>) a b
  $ let $ $ a $ resolve self a
          $ b $ resolve self b
    $ cond
      $ $ and (pair? a) (pair? b) (= (length a) (length b))
        $ for-each (cut unify self <> <>) a b
      $ $ and (number? a) (number? b)
       ; as both are tip (local minimum), ensured by resolve, we can just join the set
        $ let1 t $ newtype! self
          $ add-substitution! self a t
          $ add-substitution! self b t
      $ $ number? a
        $ add-substitution! self a b
      $ $ number? b
        $ add-substitution! self b a
      $ $ equal? a b
        'ok
      $ else
        $ error <infer-type-mismatch-error> "type mismatch" a b

$ define-method unify-as-function $ (self <infer>) expected-type
  $ let1 t $ resolve self expected-type
    $ if $ pair? t
      t
      $ let1 pair $ cons $ newtype! self
                         $ newtype! self
        $ unify self pair expected-type
        pair

$ define $ refresh-type-variables type
  $ rewrite-type type
    $ memoize
      $ ^n $ if $ >= n 0
                n
                $ newtype! self

$ define-method check $ (self <infer>) expected-type expr env
  $ cond
    $ $ symbol? expr
      $ let1 t $ assq-ref (ref self 'env) expr
        $ unless t
          $ raise <infer-error> "type not found:" expr
        $ unify self expected-type $ refresh-type-variables t
    $ $ pair? expr
     $ case $ car expr
       $ $ ^
         $ check-abs self expected-type expr env
       $ $ let
         $ check-let self expected-type expr env
       $ else
         $ check-app self expected-type expr env
    $ $ number? expr
      $ unify self expected-type 'num
    $ $ boolean? expr
      $ unify self expected-type 'bool
    $ $ null? expr
      $ unify self expected-type 'null
    $ else
      $ error <infer-internal-error> "unknown expression" expr

$ define $ generalize type env
    $ let $ $ ftv $ collect-free-type-variables env
            $ count 0
      $ rewrite-type $ resolve type
        $ memoize
          $ ^t
            $ if $ memq t ftv
              t
              $ begin
                $ inc! count
                $ - count

$ define $ collect-free-type-variables env
  $ map resolve
    $ filter $ every-pred number? ($ <= 0 $)
      $ apply append
        $ map cdr env

$ define-method check-let $ (self <infer>) expected-type expr env
  ; actually it's let1
  $ match-let1 (_ var var-expr body) expr
    $ let* $ $ tvar    $ newtype! self
             $ var-env $ acons var tvar newtype
      $ check tvar var-expr var-env
      $ let1 body-env $ acons var (generalize tvar var-env) var-env
        $ check self expected-type body body-env

$ define-method check-app $ (self <infer>) expected-type expr env
  $ let1 callee-type $ newtype! self
    ; currying
    $ case $ length expr
      $ [1] $ error <infer-syntax-error> "malformed application" expr
      $ [2] $ check self callee-type (car expr) env
      $ else $ check-app self callee-type (drop-right expr 1) env
    $ match-let1 (targ . tresult) $ unify-as-function self callee-type
      $ check self targ (last expr) env
      $ unify self tresult expected-type

$ define-method check-abs $ (self <infer>) expected-type expr env
  $ match-let1 (targ . tresult) $ unify-as-function self expected-type
    $ match expr
      $ (_ ((? symbol? arg) rest ..1) body)
        $ check-abs self tresult `(^ ,rest ,body) $ acons arg targ env
      $ (_ (or ((? symbol? arg)) (? symbol? arg)) body)
        $ check self tresult body $ acons arg targ env
      $ else
        $ error <infer-syntax-error> "malformed lambda" expr

$ define $ check-syntax expr
  $ match expr
    $ $ _
      $ error <infer-syntax-error> "application without argument is not allowed" expr
    $ ('^ . args-and-body)
      $ match args-and-body
        $ ((or (? symbol?) ((? symbol?) ..1)) body)
          $ check-syntax body
        $ else
          $ error <infer-syntax-error> "malformed lambda" expr
    $ ('let . bind-and-body)
      $ match bind-and-body
        $ $ (? symbol?) bind-expr body
          $ check-syntax bind-expr
          $ check-syntax body
        $ else
          $ error <infer-syntax-error> "malformed let" expr
    $ $ ? pair?
      $ for-each check-syntax expr
    $ else
      'ok

$ define $ pretty-expr e
  $ match e
    $ $ '^ arg body
      #`"(\\,arg -> ,(pretty-expr body))"
    $ $ 'let var expr body
      #`"(let ,var = ,(pretty-expr expr) in ,(pretty-expr body))"
    $ $ ? pair?
      #`"(,(string-join (map prety-expr e)))"
    $ else
     $ x->string e

$ define $ generate-expr depth
  $ define var!
    $ let1 count -1
      $ ^ $ 
        $ inc! count
        $ number->name count
  $ let loop $ $ depth depth
               $ vars '()
    $ case $ cond
            $ $ < depth 0
              2
            $ $ and (= depth 0) (null? vars)
              1
            $ else
              $ random-integer $ if (null? vars) 2 3
      $ $ 0
        $ list $ loop (- depth 1) vars
               $ loop (- depth 1) vars
      $ $ 1
        $ let1 v $ var!
          $ if $ zero? $ random-integer 1
            $ list '^   v $ loop (- depth 1) $ cons v vars
            $ list 'let v $ loop (- depth 1) $ cons v vars
                          $ loop (- depth 1) $ cons v vars
      $ else
        $ ref vars $ random-integer $ length vars

an evaluator of $-expression with a random source in $exp syntax for example.