src/thales/prepare.scm

   1 (define-module (thales prepare)
   2     #:export (relpath->module-name
   3               string-starts-with
   4               string-strip-prefix
   5               flatten-file-system-tree
   6               list-modules
   7               check-resolution
   8               perform-configure)
   9     #:use-module (thales core-modules)
  10     #:use-module (thales syntax)
  11     #:use-module (ice-9 match)
  12     #:use-module (ice-9 ftw)
  13     #:use-module (srfi srfi-1))
  14 (use-modules (thales seal))
  15
  16 (sealed string-starts-with
  17         (& "foo" "fo" => #t)
  18         (& "fo" "foo" => #f)
  19         (& "f" #\c   -->))
  20
  21 (define (string-starts-with str prefix)
  22     (define prefix-length (string-length prefix))
  23     (and (>= (string-length str) prefix-length)
  24          (equal? prefix (substring str 0 prefix-length))))
  25
  26 (sealed string-strip-prefix
  27         (& "foo" "f" => "oo")
  28         (& "bar" "f" => "bar"))
  29
  30 (define (string-strip-prefix str prefix)
  31     (if (string-starts-with str prefix)
  32         (substring str (string-length prefix))
  33         str))
  34
  35 (sealed string-empty?
  36         (& "fo" => #f)
  37         (& ""   => #t))
  38 (define (string-empty? str) (equal? str ""))
  39
  40 (sealed relpath->module-name
  41         (& "/foo/bar/baz.scm" => (foo bar baz))
  42         (& "foo/bar/baz"      => (foo bar baz)))
  43 (define* (relpath->module-name path)
  44     (map (compose string->symbol #[basename <> ".scm"])
  45          (filter (negate string-empty?) (string-split path #\/))))
  46
  47 (define (stat-directory? st)
  48     (eq? (stat:type st) 'directory))
  49 (define (stat-regular? st)
  50     (eq? (stat:type st) 'regular))
  51
  52 (sealed have-extension?
  53         (& "foo.foo" ".foo" => #t)
  54         (& "barfoo"  ".foo" => #f))
  55
  56 (define (have-extension? str ext)
  57     (not (equal? str (basename str ext))))
  58
  59 (define (flatten-file-system-tree tree)
  60     (define (flatten1 l) (apply append l))
  61     (map reverse
  62          (let recursive ((prefix '()) (branch tree))
  63              (match branch
  64                     ((name st childs ...)
  65                      (cond
  66                       ((stat-directory? st)
  67                        (flatten1
  68                         (map #[recursive (cons (string->symbol name) prefix) <>]
  69                              childs)))
  70                       ((stat-regular? st)
  71                        (if (have-extension? name ".scm")
  72                            (list (cons (string->symbol (basename name ".scm"))
  73                                        prefix))
  74                            '()))
  75                       (else '())))
  76                     (_ '())))))
  77 (define (list-modules dir)
  78     (map cdr
  79          (flatten-file-system-tree (file-system-tree dir))))
  80
  81
  82 (define (module-resolvable? mod)
  83     (resolve-module mod #:ensure #f))
  84
  85 (define (find-provider modname)
  86     (guile-provides? modname))
  87
  88
  89 (define (check-dependency dep)
  90     (unless (module-resolvable? dep)
  91             (throw 'unresolved-dependency dep))
  92     (find-provider dep))
  93
  94
  95 (define (module-deps modname)
  96     (map module-name (module-uses
  97                       (resolve-module modname
  98                                       #:ensure #f))))
  99
 100 (define* (perform-configure modules #:key (unknown-sourced (const #t)))
 101     (delete-duplicates
 102      (filter symbol?
 103              (apply append
 104                     (for* (mod in modules)
 105                           (format #t "Module ~a.\n" mod)
 106                           (unless (module-resolvable? mod)
 107                                   (throw 'unresolved-module mod))
 108                           (for* (dep in (module-deps mod))
 109                                 (format #t " Checking for ~a... " dep)
 110                                 (if (member dep modules)
 111                                     (format #t "self\n")
 112                                     (let ((provider (check-dependency dep)))
 113                                         (if provider (format #t "~a\n" provider)
 114                                             (begin
 115                                                 (unknown-sourced dep)
 116                                                 (format #t "unknown\n")))
 117                                         provider))))))))