;;;; AST-based C# pretty-printer demo
;;;; Written by Ivan Shvedunov
;;;; (ivan4th/fionbio, ivan4th AT gmail DOT com), 2005
;;;;
;;;; Inspired by DPP (Dylan Pretty-Printer, a part of Peter Norvig's
;;;; Lisp to Dylan Converter - http://www.norvig.com/ltd/doc/ltd.html)
;;;; and by Dick Waters' paper "Some Useful Lisp Algorithms: Part 2"
;;;; (http://www.merl.com/publications/TR1993-017/)
;;;; See also: XP pretty-printer documentation in XP distribution
;;;; http://www-2.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/io/xp/xp.tgz
;;;;
;;;; Requires standard-conforming pretty printer.
;;;; Will not work on GNU CLisp. Tested with SBCL (0.9.2, 0.8.16),
;;;; Allegro CL 6.2 and LispWorks 4.3.
;;;;
;;;; This software is "as is", and has no warranty of any kind.  The
;;;; author assumes no responsibility for the consequences of any use
;;;; of this software.

(in-package :cl-user)

;;; AST printer, much more concise than your CodeDOM and perhaps R# :-P
;;; Can be easily extended to support other language constructs &
;;; several languages simultaneously

;; pretty-print dispatch table: type -> printing func correspondence
(defvar *dispatch* (copy-pprint-dispatch))

(defun ast-print (x &optional (stream *standard-output*))
  "Print the expression x using AST dispatch rules"
  (write x :pretty t :pprint-dispatch *dispatch* :stream stream))

(defun ast-print-form (stream form)
  "Print the AST node (form)"
  (if (and (symbolp (first form))
           (get (first form) 'ast-form))
      (funcall (get (first form) 'ast-form) stream form)
      (error "unknown form: ~S" form)))

;; set dispatch function for cons type in our pretty-print dispatch table
(set-pprint-dispatch 'cons #'ast-print-form 0 *dispatch*)

(defmacro defprinter (name args &body body)
  "Define a printer for specified AST node type"
  (let ((func-name (intern (format nil "PRINT-FORM-~A" name)))
        (item (gensym)))
    `(progn
       (defun ,func-name (stream ,item)
         (destructuring-bind ,args (rest ,item)
           ,@body))
       (setf (get ',name 'ast-form) ',func-name))))

;;; AST printing specs for C#
;;; (write other specs, get VB.NET, Java, C++, Fortran, etc.)

;; please note that the following function could be writen in a more
;; clear way using pprint-* funcs, but now I'm just too lazy
(defun print-statement-with-body (stream body two-newlines fmt &rest args)
  "Print the statement with brace-enclosed body"
  (format stream
          (if two-newlines
              "~?~:@_~@<{~4i~{~:@_~w~^~:@_~}~i~:@_}~:>"
              "~?~:@_~@<{~4i~{~:@_~w~}~i~:@_}~:>")
          fmt args body))

;; identifier - printed literally
(defprinter :id (id)
  (write-string id stream))

;; private int x;
(defprinter :field (type name)
  (format stream "private ~a ~a;" type name))

;; public int SomeProp { ... }
(defprinter :property (type name &rest body)
  (print-statement-with-body stream body nil "public ~a ~a" type name))

;; get { ... }
(defprinter :get (&rest body)
  (print-statement-with-body stream body nil "get"))

;; set { ... }
(defprinter :set (&rest body)
  (print-statement-with-body stream body nil "set"))

;; return x;
(defprinter :return (expr)
  (format stream "return ~w;" expr))

;; argument
(defprinter :arg (type name)
  (format stream "~a ~a" type name))

;; constructor
(defprinter :constructor (name args &rest body)
  (print-statement-with-body stream body nil "~a(~@<~{~w~^, ~_~}~:>)" name args))

;; a = b;
(defprinter :setf (lvalue rvalue)
  (format stream "~w = ~w;" lvalue rvalue))

;; public class SomeClass { ... }
(defprinter :class (name &rest body)
  (print-statement-with-body stream body t "public class ~a" name))

;; namespace SomeNS { ... }
(defprinter :namespace (name &rest body)
  (print-statement-with-body stream body t "namespace ~a" name))

;; comment
(defprinter :comment (text)
  (format stream "// ~a" text))

;;; Data class generation

(defun generate-csharp-class (object)
  "Generate a C# class from DSL spec"
  (destructuring-bind (class-name . properties) (rest object)
    (loop for (nil prop-name prop-type) in properties
          for sharp-prop-name = (format nil "~:(~a~)" prop-name) ; C# property name
          for field-name = (concatenate 'string "_" prop-name) ; C# field name
          collect `(:arg ,prop-type ,prop-name) into init-args
          collect `(:setf (:id ,field-name) (:id ,prop-name)) into init
          nconc `((:field ,prop-type ,field-name)
                  (:property ,prop-type ,sharp-prop-name
                    (:get (:return (:id ,field-name)))
                    (:set (:setf (:id ,field-name) (:id "value"))))) into props
          finally (return
                    `(:class ,class-name
                      (:constructor ,class-name ()
                       (:comment "NOOP"))
                      (:constructor ,class-name ,init-args
                       ,@init)
                      ,@props)))))

(defun generate-csharp-classes (data)
  "Generate C# classes from DSL spec"
  (destructuring-bind (ns-name . classes) (rest data)
    `(:namespace ,ns-name
      ,@(mapcar #'generate-csharp-class classes))))

;;; Facade

(defun make-data-class-file (data file-name)
  "Generate a C# source file from data class descriptions"
  (with-open-file (s file-name
                     :direction :output
                     :if-does-not-exist :create
                     :if-exists :supersede)
    (ast-print (generate-csharp-classes data) s)
    nil))

;;; Test data

(defparameter *tst-ast* '(:namespace "MyTestNS"
                          (:class "MyTestClass"
                           (:field "int" "_someprop")
                           (:constructor "MyTestClass" ((:arg "int" "someprop"))
                            (:comment "This is a test")
                            (:setf (:id "_someprop") (:id "someprop")))
                           (:property "int" "SomeProp"
                            (:get (:return (:id "_someprop")))
                            (:set (:setf (:id "_someprop") (:id "value"))))
                           (:property "int" "AnotherProp"
                            (:get (:return 0))))))

(defparameter *tst-data* '(namespace "MyNS"
                           (object "Obj1"
                            (property "prop1" "int")
                            (property "prop2" "string")
                            (property "dblprop" "double"))
                           (object "Obj2"
                            (property "someprop" "object[]"))))

;; try: (make-data-class-file *tst-data* "c:\somefile.cs")