;; Define Struct Syntactic Sugar

;; Copyright (c) 2008 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; (at dvanhorn (dot ccs neu edu))

;; This module implements a desugaring of define-struct
;; into a series of defines.

#lang scheme
(require htdp/testing)
(require lang/htdp-advanced)

(provide (all-defined-out))

(require "data.scm") 
(require "parser.scm")

;; struct->defines : DefnStruct -> [Listof DefnVal]
;; translate away define-struct into a series of
;; procedure definitions.
#|
This translates definitions of the form:

   (define-struct foo (x y z))

Into:

   (define foo (make-structure-type 'foo))
   (define (make-foo x y z)
     (make-structure foo (vector x y z)))

   (define foo-x (struct-ref foo 0))
   (define foo-y (struct-ref foo 1))
   (define foo-z (struct-ref foo 2))
   (define foo? (has-type? foo))

See the run-time support, ie. definition of make-structure-type,
make-structure, struct-ref, and has-type? at the end.
|#
  
(define (struct->defines str)
  (let ((name (<definition-struct>-id str))
        (fields (<definition-struct>-field-ids str)))
    (append
     (list (define-the-struct name)
           (define-the-maker name fields)
           (define-the-pred name))
     (define-the-accs name fields))))
           
(check-expect 
 (struct->defines (parse-definition '(define-struct f (x y z))))
 (map parse-definition
      '((define f (make-structure-type 'f))
        (define make-f (lambda (x y z) (make-structure f (vector x y z))))
        (define f? (has-type? f))
        (define f-x (struct-ref f 0))
        (define f-y (struct-ref f 1))
        (define f-z (struct-ref f 2)))))

;; define-the-struct : Id -> DefnVal
(define (define-the-struct name)
  (make-<definition-value> 
   name
   (make-<application>
    (make-<identifier> 'make-structure-type)
    (list (make-<quote> name)))))

(check-expect (define-the-struct (parse-expr 'f))
              (parse-definition '(define f (make-structure-type 'f))))

;; define-the-maker : Id [Listof Id] -> DefnVal
(define (define-the-maker name fields)
  (make-<definition-value>
   (id-prefix 'make- name)
   (make-<lambda> fields
                  (make-<application> 
                   (make-<identifier> 'make-structure)
                   (list
                    name
                    (make-<application> (make-<identifier> 'vector)
                                        fields))))))

(check-expect (define-the-maker (parse-expr 'f) (map parse-expr '(x y z)))
              (parse-definition 
               '(define make-f 
                  (lambda (x y z) (make-structure f (vector x y z))))))

;; define-the-pred : Id -> DefnVal
(define (define-the-pred name)
  (make-<definition-value>
   (id-suffix name '?)
   (make-<application> (make-<identifier> 'has-type?)
                       (list name))))

(check-expect (define-the-pred (parse-expr 'f))
              (parse-definition '(define f? (has-type? f))))

;; define-the-accs : Id [Listof Id] -> [Listof DefnVal]
(define (define-the-accs name fields)
  (map (lambda (f i) 
         (make-<definition-value>
          (id-hyphen name f)
          (make-<application> (make-<identifier> 'struct-ref)
                              (list name
                                    (make-<number> i)))))
       fields 
       (build-list (length fields) identity)))

(check-expect (define-the-accs (parse-expr 'f) (map parse-expr '(x y z)))
              (map parse-definition
                   '((define f-x (struct-ref f 0))
                     (define f-y (struct-ref f 1))
                     (define f-z (struct-ref f 2)))))

;; Helper procedures for constructing identifiers.

;; id-prefix: Symbol Id -> Id
(define (id-prefix sym id)
  (make-<identifier>
   (string->symbol
    (string-append (symbol->string sym)
                   (symbol->string (<identifier>-symbol id))))))

(check-expect (id-prefix 'foo- (parse-expr 'bar))
              (parse-expr 'foo-bar))

;; id-suffix : Id Symbol -> Id
(define (id-suffix id sym)
  (make-<identifier>
   (string->symbol
    (string-append (symbol->string (<identifier>-symbol id))
                   (symbol->string sym)))))

(check-expect (id-suffix (parse-expr 'foo-) 'bar)
              (parse-expr 'foo-bar))

;; id-hyphen : Id Id -> Id
(define (id-hyphen id1 id2)
  (id-prefix (<identifier>-symbol (id-suffix id1 '-)) id2))

(check-expect (id-hyphen (parse-expr 'foo) (parse-expr 'bar))
              (parse-expr 'foo-bar))

;; Run time support for structures.
(define-struct structure (type vals))

(define (make-structure-type sym) (lambda () sym))

(check-expect ((lambda (_) 'ok) ((make-structure-type 'foo)))
              'ok)

(define (has-type? t)
  (lambda (x)
    (and (structure? x)
         (eq? t (structure-type x)))))
  
;; make-structure-type is "generative".
(check-expect ((has-type? (make-structure-type 'foo))
               (make-structure (make-structure-type 'foo) 'ignore))
              false)

(check-expect (let ((f (make-structure-type 'foo)))
                ((has-type? f)
                 (make-structure f 'ignore)))
              true)

(define (struct-ref t i)
  (lambda (x)
    (cond [((has-type? t) x) (vector-ref (structure-vals x) i)]
          [else (error 'struct-ref "not a struct")])))

(check-expect (let ((f (make-structure-type 'foo)))
                ((struct-ref f 0) (make-structure f (vector 'x))))
              'x)

(check-error (let ((f (make-structure-type 'foo)))
               ((struct-ref f 0) false))
             "struct-ref: not a struct")

(generate-report)