;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;;
;;; 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 (guix import cabal)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (guix monads)
  #:export (read-cabal
            parse-cabal
            eval-cabal
            
            cabal-package?
            cabal-package-name
            cabal-package-version
            cabal-package-license
            cabal-package-home-page
            cabal-package-source-repository
            cabal-package-synopsis
            cabal-package-description
            cabal-package-executables
            cabal-package-library
            cabal-package-test-suites
            cabal-package-flags
            cabal-package-eval-environment

            cabal-source-repository?
            cabal-source-repository-use-case
            cabal-source-repository-type
            cabal-source-repository-location

            cabal-flag?
            cabal-flag-name
            cabal-flag-description
            cabal-flag-default
            cabal-flag-manual

            cabal-dependency?
            cabal-dependency-name
            cabal-dependency-version

            cabal-executable?
            cabal-executable-name
            cabal-executable-dependencies

            cabal-library?
            cabal-library-dependencies

            cabal-test-suite?
            cabal-test-suite-name
            cabal-test-suite-dependencies))

;; Part 1:
;;
;; Functions used to read a Cabal file.

;; This record stores the state information needed during parsing of Cabal
;; files.
(define-record-type  <cabal-parse-state>
  (make-cabal-parse-state lines minimum-indent indents conditionals
                          true-group? true-group false-group
                          true-group?-stack true-group-stack false-group-stack)
  cabal-parse-state?
  (lines cabal-parse-state-lines)
  (minimum-indent cabal-parse-state-minimum-indent)
  (indents cabal-parse-state-indents)
  (conditionals cabal-parse-state-conditionals)
  (true-group? cabal-parse-state-true-group?)
  (true-group cabal-parse-state-true-group)
  (false-group cabal-parse-state-false-group)
  (true-group?-stack cabal-parse-state-true-group?-stack)
  (true-group-stack cabal-parse-state-true-group-stack)
  (false-group-stack cabal-parse-state-false-group-stack))

(define key-value-rx
  ;; Regular expression matching "key: value"
  (make-regexp "([a-zA-Z0-9-]+):[ \t]*(\\w?.*)$"))

(define comment-rx
  ;; Regexp matching Cabal comment lines.
  (make-regexp "^ *--"))

(define (has-key? line)
  "Check if LINE includes a key."
  (regexp-exec key-value-rx line))

(define (comment-line? line)
  "Check if LINE is a comment line."
  (regexp-exec comment-rx line))

