#!/usr/bin/env -S guile -e start -s
!#
;;; coding: utf-8
;;; $Id: debian-copyrighter.scm,v 1.69 2023/12/14 16:31:57 fpp Exp fpp $
;;; Copyright © 2022-2023 Frank Pursel <frank.pursel@gmail.com>

 ;; The debian-copyrighter 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.
 ;; .
 ;; The debian-copyrighter 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 The debian-copyrighter.  If not, see <http://www.gnu.org/licenses/>.
 ;; .
 ;; On Debian systems, the complete text of the GNU General Public License
 ;; Version 3 can be found in `/usr/share/common-licenses/GPL-3'.


;; Guile tools to assist in automating the creation of debian copyright files as
;; at https://www.debian.org/doc/packaging-manuals/copyright-format/1.0
(use-modules
 (ice-9 getopt-long)
 (ice-9 format)
 (ice-9 ftw)
 (ice-9 match)
 (srfi srfi-1)
 (srfi srfi-9)
 (srfi srfi-9 gnu)
 (srfi srfi-11)
 (ice-9 regex)
 (ice-9 rdelim)
 (srfi srfi-64)
 (srfi srfi-26))

(define-record-type <licensed-file>
  (make-licensed-file full-name dir license copyright-list)
  licensed-file?
  (full-name licensed-file-name set-licensed-file-name!)
  (dir licensed-file-dir set-licensed-file-dir!)
  (license licensed-file-license set-licensed-file-license!)
  (copyright-list licensed-file-copyright-list set-licensed-file-copyright-list!))

(define (licensed-file-license->string rec)
  "license must be a symbol for processing but then a string at output."
  (let ((lfl (licensed-file-license rec)))
    (if lfl
	(symbol->string (licensed-file-license rec))
	"No License Found")))

(define-record-type <copyright>
  (make-copyright tag year-list)
  copyright?
  (tag copyright-tag set-copyright-tag!)
  (year-list copyright-year-list set-copyright-year-list!))

(define diagnostic-str "Done!\n")

;;; Tools to compress a list of numeric years.
(define (group-adj-aux sorted-l res)
  (if (null? sorted-l)
      (reverse res)
      (group-adj-aux (cdr sorted-l) (if (memv (+ 1 (car (car res))) sorted-l)
					(cons (cons (car sorted-l) (car res)) (cdr res))
					(cons (list (car sorted-l)) res)))))

(define (group-adj num-lst)
  (let ((sl (sort num-lst <=)))
    (group-adj-aux (cdr sl) (list (list (car sl))))))

(define (stringify-group lst)
  (if (< (length lst) 2)
      (number->string (car lst))
      (let ((sl (sort lst <=)))
	(string-concatenate (list
			     (number->string (car sl))
			     "-"
			     (number->string (last sl)))))))


(define (compr-yr-lst-aux groups res)
  (if (null? groups)
      res
      (compr-yr-lst-aux (cdr groups) (string-concatenate
				      (list res "," (stringify-group (car groups)))))))

(define (compr-yr-lst yr-lst)
  "Return a string describing both consecutive and non-consecutive ranges of years."
  (if (null? yr-lst)
      ""
      (let* ((groups (group-adj yr-lst)))
	(string-drop (compr-yr-lst-aux groups "") 1)
	)))

(define (min-max-yr-lst yr-lst)
  "Return the span of all copyr years, eg (min-max-yr-lst (list 1995 1996 2005))
returns \"1995,2005\".  Or the empty string for no copyrights."
  (let ((len-yr-lst (if (null? yr-lst) 0 (length yr-lst))))
    (cond
	  ((zero? len-yr-lst) "")
	  ((= 1 len-yr-lst) (format #f "~a" (car yr-lst)))
	  (#t  (let* ((sorted-num-list (sort yr-lst <=))
		      (min-yr (car sorted-num-list))
		      (max-yr (car (reverse sorted-num-list))))
		 (format #f "~a-~a" min-yr max-yr)))
	  )
    )
  )

;; Defining default copyright years display format func
(define display-cprt-yrs compr-yr-lst)

					;(test-begin "Compression of year lists to string")
					;(test-assert (string=? "1990,1999-2000,2020-2022" (compr-yr-lst test-yr-list)))
					;(test-end)

;;; Tools to convert year strings to number-year lists.
(define (years-fm-lst lst res)
  (let ((regex (make-regexp "(20|19)[8,9,0,1,2][0-9]" )))
    (let nxt-yr ((l lst) (result '()))
      (if (null? l)
	  result
	  (nxt-yr (cdr l) (let ((rr (regexp-exec regex (car l))))
			    (if rr
				(cons (string->number (match:substring rr)) result)
				result)))
	  ))))

(define (expand-hyphen-yrs h-yr-str)
  (let* ((str-l (string-split h-yr-str (string-ref h-yr-str 4)))
	 (fixed-2digit-str-l (map (lambda (ns)
				    (if (= (string-length ns) 4)
					ns
					(let ((num (string->number ns)))
					  (if (> 50 num)
					      (format #f "~a" (+ 2000 num))
					      (format #f "~a" (+ 1900 num))))))
				  str-l))
	 (n-lst (sort (map string->number fixed-2digit-str-l) <=))
	 (low (car n-lst))
	 (high (cadr n-lst)))
    (string-join (map number->string (iota (- high low -1) low)) ",")
    )
  )


;;(define hy-yrs-cre-old (make-regexp "(19|20)[8,9,0,1,2][0-9][-–](19|20)[8,9,0,1,2][0-9]"))
(define hy-yrs-cre (make-regexp "(19|20)[8,9,0,1,2][0-9][-–][0-9][0-9]+"))

(define (dehyphenate-line str)
  (let ((match? (regexp-exec hy-yrs-cre str)))
    (if match?
	(dehyphenate-line
	 (regexp-substitute #f match?
			    'pre (expand-hyphen-yrs (match:substring match?)) 'post))
	str))
  )

;(test-begin "Line dehyphenation")
;(test-assert (string=? "1999,2000,2001" (dehyphenate-line "1999-2001")))
;(test-assert (string=? "1999,2000,2001,2005" (dehyphenate-line "1999-2001,2005")))
;; (test-assert (string=? (dehyphenate-line "1999-2001,2009,2020-2022")
;; 		       "1999,2000,2001,2009,2020,2021,2022"))
;(test-end "Line dehyphenation")


(define (canon-year n)
  (if (< n 100)
      (if (> n 50)
	  (+ n 1900)
	  (+ n 2000))
      n))

(define (years-str->nlst str)
  (let ((dehyphenated (dehyphenate-line
		       str)))
    (map canon-year
	 (filter number?
		 (map string->number
		      (map string-trim-both (string-split dehyphenated #\,)))))
    )
  )

;; (test-begin "strings-to-lists-of-numbers")
;; (test-assert (equal? (list 1999 2000 2001) (years-str->nlst "1999-2001")))
;; (test-assert (equal? (list 1999 2000 2001 2005 2006 2007)
;; 		     (years-str->nlst "1999-2001,2005-2007")))
;; (test-assert (equal? (list 2000 2001 2002 2010)
;; 		     (years-str->nlst (compr-yr-lst (list 2000 2001 2002 2010)))))
;; (test-end "strings-to-lists-of-numbers")

(define licenses
  (list
   '(GPL-3.0+ "Id: debian-copyrighter.scm")
   '(Expat-and-GPL-3.0+ "GNU General Public License" "Version 3" "any later"
			"Permission is hereby granted, free of charge, to any person obtaining")
   '(GPL-3.0+ "GNU General Public License" "Version 3" "any later")
   '(GPL-3.0+ "same license as the( GNU)* guix package")
   '(GPL-2.0+ "GNU General Public License" "version 2" "any later")
   '(GPL-2or3 "GNU General Public License" "version 2" "version 3")
   '(GPL-2.0 "GNU " "Public License" "Version 2")
   '(GPL-2.0 "GNU General Public" "License version 2")
   '(GPL-2.0 "GNU GPL version 2")
   '(GPL "GNU General Public")
   '(BEER-WARE "BEER-WARE LICENSE")
   '(LGPL-2.1+ "GNU Lesser General Public"
	       "version 2.1" "any later")
   '(LGPL-3.0+ "GNU Lesser General Public"
	       "This library is free software"
	       "version 3")
   '(GFDL-1.3+ "GNU Free Documentation" "Version 1.3" "any later")
   '(GFDL "GNU Free Documentation License")
   '(GLGPL "GNU Library General Public License")
   '(BSD-2-Clause "Redistribution" "provided that the following conditions are met:"
		  "1" "2" "AS IS")
   '(BSD-3-Clause "Redistribution" "provided that the following conditions are met:"
		  "Neither the name of the author nor the names of contributors")
   '(Modified-BSD-4 "Redistribution and use" "software must not be misrepresented" "altered source versions must be plainly marked")
   '(BSD-style "BSD-style license")
   '(Expat "Permission is hereby granted, free of charge, to any person obtaining")
   '(MIT "MIT License")
   '(PERMISSIVE "This file can be copied and used freely without restrictions."
		"It can be used in projects which are not available")
   '(PERMISSIVE-VARIANT1 "Copying and distribution of this file, with or without modification" "are permitted in any medium without royalty")
   '(PERMISSIVE-VARIANT2 "Permission to copy, use, modify, sell and distribute")
   '(UNKNOWN "(source|permission|distribut|modify)") ;; Incomplete results must be at end.
		    ))

(define (lines-of-file fn)
  (let ((iport (open-file fn "r" )))
    (do ((line (read-line iport) (read-line iport))
	 (result '() (cons line result)))
	((eof-object? line) (begin (close-port iport) (reverse result))))))

(define (file-contains-icase? re)
  (let ((compiled-re (make-regexp re regexp/icase)))
    (lambda (lof)
      (any (lambda (l-of-f) (regexp-exec compiled-re l-of-f)) lof)))
  )

(define (lof-contains-license? lof)
  (or ((file-contains-icase? " license") lof)
      ((file-contains-icase? " Redistribution and use ") lof)
     ))

(define (dir-from-full-file-name ffn)
  (string-join (reverse (cdr (reverse (string-split ffn #\/)))) "/"))

(define (test-lic? lic-clause)
  "When applied to a file-string we return either #f or the symbol of the successfully tested license clause.  One of licenses, above."
  (lambda (file-str)
    (let* ((lic-symb (car lic-clause))
	   (lic-tests (cdr lic-clause))
	   (compiled-lic-tests (map (lambda (re) (make-regexp re regexp/icase)) lic-tests)))
      (and (every (lambda (c-re) (regexp-exec c-re file-str)) compiled-lic-tests) lic-symb)))
  )

(define license-tests (map test-lic? licenses))

(define (license-of lof tests)
  "When applied to a list of the lines in a file this returns the symbol of a matching license or 'any, which indicates no license was identified."
  (let ((file-str (string-join lof " ")))
    (any (lambda (lic-test) (lic-test file-str) ) tests)))

;; (test-group "license-of"
;;   (test-assert (not ((test-lic? (list 'x-sym "A" "tree")) "A buffalo")))
;;   (test-assert (eq? 'xsym ((test-lic? (list 'xsym "A" "tree")) "A tree and more"))))

;(define years-re (make-regexp "(20|19)[8,9,0,1,2][0-9][ \t]?[-–,]?[ \t]?[0-9][0-9]+"))
(define years-re (make-regexp "[-–,0-9][-–,0-9[:space:]]+"))


(define (make-copyright-from match)
  (let* (
	 (copyright-info (match:substring match 3))
	 (years-mat (regexp-exec years-re copyright-info))
	 (years-str (if years-mat
			(match:substring years-mat)
					; (match:substring match)
			""
			))
	 (tag-str (fold
		   (lambda (c s) (string-trim-both s c))
		   (if years-mat
		       (if (equal? "" (match:prefix years-mat))
			   (string-drop copyright-info (string-length years-str))
			   (match:prefix years-mat))
		       copyright-info)
		   ;; Note that order and repetitions matter here.
		   (list #\space #\tab #\: #\. #\- #\* #\* #\\ #\/ #\; #\% #\space #\tab))))
    (if (> 0 (string-length tag-str))
	"Empty Copyright Tag"
	(make-copyright tag-str (years-str->nlst years-str)))))
  

(define copyr-re (make-regexp
		  (string-concatenate
		   (list "copyright (\\([Cc]\\)|"
			 (list->string (list #\x00A9))
			 ") "))
		  regexp/icase))

;; (define copyr-re-i (make-regexp
;; 		  (string-concatenate
;; 		   (list "copyright( \\([Cc]\\)| "
;; 			 (list->string (list #\x00A9))
;; 			 ")* "))
;; 		  regexp/icase))

(define copyr-re-i (make-regexp
		    (string-concatenate
		     (list "(copyright|!copyright notice|!copyright HOLD)[[:space:]0-9]+(\\([Cc]\\)|"
			   (list->string (list #\x00A9))
			   ")[[:space:]]*(.*)"))
		    regexp/icase))

(define (copyrights-of-aux lof)
  (if (null? lof)
      '()
      (let ((match? (regexp-exec copyr-re-i (car lof))))
	(if match?
	    (cons
	     (make-copyright-from match?)
	     (copyrights-of-aux (cdr lof)))
	    (copyrights-of-aux (cdr lof))))))

;;; Enabling additional testing
(define (copyright-from-str str)
  (let ((m? (regexp-exec copyr-re-i str)))
    (if m?
	(make-copyright-from m?)
	#f)))

(define copyright-po-cre (make-regexp "([-–,] ?(20|19)[8,9,1,2][0-9])+\\.?[[:blank:]]*$"))

(define (make-copyright-from-po match)
  (let* ((tag-str (string-drop (match:prefix match) 2))
	 (dirty-years-str (match:substring match))
	 (years-str-minus-dot (if (string-match "\\." dirty-years-str)
				  (regexp-substitute #f
						     (string-match "\\." dirty-years-str)
						     'pre "" 'post)
				  dirty-years-str))
	 (years-str (regexp-substitute #f (string-match "^, " years-str-minus-dot) 'post)))
    (make-copyright tag-str (years-str->nlst years-str))
    ))

(define (copyrights-of-po-aux lof)
  (if (null? lof)
      '()
      (let ((match? (regexp-exec copyright-po-cre (car lof))))
	(if match?
	    (cons
	     (make-copyright-from-po match?)
	     (copyrights-of-po-aux (cdr lof)))
	    (copyrights-of-po-aux (cdr lof)))))
  )

(define (copyrights-of lof bname)
  (if (string-match ".*\\.po$" bname)
      (append (copyrights-of-aux lof) (copyrights-of-po-aux lof))
      (copyrights-of-aux lof)))

(define (enter? name stat results)
  (not (string-match "\\.git" name)))

(define (leaf name stat result)
  (let ((res result))
    (if #t   ;; (string-match ".*\\.(scm|po)$" name)
	(let ((lof (lines-of-file name))
	      )
	  (if (lof-contains-license? lof)
	      (hash-set! res name (make-licensed-file
				   name
				   (dir-from-full-file-name name)
				   (license-of lof license-tests)
				   ;;; Flagging copyright problems
				   (let ((copyrights 
					   (copyrights-of lof (basename name))))
				     (if (every copyright? copyrights)
					 copyrights
					 (begin
					   (pk name)
					   (filter copyright? copyrights))))
				   ))
	      )
	  ))
    res
    )
  )

(define (filter-empty-copyrights copyr-list)
  (let* ((copyr-re (make-regexp "copyright" regexp/icase))
	 (empty-copyr?
	  (lambda (copyr)
	    (not (regexp-exec copyr-re (copyright-tag copyr)))))
	 )
    (filter empty-copyr? copyr-list))
  )


;;; Function to do things with transforms that are defined below.
(define (str-transfm transform)
  (lambda (str)
    (let* ((cre (car transform))
	   (subst-str (cadr transform))
	   (m? (regexp-exec cre str))
	   )
      (if m?
	  (regexp-substitute
	   #f
	   m?
	   'pre
	   subst-str
	   'post)
	  str))))

(define (gbl-str-transfm transform)
  (lambda (str)
    (let* ((cre (car transform))
	   (subst-str (cadr transform))
	   )
      (regexp-substitute/global
       #f
       cre
       str
       'pre
       subst-str
       'post)
      )))

;;; Defining some simple string transformations.  They define regular expressions that
;;; when matched are replaced by a string constant.
;;;
;;; They are simple and composable.
(define non-lic-chars (list
		       (make-regexp "[|_]+" regexp/extended) ""))
(define invalid-lic-1 (list
		       (make-regexp "GPL-2\\.0-or-later" regexp/basic) "GPL-2.0+"))
(define invalid-lic-2 (list (make-regexp "GPL-2\\.0-only" regexp/basic) "GPL-2.0"))
(define invalid-lic-3 (list
		       (make-regexp "GPL-3\\.0-or-later" regexp/basic) "GPL-3.0+"))
(define invalid-lic-4 (list
		       (make-regexp "GPL-3\\.0-only" regexp/basic) "GPL-3.0"))
(define GPL-space-to-hyphen (list (make-regexp "GPL 2" regexp/basic) "GPL-2"))
(define or-later (list (make-regexp "-or-later ") "+ "))

;; Here we compose multiple transforms into a single operation.
(define spdx-license-canonicalize
  (compose
   (gbl-str-transfm non-lic-chars)
   (str-transfm invalid-lic-1)
   (str-transfm invalid-lic-2)
   (str-transfm invalid-lic-3)
   (str-transfm invalid-lic-4)
   (str-transfm GPL-space-to-hyphen)
   (str-transfm or-later)
   ))

(define (spdx-license? lof)
  (spdx-license-auxx lof #f 15))

(define spdx-raw-re (make-regexp "([-[:alpha:]]+):[:space:]*(.*)"))

(define spdx-lic-raw-re
  (make-regexp "SPDX-License-Identifier:[[:space:]]*(.*)"))
(define spdx-lic-dquot-re
  (make-regexp "SPDX-License-Identifier:[[:space:]]*\"(.*)\""))
(define spdx-lic-cparen-re
  (make-regexp "SPDX-License-Identifier:[[:space:]]*\\((.*)\\)"))

(define prune-end-comment-re
  (make-regexp "(.*)[[:space:]]*\\*/"))

(define (spdx-license-identifier-value-raw line)
  (let ((value+end
	 (cond
	  ((regexp-exec spdx-lic-cparen-re line) => (cut match:substring <> 1))
	  ((regexp-exec spdx-lic-dquot-re line) => (cut match:substring <> 1))
	  ((regexp-exec spdx-lic-raw-re line) => (cut match:substring <> 1))
	  (else #f))))
    (if value+end
	(let ((end-comment-match? (regexp-exec prune-end-comment-re value+end)))
	  (string-trim-right (if end-comment-match?
				 (match:substring end-comment-match? 1)
				 value+end)))
	#f
	)
    )
  )

(define (spdx-license-identifier-value line)
  (let ((raw-license-identifier (spdx-license-identifier-value-raw line)))
    (if (string? raw-license-identifier)
	(string->symbol
	 (spdx-license-canonicalize
	  raw-license-identifier))
	raw-license-identifier)
    )
  )

(define (spdx-license-auxx lof res lines-to-check)
  (if (or (null? lof) res (< lines-to-check 1))
      res
      (spdx-license-auxx
       (cdr lof)
       (spdx-license-identifier-value (car lof))
       (- lines-to-check 1)
       )
      )
  )
  

;;; Unified licensing policy
(define (licensing? text-lic spdx-lic)
  (cond ((not (or text-lic spdx-lic)) ;; No license found
	 #f)
	((and text-lic spdx-lic) ;; Both licenses found
	 (if (eq? text-lic spdx-lic)
	     text-lic
	     (if (eq? text-lic 'UNKNOWN)
		 spdx-lic
		 text-lic)))
	((or text-lic spdx-lic) => identity) 
	))

;;; Revised base-cut-leaf to incorporate SPDX license information if available.
(define (base-cut-leaf base-dir exclusion-func)
  (let ((trim-base (lambda (name)
		     (let ((lbd (string-length base-dir)))
		       ;; (if (char=? #\/ (last (string->list base-dir)))
		       ;; 	   (substring name (1+ lbd))
		       ;; 	   (substring name lbd)
		       ;; 	   )
		       (substring name (1+ lbd))
		       ))))
    (lambda (name stat result)
      (let ((res result))
	(if (exclusion-func name stat result) ;;#t or (string-match ".*\\.(scm|po)$" name)
	    (let* ((lof (lines-of-file name))
		   (text-lic? (and (lof-contains-license? lof)
				  (license-of lof license-tests)
				  )
			      )
		   (spdx-lic? (spdx-license? lof))
		   )
	      (hash-set! res name (make-licensed-file
				   (trim-base name)
				   (dir-from-full-file-name name)
				   (licensing? text-lic? spdx-lic?)
				   (filter copyright?
				    (copyrights-of lof (basename name)))))
		  
	      ))
	res
	))))


(define (up name stat results) results)
(define (down name stat results) results)
(define (skip name stat results) results)
(define (err name stat errno results) results)

(define (analyze-single-file fn)
  "Provide the analysis for a single file.  For testing."
  (let* ((lof (lines-of-file fn))
	 (text-lic? (and (lof-contains-license? lof)
			 (license-of lof license-tests)))
	 (spdx-lic? (spdx-license? lof))
	 (copyrights (copyrights-of lof (basename fn))))
    (format #t "Prose-license: ~a~%SPDX-license: ~a~%Arbit: ~a~%Copyrights: ~a~%"
	    text-lic?
	    spdx-lic?
	    (licensing? text-lic? spdx-lic?)
	    (string-join
	     (map (lambda (x) (format #f "~a" x)) copyrights)
	     "\n"))
    ))

(define (hash-for-dir-tree dir)
  "Main entry point to scan a directory tree and return a hash of all files with license and copyright analyses."
  (let ((leaf (base-cut-leaf dir (const #t))))
    (file-system-fold enter? (base-cut-leaf dir (const #t)) down up skip err
		      (make-hash-table 1200)
		      dir
		      stat)))

(define (enter-w-exclusions? excl-list)
  "Provided a set of regular-expressions return an enter? function. Delimited defined by excl-delim-char"
  (if (null? excl-list)
      (lambda (name stat results) #t)
      (let* ((l-regex excl-list)
	     (l-reg-compiled (map (lambda (reg) (make-regexp reg)) l-regex))
	     (check-name?
	      (lambda (fname)
		(any (lambda (cregexp) (regexp-exec cregexp fname)) l-reg-compiled))))
	(lambda (name stat results)
	  (not (check-name? name))))))

(define (hash-for-dir-tree-w-exclusions dir regexp-list)
  (let ((leaf (base-cut-leaf dir (enter-w-exclusions? regexp-list)))
	(enter? (enter-w-exclusions? regexp-list)))
    (file-system-fold enter? leaf down up skip err
		      (make-hash-table 1200)
		      dir
		      stat)))

(define (problems-to-investigate dir)
  (let ((loc-hash (hash-for-dir-tree dir)))
    (list (cons 'no-copyright-files
		(hash-fold (lambda (k v p)
			     (if (= 0 (length (licensed-file-copyright-list v)))
				 (cons k p)
				 p))
			   '()
			   loc-hash))
	  (cons 'no-license-files
		(hash-fold (lambda (k v p)
			     (if (eq? 'any (licensed-file-license v))
				 (cons k p)
				 p))
			   '()
			   loc-hash))
	  (cons 'data-hash loc-hash))))

(define (freq-aux lst res)
  (if (null? lst)
      res
      (let-values (((car-part cdr-part)
		    (partition
		     (lambda (e) (eq? e (car lst)))
		     lst)))
	(freq-aux cdr-part (alist-cons (car lst) (length car-part) res)))))

(define (freq lst)
  "Return an alist uniq elements from lst with count of each."
  (freq-aux lst '()))

(define (license-freq dir hash)
  (freq (hash-fold (lambda (k v p) (if (string=? dir (licensed-file-dir v)) (cons (licensed-file-license v) p) p)) '() hash))
  )

(define (dirs-in-tree base-dir)
  (let ((entry? (lambda (name stat result ) (not (string-match "\\.git" name))))
	(leaf (lambda  (name stat result) result))
	(skip (lambda  (name stat result) result))
	(up (lambda  (name stat result) (cons name result)))
	(down (lambda  (name stat result) result))
	(err (lambda  (name stat errno result) result))
	)
    (file-system-fold entry? leaf down up skip err '() base-dir stat)))

(define (single-licensed-dir? dir hash)
  (let ((lic-lst (license-freq dir hash)))
    (if (= 1 (length lic-lst))
	(car (car lic-lst))
	#f)))

(define (licenses-found hash)
  "Given a dir-tree hash return a list of license symbols returned."
  (hash-fold (lambda (k v p) (lset-adjoin eq? p (licensed-file-license v)) )
	     '()
	     hash))

(define (license-counts hash lic-list)
  "Given the hash and list of licenses return a sorted alist of
(license . count) elements"
  (sort (map (lambda (lic)
	       (cons lic (hash-count
			  (lambda (k v) (eq? lic (licensed-file-license v)))
			  hash)))
	     lic-list)
	(lambda (x y) (>= (cdr x) (cdr y))))
  )

(define (join-copyright-lists res new-crl)
  (if (null? new-crl)
      res
      (join-copyright-lists 
       (let ((match? (assoc (caar new-crl) res)))
	 (if match?
	     (let* ((tag (car match?))
		    (res-copyright (cdr match?))
		    (res-yr-lst (copyright-year-list res-copyright))
		    (new-crl-yr-lst (copyright-year-list (cdar new-crl)))
		    (joint-year-list (lset-union eqv? res-yr-lst new-crl-yr-lst))
		    (updated-copyr (make-copyright tag joint-year-list)))
	       (assoc-set! res tag updated-copyr))
	     (acons (caar new-crl) (cdar new-crl) res)))
       (cdr new-crl))))

(define (consolidate-copyright-lists-aux copyr-list res)
  (if (null? copyr-list)
      res
      (consolidate-copyright-lists-aux
       (cdr copyr-list)
       (join-copyright-lists res (car copyr-list)))))

(define (consolidate-copyright-lists copyr-lst)
  (consolidate-copyright-lists-aux
   (cdr copyr-lst)
   (car copyr-lst)
   ))

(define (expanded-copyr-list copyr-list)
  (map (lambda (copyr) (cons (copyright-tag copyr) copyr)) copyr-list))

(define (licensed-files/license hash lic)
  (let ((alist-of-lic (hash-fold (lambda (k v p) (if (eq? lic (licensed-file-license v)) (acons (licensed-file-name v) v p) p)) '() hash)))
    (make-licensed-file
     (apply list (map car alist-of-lic))
     #f
     lic
     (consolidate-copyright-lists
      (map
       (compose expanded-copyr-list licensed-file-copyright-list cdr)
       alist-of-lic))
     )
    ))


(define (hash-head n hash)
  "Returns a list of licensed-file records n elems long."
  (hash-fold (lambda (k v p) (if (< (length p) n) (cons v p) p)) '() hash))

(define (gather-copyrights k licensed-file-rec copyr-alist)
  (let* ((copyright-list (licensed-file-copyright-list licensed-file-rec)))
    (let proc-copyr ((copyr-l copyright-list) (alist copyr-alist))
      (if (null? copyr-l)
	  alist
	  (proc-copyr (cdr copyr-l)
		      (let* ((next-copyright (car copyr-l))
			     ;(yr-str (car next-c))
			     (yr-list (copyright-year-list next-copyright))
			     (tag-str (copyright-tag next-copyright))
			     (existing-cr? (assoc tag-str alist)))
			(if existing-cr?
			    (let* ((all-yr-lst (lset-union eqv? yr-list (copyright-year-list (cdr existing-cr?)))))
			      (assoc-set! alist tag-str (make-copyright tag-str all-yr-lst)))
			    (acons tag-str next-copyright alist)
			    )
			)))
      )))

;;; Getting all copyrights into alist for 
(define (all-copyrights hash)
  "Return alist keyed on copyright holder strings holding list of copyright years."
  (hash-fold gather-copyrights '() hash))

(define (fmt-copyright copyr-fm-alist)
  (string-concatenate (list (display-cprt-yrs (cdr copyr-fm-alist)) " " (car copyr-fm-alist) "\n")))


;;; Partitioning copyrights for a particular set of file directories

;; First need to convert licensed-file hash to an alist so we can partition all files.
(define (licensed-files-to-alist hash)
  (hash-fold (lambda (k v p) (cons v p) ) '() hash))

;; report out a globbed dir and return the other partition

;;; Partition files by license starting with the largest
;;; the largest partition will be attributed to *
;;; Subsequent licenses will list the licensed filenames.

(define sort-copyrights-by-tag-then-first-4
  (lambda (copyr-lst)
    (sort copyr-lst
	  (lambda (x y)
	    (let* ((x-yl (copyright-year-list (cdr x)))
		   (y-yl (copyright-year-list (cdr y)))
		   (x-f-y (if (null? x-yl)
			      '()
			      (car (sort x-yl <=))))
		   (y-f-y (if (null? y-yl)
			      '()
			      (car (sort y-yl <=))))
		   )
	      (if (and (number? x-f-y) (number? y-f-y) (= x-f-y y-f-y))
		  (string<=? (copyright-tag (cdr x)) (copyright-tag (cdr y)))
		  (and (number? x-f-y) (number? y-f-y) (<= x-f-y y-f-y))
		  ))))
    ))

;;; Record printing tools 
(set-record-type-printer!
 <copyright>
 (lambda (rec port)
   (format port "~a ~a~%"
	   (display-cprt-yrs (copyright-year-list rec))
	   (copyright-tag rec))))
(set-record-type-printer!
 <licensed-file>
 (lambda (rec port)
   (let ((name (licensed-file-name rec)))
     (if (not (list? name))
	 (format port
		 "File: ~a~%Copyright:\n~a~%License: ~a~%"
		 name
		 (string-join
		  (map (lambda (copyr-rec)
			 (format #f "~a ~a"
				 (display-cprt-yrs
				  (copyright-year-list copyr-rec))
				 (copyright-tag copyr-rec))
			 ;; (string-concatenate
			 ;;  (list
			 ;;   " "
			 ;;   (display-cprt-yrs
			 ;;    (copyright-year-list copyr-rec))
			 ;;   " "
			 ;;   (copyright-tag copyr-rec)))
			       )
		       (licensed-file-copyright-list rec))
		  "\n")
		 (licensed-file-license->string rec))
	 (format port
		 "Copyright:\n~a~%License: ~a~%"
		 (let ((copr-l (sort-copyrights-by-tag-then-first-4 (licensed-file-copyright-list rec))))
		   (if (null? copr-l)
		       ""
		       (string-join
			(map (lambda (ae)
			       (let ((copyr (cdr ae)))
				 (string-concatenate
				  (list
				   ;; " "
				   (display-cprt-yrs (copyright-year-list copyr))
				   " "
				   (copyright-tag copyr)))))
			     copr-l)
			"\n")))
		 (licensed-file-license->string rec))
	 ))))

(define (all-output dir-tree exclusion-list)
  (let* ((d-hash (hash-for-dir-tree-w-exclusions dir-tree exclusion-list))
	 (alist (hash-fold (lambda (k v p) (acons k v p)) '() d-hash))
	 (sorted-al (sort alist (lambda (x y) (string<=? (car x) (car y))))))
    (for-each
     (lambda (file-rec)
       (display (cdr file-rec))
       (newline))
     sorted-al)
    ))

;; (define (license-filename-sort d-hash licenses)
;;   (sort licenses
;; 	(lambda (x y)
;; 	  (string<=?
;; 	   (licensed-file-name (licensed-files/license d-hash x))
;; 	   (licensed-file-name (licensed-files/license d-hash y))
;; 		     ))))

(define (default-output dir-tree exclusion-list)
  (let* ((d-hash (hash-for-dir-tree-w-exclusions dir-tree exclusion-list))
	 (license-freqs (license-counts d-hash (licenses-found d-hash)))
	 (license-freqs-wo-falses (remove (lambda (x) (eq? (car x) #f)) license-freqs))
	 (dominant-lic (caar license-freqs-wo-falses))
	 (rem-licenses (map car (cdr license-freqs-wo-falses)))
	 )
    (format #t "Files: *~%~a~%"
	    (licensed-files/license d-hash dominant-lic))
    (for-each
     (lambda (lic)
       (let ((licensed-file-rec (licensed-files/license d-hash lic)))
	 (format #t "Files:\n ~a~%"
		 (string-join
		  (sort (licensed-file-name licensed-file-rec)
			string<=?) "\n "))
	 (display licensed-file-rec)
	 (newline)))
     rem-licenses )
    ))

(define (margs opt-name parsed-opts default-regexp)
  (let* ((pairs (filter (lambda (cell) (pair? cell)) parsed-opts))
	 (matched-pairs (filter (lambda (cell) (eq? (car cell) opt-name)) pairs))
	 )
    (if (> (length matched-pairs) 0)
	(map cdr matched-pairs)
	default-regexp)))


(define (start args)
  (let* ((option-spec '((single-file (single-char #\f) (value #t))
			(dir (single-char #\d) (value #t))
			(exclusions (single-char #\x) (value #t))
			(list-files (single-char #\L) (value #f))
			(short-years (single-char #\s) (value #f))
			(all (single-char #\A) (value #f))
			(help (single-char #\h) (value #f))))
	 (options (getopt-long args option-spec))
	 (filename (option-ref options 'single-file #f))
	 (dir-provided (option-ref options 'dir #f))
	 (ex-list (margs 'exclusions options '()))
	 (list-files (option-ref options 'list-files #f))
	 (shorten-years (option-ref options 'short-years #f))
	 (all (option-ref options 'all #f))
	 (help-wanted (option-ref options 'help #f))
	 )
    (if help-wanted
	(display "
debian-copyrighter [options]
  -h,  --help  Display this help
  -d,  --dir   (required) Provide directory path for scanning
  -s,  --short-years  display copyright years in shortest form
  -x,  --exclusions Possibly multiple regular-expressions for
               dirs and/or files to be excluded from analysis
  -A,  --all   Lists license, copyright holders for all files (long)
  -f,  --single-file (pre-empts -d, -x, and -A) Analyze the given 
               filename (for testing).

Scans the provided dir for files containing license
information and outputs collective summary of copyright holder
information found.

If -x is provided with a regular expression directories or filenames
matching any of these patterns will be excluded from processing.  By
default this list is empty.  Multiple -x options can be added to the
command line.

If -A is selected each file is listed individually.  Suited for
filtering, troubleshooting or exploration.

If -f <filename> provide a summary of what information is found within.
"))
    (if shorten-years (set! display-cprt-yrs min-max-yr-lst))
    (if filename
	(analyze-single-file filename)
	(if dir-provided
	    (cond
	     (all (all-output dir-provided ex-list))
	     (list-files #t)
	     (#t (begin
		   (display (string-concatenate (list "Scanning: " dir-provided "\n")))
		   (default-output dir-provided ex-list))))
	    (display "Must provide the directory to read using the -d option. Or get --help.\n")
	    ))
    (display diagnostic-str)
    )
  )
