;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (more build maven plugin)
  #:use-module (more build maven java)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (generate-mojo-from-files
	    default-convert-type
	    maven-convert-type))

(define-record-type mojo
  (make-mojo package name goal description requires-direct-invocation?
             requires-project? requires-reports? aggregator?
             requires-online? inherited-by-default? instantiation-strategy
             execution-strategy since thread-safe? phase parameters components)
  mojo?
  (package mojo-package)
  (name mojo-name)
  (goal mojo-goal)
  (description mojo-description)
  (requires-direct-invocation? mojo-requires-direct-invocation?)
  (requires-project? mojo-requires-project?)
  (requires-reports? mojo-requires-reports?)
  (aggregator? mojo-aggregator?)
  (requires-online? mojo-requires-online?)
  (inherited-by-default? mojo-inherited-by-default?)
  (instantiation-strategy mojo-instantiation-strategy)
  (execution-strategy mojo-execution-strategy)
  (since mojo-since)
  (thread-safe? mojo-thread-safe?)
  (phase mojo-phase)
  (parameters mojo-parameters)
  (components mojo-components))

(define* (update-mojo mojo
           #:key
           (package (mojo-package mojo))
           (name (mojo-name mojo))
           (goal (mojo-goal mojo))
           (description (mojo-description mojo))
           (requires-direct-invocation? (mojo-requires-direct-invocation? mojo))
           (requires-project? (mojo-requires-project? mojo))
           (requires-reports? (mojo-requires-reports? mojo))
           (aggregator? (mojo-aggregator? mojo))
           (requires-online? (mojo-requires-online? mojo))
           (inherited-by-default? (mojo-inherited-by-default? mojo))
           (instantiation-strategy (mojo-instantiation-strategy mojo))
           (execution-strategy (mojo-execution-strategy mojo))
           (since (mojo-since mojo))
           (thread-safe? (mojo-thread-safe? mojo))
           (phase (mojo-phase mojo))
           (parameters (mojo-parameters mojo))
           (components (mojo-components mojo)))
  (make-mojo package name goal description requires-direct-invocation?
             requires-project? requires-reports? aggregator?
             requires-online? inherited-by-default? instantiation-strategy
             execution-strategy since thread-safe? phase parameters components))

(define-record-type mojo-parameter
  (make-mojo-parameter name type since required editable description
                       configuration)
  mojo-parameter?
  (name          mojo-parameter-name)
  (type          mojo-parameter-type)
  (since         mojo-parameter-since)
  (required      mojo-parameter-required)
  (editable      mojo-parameter-editable)
  (description   mojo-parameter-description)
  (configuration mojo-parameter-configuration))

(define* (update-mojo-parameter mojo-parameter
           #:key (name (mojo-parameter-name mojo-parameter))
                 (type (mojo-parameter-type mojo-parameter))
                 (since (mojo-parameter-since mojo-parameter))
                 (required (mojo-parameter-required mojo-parameter))
                 (editable (mojo-parameter-editable mojo-parameter))
                 (description (mojo-parameter-description mojo-parameter))
                 (configuration (mojo-parameter-configuration mojo-parameter)))
  (make-mojo-parameter name type since required editable description
                       configuration))

(define-record-type mojo-component
  (make-mojo-component field role hint)
  mojo-component?
  (field mojo-component-field)
  (role  mojo-component-role)
  (hint  mojo-component-hint))

(define* (update-mojo-component mojo-component
           #:key (field (mojo-component-field mojo-component))
                 (role (mojo-component-role mojo-component))
                 (hint (mojo-component-hint mojo-component)))
  (make-mojo-component field role hint))

(define (generate-mojo-parameter mojo-parameter)
  `(parameter (name ,(mojo-parameter-name mojo-parameter))
              (type ,(mojo-parameter-type mojo-parameter))
              ,@(if (mojo-parameter-since mojo-parameter)
                    `(since (mojo-parameter-since mojo-parameter))
                    '())
              (required ,(if (mojo-parameter-required mojo-parameter) "true" "false"))
              (editable ,(if (mojo-parameter-editable mojo-parameter) "true" "false"))
              (description ,(mojo-parameter-description mojo-parameter))))