(define (line-indentation+rest line)
  "Returns two results: The number of indentation spaces and the rest of
LINE (without indentation)."
  (let loop ((line-lst (string->list line))
             (count 0))
    ;; Sometimes values are spread over multiple lines and new lines start
    ;; with a comma ',' with the wrong indentation.  See e.g. haddock-api.
    (if (or (null? line-lst)
            (not (or
                  (eqv? (first line-lst) #\space)
                  (eqv? (first line-lst) #\,)
                  (eqv? (first line-lst) #\tab))))
        (values count (list->string line-lst))
        (loop (cdr line-lst) (+ count 1)))))

(define (multi-line-value lines seed)
  "Function to read a value split across multiple lines. LINES are the
remaining input lines to be read.  SEED is the value read on the same line as
the key.  Return two values: A list with the values and the remaining lines to
be processed."
  (define (multi-line-value-with-min-indent lines seed min-indent)
    (if (null? lines)
        (values '() '())
        (let-values (((current-indent value) (line-indentation+rest (first lines)))
                     ((next-line-indent next-line-value)
                      (if (null? (cdr lines))
                          (values #f "")
                          (line-indentation+rest (second lines)))))
          (if (or (not next-line-indent) (< next-line-indent min-indent)
                  (regexp-exec condition-rx next-line-value))
              (values (reverse (cons value seed)) (cdr lines))
              (multi-line-value-with-min-indent (cdr lines) (cons value seed)
                                                min-indent)))))

  (let-values (((current-indent value) (line-indentation+rest (first lines))))
    (multi-line-value-with-min-indent lines seed current-indent)))

(define (read-and-trim-line port)
  (let ((line (read-line port)))
    (if (string? line)
        (string-trim-both line #\return)
        line)))

(define (strip-insignificant-lines port)
  (let loop ((line (read-and-trim-line port))
             (result '()))
    (cond
     ((eof-object? line)
      (reverse result))
     ((or (string-null? line) (comment-line? line))
      (loop (read-and-trim-line port) result))
     (else
      (loop (read-and-trim-line port) (cons line result))))))

(define (read-cabal port)
  "Parses a Cabal file from PORT.  Return an S-expression representing the
content of the file.  We try do deduce the Cabal format from the following
document: https://www.haskell.org/cabal/users-guide/developing-packages.html.
Keys are case-insensitive.  We therefore lowercase them.  Values are
case-sensitive.  Currently only indentation-structured files are parsed.
Braces structured files are not handled."
  (let ((lines (strip-insignificant-lines port)))
    (call-with-values
        (lambda ()
          (run-with-state (parse-cabal '())
            (make-cabal-parse-state lines -1 '() '() #t '() '() '() '() '())))
      (lambda (result state) result))))

(define (parse-cabal result)
  "Parse a Cabal file and append its content to RESULT (a list).  Return the
updated result as a monadic value in the state monad."
  (mlet* %state-monad ((state (current-state)))
    (match state
      (($ <cabal-parse-state> lines minimum-indent indents conditionals
                              true-group? true-group false-group
                              true-group?-stack true-group-stack
                              false-group-stack)
       (let*-values
           (((current-indent line)
             (if (null? lines)
                 (values 0 "")
                 (line-indentation+rest (first lines))))
            ((next-line-indent next-line)
             (if (or (null? lines) (null? (cdr lines)))
                 (values 0 "")
                 (line-indentation+rest (second lines))))
            ((key-value-rx-result) (has-key? line))
            ((end-of-file?) (null? lines))
            ((is-simple-key-value?) (and (= next-line-indent current-indent)
                                         key-value-rx-result))
            ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
                                             key-value-rx-result))
            ((key) (and=> key-value-rx-result
                          (lambda (rx-res)
                            (string-downcase (match:substring rx-res 1)))))
            ((value) (and=> key-value-rx-result (cut match:substring <> 2))))
         (cond
          (end-of-file? (return (reverse result)))
          (is-simple-key-value?
           (>>= (state-add-entry (list key `(,value)) result (cdr lines))
                parse-cabal))
          (is-multi-line-key-value?
           (let*-values 
               (((value-lst lines)
                 (multi-line-value (cdr lines)
                                   (if (string-null? value) '() `(,value)))))
             (>>= (state-add-entry (list key value-lst) result lines)
                  parse-cabal)))
          (else ; it's a section
           (let* ((section-header (string-tokenize (string-downcase line)))
                  (section-type (string->symbol (first section-header)))
                  (section-name (if (> (length section-header) 1)
                                     (second section-header)
                                     "")))
             (mbegin %current-monad
               (set-current-state 
                (set-fields state
                            ((cabal-parse-state-minimum-indent) current-indent)
                            ((cabal-parse-state-lines) (cdr lines))))
               (>>=
                (>>= (parse-cabal-section '())
                     (lambda (section-contents)
                       (mlet* %state-monad ((state (current-state)))
                         (mbegin %current-monad
                           (set-current-state
                            (set-fields state
                                        ((cabal-parse-state-minimum-indent) -1)))
                           (return 
                            (cons (append
                                   (if (string-null? section-name)
                                       (list 'section section-type)
                                       (list 'section section-type section-name))
                                   (list section-contents))
                                  result))))))
                parse-cabal))))))))))

(define (parse-cabal-section result)
  "Parse a section of a cabal file and append its content to RESULT (a list).
Return the updated result as a value in the state monad."
  (mlet* %state-monad ((state (current-state)))
    (match state
      (($ <cabal-parse-state> lines minimum-indent indents conditionals
                              true-group? true-group false-group
                              true-group?-stack true-group-stack
                              false-group-stack)
       (let*-values
           (((current-indent line)
             (if (null? lines)
                 (values 0 "")
                 (line-indentation+rest (first lines))))
            ((next-line-indent next-line)
             (if (or (null? lines) (null? (cdr lines)))
                 (values 0 "")
                 (line-indentation+rest (second lines))))
            ((key-value-rx-result) (has-key? line))
            ((end-of-section?) (or (<= current-indent minimum-indent)
                                   (null? lines)))
            ;; If this is the last line of the section, then it can't be the
            ;; start of a conditional or an 'else'.
            ((last-line-of-section?) (<= next-line-indent minimum-indent))
            ((is-simple-key-value?) (or (and (= next-line-indent current-indent)
                                             key-value-rx-result)
                                        (and (pair? conditionals)
                                             (= next-line-indent (first indents))
                                             (string-prefix? "else" next-line))))
            ((is-multi-line-key-value?) (and (> next-line-indent current-indent)
                                             key-value-rx-result))
            ((end-of-cond?)
             (and (pair? conditionals)
                  (or (and (= next-line-indent (first indents))
                           (not (string-prefix? "else" next-line)))
                      (< next-line-indent (first indents)))))
            ((is-else?) (and (pair? conditionals)
                             (= current-indent (first indents))
                             (string-prefix? "else" line)))
            ((condition) (cabal-conditional-line->sexp line))
            ((key) (and=> key-value-rx-result
                          (lambda (rx-res)
                            (string-downcase (match:substring rx-res 1)))))
            ((value) (and=> key-value-rx-result
                            (cut match:substring <> 2))))
         (cond
          (end-of-section?
           (if (pair? indents)
               (state-reduce-indentation (1- (length indents)) #f result lines)
               (return result)))
          (last-line-of-section?
           (if (pair? indents)
               (state-reduce-indentation
                (1- (length indents)) (list key `(,value)) result (cdr lines))
               (mbegin %current-monad
                 (set-current-state 
                  (set-fields state ((cabal-parse-state-lines) (cdr lines))))
                 (return (cons (list key `(,value)) result)))))
          (is-simple-key-value?
           (>>= (state-add-entry (list key `(,value)) result (cdr lines))
                parse-cabal-section))
          (is-multi-line-key-value?
           (let*-values
               ;; VALUE-LST is the full multi-line value and LINES are the
               ;; remaining lines to be parsed (from the line following the
               ;; multi-line value).  We need to check if we are at the end of
               ;; a conditional or at the end of the section.
               (((value-lst lines)
                 (multi-line-value (cdr lines)
                                   (if (string-null? value) '() `(,value))))
                ((ind line) (if (null? lines)
                                (values 0 "")
                                (line-indentation+rest (first lines))))
                ((end-of-cond?) (and (pair? conditionals)
                                     (or (and (= ind (first indents))
                                              (not (string-prefix? "else" line)))
                                         (< ind (first indents)))))
                ;; If IND is not in INDENTS, assume that we are at the end of
                ;; the section.
                ((idx) (or (and=>
                            (list-index (cut = ind <>) indents)
                            (cut + <> (if (string-prefix? "else" line) -1 0)))
                           (1- (length indents)))))
             (if end-of-cond?
                 (>>= (state-reduce-indentation idx (list key value-lst)
                                                result lines)
                      parse-cabal-section)
                 (>>= (state-add-entry (list key value-lst) result lines)
                      parse-cabal-section))))
          (end-of-cond?
           (let ((idx (+ (list-index (cut = next-line-indent <>) indents)
                         (if (string-prefix? "else" next-line) -1 0))))
             (>>= (state-reduce-indentation idx (list key `(,value)) result
                                         (if (pair? lines) (cdr lines) '()))
                  parse-cabal-section)))
          (is-else?
           (mbegin %current-monad
             (set-current-state 
              (set-fields state
                          ((cabal-parse-state-lines) (cdr lines))
                          ((cabal-parse-state-true-group?) #f)))
             (parse-cabal-section result)))
          (condition
           (mbegin %current-monad
             (state-add-conditional condition current-indent)
             (parse-cabal-section result)))))))))

(define (state-reduce-indentation index entry result lines)
  "Given RESULT, if ENTRY is not #f, add it as appropriate and return the
updated result as a value in the state monad.  Update the state according to
the reduction of the indentation level specified by INDEX, an index of an
entry in the 'indentations' field of the state.  As an example, if there are
two nested conditional levels, the first starting at indentation 2 and the
second at indentation 4, then the 'indentations' field of state is '(4 2) and
an INDEX value of 0 means that the second conditional is finished.  Set the
remaining lines to be parsed to LINES."
  (lambda (state)
    (match state
      (($ <cabal-parse-state> _ minimum-indent indents conditionals
                              true-group? true-group false-group
                              true-group?-stack true-group-stack
                              false-group-stack)
       ;; The suffix '-d' stays for 'drop'.
       (let*-values (((inds-d inds) (split-at indents (1+ index)))
                     ((conds-d conds) (split-at conditionals (1+ index)))
                     ((t-g?-s-d t-g?-s)
                      (if (> (length true-group?-stack) index)
                          (split-at true-group?-stack (1+ index))
                          (values true-group?-stack '())))
                     ((t-g-s-d t-g-s)
                      (if (> (length true-group-stack) index)
                          (split-at true-group-stack (1+ index))
                          (values true-group-stack '())))
                     ((f-g-s-d f-g-s)
                      (if (> (length false-group-stack) index)
                          (split-at false-group-stack (1+ index))
                          (values false-group-stack '())))
                     ((t-g?)
                      (if (> (length true-group?-stack) index) 
                          (last t-g?-s-d) #t))
                     ((t-g) (if (and true-group? entry)
                                (cons entry true-group)
                                true-group))
                     ((f-g) (if (or true-group? (not entry))
                                false-group
                                (cons entry false-group)))
                     ((res) result))
         (let reduce-by-one ((conds-d conds-d) (t-g t-g) (f-g f-g) (res res)
                             (t-g?-s-d t-g?-s-d) (t-g-s-d t-g-s-d) 
                             (f-g-s-d f-g-s-d))
           (cond
            ((null? conds-d)
             (values res
                     (set-fields state
                                 ((cabal-parse-state-lines) lines)
                                 ((cabal-parse-state-indents) inds)
                                 ((cabal-parse-state-conditionals) conds)
                                 ((cabal-parse-state-true-group?) t-g?)
                                 ((cabal-parse-state-true-group) t-g)
                                 ((cabal-parse-state-false-group) f-g)
                                 ((cabal-parse-state-true-group?-stack) t-g?-s)
                                 ((cabal-parse-state-true-group-stack) t-g-s)
                                 ((cabal-parse-state-false-group-stack) f-g-s))))
            ((null? t-g?-s-d)
             (reduce-by-one (cdr conds-d) '() '()
                            (cons `(if ,(first conds-d) ,t-g ,f-g) res)
                            t-g?-s t-g-s f-g-s))
            ((first t-g?-s-d)
             (reduce-by-one (cdr conds-d)
                            (cons `(if ,(first conds-d) ,t-g ,f-g) 
                                  (first t-g-s-d))
                            (first f-g-s-d) res
                            (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d)))
            (else
             (reduce-by-one (cdr conds-d) (first t-g-s-d)
                            (cons `(if ,(first conds-d) ,t-g ,f-g) 
                                  (first f-g-s-d))
                            res
                            (cdr t-g?-s-d) (cdr t-g-s-d) (cdr f-g-s-d))))))))))

(define (state-add-entry entry result lines)
  "Given the current RESULT, adds ENTRY as appropriate.  Set the remaining
lines to be parsed to LINES.  Retrun the updated result as a value in the
state monad."
  (lambda (state)
    (match state
      (($ <cabal-parse-state> _ minimum-indent indents conditionals
                              true-group? true-group false-group
                              true-group?-stack true-group-stack
                              false-group-stack)
       (cond
        ((null? conditionals)
         (values (cons entry result)
                 (set-fields state
                             ((cabal-parse-state-lines) lines))))
        (true-group?
         (values result
                 (set-fields state
                             ((cabal-parse-state-true-group)
                              (cons entry true-group))
                             ((cabal-parse-state-lines) lines))))
        (else
         (values result
                 (set-fields state
                             ((cabal-parse-state-false-group)
                              (cons entry false-group))
                             ((cabal-parse-state-lines) lines)))))))))

(define (state-add-conditional condition indentation)
  "Add CONDITION at INDENTATION level to the current state.  Return the value
*unspecified* in the state monad."
  (lambda (state)
    (match state
      (($ <cabal-parse-state> lines minimum-indent indents conditionals
                              true-group? true-group false-group
                              true-group?-stack true-group-stack
                              false-group-stack)
       (if (null? conditionals)
           (values '*unspecified*
                   (set-fields state
                               ((cabal-parse-state-lines) (cdr lines))
                               ((cabal-parse-state-conditionals)
                                (cons condition conditionals))
                               ((cabal-parse-state-indents)
                                (cons indentation indents))
                               ((cabal-parse-state-true-group?) #t)))
           (values '*unspecified*
                   (set-fields state
                               ((cabal-parse-state-lines) (cdr lines))
                               ((cabal-parse-state-conditionals)
                                (cons condition conditionals))
                               ((cabal-parse-state-indents)
                                (cons indentation indents))
                               ((cabal-parse-state-true-group?) #t)
                               ((cabal-parse-state-true-group) '())
                               ((cabal-parse-state-false-group) '())
                               ((cabal-parse-state-true-group?-stack)
                                (cons true-group? true-group?-stack))
                               ((cabal-parse-state-true-group-stack)
                                (cons true-group true-group-stack))
                               ((cabal-parse-state-false-group-stack)
                                (cons false-group false-group-stack)))))))))
      
(define condition-rx
  ;; Regexp for conditionals.
  (make-regexp "^if +(.*)$"))

(define (cabal-extract-condition line)
  "Extract the test condition from a conditional LINE."
  (let ((rx-result (regexp-exec condition-rx (string-downcase line))))
    (if rx-result (match:substring rx-result 1) #f)))

(define (cabal-conditional-line->sexp line)
  "Extract the test condition from LINE and convert it into an S-expression."
  (let ((conditional (cabal-extract-condition line)))
    (and=> conditional
           (compose cabal-test-keywords->sexp
                    cabal-conditional->sexp-like
                    cabal-impl-with-and->impl-and))))

(define parens-rx
  ;; Parentheses within conditions
  (make-regexp "\\((.+)\\)"))

(define or-rx
  ;; OR operator in conditions
  (make-regexp " *\\|\\| *"))

(define and-rx
  ;; AND operator in conditions
  (make-regexp " *&& *"))

(define not-rx
  ;; NOT operator in conditions
  (make-regexp "^!.+"))

(define (bi-op-args str match-lst)
  "Return a list with the arguments of (logic) bianry operators.  MATCH-LST
is the result of 'list-match' against a binary operator regexp on STR."
  (let ((operators (length match-lst)))
    (map (lambda (from to)
           (substring str from to))
         (cons 0 (map match:end match-lst))
         (append (map match:start match-lst) (list (string-length str))))))

(define (bi-op->sexp-like bi-op args)
  "BI-OP is a string with the name of a Scheme operator which in a Cabal file
is represented by a binary operator.  ARGS are the arguments of said operator.
Return a string representing an S-expression of the operator applied to its
arguments."
  (if (= (length args) 1)
      (first args)
      (string-append "(" bi-op
                     (fold (lambda (arg seed) (string-append seed " " arg))
                           "" args) ")")))

(define (not->sexp-like arg)
  "If the string ARG is prefixed by a Cabal negation operator, convert it to
an equivalent Scheme S-expression string."
  (if (regexp-exec not-rx arg)
      (string-append "(not "
                     (substring arg 1 (string-length arg))
                     ")")
      arg))

(define (parens-less-cond->sexp-like conditional)
  "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
syntax.  This procedure accepts only simple conditionals without parentheses."
  ;; The outher operation is the one with the lowest priority: OR
  (bi-op->sexp-like
   "or"
   ;; each OR argument may be an AND operation
   (map (lambda (or-arg)
          (let ((m-lst (list-matches and-rx or-arg)))
            ;; is there an AND operation?
            (if (> (length m-lst) 0)
                (bi-op->sexp-like
                 "and"
                 ;; expand NOT operators when there are ANDs
                 (map not->sexp-like (bi-op-args or-arg m-lst)))
                ;; ... and when there aren't.
                (not->sexp-like or-arg))))
        ;; list of OR arguments
        (bi-op-args conditional (list-matches or-rx conditional)))))

(define test-keyword-ornament "__")

(define tests-rx
  ;; Cabal test keywords
  (make-regexp "(os|arch|flag|impl) *\\(([ a-zA-Z0-9_.<>=-]+)\\)"))

(define impl-with-and
  (make-regexp 
    "(impl) *\\(([ a-zA-Z0-9_-]+) *([ 0-9_.<>=-]+) *(&&) *([ 0-9_.<>=-]+) *\\)"))

(define (cabal-impl-with-and->impl-and conditional)
  "Transform any compiler version range specificication appearing in
CONDITIONAL into two specifications and an 'and' conjunction.  For example,
the specification \"impl(ghc >= 7.2 && < 7.6)\" is transformed into 
\"impl(ghc >= 7.2 ) && impl(ghc < 7.6)\"."
  (regexp-substitute/global #f impl-with-and 
                            conditional
                            'pre 1 "(" 2 3 ") " 4 " " 1 "(" 2 5 ")" 'post))

(define (cabal-conditional->sexp-like conditional)
  "Convert a Cabal CONDITIONAL string into a string with equivalent Scheme
syntax."
  ;; First we substitute TEST-KEYWORD-ORNAMENT for parentheses around tests
  ;; keywords so that parentheses are only used to set precedences. This
  ;; substantially simplify parsing.
  (let ((conditional
         (regexp-substitute/global #f tests-rx conditional
                                   'pre 1 test-keyword-ornament 2
                                   test-keyword-ornament 'post)))
    (let loop ((sub-cond conditional))
      (let ((rx-result (regexp-exec parens-rx sub-cond)))
        (cond
         (rx-result
          (parens-less-cond->sexp-like
           (string-append
            (match:prefix rx-result)
            (loop (match:substring rx-result 1))
            (match:suffix rx-result))))
         (else
          (parens-less-cond->sexp-like sub-cond)))))))

(define (cabal-test-keywords->sexp sexp-like-cond)
  "In the string SEXP-LIKE-COND substitute test keywords \"os(...)\" and
\"arch(...)\" with equivalent Scheme checks.  Retrun an S-expression."
  (with-input-from-string 
      (fold-right
       (lambda (test sexp)
         (match test
           ((type pre-match post-match)
            (let ((rx (make-regexp
                       (string-append type test-keyword-ornament
                                      " *([a-zA-Z0-9_-]+) *([<>=]*) *([0-9.]*) *"
                                      test-keyword-ornament))))
              (regexp-substitute/global
               #f rx sexp
               'pre pre-match 2 3 4 post-match 'post)))
           (_ sexp)))
       sexp-like-cond
       '(("(os)" "(os \"" "\")")
         ("(arch)" "(arch \"" "\")")
         ("(impl)" "(impl \"" "\")")
         ("(flag)" "(flag \"" "\")")))
    read))

;; Part 2:
;;
;; Evaluate the S-expression returned by 'read-cabal'.

;; This defines the object and interface that we provide to access the Cabal
;; file information.  Note that this does not include all the pieces of
;; information of the Cabal file, but only the ones we currently are
;; interested in.
(define-record-type <cabal-package>
  (make-cabal-package name version license home-page source-repository
                      synopsis description
                      executables lib test-suites
                      flags eval-environment)
  cabal-package?
  (name   cabal-package-name)
  (version cabal-package-version)
  (license cabal-package-license)
  (home-page cabal-package-home-page)
  (source-repository cabal-package-source-repository)
  (synopsis cabal-package-synopsis)
  (description cabal-package-description)
  (executables cabal-package-executables)
  (lib cabal-package-library) ; 'library' is a Scheme keyword
  (test-suites cabal-package-test-suites)
  (flags cabal-package-flags)
  (eval-environment cabal-package-eval-environment)) ; alist

(set-record-type-printer! <cabal-package>
                          (lambda (package port)
                            (format port "#<cabal-package ~a-~a>"
                                      (cabal-package-name package)
                                      (cabal-package-version package))))

(define-record-type <cabal-source-repository>
  (make-cabal-source-repository use-case type location)
  cabal-source-repository?
  (use-case cabal-source-repository-use-case)
  (type cabal-source-repository-type)
  (location cabal-source-repository-location))

;; We need to be able to distinguish the value of a flag from the Scheme #t
;; and #f values.
(define-record-type <cabal-flag>
  (make-cabal-flag name description default manual)
  cabal-flag?
  (name cabal-flag-name)
  (description cabal-flag-description)
  (default cabal-flag-default) ; 'true or 'false
  (manual cabal-flag-manual))  ; 'true or 'false

(set-record-type-printer! <cabal-flag>
                          (lambda (package port)
                            (format port "#<cabal-flag ~a default:~a>"
                                      (cabal-flag-name package)
                                      (cabal-flag-default package))))

(define-record-type <cabal-dependency>
  (make-cabal-dependency name version)
  cabal-dependency?
  (name cabal-dependency-name)
  (version cabal-dependency-version))

(define-record-type <cabal-executable>
  (make-cabal-executable name dependencies)
  cabal-executable?
  (name cabal-executable-name)
  (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency>

(define-record-type <cabal-library>
  (make-cabal-library dependencies)
  cabal-library?
  (dependencies cabal-library-dependencies)) ; list of <cabal-dependency>

(define-record-type <cabal-test-suite>
  (make-cabal-test-suite name dependencies)
  cabal-test-suite?
  (name cabal-test-suite-name)
  (dependencies cabal-test-suite-dependencies)) ; list of <cabal-dependency>

(define (cabal-flags->alist flag-list)
    "Retrun an alist associating the flag name to its default value from a
list of <cabal-flag> objects."
  (map (lambda (flag) (cons (cabal-flag-name flag) (cabal-flag-default flag)))
       flag-list))

(define (eval-cabal cabal-sexp env)
  "Given the CABAL-SEXP produced by 'read-cabal', evaluate all conditionals
and return a 'cabal-package' object.  The values of all tests can be
overwritten by specifying the desired value in ENV.  ENV must be an alist.
The accepted keys are: \"os\", \"arch\", \"impl\" and a name of a flag.  The
value associated with a flag has to be either \"true\" or \"false\".  The
value associated with other keys has to conform to the Cabal file format
definition."
  (define (os name)
    (let ((env-os (or (assoc-ref env "os") "linux")))
      (string-match env-os name)))
  
  (define (arch name)
    (let ((env-arch (or (assoc-ref env "arch") "x86_64")))
      (string-match env-arch name)))
  
  (define (impl haskell)
    (let* ((haskell-implementation (or (assoc-ref env "impl") "ghc"))
           (impl-rx-result-with-version
            (string-match "([a-zA-Z0-9_]+)-([0-9.]+)" haskell-implementation))
           (impl-name (or (and=> impl-rx-result-with-version
                                 (cut match:substring <> 1))
                          haskell-implementation))
           (impl-version (and=> impl-rx-result-with-version
                                (cut match:substring <> 2)))
           (cabal-rx-result-with-version
            (string-match "([a-zA-Z0-9_-]+) *([<>=]+) *([0-9.]+) *" haskell))
           (cabal-rx-result-without-version 
            (string-match "([a-zA-Z0-9_-]+)" haskell))
           (cabal-impl-name (or (and=> cabal-rx-result-with-version
                                       (cut match:substring <> 1))
                                (match:substring 
                                 cabal-rx-result-without-version 1)))
           (cabal-impl-version (and=> cabal-rx-result-with-version
                                      (cut match:substring <> 3)))
           (cabal-impl-operator (and=> cabal-rx-result-with-version
                                       (cut match:substring <> 2)))
           (comparison (and=> cabal-impl-operator
                              (cut string-append "string" <>))))
      (if (and cabal-impl-version impl-version)
          (eval-string
           (string-append "(string" cabal-impl-operator
                          " \"" haskell-implementation "\""
                          " \"" cabal-impl-name "-" cabal-impl-version "\")"))
          (string-match cabal-impl-name impl-name))))
  
  (define (cabal-flags)
    (make-cabal-section cabal-sexp 'flag))
  
  (define (flag name)
    (let ((value (or (assoc-ref env name)
                     (assoc-ref (cabal-flags->alist (cabal-flags)) name))))
      (if (eq? value 'false) #f #t)))
  
  (define (eval sexp)
    (match sexp
      (() '())
      ;; nested 'if'
      ((('if predicate true-group false-group) rest ...)
       (append (if (eval predicate)
                   (eval true-group)
                   (eval false-group))
               (eval rest)))
      (('if predicate true-group false-group)
       (if (eval predicate)
           (eval true-group)
           (eval false-group)))
      (('flag name) (flag name))
      (('os name) (os name))
      (('arch name) (arch name))
      (('impl name) (impl name))
      (('not name) (not (eval name)))
      ;; 'and' and 'or' aren't functions, thus we can't use apply
      (('and args ...) (fold (lambda (e s) (and e s)) #t (eval args)))
      (('or args ...) (fold (lambda (e s) (or e s)) #f (eval args)))
      ;; no need to evaluate flag parameters
      (('section 'flag name parameters)
       (list 'section 'flag name parameters))
      ;; library do not have a name parameter
      (('section 'library parameters)
       (list 'section 'library (eval parameters)))
      (('section type name parameters)
       (list 'section type name (eval parameters)))
      (((? string? name) values)
       (list name values))
      ((element rest ...)
       (cons (eval element) (eval rest)))
      (_ (raise (condition
                 (&message (message "Failed to evaluate Cabal file. \
See the manual for limitations.")))))))

  (define (cabal-evaluated-sexp->package evaluated-sexp)
    (let* ((name (lookup-join evaluated-sexp "name"))
           (version (lookup-join evaluated-sexp "version"))
           (license (lookup-join evaluated-sexp "license"))
           (home-page (lookup-join evaluated-sexp "homepage"))
           (home-page-or-hackage
            (if (string-null? home-page)
                (string-append "http://hackage.haskell.org/package/" name)
                home-page))
           (source-repository (make-cabal-section evaluated-sexp
                                                  'source-repository))
           (synopsis (lookup-join evaluated-sexp "synopsis"))
           (description (lookup-join evaluated-sexp "description"))
           (executables (make-cabal-section evaluated-sexp 'executable))
           (lib (make-cabal-section evaluated-sexp 'library))
           (test-suites (make-cabal-section evaluated-sexp 'test-suite))
           (flags '())
           (eval-environment '()))
      (make-cabal-package name version license home-page-or-hackage
                          source-repository synopsis description executables lib
                          test-suites flags eval-environment)))

  ((compose cabal-evaluated-sexp->package eval) cabal-sexp))

(define (make-cabal-section sexp section-type)
  "Given an SEXP as produced by 'read-cabal', produce a list of objects
pertaining to SECTION-TYPE sections.  SECTION-TYPE must be one of:
'executable, 'flag, 'test-suite, 'source-repository or 'library."
  (filter-map (cut match <>
                   (('section (? (cut equal? <> section-type)) name parameters)
                    (case section-type
                      ((test-suite) (make-cabal-test-suite
                                      name (dependencies parameters)))
                      ((executable) (make-cabal-executable
                                      name (dependencies parameters)))
                      ((source-repository) (make-cabal-source-repository
                                            name
                                            (lookup-join parameters "type")
                                            (lookup-join parameters "location")))
                      ((flag)
                       (let* ((default (lookup-join parameters "default"))
                              (default-true-or-false
                                (if (and default (string-ci=? "false" default))
                                    'false
                                    'true))
                              (description (lookup-join parameters "description"))
                              (manual (lookup-join parameters "manual"))
                              (manual-true-or-false
                               (if (and manual (string-ci=? "true" manual))
                                   'true
                                   'false)))
                         (make-cabal-flag name description
                                          default-true-or-false
                                          manual-true-or-false)))
                      (else #f)))
                   (('section (? (cut equal? <> section-type) lib) parameters)
                    (make-cabal-library (dependencies parameters)))
                   (_ #f))
              sexp))

(define* (lookup-join key-values-list key #:optional (delimiter " "))
  "Lookup and joint all values pertaining to keys of value KEY in
KEY-VALUES-LIST.  The optional DELIMITER is used to specify a delimiter string
to be added between the values found in different key/value pairs."
  (string-join 
   (filter-map (cut match <> 
                    (((? (lambda(x) (equal? x key))) value)
                     (string-join value delimiter))
                    (_ #f))
               key-values-list)
   delimiter))

(define dependency-name-version-rx
  (make-regexp "([a-zA-Z0-9_-]+) *(.*)"))

(define (dependencies key-values-list)
  "Return a list of 'cabal-dependency' objects for the dependencies found in
KEY-VALUES-LIST."
  (let ((deps (string-tokenize (lookup-join key-values-list "build-depends" ",")
                               (char-set-complement (char-set #\,)))))
    (map (lambda (d)
           (let ((rx-result (regexp-exec dependency-name-version-rx d)))
             (make-cabal-dependency
              (match:substring rx-result 1)
              (match:substring rx-result 2))))
         deps)))

;;; cabal.scm ends here