commit 6a82e8ad5c44b3d93d46ddf1435abf7d80c5fd21 from: mtmn date: Sun Aug 23 20:33:51 2026 UTC init commit - /dev/null commit + 6a82e8ad5c44b3d93d46ddf1435abf7d80c5fd21 blob - /dev/null blob + 2447609dbb04bc1136d075e148ea2d181003f9ea (mode 644) --- /dev/null +++ .gitignore @@ -0,0 +1,2 @@ +/build/ +/src/mcol/*.so blob - /dev/null blob + bd5958dd78c5d3c24a0377bfa5e02d9c0ec13c79 (mode 644) --- /dev/null +++ Makefile @@ -0,0 +1,54 @@ +SCHEME ?= scheme +INPUT ?= $(if $(MCOL_INPUT),$(MCOL_INPUT),.) +PREFIX ?= /usr/local +BINDIR ?= $(PREFIX)/bin +LIBEXECDIR ?= $(PREFIX)/libexec/mcol +MANDIR ?= $(PREFIX)/share/man +LIBDIR = src +RUN = $(SCHEME) --libdirs $(LIBDIR) --program +SOURCES = src/mcol/core.sls src/mcol/tui.sls bin/mcol.ss + +.PHONY: all tui build test install uninstall clean help + +all: build + +tui: + $(RUN) bin/mcol.ss --input "$(INPUT)" + +build: build/mcol.so + +build/mcol.so: $(SOURCES) tools/build.ss + mkdir -p build + $(SCHEME) --libdirs $(LIBDIR) --compile-imported-libraries --program tools/build.ss + +test: + MCOL_INPUT="$(INPUT)" $(RUN) test/test.ss + +install: build/mcol.so + install -d "$(DESTDIR)$(BINDIR)" "$(DESTDIR)$(LIBEXECDIR)/lib/mcol" \ + "$(DESTDIR)$(MANDIR)/man1" + install -m 755 bin/mcol "$(DESTDIR)$(BINDIR)/mcol" + install -m 755 build/mcol.so "$(DESTDIR)$(LIBEXECDIR)/mcol.so" + install -m 644 src/mcol/core.so src/mcol/tui.so "$(DESTDIR)$(LIBEXECDIR)/lib/mcol/" + install -m 644 doc/mcol.1 "$(DESTDIR)$(MANDIR)/man1/mcol.1" + +uninstall: + rm -f "$(DESTDIR)$(BINDIR)/mcol" "$(DESTDIR)$(LIBEXECDIR)/mcol.so" \ + "$(DESTDIR)$(LIBEXECDIR)/lib/mcol/core.so" \ + "$(DESTDIR)$(LIBEXECDIR)/lib/mcol/tui.so" \ + "$(DESTDIR)$(MANDIR)/man1/mcol.1" + +clean: + rm -rf build src/mcol/*.so + +help: + @printf '%s\n' \ + 'make tui Run the ANSI terminal browser' \ + 'make build Compile the Chez Scheme program' \ + 'make test Run fixture and repository tests' \ + 'make install Install mcol and its manual' \ + 'make uninstall Remove installed files' \ + 'make clean Remove generated artifacts' \ + '' \ + 'Variables: INPUT=. SCHEME=scheme PREFIX=/usr/local DESTDIR=' \ + ' BINDIR=PREFIX/bin LIBEXECDIR=PREFIX/libexec/mcol MANDIR=PREFIX/share/man' blob - /dev/null blob + 8283d22422e606634ca60f721913a870e1bac089 (mode 644) --- /dev/null +++ README.md @@ -0,0 +1,54 @@ +# mcol + +Terminal browser for an MPD release archive, written in Chez Scheme. + +Paths are read as: + +- `artist/album` +- `label/artist/release` + +Parent paths are not counted as releases. All recognized files are scanned; no +date cutoff is applied. + +## Run + +Requires Chez Scheme 10.4 or newer. Playback requires `mpc`. + +```sh +make tui INPUT=/path/to/releases +``` + +Input is chosen from `--input`, then `MCOL_INPUT`, then the current directory: + +```sh +export MCOL_INPUT=~/src/mtmn.name/releases +make tui +``` + +## Keys + +```text +m months w weeks l labels +a artists s search r random play +p play release q queue release +nn next page pp prev page b back +? help / filter +``` + +Enter a row number to open it. Commands such as `:month 2026-08`, +`:day 2026-08-11`, `:label Warp`, `:artist Autechre`, and `:search Autechre` +are also accepted. + +Use `p 4 5 2` to append visible releases 4, 5, and 2 and start the first one. +Use `q 4 5 2` to append them without changing playback. + +## Build and install + +```sh +make build +make test INPUT=/path/to/releases +make install # /usr/local +make install PREFIX=~/.local +``` + +See `mcol(1)` after installation. Set `NO_COLOR=1` to disable colour. blob - /dev/null blob + 0aabebd13f3644c1fa945560180f2527a84c8f41 (mode 644) --- /dev/null +++ bin/mcol @@ -0,0 +1,6 @@ +#!/bin/sh +set -eu + +mcol_bin_dir=$(CDPATH= cd -- "$(dirname -- "$0")" && pwd) +mcol_runtime_dir="$mcol_bin_dir/../libexec/mcol" +exec scheme --libdirs "$mcol_runtime_dir/lib" --program "$mcol_runtime_dir/mcol.so" "$@" blob - /dev/null blob + 63a094f0efcff0274c7d0b113ca7eb84f699559e (mode 644) --- /dev/null +++ bin/mcol.ss @@ -0,0 +1,37 @@ +#!/usr/bin/env scheme --program +(import (chezscheme) + (mcol core) + (mcol tui)) + +(define (usage port) + (display "Usage: mcol [--input PATH] [--strict]\n" port) + (display "Input: --input PATH, then MCOL_INPUT, then the current directory.\n" port) + (display "Runs the interactive ANSI terminal browser. Set NO_COLOR=1 to disable color.\n" port)) + +(define arguments (cdr (command-line))) +(define default-input (or (getenv "MCOL_INPUT") ".")) +(define (parse-arguments arguments) + (let loop ([remaining arguments] + [input default-input] + [strict? #f] + [help? #f]) + (cond + [(null? remaining) (values input strict? help?)] + [(string=? (car remaining) "--input") + (if (or (null? (cdr remaining)) + (member (cadr remaining) '("--input" "--strict" "--help" "-h"))) + (error 'mcol "missing value for --input") + (loop (cddr remaining) (cadr remaining) strict? help?))] + [(string=? (car remaining) "--strict") (loop (cdr remaining) input #t help?)] + [(or (string=? (car remaining) "--help") (string=? (car remaining) "-h")) + (loop (cdr remaining) input strict? #t)] + [else (error 'mcol "unknown option" (car remaining))]))) + +(guard (condition (else (display "mcol: " (current-error-port)) + (display-condition condition (current-error-port)) + (newline (current-error-port)) + (exit 1))) + (let-values ([(input strict? help?) (parse-arguments arguments)]) + (if help? + (usage (current-output-port)) + (run-tui (summarize (scan-database input strict?)))))) blob - /dev/null blob + d3f6be58e4c132b824df642eafd4f3215950b56b (mode 644) --- /dev/null +++ doc/mcol.1 @@ -0,0 +1,95 @@ +.TH MCOL 1 "2026-08-12" "mcol" "User Commands" +.SH NAME +mcol \- browse an MPD release archive +.SH SYNOPSIS +.B mcol +.RB [ \-\-input " " PATH ] +.RB [ \-\-strict ] +.SH DESCRIPTION +.B mcol +is a terminal browser for a directory of release lists. +It reads two-part paths as artist/album and longer paths as +label/artist/release. +.PP +The input directory comes from +.BR \-\-input , +.BR MCOL_INPUT , +or the current directory, in that order. +All recognized files are scanned. +Playback uses +.BR mpc (1). +.SH OPTIONS +.TP +.BI \-\-input " PATH" +Read the archive at PATH. +.TP +.B \-\-strict +Fail on malformed historical filenames. +.TP +.BR \-h , " \-\-help" +Print usage. +.SH KEYS +.TP +.BR m , +.BR w , +.BR l , +.B a +Show months, weeks, labels, or artists. +.TP +.B s +Search artists, labels, releases, and paths. +.TP +.B p +Append the selected release to the MPD queue and play its first track. +.B p N ... +does the same for numbered release rows in the given order. +.TP +.B q +Append the selected release to the end of the MPD queue. +.B q N ... +queues numbered release rows in the given order. +.TP +.B NUMBER +Open a row. +.TP +.BR [ , +.B ] +Move between pages. +.TP +.B b +Go back. +.TP +.B /TEXT +Filter the labels or artists list. +.TP +.B ? +Show help. +.TP +.B x +Exit. +.SH COMMANDS +.BR ":month YYYY-MM" , +.BR ":day YYYY-MM-DD" , +.BR ":label NAME" , +.BR ":artist NAME" , +.BR ":release PATH" , +and +.BR ":search QUERY" . +.SH ENVIRONMENT +.TP +.B MCOL_INPUT +Default input directory. +.TP +.B NO_COLOR +Disable colour. +.TP +.B MPD_HOST +MPD server or socket, read by +.BR mpc (1). +.TP +.BR COLUMNS , " LINES" +Override terminal dimensions. +.SH EXIT STATUS +Zero on normal exit, non-zero on error. +.SH SEE ALSO +.BR mpd (1) blob - /dev/null blob + 346232c998df4635eafb80515b5c8c5a405e7d4a (mode 644) --- /dev/null +++ src/mcol/core.sls @@ -0,0 +1,460 @@ +(library + (mcol core) + (export scan-database + summarize + normalize-path + days-in-month + report-ref) + (import (chezscheme)) + (define-record-type entry (fields normalized components)) + (define-record-type source (fields path kind date period-start period-end entries)) + (define-record-type database (fields sources)) + (define (report-ref report key) + (cond + [(assq key report) + => + cdr] + [else #f])) + (define (string-prefix? prefix text) + (and (<= (string-length prefix) (string-length text)) + (string=? prefix (substring text 0 (string-length prefix))))) + (define (string-suffix? suffix text) + (and (<= (string-length suffix) (string-length text)) + (string=? + suffix + (substring text (- (string-length text) (string-length suffix)) (string-length text))))) + (define (split-string text separator) + (let loop ([start 0] + [at 0] + [result '()]) + (cond + [(= at (string-length text)) (reverse (cons (substring text start at) result))] + [(char=? (string-ref text at) separator) + (loop (+ at 1) (+ at 1) (cons (substring text start at) result))] + [else (loop start (+ at 1) result)]))) + (define (join-strings items separator) + (if (null? items) + "" + (let-values ([(port extract) (open-string-output-port)]) + (display (car items) port) + (for-each (lambda (item) + (display separator port) + (display item port)) + (cdr items)) + (extract)))) + (define trim-characters '(#\space #\tab #\newline #\return #\nul)) + (define (trim-line line) + (let loop-left ([left 0]) + (if (and (< left (string-length line)) (memv (string-ref line left) trim-characters)) + (loop-left (+ left 1)) + (let loop-right ([right (string-length line)]) + (if (and (> right left) (memv (string-ref line (- right 1)) trim-characters)) + (loop-right (- right 1)) + (substring line left right)))))) + (define (normalize-path line) + (let* ([trimmed (trim-line line)] + [end (let loop ([n (string-length trimmed)]) + (if (and (> n 0) (char=? (string-ref trimmed (- n 1)) #\/)) + (loop (- n 1)) + n))] + [path (substring trimmed 0 end)]) + (if (or (string=? path "") (string=? path ".")) + (values #f '()) + (let ([parts (split-string path #\/)]) (values (join-strings parts "/") parts))))) + (define (integer-safe text) + (and (> (string-length text) 0) + (for-all char-numeric? (string->list text)) + (string->number text))) + (define (leap-year? year) + (and (= (mod year 4) 0) (or (not (= (mod year 100) 0)) (= (mod year 400) 0)))) + (define (days-in-month year month) + (case month + [(1 3 5 7 8 10 12) 31] + [(4 6 9 11) 30] + [(2) (if (leap-year? year) 29 28)] + [else 0])) + (define (valid-date? year month day) + (and year month day (<= 1 month 12) (<= 1 day (days-in-month year month)))) + (define (date-string year month day) + (format "~4,'0d-~2,'0d-~2,'0d" year month day)) + (define (date<=? a b) + (or (string=? a b) (string + cdr] + [else #f])) + (define (path-join left right) + (cond + [(string=? left "") right] + [(char=? (string-ref left (- (string-length left) 1)) #\/) (string-append left right)] + [else (string-append left "/" right)])) + (define (collect-text-files root) + (let walk ([directory root] + [relative ""] + [result '()]) + (fold-left + (lambda (files name) + (let ([path (path-join directory name)] + [rel (if (string=? relative "") + name + (path-join relative name))]) + (cond + [(and (file-directory? path) + (not (exists (lambda (ignored) (string=? name ignored)) '(".git" "build")))) + (walk path rel files)] + [(and (file-regular? path) (string-suffix? ".txt" name)) (cons (cons path rel) files)] + [else files]))) + result + (directory-list directory)))) + (define (read-lines path) + (guard (condition (else (let* ([port (open-file-input-port path (file-options) 'block #f)] + [bytes (get-bytevector-all port)]) + (close-port port) + (split-string (list->string (map integer->char + (bytevector->u8-list bytes))) + #\newline)))) + (call-with-input-file path + (lambda (port) + (let loop ([lines '()]) + (let ([line (get-line port)]) + (if (eof-object? line) + (reverse lines) + (loop (cons line lines))))))))) + (define (parse-date parts order) + (and (= (length parts) 3) + (let ([year (integer-safe (list-ref parts (vector-ref order 0)))] + [month (integer-safe (list-ref parts (vector-ref order 1)))] + [day (integer-safe (list-ref parts (vector-ref order 2)))]) + (and (valid-date? year month day) (list year month day))))) + (define (parse-iso stem) + (parse-date (split-string stem #\-) '#(0 1 2))) + (define (parse-dmy stem) + (parse-date (split-string stem #\_) '#(2 1 0))) + (define (parse-session stem) + (and (string-prefix? "stdin_playlist_" stem) + (>= (string-length stem) 23) + (let* ([stamp (substring stem 15 23)] + [year (integer-safe (substring stamp 0 4))] + [month (integer-safe (substring stamp 4 6))] + [day (integer-safe (substring stamp 6 8))]) + (and (valid-date? year month day) (list year month day))))) + ;; Returns kind, year, month, day, and ordinal week. + (define (classify relative) + (let* ([parts (split-string relative #\/)] + [file (car (reverse parts))] + [stem (if (string-suffix? ".txt" file) + (substring file 0 (- (string-length file) 4)) + file)]) + (cond + [(string=? relative "all.txt") (values 'catalog #f #f #f #f)] + [(or (< (length parts) 2) (string=? (car parts) "mixes")) (values 'ignored #f #f #f #f)] + [else + (let ([year (integer-safe (car parts))]) + (if (not year) + (values 'ignored #f #f #f #f) + (cond + [(and (= (length parts) 3) (string=? (cadr parts) "dailies")) + (let ([date (or (parse-iso stem) (parse-session stem))]) + (if date + (values (if (string-prefix? "stdin_playlist_" stem) 'session 'daily-fallback) + (car date) + (cadr date) + (caddr date) + #f) + (values 'malformed year #f #f #f)))] + [(>= (length parts) 3) + (let ([month (month-number (cadr parts))]) + (cond + [(and month (>= (length parts) 4) (string=? (caddr parts) "dailies")) + (let ([date (or (parse-iso stem) (parse-dmy stem))]) + (if date + (values 'daily (car date) (cadr date) (caddr date) #f) + (values 'malformed year month #f #f)))] + [(and month (>= (length parts) 4) (string=? (caddr parts) "labels")) + (values 'ignored year month #f #f)] + [(and month (= (length parts) 3)) + (let* ([bits (split-string stem #\_)] + [week (and (= (length bits) 3) (integer-safe (car bits)))]) + (if (and week (<= 1 week 4)) + (values 'weekly year month #f week) + (values 'malformed year month #f #f)))] + [else (values 'ignored year month #f #f)]))] + [else (values 'ignored year #f #f #f)])))]))) + (define (week-period year month week) + (let ([start (case week + [(1) 1] + [(2) 8] + [(3) 15] + [else 22])]) + (values (date-string year month start) + (date-string year + month + (if (= week 4) + (days-in-month year month) + (+ start 6)))))) + (define (lines->entries lines) + (let loop ([remaining lines] + [entries '()]) + (if (null? remaining) + (reverse entries) + (let-values ([(normalized components) (normalize-path (car remaining))]) + (if normalized + (loop (cdr remaining) (cons (make-entry normalized components) entries)) + (loop (cdr remaining) entries)))))) + (define (scan-database root . options) + (unless (file-directory? root) + (error 'scan-database "input is not a directory" root)) + (unless (file-regular? (path-join root "all.txt")) + (error 'scan-database "input does not contain all.txt" root)) + (let ([strict? (and (pair? options) (car options))]) + (let loop ([files (sort (lambda (a b) (stringentries lines)] + [date (and day (date-string year month day))] + [start #f] + [end #f]) + (when week + (let-values ([(s e) (week-period year month week)]) + (set! start s) + (set! end e))) + (loop (cdr files) + (cons (make-source relative kind date start end entries) sources) + (or malformed? (eq? kind 'malformed))))))))))) + (define (sources-of-kind database kind) + (filter (lambda (item) (eq? (source-kind item) kind)) (database-sources database))) + (define (make-string-table) + (make-hashtable string-hash string=?)) + (define (table-keys table) + (vector->list (hashtable-keys table))) + (define (sorted-keys table) + (sort string= n (length parts))) + (hashtable-set! children (join-strings (list-head parts n) "/") #t)))) + unique) + (filter (lambda (item) (not (hashtable-contains? children (entry-normalized item)))) unique))) + (define (leaf-counts entries) + (let ([leaves (terminal-entries entries)]) + (let loop ([remaining leaves] + [single 0] + [two 0] + [three 0]) + (if (null? remaining) + (values leaves single two three) + (case (length (entry-components (car remaining))) + [(1) (loop (cdr remaining) (+ single 1) two three)] + [(2) (loop (cdr remaining) single (+ two 1) three)] + [else (loop (cdr remaining) single two (+ three 1))]))))) + (define (object . pairs) + pairs) + (define (field object + key) + (cond + [(assq key object) + => + cdr] + [else #f])) + (define (entry->item item) + (let ([parts (entry-components item)]) + (cond + [(>= (length parts) 3) + (object (cons 'type "label-release") + (cons 'path (entry-normalized item)) + (cons 'label (car parts)) + (cons 'artist (cadr parts)) + (cons 'release (join-strings (cddr parts) "/")))] + [(= (length parts) 2) + (object (cons 'type "artist-album") + (cons 'path (entry-normalized item)) + (cons 'label #f) + (cons 'artist (car parts)) + (cons 'release (cadr parts)))] + [else + (object (cons 'type "unclassified") + (cons 'path (entry-normalized item)) + (cons 'label #f) + (cons 'artist (car parts)) + (cons 'release #f))]))) + (define (file-summary item) + (let ([leaves (terminal-entries (source-entries item))]) + (object (cons 'source (source-path item)) + (cons 'date (source-date item)) + (cons 'periodStart (source-period-start item)) + (cons 'periodEnd (source-period-end item)) + (cons 'additions + (length (filter (lambda (entry) (>= (length (entry-components entry)) 2)) + leaves))) + (cons 'items (map entry->item leaves))))) + (define (canonical-sources database) + (let ([table (make-string-table)] + [session-counts (make-string-table)]) + (for-each (lambda (item) + (let* ([date (source-date item)] + [current (hashtable-ref table date #f)] + [count (+ 1 (hashtable-ref session-counts date 0))] + [entries (if current + (append (source-entries current) (source-entries item)) + (source-entries item))]) + (hashtable-set! session-counts date count) + (hashtable-set! + table + date + (make-source (format "~a session playlist~a" count (if (= count 1) "" "s")) + 'session + date + #f + #f + entries)))) + (sources-of-kind database 'session)) + ;; A regular daily source is authoritative. Sessions are a fallback for + ;; dates where no daily file exists. + (for-each (lambda (item) (hashtable-set! table (source-date item) item)) + (sources-of-kind database 'daily-fallback)) + (for-each (lambda (item) (hashtable-set! table (source-date item) item)) + (sources-of-kind database 'daily)) + table)) + (define (canonical-days canonical) + (map (lambda (date) (file-summary (hashtable-ref canonical date #f))) (sorted-keys canonical))) + (define (expected-month-days period) + (let ([year (string->number (substring period 0 4))]) + (days-in-month year (string->number (substring period 5 7))))) + (define (aggregate-months days) + (let ([table (make-string-table)]) + (for-each (lambda (day) + (let* ([key (substring (field day + 'date) + 0 + 7)] + [row (hashtable-ref table key #f)]) + (unless row + (set! row + (object (cons 'period key) (cons 'additions 0) (cons 'observedDays 0))) + (hashtable-set! table key row)) + (set-cdr! (assq 'additions row) + (+ (field row + 'additions) + (field day + 'additions))) + (set-cdr! (assq 'observedDays row) + (+ 1 + (field row + 'observedDays))))) + days) + (map (lambda (key) + (let* ([row (hashtable-ref table key #f)] + [expected (expected-month-days key)]) + (append row + (object (cons 'expectedDays expected) + (cons 'coverage + (/ (round (* 1000.0 + (/ (field row + 'observedDays) + (max 1 expected)))) + 10.0)))))) + (sorted-keys table)))) + (define (label-summary canonical) + (let ([counts (make-string-table)]) + (for-each + (lambda (date) + (for-each + (lambda (item) + (let ([parts (entry-components item)]) + (cond + [(>= (length parts) 3) + (hashtable-set! counts (car parts) (+ 1 (hashtable-ref counts (car parts) 0)))] + [(= (length parts) 2) + (hashtable-set! counts + "(artist / album)" + (+ 1 (hashtable-ref counts "(artist / album)" 0)))]))) + (terminal-entries (source-entries (hashtable-ref canonical date #f))))) + (table-keys canonical)) + (sort (lambda (a b) + (> (field a + 'count) + (field b + 'count))) + (map (lambda (key) (object (cons 'name key) (cons 'count (hashtable-ref counts key 0)))) + (table-keys counts))))) + (define (weekly-summary database days) + (map (lambda (item) + (let* ([row (file-summary item)] + [daily-total (fold-left (lambda (sum day) + (if (and (date<=? (source-period-start item) + (field day + 'date)) + (date<=? (field day + 'date) + (source-period-end item))) + (+ sum + (field day + 'additions)) + sum)) + 0 + days)]) + (append row (object (cons 'dailyAdditions daily-total))))) + (sources-of-kind database 'weekly))) + (define (summarize database) + (let* ([canonical (canonical-sources database)] + [days (canonical-days canonical)]) + (let* ([catalog-sources (sources-of-kind database 'catalog)] + [catalog-source (and (pair? catalog-sources) (car catalog-sources))] + [catalog (if catalog-source + (source-entries catalog-source) + '())]) + (let-values ([(leaves single two three) (leaf-counts catalog)]) + (object (cons 'current + (object (cons 'paths (length (unique-entries catalog))) + (cons 'roots + (length (filter (lambda (item) + (= (length (entry-components item)) 1)) + catalog))) + (cons 'single single) + (cons 'artistAlbums two) + (cons 'labelReleases three) + (cons 'terminalAdditions (+ two three)))) + (cons 'catalog (map entry->item leaves)) + (cons 'days days) + (cons 'months (aggregate-months days)) + (cons 'weeks (weekly-summary database days)) + (cons 'labels (label-summary canonical)))))))) blob - /dev/null blob + 42ac9878c65171a6ebc00b799178faead66c7330 (mode 644) --- /dev/null +++ src/mcol/tui.sls @@ -0,0 +1,914 @@ +(library + (mcol tui) + (export run-tui) + (import (chezscheme) + (mcol core)) + (define esc (string (integer->char 27))) + (define color? (not (getenv "NO_COLOR"))) + (define (ansi code text) + (if color? + (string-append esc "[" code "m" text esc "[0m") + text)) + (define (cyan text) + (ansi "38;2;155;246;255" text)) + (define (blue text) + (ansi "38;2;155;177;255" text)) + (define (green text) + (ansi "38;2;202;255;191" text)) + (define (yellow text) + (ansi "38;2;253;255;182" text)) + (define (purple text) + (ansi "38;2;255;198;255" text)) + (define (muted text) + (ansi "38;2;108;117;125" text)) + (define (intense text) + (ansi "1;38;2;248;249;250" text)) + (define (clear-screen) + (display esc) + (display "[2J") + (display esc) + (display "[H")) + (define (field object + key) + (report-ref object key)) + (define (string-prefix? prefix text) + (and (<= (string-length prefix) (string-length text)) + (string=? prefix (substring text 0 (string-length prefix))))) + (define (fmt number) + (format "~:d" (or number 0))) + (define (string-contains? text query) + (let ([text (string-downcase text)] + [query (string-downcase query)]) + (let loop ([at 0]) + (cond + [(= (string-length query) 0) #t] + [(> (+ at (string-length query)) (string-length text)) #f] + [(string=? query (substring text at (+ at (string-length query)))) #t] + [else (loop (+ at 1))])))) + (define (string-suffix? suffix text) + (and (<= (string-length suffix) (string-length text)) + (string=? + suffix + (substring text (- (string-length text) (string-length suffix)) (string-length text))))) + (define (trim-newlines text) + (let loop ([end (string-length text)]) + (if (and (> end 0) (memv (string-ref text (- end 1)) '(#\newline #\return))) + (loop (- end 1)) + (substring text 0 end)))) + (define (line-count text) + (let ([text (trim-newlines text)]) + (if (string=? text "") + 0 + (+ 1 + (fold-left (lambda (count character) + (if (char=? character #\newline) + (+ count 1) + count)) + 0 + (string->list text)))))) + (define (shell-quote text) + (let-values ([(port extract) (open-string-output-port)]) + (display "'" port) + (for-each (lambda (character) + (if (char=? character #\') + (display "'\\''" port) + (write-char character port))) + (string->list text)) + (display "'" port) + (extract))) + (define command-marker "__MCOL_COMMAND_OK__") + (define (run-command command) + (let* ([ports (process (string-append command " 2>&1 && printf '\\n" command-marker "'"))] + [input (car ports)] + [output (cadr ports)]) + (close-output-port output) + (let* ([result (get-string-all input)] + [success? (string-suffix? command-marker result)] + [payload + (if success? + (substring result 0 (- (string-length result) (string-length command-marker))) + result)]) + (close-input-port input) + (values success? (trim-newlines payload))))) + (define (clip text width) + (cond + [(<= width 0) ""] + [(<= (string-length text) width) text] + [(<= width 1) (substring text 0 width)] + [else (string-append (substring text 0 (- width 1)) "…")])) + (define (pad text width) + (let ([text (clip text width)]) + (string-append text (make-string (max 0 (- width (string-length text))) #\space)))) + (define (terminal-width) + (let ([value (and (getenv "COLUMNS") (string->number (getenv "COLUMNS")))]) + (max 60 (min 160 (or value 100))))) + (define (terminal-lines) + (let ([value (and (getenv "LINES") (string->number (getenv "LINES")))]) + (max 12 (- (or value 30) 12)))) + (define (rule) + (display (muted (make-string (terminal-width) #\─))) + (newline)) + (define (unique-by-path items) + (let ([seen (make-hashtable string-hash string=?)]) + (filter (lambda (item) + (let ([path (field item + 'path)]) + (if (hashtable-contains? seen path) + #f + (begin + (hashtable-set! seen path #t) + #t)))) + items))) + (define-record-type row (fields label action path)) + (define (run-tui report) + (let* ([months (or (field report + 'months) + '())] + [days (or (field report + 'days) + '())] + [weeks (or (field report + 'weeks) + '())] + [labels (or (field report + 'labels) + '())] + [catalog (or (field report + 'catalog) + '())] + [events (apply append + (map (lambda (day) + (map (lambda (item) + (append item + (list (cons 'date + (field day + 'date))))) + (or (field day + 'items) + '()))) + days))] + [screen 'months] + [value #f] + [trail '()] + [page 0] + [query ""] + [status-message ""] + [status-error? #t] + [current-actions '()] + [running? #t]) + + (define (open next . argument) + (set! trail (cons (cons screen value) trail)) + (set! screen next) + (set! value (and (pair? argument) (car argument))) + (set! page 0) + (set! query "")) + (define (root next) + (set! trail '()) + (set! screen next) + (set! value #f) + (set! page 0) + (set! query "")) + (define (back) + (when (pair? trail) + (set! screen (caar trail)) + (set! value (cdar trail)) + (set! trail (cdr trail)) + (set! page 0) + (set! query ""))) + (define (link label + action) + (make-row label action #f)) + (define (release-link label path) + (make-row label (lambda () (open 'release path)) path)) + (define (plain label) + (make-row label #f #f)) + (define (status! message error?) + (set! status-message message) + (set! status-error? error?)) + (define (add-releases paths) + (let loop ([remaining paths]) + (if (null? remaining) + #t + (let-values ([(added? error) + (run-command (string-append "mpc --quiet add -- " + (shell-quote (car remaining))))]) + (if added? + (loop (cdr remaining)) + (begin + (status! (if (string=? error "") "could not add release" error) #t) + #f)))))) + (define (queue-releases paths) + (when (add-releases paths) + (status! (format "queued ~a release~a" (length paths) (if (= (length paths) 1) "" "s")) + #f))) + (define (play-releases paths) + (let-values ([(listed? listing) (run-command "mpc --format '%position%' playlist")]) + (if (not listed?) + (status! (if (string=? listing "") "could not read MPD queue" listing) #t) + (let ([position (+ 1 (line-count listing))]) + (when (add-releases paths) + (let-values ([(played? play-error) (run-command (format "mpc --quiet play ~a" + position))]) + (if played? + (status! (format "playing ~a release~a from queue position ~a" + (length paths) + (if (= (length paths) 1) "" "s") + position) + #f) + (status! (if (string=? play-error "") + "release queued, but playback failed" + play-error) + #t)))))))) + (define (unique-strings items) + (let ([seen (make-hashtable string-hash string=?)]) + (filter (lambda (item) + (if (hashtable-contains? seen item) + #f + (begin + (hashtable-set! seen item #t) + #t))) + items))) + (define dates-by-path + (let ([index (make-hashtable string-hash string=?)]) + (for-each (lambda (item) + (let* ([path (field item + 'path)] + [dates (hashtable-ref index path #f)]) + (unless dates + (set! dates (make-hashtable string-hash string=?)) + (hashtable-set! index path dates)) + (hashtable-set! dates + (field item + 'date) + #t))) + events) + index)) + (define (dates-for path) + (let ([dates (hashtable-ref dates-by-path path #f)]) + (if dates + (sort stringlist (hashtable-keys dates))) + '()))) + (define (find-day date) + (find (lambda (day) + (string=? date + (field day + 'date))) + days)) + (define (find-week source) + (find (lambda (week) + (string=? source + (field week + 'source))) + weeks)) + (define (ascii-spark rows key) + (let* ([glyphs '#(#\▁ #\▂ #\▃ #\▄ #\▅ #\▆ #\▇ #\█)] + [maximum (max 1 + (fold-left max + 0 + (map (lambda (row) + (field row + key)) + rows)))]) + (list->string (map (lambda (row) + (vector-ref glyphs + (min 7 + (inexact->exact (floor (* 7 + (/ (field row + key) + maximum))))))) + rows)))) + (define search-items (unique-by-path (append catalog events))) + (define (remove-at items index) + (let loop ([items items] [index index] [result '()]) + (if (= index 0) + (append (reverse result) (cdr items)) + (loop (cdr items) (- index 1) (cons (car items) result))))) + (define (random-releases count) + (let loop ([available search-items] [count count] [result '()]) + (if (= count 0) + (reverse result) + (let ([index (random (length available))]) + (loop (remove-at available index) + (- count 1) + (cons (field (list-ref available index) 'path) result)))))) + (define items-by-path + (let ([index (make-hashtable string-hash string=?)]) + (for-each (lambda (item) + (hashtable-set! index + (field item + 'path) + item)) + search-items) + index)) + (define (artist-index) + (let ([table (make-hashtable string-hash string=?)]) + (for-each (lambda (item) + (let* ([artist (field item + 'artist)] + [paths (and artist (hashtable-ref table artist #f))]) + (when artist + (unless paths + (set! paths (make-hashtable string-hash string=?)) + (hashtable-set! table artist paths)) + (hashtable-set! paths + (field item + 'path) + #t)))) + search-items) + (sort (lambda (a b) + (or (> (cdr a) (cdr b)) (and (= (cdr a) (cdr b)) (stringlist (hashtable-keys table)))))) + + (define artists (artist-index)) + + (define (search-match? item needle) + (exists (lambda (key) + (let ([candidate (field item + key)]) + (and candidate (string-contains? candidate needle)))) + '(artist label release path))) + (define (search-rank item needle) + (let ([needle (string-downcase needle)]) + (define (exact? key) + (let ([candidate (field item + key)]) + (and candidate (string=? (string-downcase candidate) needle)))) + (define (prefix? key) + (let ([candidate (field item + key)]) + (and candidate (string-prefix? needle (string-downcase candidate))))) + (cond + [(or (exact? 'artist) (exact? 'label) (exact? 'release)) 0] + [(prefix? 'artist) 1] + [(and (field item + 'artist) + (string-contains? (field item + 'artist) + needle)) + 2] + [(prefix? 'release) 3] + [(and (field item + 'release) + (string-contains? (field item + 'release) + needle)) + 4] + [(prefix? 'label) 5] + [(and (field item + 'label) + (string-contains? (field item + 'label) + needle)) + 6] + [else 7]))) + + ;; Index path trigrams once. The path already contains label, artist, and + ;; release; field verification below eliminates false positives. + (define (n-grams text width) + (let ([text (string-downcase text)]) + (let loop ([at 0] + [result '()]) + (if (> (+ at width) (string-length text)) + (reverse result) + (loop (+ at 1) (cons (substring text at (+ at width)) result)))))) + (define (release-action action) + (cond + [(not (eq? screen 'release)) (status! "open a release first" #t)] + [(not (hashtable-contains? items-by-path value)) (status! "release not found" #t)] + [else (action (list value))])) + (define (words text) + (let loop ([characters (string->list text)] + [word '()] + [result '()]) + (cond + [(null? characters) + (reverse (if (null? word) + result + (cons (list->string (reverse word)) result)))] + [(char-whitespace? (car characters)) + (loop (cdr characters) + '() + (if (null? word) + result + (cons (list->string (reverse word)) result)))] + [else (loop (cdr characters) (cons (car characters) word) result)]))) + (define (batch-release-action verb arguments action) + (let ([numbers (map string->number arguments)]) + (cond + [(null? arguments) (release-action action)] + [(exists (lambda (number) (or (not number) (not (integer? number)))) numbers) + (status! (string-append verb " expects row numbers") #t)] + [(exists (lambda (number) (not (<= 1 number (length current-actions)))) numbers) + (status! "row number out of range" #t)] + [else + (let ([rows (map (lambda (number) (list-ref current-actions (- number 1))) numbers)]) + (if (exists (lambda (item) (not (row-path item))) rows) + (status! "all selected rows must be releases" #t) + (action (map row-path rows))))]))) + (define search-index + (let ([index (make-hashtable string-hash string=?)]) + (for-each + (lambda (item) + (for-each (lambda (gram) + (hashtable-set! index gram (cons item (hashtable-ref index gram '())))) + (unique-strings (n-grams (field item + 'path) + 3)))) + search-items) + index)) + (define (search-candidates needle) + (let* ([needle (string-downcase needle)] + [grams (unique-strings (n-grams needle 3))] + [postings (map (lambda (gram) (hashtable-ref search-index gram #f)) grams)]) + (cond + [(< (string-length needle) 3) + (filter (lambda (item) (search-match? item needle)) search-items)] + [(exists not postings) '()] + [else + (filter (lambda (item) (search-match? item needle)) + (fold-left (lambda (shortest items) + (if (< (length items) (length shortest)) items shortest)) + (car postings) + (cdr postings)))]))) + + (define (item-line item suffix) + (let* ([width (terminal-width)] + [artist-width (max 14 (quotient width 4))] + [label-width (max 12 (quotient width 5))] + [release-width (max 16 (- width artist-width label-width 17))]) + (string-append (pad (or (field item + 'artist) + "—") + artist-width) + " " + (pad (or (field item + 'release) + (field item + 'path)) + release-width) + " " + (pad (or (field item + 'label) + "[no label]") + label-width) + (if suffix + (string-append " " suffix) + "")))) + + ;; Each view returns informational lines and selectable rows. + (define (view-months) + (let* ([current (field report + 'current)] + [info (list (format "paths ~a releases ~a" + (fmt (field current + 'paths)) + (fmt (field current + 'terminalAdditions))) + (string-append (blue (ascii-spark months 'additions)) + " additions / month"))]) + (values info + (map (lambda (month) + (let ([period (field month + 'period)]) + (link (format "~a ~8a additions ~a/~a days ~a% coverage" + (pad period 8) + (fmt (field month + 'additions)) + (field month + 'observedDays) + (field month + 'expectedDays) + (field month + 'coverage)) + (lambda () (open 'month period))))) + months)))) + + (define (view-month) + (let* ([month-days (filter (lambda (day) + (string-prefix? value + (field day + 'date))) + days)] + [info (list (string-append (blue (ascii-spark month-days 'additions)) + " additions / observed day"))]) + (values info + (map (lambda (day) + (link (format "~a ~5a additions ~a" + (field day + 'date) + (field day + 'additions) + (field day + 'source)) + (lambda () + (open 'day + (field day + 'date))))) + month-days)))) + + (define (view-day) + (let ([day (find-day value)]) + (if (not day) + (values (list "day not found") '()) + (values (list (format "~a additions // ~a" + (field day + 'additions) + (field day + 'source))) + (map (lambda (item) + (release-link (item-line item #f) + (field item + 'path))) + (or (field day + 'items) + '())))))) + + (define (view-weeks) + (values (list "weekly source / daily aggregate // compared, never combined") + (map (lambda (week) + (link (format "~a..~a weekly ~6a daily ~6a ~a" + (field week + 'periodStart) + (field week + 'periodEnd) + (field week + 'additions) + (field week + 'dailyAdditions) + (field week + 'source)) + (lambda () + (open 'week + (field week + 'source))))) + weeks))) + + (define (view-week) + (let ([week (find-week value)]) + (if (not week) + (values (list "week not found") '()) + (values (list (format "~a..~a // ~a additions // ~a" + (field week + 'periodStart) + (field week + 'periodEnd) + (field week + 'additions) + (field week + 'source))) + (map (lambda (item) + (release-link (item-line item #f) + (field item + 'path))) + (or (field week + 'items) + '())))))) + + (define (view-labels) + (let ([visible (filter (lambda (item) + (string-contains? (field item + 'name) + query)) + labels)]) + (values (list (format "~a labels~a" + (length visible) + (if (string=? query "") + "" + (string-append " matching “" query "”")))) + (map (lambda (item) + (let ([name (field item + 'name)]) + (link (format "~a ~a additions" + (pad name (- (terminal-width) 24)) + (fmt (field item + 'count))) + (lambda () (open 'label name))))) + visible)))) + + (define (view-label) + (let* ([matches? (lambda (item) + (if (string=? value "(artist / album)") + (string=? (field item + 'type) + "artist-album") + (equal? value + (field item + 'label))))] + [items (unique-by-path (append (filter matches? catalog) (filter matches? events)))] + [artists (unique-strings (map (lambda (item) + (field item + 'artist)) + items))]) + (values (list (format "~a releases // ~a artists" (length items) (length artists))) + (map (lambda (item) + (release-link (item-line item + (let ([dates (dates-for (field item + 'path))]) + (if (null? dates) + "catalog" + (car dates)))) + (field item + 'path))) + items)))) + + (define (view-artists) + (let ([visible (filter (lambda (item) (string-contains? (car item) query)) artists)]) + (values (list (format "~a artists~a" + (length visible) + (if (string=? query "") + "" + (string-append " matching “" query "”")))) + (map (lambda (item) + (let ([name (car item)]) + (link (format "~a ~a releases" + (pad name (- (terminal-width) 23)) + (fmt (cdr item))) + (lambda () (open 'artist name))))) + visible)))) + + (define (view-artist) + (let ([items (unique-by-path (filter (lambda (item) + (equal? value + (field item + 'artist))) + (append catalog events)))]) + (values (list (format "~a releases" (length items))) + (map (lambda (item) + (release-link (item-line item + (let ([dates (dates-for (field item + 'path))]) + (if (null? dates) + "catalog" + (car dates)))) + (field item + 'path))) + items)))) + + (define (view-search) + (let ([items (sort (lambda (left right) + (let ([left-rank (search-rank left value)] + [right-rank (search-rank right value)]) + (or (< left-rank right-rank) + (and (= left-rank right-rank) + (string-cistring (car item)))) + items) + " / "))) + (define (string-join items separator) + (if (null? items) + "" + (fold-left (lambda (result item) (string-append result separator item)) + (car items) + (cdr items)))) + + (define (render) + (clear-screen) + (display (intense "mcol")) + (display (muted " release database // all sources")) + (newline) + (display + (muted "[m]onths [w]eeks [l]abels [a]rtists [s]earch [p]lay [q]ueue [r]random [?]help [x]exit")) + (newline) + (rule) + (display (muted (string-append "~/" (crumbs)))) + (newline) + (display (cyan "mcol> ")) + (display (intense (symbol->string screen))) + (when value + (display " ") + (display (purple (format "~a" value)))) + (newline) + (let-values ([(info rows) (current-view)]) + (for-each (lambda (line) + (display line) + (newline)) + info) + (when (pair? info) + (newline)) + (let* ([page-size (terminal-lines)] + [page-count (max 1 (inexact->exact (ceiling (/ (length rows) page-size))))] + [safe-page (min page (- page-count 1))] + [start (* safe-page page-size)] + [visible (list-head (list-tail rows start) + (min page-size (- (length rows) start)))]) + (set! page safe-page) + (set! current-actions visible) + (let loop ([items visible] + [number 1]) + (unless (null? items) + (let ([item (car items)]) + (if (row-action item) + (begin + (display (cyan (format "[~2d] " number))) + (display (blue (row-label item)))) + (begin + (display (muted " · ")) + (display (row-label item)))) + (newline) + (loop (cdr items) (+ number 1))))) + (when (> page-count 1) + (newline) + (display (muted (format "page ~a/~a // nn next // pp previous" (+ page 1) page-count))) + (newline)))) + (when (not (string=? status-message "")) + (newline) + (display ((if status-error? yellow green) (string-append (if status-error? "[!] " "[+] ") + status-message))) + (newline) + (set! status-message "") + (set! status-error? #t)) + (rule) + (display (cyan ": ")) + (flush-output-port (current-output-port))) + + (define (colon-command input) + (let* ([body (substring input 1 (string-length input))] + [space (string-index body #\space)] + [verb (if space + (substring body 0 space) + body)] + [argument (if space + (substring body (+ space 1) (string-length body)) + "")]) + (cond + [(and (string=? verb "month") (not (string=? argument ""))) (open 'month argument)] + [(and (string=? verb "day") (not (string=? argument ""))) (open 'day argument)] + [(and (string=? verb "label") (not (string=? argument ""))) (open 'label argument)] + [(and (string=? verb "artist") (not (string=? argument ""))) (open 'artist argument)] + [(and (string=? verb "release") (not (string=? argument ""))) (open 'release argument)] + [(and (string=? verb "search") (not (string=? argument ""))) (open 'search argument)] + [else (set! status-message (string-append "unknown command: " input))]))) + (define (string-index text character) + (let loop ([at 0]) + (cond + [(= at (string-length text)) #f] + [(char=? (string-ref text at) character) at] + [else (loop (+ at 1))]))) + + (define (handle input) + (if (eof-object? input) + (set! running? #f) + (let* ([parts (words input)] + [verb (and (pair? parts) (car parts))] + [arguments (if (pair? parts) + (cdr parts) + '())]) + (cond + [(string=? input "") #f] + [(string=? input "x") (set! running? #f)] + [(string=? input "?") (open 'help)] + [(string=? input "b") (back)] + [(string=? input "m") (root 'months)] + [(string=? input "w") (root 'weeks)] + [(string=? input "l") (root 'labels)] + [(string=? input "a") (root 'artists)] + [(string=? input "r") + (display (purple "random releases [5]> ")) + (flush-output-port (current-output-port)) + (let ([answer (get-line (current-input-port))]) + (cond + [(eof-object? answer) (set! running? #f)] + [(string=? answer "") (play-releases (random-releases 5))] + [else + (let ([count (string->number answer)]) + (cond + [(or (not count) (not (integer? count)) (<= count 0)) + (set! status-message "random play expects a positive number")] + [(> count (length search-items)) + (set! status-message (format "only ~a releases available" (length search-items)))] + [else (play-releases (random-releases count))]))]))] + [(string=? verb "p") (batch-release-action "p" arguments play-releases)] + [(string=? verb "q") (batch-release-action "q" arguments queue-releases)] + [(string=? input "s") + (display (purple "search> ")) + (flush-output-port (current-output-port)) + (let ([needle (get-line (current-input-port))]) + (cond + [(eof-object? needle) (set! running? #f)] + [(string=? needle "") (set! status-message "search query cannot be empty")] + [else (open 'search needle)]))] + [(string=? input "nn") (set! page (+ page 1))] + [(string=? input "pp") (set! page (max 0 (- page 1)))] + [(and (> (string-length input) 1) (char=? (string-ref input 0) #\/)) + (set! query (substring input 1 (string-length input))) + (set! page 0)] + [(and (> (string-length input) 1) (char=? (string-ref input 0) #\:)) + (colon-command input)] + [(string->number input) + => + (lambda (number) + (if (and (integer? number) + (<= 1 number (length current-actions)) + (row-action (list-ref current-actions (- number 1)))) + ((row-action (list-ref current-actions (- number 1)))) + (set! status-message "no selectable row with that number")))] + [else (set! status-message (string-append "unknown input: " input))])))) + + (dynamic-wind (lambda () + (display esc) + (display "[?1049h") + (display esc) + (display "[?25h")) + (lambda () + (let loop () + (when running? + (render) + (handle (get-line (current-input-port))) + (loop)))) + (lambda () + (display esc) + (display "[0m") + (display esc) + (display "[?1049l") + (display "mcol: bye") + (newline)))))) blob - /dev/null blob + a13565512953dcf6c09df4dc49b0a90e039ce9a5 (mode 644) --- /dev/null +++ test/test.ss @@ -0,0 +1,140 @@ +(import (chezscheme) + (mcol core)) + +(define checks 0) +(define (check value message) + (set! checks (+ checks 1)) + (unless value + (error 'mcol-test message))) + +(define (field object + key) + (report-ref object key)) + +(define (mkdir-p path) + (let ([parts (filter + (lambda (part) (not (string=? part ""))) + (let loop ([start 0] + [at 0] + [result '()]) + (cond + [(= at (string-length path)) (reverse (cons (substring path start at) result))] + [(char=? (string-ref path at) #\/) + (loop (+ at 1) (+ at 1) (cons (substring path start at) result))] + [else (loop start (+ at 1) result)])))]) + (let loop ([parts parts] + [current (if (char=? (string-ref path 0) #\/) "/" "")]) + (unless (null? parts) + (let ([next (if (or (string=? current "") (string=? current "/")) + (string-append current (car parts)) + (string-append current "/" (car parts)))]) + (unless (file-exists? next) + (mkdir next)) + (loop (cdr parts) next)))))) + +(define (write-lines root relative lines) + (let* ([path (string-append root "/" relative)] + [slash (let loop ([n (- (string-length path) 1)]) + (cond + [(< n 0) #f] + [(char=? (string-ref path n) #\/) n] + [else (loop (- n 1))]))]) + (mkdir-p (substring path 0 slash)) + (call-with-output-file path + (lambda (port) + (for-each (lambda (line) + (display line port) + (newline port)) + lines)) + 'replace))) + +(define (fixture-test) + (let ([root (format "/tmp/mcol-test-~a" (time-nanosecond (current-time)))]) + (mkdir-p root) + (write-lines root "all.txt" '("Label/Artist/Release" "Artist/Album" "Solo")) + (write-lines root + "2026/may/dailies/2026-05-02.txt" + '("Label" "Label/Artist" "Label/Artist/Release/" "Artist" "Artist/Album" "." "")) + (write-lines root "2026/dailies/2026-05-02.txt" '("Wrong/Fallback")) + (write-lines root "2026/may/1_05_2026.txt" '("Label/Artist/Release" "Artist/Album")) + (write-lines root "2026/may/labels/1_05_2026_labels.txt" '("Label")) + (write-lines root "2026/may/dailies/2026-05-20.txt" '("Future/Album")) + (write-lines root "2026/dailies/stdin_playlist_20260521_120000.txt" '("Session/One")) + (write-lines root "2026/dailies/stdin_playlist_20260521_130000.txt" '("Session/Two")) + (write-lines root "2026/may/not-a-week.txt" '("Malformed/Source")) + (let* ([database (scan-database root)] + [report (summarize database)] + [current (field report + 'current)] + [days (field report + 'days)]) + (check (= 1 + (field current + 'labelReleases)) + "three-part classification") + (check (= 1 + (field current + 'artistAlbums)) + "two-part classification") + (check (= 1 + (field current + 'single)) + "single classification") + (check (= 3 (length days)) "all dated sources scanned") + (check (string=? "2026-05-20" + (field (cadr days) + 'date)) + "later date retained") + (check (= 2 + (field (car days) + 'additions)) + "parents excluded") + (check (string=? (field (car days) + 'source) + "2026/may/dailies/2026-05-02.txt") + "month-local source precedence") + (check (= 2 + (length (field (car days) + 'items))) + "day exposes selectable releases") + (check (= 3 + (length (field report + 'catalog))) + "catalog exposes terminal records") + (check (= 2 + (field (caddr days) + 'additions)) + "same-day session sources merged") + (check (string=? "2 session playlists" + (field (caddr days) + 'source)) + "session fallback source shown")) + (check (guard (condition (else #t)) (scan-database root #t) #f) + "strict scan rejects malformed filenames"))) + +(define (utility-test) + (let-values ([(path parts) (normalize-path " Label/Artist/Release/ ")]) + (check (string=? path "Label/Artist/Release") "trailing slash normalization") + (check (= 3 (length parts)) "component parsing")) + (check (= 29 (days-in-month 2024 2)) "leap year") + (check (= 28 (days-in-month 2025 2)) "common year")) + +(define (repository-test) + (let ([root (or (getenv "MCOL_INPUT") ".")]) + (when (file-exists? (string-append root "/all.txt")) + (let* ([report (summarize (scan-database root))] + [current (field report + 'current)]) + (check (= 48572 + (field current + 'paths)) + "repository paths") + (check (= 7057 + (field current + 'roots)) + "repository roots"))))) + +(utility-test) +(fixture-test) +(repository-test) +(format #t "mcol: ~a checks passed~%" checks) blob - /dev/null blob + 6b08df305bc5c334dccd98ab75fceecc8566d2b5 (mode 644) --- /dev/null +++ tools/build.ss @@ -0,0 +1,2 @@ +(import (chezscheme)) +(compile-program "bin/mcol.ss" "build/mcol.so")