add --query option

quad/fontproof/command.rkt

@@ -1,5 +1,6 @@
 #lang debug racket
 (require racket/logging
+         racket/match
          "main.rkt")
 
 (module+ raco
@@ -25,6 +26,7 @@
   (define output-qml? #false)
   (define make-bold? #false)
   (define make-italic? #false)
+  (define query-mode? #false)
   (define families
     (command-line
      #:program "fontproof"
@@ -53,26 +55,40 @@
                          (set! make-italic? #true)]
      [("-q" "--qml")  "output QML file"
                       (set! output-qml? #true)]
+     [("--query")  "resolve each family name and font path and show status"
+                   (set! query-mode? #true)]
      #:args font-family-names-or-font-paths
      font-family-names-or-font-paths))
   (match families
-    [(? null?) (raise-user-error "no font to proof; exiting")]
+    [(? null?) (raise-user-error "no fonts to proof; exiting")]
     [_ (for ([family (in-list families)])
-            (make-proof family
+            (cond
-                        (or doc (match (current-input-port)
+              [query-mode?
-                                  ;; pull text out of stdin, if any
+               (define status
-                                  ;; use `terminal-port?` to distinguish piped input from tty input
+                 (match family
-                                  [(not (? terminal-port?))
+                   [(? font-path-string? ps)
-                                   (string-join (for/list ([t (in-port read)])
+                    (format (if (file-exists? ps) "found at ~v" "not found at ~v") (path->string (path->complete-path ps)))]
-                                                          (format "~a" t)) " ")]
+                   [_ (match-define-values (trimmed-family bold? italic?) (resolve-family-bold-italic family))
-                                  [_ #false]))
+                      (match ((dynamic-require 'fontland/font-path 'family->path) trimmed-family #:bold bold? #:italic italic?)
-                        #:page-size page-size
+                        [#false "not found among installed fonts"]
-                        #:bold make-bold?
+                        [pth (format "found installed at ~v" pth)])]))
-                        #:italic make-italic?
+               (log-info (format "family ~v ~a" family status))]
-                        #:font-sizes font-sizes
+              [else
-                        #:line-heights line-heights
+               (make-proof family
-                        #:output-file-path output-file-path
+                           (or doc (match (current-input-port)
-                        #:replace replace
+                                     ;; pull text out of stdin, if any
-                        #:qml output-qml?))]))
+                                     ;; use `terminal-port?` to distinguish piped input from tty input
+                                     [(not (? terminal-port?))
+                                      (string-join (for/list ([t (in-port read)])
+                                                             (format "~a" t)) " ")]
+                                     [_ #false]))
+                           #:page-size page-size
+                           #:bold make-bold?
+                           #:italic make-italic?
+                           #:font-sizes font-sizes
+                           #:line-heights line-heights
+                           #:output-file-path output-file-path
+                           #:replace replace
+                           #:qml output-qml?)]))]))
 
 

quad/fontproof/main.rkt

@@ -23,6 +23,17 @@
 
 (define (boolean->string bool) (if bool "true" "false"))
 
+(define font-file-extensions '(#".otf" #".ttf" #".woff"))
+(define (font-path-string? x)
+  (and (path-string? x)
+       (member (path-get-extension (string->path x)) font-file-extensions)
+       #true))
+
+(define (resolve-family-bold-italic font-name-arg)
+  (define bi-suffix-pat #px"\\s*((?i:bold))?\\s*((?i:italic))?$")
+  (match-define (list suffix bold? italic?) (regexp-match bi-suffix-pat font-name-arg))
+  (values (string-trim font-name-arg suffix #:left? #false) bold? italic?))
+
 (define (make-proof font-or-qml [sample-text #f]
                     #:bold [make-bold #false]
                     #:italic [make-italic #false]
@@ -40,14 +51,11 @@
        (values doc output-file-path)]
       [font-name-arg
        (unless (and sample-text (non-empty-string? sample-text))
-         (raise-user-error "nothing to proof; exiting"))
+         (raise-user-error "no text to proof; exiting"))
        (define-values (initial-font-family initial-font-bold initial-font-italic)
          (match font-name-arg
-           [(? path-string? ps) (values (path->string (path->complete-path ps)) #f #f)]
+           [(? font-path-string? ps) (values (path->string (path->complete-path ps)) #f #f)]
-           [_ 
+           [_ (resolve-family-bold-italic font-name-arg)]))
-            (let ([bi-suffix-pat #px"\\s*((?i:bold))?\\s*((?i:italic))?$"])
-              (match-define (list suffix bold? italic?) (regexp-match bi-suffix-pat font-name-arg))
-              (values (string-trim font-name-arg suffix #:left? #false) bold? italic?))]))
        (log-fontproof-info (format "generating proof for ~a" font-name-arg))
        (define page-size (or page-size-arg "letter"))
        (define font-sizes (string-split (or font-sizes-arg "12 10.5 9")))