;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nodejs.scm
;; Copyright (C) 2025, 2026 Cor Legemaat <cor@cor.za.net>
;;
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published by the
;; Free Software Foundation, version 3 of the License.
;;
;; ebuild-autogen 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
;; ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (ebuild gen nodejs)
  #:use-module (ebuild utils)
  #:use-module (ebuild defs)
	#:use-module (ebuild gen)
	#:use-module (ebuild pkt-map)
	#:use-module (ebuild state)
	#:use-module (ebuild repo)
	#:use-module (ebuild semver)
	#:use-module (ebuild fetchers npmjs)
  #:use-module (dql dql)
  #:use-module (rx irregex)
  #:use-module (ice-9 pretty-print)
	#:use-module (ice-9 receive)
  #:use-module (ice-9 string-fun)
  #:use-module (ice-9 textual-ports)
  #:use-module (srfi srfi-1)
	#:use-module (srfi srfi-19))

(define get-constraints
	(lambda (spec)
		""
		(let ((raw (irregex-extract '(seq (or bos (look-behind space))
																			(? (or "^" "~" "*" "<" ">" "="
																						 ">=" "<=" "=="))
																			(* space)
																			(+ num)
																			(* (seq "." (+ num)))
																			(? (seq "-" (+ alphanum) (* "." (+ num)))))
																spec)))
			;; Return method, slot depth, comps
			(map (lambda (const)
						 (cond ((string-prefix? "^" const)
										;; Major match minor and patch higher than.
										(list (cons 'type '=)
													(cons 'slot-level 1)
													(cons 'components
																(take (semver->comps (string-drop const 1)) 1))))
									 ((string-prefix? "~" const)
										;; Major and minor match, patch higher than.
										(list (cons 'type '=)
													(cons 'slot-level 2)
													(cons 'components
																(take (semver->comps (string-drop const 1)) 2))))
									 ((string-prefix? "*" const)
										;; Any version.
										(list (cons 'type '())
													(cons 'slot-level 0)
													(cons 'components '())))
									 ((string-prefix? ">=" const)
										;; Newer then.
										(list (cons 'type '>=)
													(cons 'slot-level 0)
													(cons 'components
																(semver->comps (string-drop const 2)))))
									 ((string-prefix? "<=" const)
										;; Newer then.
										(list (cons 'type '<=)
													(cons 'slot-level 0)
													(cons 'components
																(semver->comps (string-drop const 2)))))
									 ((string-prefix? "<" const)
										;; Newer then.
										(list (cons 'type '<)
													(cons 'slot-level 0)
													(cons 'components
																(semver->comps (string-drop const 1)))))
									 ((string-prefix? ">" const)
										;; Newer then.
										(list (cons 'type '>)
													(cons 'slot-level 0)
													(cons 'components
																(semver->comps (string-drop const 1)))))
									 ((string-prefix? "=" const)
										;; Newer then.
										(list (cons 'type '=)
													(cons 'slot-level
																(length (semver->comps (string-drop const 1))))
													(cons 'components
																(semver->comps (string-drop const 1)))))
									 (else
										;; Exact version.
										(list (cons 'type '=)
													(cons 'slot-level
																(length (semver->comps const)))
													(cons 'components (semver->comps const))))))
					 raw))))

(define replace-npm-folder
	(lambda (npm-name)
		""
		(let ((folder-match (irregex-search `(seq (look-behind (seq bos "@"))
																							(+ (or alphanum #\- #\_ #\.))
																							(look-ahead "/"))
																				npm-name)))
			(if folder-match
					(irregex-replace `(seq bos "@" (+ (or alphanum #\- #\_ #\.)) "/")
													 npm-name
													 (string-append (irregex-match-substring folder-match)
																					"+"))
					npm-name))))

(define setup-nodejs-dep
	(lambda (dep parms pkt-map-db)
		""
		(if (>= (assoc-ref parms 'verbosity) verbosity-warn)
				(begin (display "dep:") (newline)
							 (pretty-print dep)))
		(let* ((nodejs-ebuilds '())
					 (last-release-comps '())
					 (dep-vers (assoc-ref dep "version"))
					 (constraints (get-constraints dep-vers))
					 (dep-name (irregex-replace/all
											'(seq #\- (look-ahead num))
											(irregex-replace/all #\.
																					 (replace-npm-folder
																						(assoc-ref dep "pkg"))
																					 "-dot-")
											"-num"))
					 (pkt-map (let ((answ (pkt-map-get pkt-map-db
																						 (assoc-ref dep "pkg"))))
											(if (null? answ)
													#f
													(car answ))))
					 (dep-mod (if pkt-map
												(begin (setup-pkg
																(list (assoc 'repo parms)
																			(assoc 'verbosity parms)
																			(assoc 'category pkt-map)
																			(cons 'name (assoc-ref pkt-map 'pkg))))
															 (resolve-module
																`(,(string->symbol (assoc-ref pkt-map 'category))
																	,(string->symbol (assoc-ref pkt-map 'pkg))
																	autogen)))
												(begin (setup-pkg
																(list (assoc 'repo parms)
																			(assoc 'verbosity parms)
																			(cons 'category "dev-nodejs")
																			(cons 'name dep-name)))
															 (resolve-module
																`(,(string->symbol "dev-nodejs")
																	,(string->symbol dep-name)
																	autogen)))))
					 (dep-parms (let ((answ (alist-copy parms))
														(dep-graph (assoc-ref parms 'dep-graph)))
												(set! answ (assoc-set! answ
																							 'category
																							 (if pkt-map
																									 (assoc-ref pkt-map 'category)
																									 "dev-nodejs")))
												(set! answ (assoc-set! answ
																							 'name
																							 (if pkt-map
																									 (assoc-ref pkt-map 'pkg)
																									 dep-name)))
												(set! answ (assoc-set! answ
																							 'constraint
																							 constraints))
												(set! answ
															(assoc-set! answ
																					'dep-graph
																					(if dep-graph
																							(append dep-graph
																											(list (cons (assoc-ref answ
																																						 'name)
																																	constraints)))
																							(list (cons (assoc-ref parms 'name)
																													'())
																										(cons (assoc-ref answ 'name)
																													constraints)))))
												(set! answ (assoc-set! answ
																							 'npm-name
																							 (assoc-ref dep "pkg")))
												(set! answ (assoc-remove! answ "dependencies"))
												(set! answ (assoc-remove! answ "version"))
												(set! answ (assoc-remove! answ "version-values"))
												(set! answ (assoc-remove! answ 'pkgfiles))
												(set! answ (assoc-remove! answ "assets"))
												(set! answ (assoc-remove! answ "npm-name"))
												(set! answ (assoc-remove! answ "homepage"))
												(set! answ (assoc-remove! answ "description"))
												(set! answ (assoc-remove! answ "license"))
												(set! answ (assoc-remove! answ "node"))
												(set! answ (assoc-remove! answ "npm"))
												(if (>= (assoc-ref parms 'verbosity) verbosity-warn)
														(begin (display "dep-vars:") (newline)
																	 (pretty-print answ)))
												answ))
					 (state-db (state-load (assoc-ref dep-parms 'repo)
																 (assoc-ref dep-parms 'category)
																 (assoc-ref dep-parms 'name)))
					 (dep-state (state-get state-db constraints)))
			(if (>= (assoc-ref parms 'verbosity) verbosity-warn)
				(begin (display "dep-state:") (newline)
							 (pretty-print dep-state)))
			(if (and (or (nil? dep-state)
                   (time<? (date->time-utc (assoc-ref dep-state 'date))
                           (assoc-ref parms 'age-limit)))
							 (not (member (cons (assoc-ref dep-parms 'name) ;; recursive dep.
																	constraints)
														(if (assoc-ref parms 'dep-graph)
																(assoc-ref parms 'dep-graph)
																'()))))
					(let ((dep-releases
								 (semver-constrain
									(if (and dep-mod
													 (module-variable dep-mod 'get-releases))
											((module-ref dep-mod 'get-releases)
											 dep-parms)
											(fetch-npmjs dep-parms))
									constraints)))
						(set! last-release-comps (if (not (null? dep-releases))
																				 (assoc-ref (car dep-releases)
																										"version-values")
																				 '()))
						(set! nodejs-ebuilds
                  (append nodejs-ebuilds
								          (if (and dep-mod
												           (module-variable dep-mod 'generate-ebuilds))
										          ((module-ref dep-mod 'generate-ebuilds)
										           dep-parms
										           dep-releases)
										          (ebuild-gen dep-parms
																					dep-releases)))))
					(set! nodejs-ebuilds
								(append nodejs-ebuilds
												(list
												 (list
													(cons 'category (assoc-ref dep-parms 'category))
													(cons 'name (assoc-ref dep-parms 'name))
													(cons 'pkgfiles
																(append (if (assoc-ref dep-parms 'pkgfiles)
																						(assoc-ref dep-parms 'pkgfiles)
																						'())
																				(list (assoc-ref dep-state 'ebuild))))
													(cons 'distfiles (if (assoc-ref dep-parms 'distfiles)
																							 (assoc-ref dep-parms 'distfiles)
																							 '())))))))
			(if (>= (assoc-ref parms 'verbosity) verbosity-warn)
				(begin (display "dep-version:") (display dep-vers) (newline)))
			(values
			 ;; Dependencys.
			 (let ((pkg-name (string-append (if pkt-map
																					(assoc-ref pkt-map 'category)
																					"dev-nodejs")
																			"/"
																			(if pkt-map
																					(assoc-ref pkt-map 'pkg)
																					dep-name))))
				 (map (lambda (const)
								(string-append
								 (if (null? (assoc-ref const 'type))
										 ""
										 (symbol->string (assoc-ref const 'type)))
								 pkg-name
								 "-"
								 (comps->genver (if (positive? (assoc-ref const 'slot-level))
																		(if (> (length (assoc-ref const 'components))
																					 (assoc-ref const 'slot-level))
																				(take (assoc-ref const 'components)
																							(assoc-ref const 'slot-level))
																				(assoc-ref const 'components))
																		(assoc-ref const 'components)))
								 (if (eq? (assoc-ref const 'type) '=) "*" "")))
							constraints))
			 ;; Symlinks.
			 (if (null? constraints)
					 ""
					 (let ((const (car constraints)))
						 (string-append
							"\""
							(assoc-ref dep "alias")
							" -> "
							(assoc-ref dep "pkg")
							(cond ((eq? (assoc-ref const 'type) '=)
										 (string-append
											"-"
											(comps->genver
											 (if (> (length (assoc-ref const 'components))
															(assoc-ref const 'slot-level))
													 (take (assoc-ref const 'components)
																 (min (assoc-ref const 'slot-level)
																			3))
													 (take (assoc-ref const 'components)
																 (min (length (assoc-ref const 'components))
																			3))))))
										((null? last-release-comps) "") ;; Not found select any.
										;; Highest usable version is car of releases.
										((or (eq? (assoc-ref const 'type) '<)
												 (eq? (assoc-ref const 'type) '<=)
												 (> (length constraints) 1))
										 (string-append "-"
																		(comps->genver last-release-comps)))
										(else (string-append "-" (assoc-ref dep "version"))))
							"\"")))
			 ;; Ebuilds.
			 nodejs-ebuilds))))

(define gen-nodejs-ebuild
	(lambda* (vars verbosity #:key
								 (tmpl #f)
								 ignore-diff)
		""
		(let* ((pkt-map-db (pkt-map-load (assoc-ref vars 'repo) "nodejs"))
					 (vers (assoc-ref vars "version-values"))
					 (nodejs-symlinks '())
					 (nodejs-ebuilds '())
					 (nodejs-deps (append-map (lambda (dep)
																			(receive (deps links dep-ebuilds)
																					(setup-nodejs-dep dep
																														vars
																														pkt-map-db)
																				(set! nodejs-ebuilds
																							(append nodejs-ebuilds
																											dep-ebuilds))
																				(set! nodejs-symlinks
																							(append nodejs-symlinks
																											(list links)))
																				deps))
																		(if (assoc-ref vars "dependencies")
																				(assoc-ref vars "dependencies")
																				'()))))
			(append (ebuild-from-tmpl
							 (append vars
											 (list (cons "slot"
																	 (comps->genver (if (> (length vers) 3)
																											(take vers 3)
																											vers)))
														 (cons "nodejs-deps"
																	 (string-join nodejs-deps "\n\t"))
														 (cons "nodejs-symlinks"
																	 (string-join nodejs-symlinks "\n\t"))))
							 (assoc-ref vars 'verbosity)
							 #:tmpl tmpl
							 #:ignore-diff ignore-diff)
							nodejs-ebuilds))))

(define-public ebuild-gen
	(lambda* (parms releases #:key
                 (keep-components (list 1 1 2))
                 (keep (lambda (version) #f))
                 (drop (lambda (version) #f))
                 (template #f)
								 (gen-ebuild-hook gen-nodejs-ebuild)
                 (post-hook ebuild-default-post)
								 (post-ebuild-hook ebuild-default-post-ebuild)
								 ignore-autogen-diff)
		""
		((@ (ebuild gen) ebuild-gen)
		 parms releases
		 #:keep-components keep-components
		 #:keep keep
		 #:drop drop
		 #:template template
		 #:gen-ebuild-hook gen-ebuild-hook
		 #:post-hook post-hook
		 #:post-ebuild-hook post-ebuild-hook
		 #:ignore-autogen-diff ignore-autogen-diff)))