;;> A call-by-need version of the Sloth language

;;; ==================================================================
;;; Syntax

#| The BNF:
   <SLOTH> ::= <num>
             | <id>
             | { bind {{ <id> <SLOTH> } ... } <SLOTH> }
             | { fun { <id> ... } <SLOTH> }
             | { if <SLOTH> <SLOTH> <SLOTH> }
             | { <SLOTH> <SLOTH> ... }
|#

;; A matching abstract syntax tree datatype:
(define-type SLOTH
  [Num  (n number?)]
  [Id   (name symbol?)]
  [Bind (names unique-names?) (exprs (list-of SLOTH?)) (body SLOTH?)]
  [Fun  (names unique-names?) (body SLOTH?)]
  [Call (fun-expr SLOTH?) (arg-exprs (list-of SLOTH?))]
  [If   (cond-expr SLOTH?) (then-expr SLOTH?) (else-expr SLOTH?)])

;; unique-list? : List -> Boolean
;; Tests whether a list is unique, used to make `unique-names?' below.
(define (unique-list? xs)
  (or (null? xs)
      (and (not (member (first xs) (rest xs)))
           (unique-list? (rest xs)))))

;; unique-names? : Any -> Boolean
;; A predicate that is used to specify a type of unique symbol lists.
(define unique-names?
  (intersection-of (list-of symbol?) unique-list?))

;; parse-sexpr : Sexpr -> SLOTH
;; to convert s-expressions into SLOTHs
(define (parse-sexpr sexpr)
  (match sexpr
    [(number: n)    (Num n)]
    [(symbol: name) (Id name)]
    [(cons 'bind more)
     (match sexpr
       [(list 'bind (list (list (symbol: names) nameds) ...) body)
        (Bind names (map parse-sexpr nameds) (parse-sexpr body))]
       [else (error 'parse-sexpr "bad `bind' syntax in ~s" sexpr)])]
    [(cons 'fun more)
     (match sexpr
       [(list 'fun (list (symbol: names) ...) body)
        (Fun names (parse-sexpr body))]
       [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])]
    [(cons 'if more)
     (match sexpr
       [(list 'if cond then else)
        (If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))]
       [else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
    [(list fun args ...) ; other lists are applications
     (Call (parse-sexpr fun)
           (map parse-sexpr args))]
    [else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))

;; parse : String -> SLOTH
;; Parses a string containing an SLOTH expression to a SLOTH AST.
(define (parse str)
  (parse-sexpr (string->sexpr str)))

;;; ==================================================================
;;; Values and environments

(define-type ENV
  [EmptyEnv]
  [FrameEnv (frame frame?) (rest ENV?)])

(define-type VAL
  [ScmV  (x Any)]
  [FunV  (names (Listof Symbol)) (body SLOTH) (env ENV)]
  [ExprV (expr SLOTH) (env ENV) (cache (Boxof (U #f VAL)))]
  [PrimV (prim (Any ... -> Any))])

;; a frame is an association list of names and values.
(define frame?
  (list-of (lambda (x)
             (and (list? x)
                  (= 2 (length x))
                  (symbol? (first x))
                  (VAL? (second x))))))

;; extend : (Listof Symbol) (Listof VAL) ENV -> ENV
;; extends an environment with a new frame.
(define (extend names values env)
  (if (= (length names) (length values))
    (FrameEnv (map list names values) env)
    (error 'extend "arity mismatch for names: ~s" names)))

;; lookup : Symbol ENV -> VAL
;; looks a name in an environment, searching through each frame.
(define (lookup name env)
  (cases env
    [(EmptyEnv) (error 'lookup "no binding for ~s" name)]
    [(FrameEnv frame rest)
     (let ([cell (assq name frame)])
       (if cell
         (second cell)
         (lookup name rest)))]))

;; scheme-func->prim-val : (Any ... -> Any) Boolean -> VAL
;; converts a scheme function to a primitive evaluator function which
;; is a PrimV holding a ((Listof VAL) -> VAL) procedure.
;; (the result procedure doesn't check for types and arity.)
(define (scheme-func->prim-val scheme-func strict?)
  (PrimV (lambda (args)
           (let* ([args (if strict?
                          (map (lambda (a)
                                 (let ([v (strict a)])
                                   (cases v
                                     [(ScmV x) x]
                                     [else (error 'scheme-func
                                                  "bad input: ~s"
                                                  a)])))
                               args)
                          args)]
                  [result (apply scheme-func args)])
             ;; Because there are non-strict constructors, primitives
             ;; like `car' might be returning promises which are
             ;; already VAL objects.
             (if (VAL? result) result (ScmV result))))))

;; The global environment has a few primitives:
(define global-environment
  (FrameEnv (list (list '+ (scheme-func->prim-val + #t))
                  (list '- (scheme-func->prim-val - #t))
                  (list '* (scheme-func->prim-val * #t))
                  (list '/ (scheme-func->prim-val / #t))
                  (list '< (scheme-func->prim-val < #t))
                  (list '> (scheme-func->prim-val > #t))
                  (list '= (scheme-func->prim-val = #t))
                  ;; note flags:
                  (list 'cons  (scheme-func->prim-val cons* #f)) ;!
                  (list 'list  (scheme-func->prim-val list  #f))
                  (list 'car   (scheme-func->prim-val car   #t))
                  (list 'cdr   (scheme-func->prim-val cdr   #t))
                  (list 'null? (scheme-func->prim-val null? #f))
                  ;; values
                  (list 'true  (ScmV #t))
                  (list 'false (ScmV #f))
                  (list 'null  (ScmV null)))
            (EmptyEnv)))

;;; ==================================================================
;;; Evaluation

;; strict : VAL -> VAL which is not an ExprV
;; forces a (possibly nested) ExprV promise
(define (strict v)
  (cases v
    [(ExprV expr env cache)
     (or (unbox cache)
         (let ([val (strict (eval expr env))])
           (set-box! cache val)
           val))]
    [else v]))

;; eval-promise : SLOTH env -> VAL (the ExprV variant)
;; used instead of `eval' to create an evaluation promise
(define (eval-promise expr env)
  (ExprV expr env (box #f)))

;; eval : SLOTH env -> VAL
;; evaluates SLOTH expressions.
(define (eval expr env)
  (cases expr
    [(Num n)   (ScmV n)]
    [(Id name) (lookup name env)]
    [(Bind names exprs bound-body)
     (eval bound-body
           (extend names
                   (map (lambda (e) (eval-promise e env)) exprs)
                   env))]
    [(Fun names bound-body)
     (FunV names bound-body env)]
    [(Call fun-expr arg-exprs)
     (let ([fval (strict (eval fun-expr env))]
           [arg-vals (map (lambda (e) (eval-promise e env)) arg-exprs)])
       (cases fval
         [(PrimV proc) (proc arg-vals)]
         [(FunV names body fun-env)
          (eval body (extend names arg-vals fun-env))]
         [else (error 'eval "function call with a non-function: ~s"
                      fval)]))]
    [(If cond-expr then-expr else-expr)
     (eval (if (cases (strict (eval cond-expr env))
                 [(ScmV v) v] ; Scheme value => use as boolean
                 [else #t])   ; other values are always true
             then-expr
             else-expr)
           env)]))

;; run : String -> Any
;; evaluate a SLOTH program contained in a string
(define (run str)
  (let ([result (strict (eval (parse str) global-environment))])
    (cases result
      [(ScmV v) v]
      [else (error 'run
                   "evaluation returned a bad value: ~s" result)])))

;;; ==================================================================
;;; Tests

(test (run "{{fun {x} {+ x 1}} 4}")
      => 5)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
      => 4)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
                   {add1 {fun {x} {+ x 1}}}}
              {bind {{x 3}} {add1 {add3 x}}}}")
      => 7)
(test (run "{bind {{identity {fun {x} x}}
                   {foo {fun {x} {+ x 1}}}}
              {{identity foo} 123}}")
      => 124)
(test (run "{bind {{x 3}}
              {bind {{f {fun {y} {+ x y}}}}
                {bind {{x 5}}
                  {f 4}}}}")
      => 7)
(test (run "{{{fun {x} {x 1}}
              {fun {x} {fun {y} {+ x y}}}}
             123}")
      => 124)

;; test laziness
(test (run "{bind {{x {/ 1 0}}} {car {cons 1 null}}}")
      => 1)

;;; ==================================================================