#!/usr/bin/guile
!#

(use-modules (srfi srfi-1) (rnrs sorting)
  (sph) (sph cli)
  (sph module) ((sph alist) #:select (alist-bind))
  ((sph lang scheme) #:select (string->datum)) ((sph list) #:select (contains? list-prefix?))
  ((sph string) #:select (string-quote any->string))
  ((sph tree) #:select (tree-map-leafs prefix-tree->relations))
  ((sph lang indent-syntax) #:select (prefix-tree->indent-tree)))

(define guile-module-dependencies-description
  "displays a dependency tree for a module.
   module name is given with brackets, for example \"(srfi srfi-1)\"")

(define (string-trim-round-brackets a) (substring a 1 (- (string-length a) 1)))

(define (pairs->gv-digraph a) "(pair ...) -> string"
  (string-append "digraph {"
    (string-join
      (list-sort string<?
        (map (l (a) (string-append (string-quote (first a)) " -> " (string-quote (tail a)) ";")) a))
      "\n  " (q prefix))
    "\n}"))

(define (prefix-tree->gv-digraph a) "list -> string"
  (pairs->gv-digraph (delete-duplicates (prefix-tree->relations a))))

(define (module-dependencies-tree module match? max-depth)
  "module procedure:{list:module-name -> boolean} integer -> list
   get a list of module dependencies and dependency dependencies"
  (let loop ((module module) (parents (list)) (depth 0))
    (pair module
      (filter-map
        (l (a)
          (and (match? (module-name a))
            (if (contains? parents a) a
              (if (>= depth max-depth) a
                (let (b (loop a (pair a parents) (+ 1 depth))) (if (= 1 (length b)) (first b) b))))))
        (module-dependencies module)))))

(define (module-dependencies->strings strip-prefix no-brackets deps)
  (tree-map-leafs
    (l (a)
      (let*
        ( (a (module-name a))
          (a
            (if strip-prefix
              (or
                (any (l (b) (and (list-prefix? a b) (> (length a) 1) (drop a (length b))))
                  strip-prefix)
                a)
              a))
          (a (any->string a)) (a (if no-brackets (string-trim-round-brackets a) a)))
        a))
    deps))

(define
  (display-module-dependencies name format include exclude strip-prefix no-brackets max-depth)
  "(symbol ...) symbol false/(symbol:name-prefix ...) false/(symbol:name-prefix ...) false/(symbol:name-prefix ...) boolean integer -> unspecified"
  (let
    ( (match?
        (l (a) "(symbol ...) -> boolean. filter modules to include"
          (and (or (not include) (any (l (b) (list-prefix? a b)) include))
            (or (not exclude) (not (any (l (b) (list-prefix? a b)) exclude))))))
      (display-dependencies
        (l (deps)
          (display-line
            (case format
              ((indent) (prefix-tree->indent-tree (tail deps)))
              ((graphviz) (prefix-tree->gv-digraph (list deps))))))))
    (display-dependencies
      (module-dependencies->strings strip-prefix no-brackets
        (module-dependencies-tree (resolve-module name) match? max-depth)))))

(define (module-list-argument a) "string -> ((symbol ...) ...)"
  (and a (map string->datum (string-split a #\,))))

(define cli
  (cli-create #:description guile-module-dependencies-description
    #:options
    (q
      ( ( (name)) (format #:value-required? #t #:description "indent or graphviz (dot language)")
        (include #:value-required? #t #:description "prefixes to include, \"(a b),(c)\"")
        (exclude #:value-required? #t #:description "prefixes to exclude")
        (max-depth #:value-required? #t) (strip-prefix #:value-required? #t) (no-brackets)))))

(define (guile-module-dependencies options)
  (alist-bind options (name format include exclude strip-prefix no-brackets max-depth)
    (if name
      (let
        ( (name (string->datum name)) (format (if format (string->symbol format) (q indent)))
          (include (module-list-argument include)) (exclude (module-list-argument exclude))
          (strip-prefix (module-list-argument strip-prefix))
          (max-depth (if max-depth (string->number max-depth) (inf))))
        (display-module-dependencies name format include exclude strip-prefix no-brackets max-depth))
      (cli (list "--help")))))

(guile-module-dependencies (cli))