(define (generate-mojo-configuration mojo-parameter)
  (let ((config (mojo-parameter-configuration mojo-parameter)))
    (if config
        `(,(string->symbol (mojo-parameter-name mojo-parameter))
           (@ ,@config))
        #f)))

(define (generate-mojo-component mojo-component)
  `(requirement
     (role ,(mojo-component-role mojo-component))
     (role-hint ,(mojo-component-hint mojo-component))
     (field-name ,(mojo-component-field mojo-component))))

(define (generate-mojo mojo)
  `(mojo
     (goal ,(mojo-goal mojo))
     (description ,(mojo-description mojo))
     ,@(let ((val (mojo-requires-direct-invocation? mojo)))
         (if val
             `((requiresDirectInvocation ,val))
             '()))
     ,@(let ((val (mojo-requires-project? mojo)))
         (if val
             `((requiresProject ,val))
             '()))
     ,@(let ((val (mojo-requires-reports? mojo)))
         (if val
             `((requiresReports ,val))
             '()))
     ,@(let ((val (mojo-aggregator? mojo)))
         (if val
             `((aggregator ,val))
             '()))
     ,@(let ((val (mojo-requires-online? mojo)))
         (if val
             `((requiresOnline ,val))
             '()))
     ,@(let ((val (mojo-inherited-by-default? mojo)))
         (if val
             `((inheritedByDefault ,val))
             '()))
     ,@(let ((phase (mojo-phase mojo)))
             (if phase
                 `((phase ,phase))
                 '()))
     (implementation ,(string-append (mojo-package mojo) "." (mojo-name mojo)))
     (language "java")
     (instantiationStrategy ,(mojo-instantiation-strategy mojo))
     (executionStrategy ,(mojo-execution-strategy mojo))
     ,@(let ((since (mojo-since mojo)))
             (if since
                 `((since ,since))
                 '()))
     ,@(let ((val (mojo-thread-safe? mojo)))
         (if val
             `((threadSafe ,val))
             '()))
     (parameters
       ,(map generate-mojo-parameter (mojo-parameters mojo)))
     (configuration
       ,@(filter (lambda (a) a) (map generate-mojo-configuration (mojo-parameters mojo))))
     (requirements
       ,@(map generate-mojo-component (mojo-components mojo)))))


(define (default-convert-type type)
  (cond
    ((equal? type "String") "java.lang.String")
    ((equal? type "File") "java.io.File")
    ((and (> (string-length type) 6)
          (equal? (substring type 0 5) "List<"))
     "java.util.List")
    ((and (> (string-length type) 15)
          (equal? (substring type 0 14) "LinkedHashSet<"))
     "java.util.LinkedHashSet")
    (else type)))

(define (maven-convert-type type)
  (cond
    ((equal? type "MavenProject")
     "org.apache.maven.project.MavenProject")
    (else (default-convert-type type))))

(define (update-mojo-from-file mojo file convert-type)
  (define parse-tree (parse-java-file file))

  (define (update-mojo-from-attrs mojo attrs)
    (let loop ((mojo mojo) (attrs attrs))
      (match attrs
        ('() mojo)
        ((attr attrs ...)
         (match attr
           (('annotation-attr ('attr-name name) ('attr-value value))
            (cond
              ((equal? name "name")
               (loop (update-mojo mojo #:goal value) attrs))
              ((equal? name "defaultPhase")
               (loop (update-mojo mojo #:phase value) attrs))
              ((equal? name "requiresProject")
               (loop (update-mojo mojo #:requires-project? value) attrs))
              ((equal? name "threadSafe")
               (loop (update-mojo mojo #:thread-safe? value) attrs))
              (else
                (raise `(not-found-attr ,name)))))
           (_ (loop mojo attrs)))))))

  (define (update-mojo-parameter-from-attrs mojo-parameter attrs)
    (match attrs
      ('() mojo-parameter)
      (('annotation-attr ('attr-name name) ('attr-value value))
       (cond
         ((equal? name "editable")
          (update-mojo-parameter mojo-parameter #:editable value))
         ((equal? name "required")
          (update-mojo-parameter mojo-parameter #:required value))
         (else
           (update-mojo-parameter mojo-parameter
                                  #:configuration
                                  (cons
                                    (list (string->symbol name) value)
                                    (or
				      (mojo-parameter-configuration mojo-parameter)
				      '()))))))
      ((attr attrs ...)
       (match attr
         (('annotation-attr ('attr-name name) ('attr-value value))
          (cond
            ((equal? name "editable")
             (update-mojo-parameter-from-attrs
               (update-mojo-parameter mojo-parameter #:editable value)
               attrs))
            ((equal? name "required")
             (update-mojo-parameter-from-attrs
               (update-mojo-parameter mojo-parameter #:required value)
               attrs))
            (else (update-mojo-parameter-from-attrs
                    (update-mojo-parameter mojo-parameter
                                           #:configuration
                                           (cons
                                             (list (string->symbol name) value)
                                             (or
					       (mojo-parameter-configuration mojo-parameter)
					       '())))
                    attrs))))
         ((attrss ...)
          (update-mojo-parameter-from-attrs mojo-parameter (append attrss attrs)))))))

  (define (update-mojo-component-from-attrs mojo-component attrs)
    (match attrs
      ('() mojo-component)
      ((attr attrs ...)
       (match attr
         (('annotation-attr ('attr-name name) ('attr-value value))
          (cond
            ((equal? name "role")
             (update-mojo-component-from-attrs
               (update-mojo-component mojo-component #:role value)
               attrs))
            ((equal? name "hint")
             (update-mojo-component-from-attrs
               (update-mojo-component mojo-component #:hint value)
               attrs))
            (else (raise `(not-found-attr ,name)))))
         ((attrss ...)
          (update-mojo-component-from-attrs mojo-component (append attrss attrs)))))))

  (define (update-mojo-from-class-content mojo content)
    (let loop ((content content)
               (mojo mojo)
               (last-comment #f))
      (match content
        ('() mojo)
        ((('comment last-comment) content ...)
         (loop content mojo last-comment))
        ((('param-pat ('annotation-pat annot-name attrs ...) ('type-name type)
           ('param-name name)) content ...)
         (cond
           ((equal? annot-name "Parameter")
            (loop content
                  (update-mojo mojo
                               #:parameters
                               (cons (update-mojo-parameter-from-attrs
                                       (make-mojo-parameter
                                         name (convert-type type) #f #f #f last-comment #f)
                                       attrs)
                                     (mojo-parameters mojo)))
                  #f))
           ((equal? annot-name "Component")
            (loop content
                  (update-mojo mojo
                               #:components
                               (cons (update-mojo-component-from-attrs
                                       (make-mojo-component name #f #f)
                                       attrs)
                                     (mojo-components mojo)))
                  #f))
           (else (raise `(not-found-annot ,annot-name)))))
        ((('param-pat _ ...) content ...)
         (loop content mojo #f))
        ((('method-pat _ ...) content ...)
         (loop content mojo #f)))))

  (let loop ((content parse-tree)
             (mojo mojo)
             (last-comment #f))
    (if (null? content)
        mojo
        (match content
          ((tls content ...)
           (match tls
             (('package package)
              (loop content (update-mojo mojo #:package package) last-comment))
             (('comment last-comment)
              (loop content mojo last-comment))
             (('class-pat ('annotation-pat annot-name (attrs ...)) name ('extends extend)
               ('class-body class-content ...))
              (loop content
                    (update-mojo-from-class-content
                      (update-mojo-from-attrs
                        (update-mojo mojo
                                     #:name name
                                     #:description last-comment)
                        attrs)
                      class-content)
                    #f))
             (('class-pat ('annotation-pat annot-name (attrs ...)) name ('extends extend)
               ('implements implement) ('class-body class-content ...))
              (loop content
                    (update-mojo-from-class-content
                      (update-mojo-from-attrs
                        (update-mojo mojo
                                     #:name name
                                     #:description last-comment)
                        attrs)
                      class-content)
                    #f))
             (_
              (loop content mojo last-comment))))))))

(define (generate-mojo-from-files convert-type . files)
  (let ((mojo (make-mojo #f #f #f #f #f #f #f #f #f #f "per-lookup"
                         "once-per-session" #f #f #f '() '())))
    (let loop ((files files) (mojo mojo))
      (if (null? files)
          (generate-mojo mojo)
          (loop
            (cdr files)
            (update-mojo-from-file
              (update-mojo mojo
                #:package #f
                #:name #f
                #:goal #f
                #:description #f
                #:requires-direct-invocation? #f
                #:requires-project? #f
                #:requires-reports? #f
                #:aggregator? #f
                #:requires-online? #f
                #:inherited-by-default? #f
                #:instantiation-strategy "per-lookup"
                #:execution-strategy "once-per-session"
                #:since #f
                #:thread-safe? #f
                #:phase #f)
              (car files)
	      convert-type))))))