commit - /dev/null
commit + 6a82e8ad5c44b3d93d46ddf1435abf7d80c5fd21
blob - /dev/null
blob + 2447609dbb04bc1136d075e148ea2d181003f9ea (mode 644)
--- /dev/null
+++ .gitignore
+/build/
+/src/mcol/*.so
blob - /dev/null
blob + bd5958dd78c5d3c24a0377bfa5e02d9c0ec13c79 (mode 644)
--- /dev/null
+++ Makefile
+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
+# 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
+#!/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
+#!/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
+.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
+(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<? a b)))
+ (define month-names
+ '(("january" . 1) ("february" . 2)
+ ("march" . 3)
+ ("april" . 4)
+ ("may" . 5)
+ ("june" . 6)
+ ("july" . 7)
+ ("august" . 8)
+ ("september" . 9)
+ ("october" . 10)
+ ("november" . 11)
+ ("december" . 12)))
+ (define (month-number name)
+ (cond
+ [(assoc (string-downcase name) month-names)
+ =>
+ 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) (string<? (cdr a) (cdr b))) (collect-text-files root))]
+ [sources '()]
+ [malformed? #f])
+ (if (null? files)
+ (begin
+ (when (and strict? malformed?)
+ (error 'scan-database "strict scan found malformed filenames"))
+ (make-database (reverse sources)))
+ (let* ([file (car files)]
+ [path (car file)]
+ [relative (cdr file)])
+ (let-values ([(kind year month day week) (classify relative)])
+ (if (memq kind '(ignored malformed))
+ (loop (cdr files) sources (or malformed? (eq? kind 'malformed)))
+ (let* ([lines (read-lines path)]
+ [entries (lines->entries 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<? (table-keys table)))
+ (define (unique-entries entries)
+ (let ([seen (make-string-table)])
+ (filter (lambda (item)
+ (if (hashtable-contains? seen (entry-normalized item))
+ #f
+ (begin
+ (hashtable-set! seen (entry-normalized item) #t)
+ #t)))
+ entries)))
+ (define (terminal-entries entries)
+ (let ([children (make-string-table)]
+ [unique (unique-entries entries)])
+ (for-each (lambda (item)
+ (let ([parts (entry-components item)])
+ (do ((n 1 (+ n 1)))
+ ((>= 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
+(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 string<? (vector->list (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)) (string<? (car a) (car b)))))
+ (map (lambda (name)
+ (cons name (vector-length (hashtable-keys (hashtable-ref table name #f)))))
+ (vector->list (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-ci<? (field left
+ 'path)
+ (field right
+ 'path))))))
+ (search-candidates value))])
+ (values (list (format "~a result~a matching “~a” // artist, label, album/release"
+ (length items)
+ (if (= (length items) 1) "" "s")
+ value))
+ (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-release)
+ (let* ([item (hashtable-ref items-by-path value #f)]
+ [dates (dates-for value)])
+ (if (not item)
+ (values (list "release not found") '())
+ (values (list (string-append "path "
+ (field item
+ 'path))
+ (string-append "shape "
+ (field item
+ 'type)))
+ (append (list (link (string-append "artist "
+ (or (field item
+ 'artist)
+ "—"))
+ (lambda ()
+ (open 'artist
+ (field item
+ 'artist)))))
+ (if (field item
+ 'label)
+ (list (link (string-append "label "
+ (field item
+ 'label))
+ (lambda ()
+ (open 'label
+ (field item
+ 'label)))))
+ (list (plain "label [no label]")))
+ (map (lambda (date)
+ (link (format "added ~a" date)
+ (lambda () (open 'day date))))
+ dates))))))
+
+ (define (view-help)
+ (values (list "number open row nn/pp next/prev page"
+ "b back m months"
+ "w weeks l labels"
+ "a artists s search r random play"
+ "p [N...] play release(s) q [N...] queue release(s)"
+ "r random play (default: 5 releases)"
+ "/x labels/artists"
+ ":label NAME :artist NAME"
+ ":month YYYY-MM :day YYYY-MM-DD"
+ ":release PATH :search QUERY"
+ "? help x exit")
+ '()))
+
+ (define (current-view)
+ (case screen
+ [(months) (view-months)]
+ [(month) (view-month)]
+ [(day) (view-day)]
+ [(weeks) (view-weeks)]
+ [(week) (view-week)]
+ [(labels) (view-labels)]
+ [(label) (view-label)]
+ [(artists) (view-artists)]
+ [(artist) (view-artist)]
+ [(search) (view-search)]
+ [(release) (view-release)]
+ [else (view-help)]))
+
+ (define (crumbs)
+ (let ([items (reverse (cons (cons screen value) trail))])
+ (string-join (map (lambda (item)
+ (if (cdr item)
+ (format "~a:~a" (car item) (cdr item))
+ (symbol->string (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
+(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
+(import (chezscheme))
+(compile-program "bin/mcol.ss" "build/mcol.so")
