;;; Gash -- Guile As SHell
;;; Copyright © 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gash arithmetic)
  #:use-module (ice-9 i18n)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (system base lalr)
  #:export (read-arithmetic))

;;; Commentary:
;;;
;;; This module contains the lexer and parser for reading arithmetic
;;; expansions.
;;;
;;; Code:

(define nonzero-digit?
  (let ((nonzero-digits (string->char-set "123456789")))
    (lambda (chr)
      "Check if @var{chr} is a nonzero digit."
      (char-set-contains? nonzero-digits chr))))

(define* (lex-number str #:optional (start 0) (end (string-length str)))
  "Read a number token from @var{str} and return two values: the token
and its length.  If a number cannot be read, then the resulting token
will be @code{#f} and the length will be zero."
  (define (->token offset base)
    (let ((str* (substring str (+ start offset) end)))
      (receive (n count) (locale-string->integer str* base)
        (if n
            (values (make-lexical-token 'NUMBER #f n) (+ offset count))
            (values #f 0)))))
  (match (string-ref str start)
    (#\0 (match (and (< (1+ start) end) (string-ref str (1+ start)))
           ((or #\x #\X) (->token 2 16))
           (_ (->token 0 8))))
    ((? nonzero-digit?) (->token 0 10))
    (_ (values #f 0))))

(define *operators*
  `(("(" . LPAREN)
    (")" . RPAREN)
    ("~" . BITNOT)
    ("!" . LOGNOT)
    ("*" . *)
    ("/" . /)
    ("%" . %)
    ("+" . +)
    ("-" . -)
    ("<<" . <<)
    (">>" . >>)
    ("<" . <)
    ("<=" . <=)
    (">" . >)
    (">=" . >=)
    ("==" . ==)
    ("!=" . !=)
    ("&" . BITAND)
    ("^" . BITXOR)
    ("|" . BITIOR)
    ("&&" . LOGAND)
    ("||" . LOGIOR)
    ("?" . ?)
    (":" . :)
    ("=" . =)
    ("*=" . *=)
    ("/=" . /=)
    ("%=" . %=)
    ("+=" . +=)
    ("-=" . -=)
    ("<<=" . <<=)
    (">>=" . >>=)
    ("&=" . BITAND-ASSIGN)
    ("^=" . BITXOR-ASSIGN)
    ("|=" . BITIOR-ASSIGN)))

(define* (operator-prefix? str #:optional (start 0) (end (string-length str)))
  "Check if @var{str} is a prefix of an arithmetic operator."
  (any (cut string-prefix? str <> start end)
       (map car *operators*)))

(define* (lex-operator str #:optional (start 0) (end (string-length str)))
  "Read an operator token from @var{str} and return two values: the
token and its length.  If an operator cannot be read, then the resulting
token will be @code{#f} and the length will be zero."
  (define (->token op)
    (if (string-null? op)
        (values #f 0)
        (values (make-lexical-token (assoc-ref *operators* op) #f op)
                (string-length op))))
  (let loop ((k start) (acc ""))
    (if (< k end)
        (let ((next (string-append acc (string (string-ref str k)))))
          (if (operator-prefix? next)
              (loop (1+ k) next)
              (->token acc)))
        (->token acc))))

(define name-start-char?
  (let ((char-set:name-start
         (char-set-intersection char-set:ascii
                                (char-set-union char-set:letter
                                                (char-set #\_)))))
    (lambda (chr)
      "Check if @var{chr} is a valid first character for a name."
      (and (char? chr)
           (char-set-contains? char-set:name-start chr)))))

(define name-char?
  (let ((char-set:name
         (char-set-intersection char-set:ascii
                                (char-set-union char-set:letter+digit
                                                (char-set #\_)))))
    (lambda (chr)
      "Check if @var{chr} is a valid character for a name."
      (and (char? chr)
           (char-set-contains? char-set:name chr)))))

(define* (lex-name str #:optional (start 0) (end (string-length str)))
  "Read a name token from @var{str} and return two values: the token and
its length.  If a name cannot be read, then the resulting token will be
@code{#f} and the length will be zero."
  (match (string-ref str start)
    ((? name-start-char? ch)
     (let loop ((k (1+ start)) (acc (list ch)))
       (match (and (< k end) (string-ref str k))
         ((? name-char? ch) (loop (1+ k) (cons ch acc)))
         (_ (let ((result (reverse-list->string acc)))
              (values (make-lexical-token 'NAME #f result)
                      (string-length result)))))))
    (_ (values #f 0))))

(define (make-lexer str)
  "Return a lexer that reads tokens from @var{str}.  This lexer is a
stateful thunk that returns the next token each time it is called.  It
is suitable to be used with an @code{lalr-parser}."
  (define %lexers (list lex-number lex-operator lex-name))
  (define idx 0)
  (lambda ()
    (set! idx (string-index str char-set:graphic idx))
    (if (and idx (< idx (string-length str)))
        (let loop ((lexers %lexers))
          (match lexers
            (() (error "could not read arithmetic substitution" str idx))
            ((lex . rest)
             (receive (token count) (lex str idx)
               (if token
                   (begin
                     (set! idx (+ idx count))
                     token)
                   (loop rest))))))
        '*eoi*)))

(define (make-ref name)
  "Return a Scheme expression that looks up @var{name} in the current
Gash environment, returning zero if @var{name} is not set."
  `(or (string->number (getvar ,name "0")) 0))

(define* (make-assign name expr #:optional make-expr)
  "Return a Scheme expression that sets @var{name} to the result of
@var{expr} in the current Gash environment.  Optionally, @var{make-expr}
can be used to adjust the result of @var{expr} while setting
@var{name}."
  `(let ((result ,(match make-expr
                    ((? symbol?) `(,make-expr ,(make-ref name) ,expr))
                    ((? procedure?) (make-expr (make-ref name) expr))
                    (#f expr))))
     (setvar! ,name (number->string result))
     result))

(define (make-bool expr)
  "Return a Scheme expression that converts the Boolean expression
@var{expr} into a number (one for true, zero for false)."
  `(if ,expr 1 0))

(define (nonzero? expr)
  "Return a Scheme expression that checks if @var{expr} is an expression
that returns a nonzero number."
  `(not (zero? ,expr)))

(define (make-parser)
  "Create a parser that reads arithmetic expansion expressions and
returns equivalent Scheme expressions."
  (lalr-parser
   (NAME
    NUMBER
    LPAREN
    RPAREN
    (right: = *= /= %= += -= <<= >>=
            BITAND-ASSIGN BITXOR-ASSIGN BITIOR-ASSIGN)
    (right: ? :)
    (left: LOGIOR)
    (left: LOGAND)
    (left: BITIOR)
    (left: BITXOR)
    (left: BITAND)
    (left: == !=)
    (left: < <= > >=)
    (left: << >>)
    (left: + -)
    (left: * / %)
    (nonassoc: LOGNOT)
    (nonassoc: BITNOT)
    (nonassoc: unary-)
    (nonassoc: unary+))
   (expr
    (NAME) : (make-ref $1)
    (NUMBER) : $1
    (LPAREN expr RPAREN) : $2
    (+ expr (prec: unary+)) : `(+ ,$2)
    (- expr (prec: unary-)) : `(- ,$2)
    (BITNOT expr) : `(lognot ,$2)
    (LOGNOT expr) : (make-bool `(zero? ,$2))
    (expr * expr) : `(* ,$1 ,$3)
    (expr / expr) : `(quotient ,$1 ,$3)
    (expr % expr) : `(modulo ,$1 ,$3)
    (expr + expr) : `(+ ,$1 ,$3)
    (expr - expr) : `(- ,$1 ,$3)
    (expr << expr) : `(ash ,$1 ,$3)
    (expr >> expr) : `(ash ,$1 (- ,$3))
    (expr < expr) : (make-bool `(< ,$1 ,$3))
    (expr <= expr) : (make-bool `(<= ,$1 ,$3))
    (expr > expr) : (make-bool `(> ,$1 ,$3))
    (expr >= expr) : (make-bool `(>= ,$1 ,$3))
    (expr == expr) : (make-bool `(= ,$1 ,$3))
    (expr != expr) : (make-bool `(not (= ,$1 ,$3)))
    (expr BITAND expr) : `(logand ,$1 ,$3)
    (expr BITXOR expr) : `(logxor ,$1 ,$3)
    (expr BITIOR expr) : `(logior ,$1 ,$3)
    (expr LOGAND expr) : (make-bool `(and ,(nonzero? $1) ,(nonzero? $3)))
    (expr LOGIOR expr) : (make-bool `(or ,(nonzero? $1) ,(nonzero? $3)))
    (expr ? expr : expr) : `(if ,(nonzero? $1) ,$3 ,$5)
    (NAME = expr) : (make-assign $1 $3)
    (NAME *= expr) : (make-assign $1 $3 '*)
    (NAME /= expr) : (make-assign $1 $3 'quotient)
    (NAME %= expr) : (make-assign $1 $3 'modulo)
    (NAME += expr) : (make-assign $1 $3 '+)
    (NAME -= expr) : (make-assign $1 $3 '-)
    (NAME <<= expr) : (make-assign $1 $3 'ash)
    (NAME >>= expr) : (make-assign $1 $3 (lambda (x y) `(ash ,x (- ,y))))
    (NAME BITAND-ASSIGN expr) : (make-assign $1 $3 'logand)
    (NAME BITXOR-ASSIGN expr) : (make-assign $1 $3 'logxor)
    (NAME BITIOR-ASSIGN expr) : (make-assign $1 $3 'logior))))

(define (read-arithmetic str)
  "Read @var{str} as an arithmetic expansion expression and return an
equivalent Scheme expression."
  (let ((lexer (make-lexer str))
        (parser (make-parser)))
    (parser lexer error)))