Fontconfig in scheme

fontconfig.scm

#! /usr/bin/env gosh

(use srfi-1)
(use srfi-13)
(use file.util)
(use sxml.ssax)
(use sxml.sxpath)
(use text.tree)

(define (fc-getenv envvar default)
  (or (sys-getenv envvar) default))

(define (fc-base-dir)
  (fc-getenv "FONTCONFIG_PATH" "/etc/fonts"))

(define (fc-xdg-config-dir)
  (fc-getenv "XDG_CONFIG_HOME" (build-path (sys-getenv "HOME") ".config")))

(define (fc-default-conf)
  (let1 conffile (fc-getenv "FONTCONFIG_FILE" "fonts.conf")
	(if (and (relative-path? conffile) (not (file-exists? conffile)))
	    (build-path (fc-base-dir) conffile)
	    conffile)))

(define-syntax fc-if-debug
  (syntax-rules ()
    ((_ body)
     (if-let1 env (sys-getenv "FC_DEBUG") body))
    ((_ body alt)
     (if-let1 env (sys-getenv "FC_DEBUG") body alt))
    ((_ . ?)
     (syntax-error "malformed fc-if-debug" (fc-if-debug . ?)))))

(define (make-compare-after-filter-func op filter)
  (lambda (a b)
    (let ((aa (filter a))
	  (bb (filter b)))
      (op aa bb))))

(define (make-fc-string-ci-ib* op)
  (make-compare-after-filter-func op
				  (cute string-filter <>
					(lambda (a)
					  (not (char-whitespace? a))))))

(define fc-string-ci-ib= (make-fc-string-ci-ib*
			  string-ci=))

(define fc-string-ci-ib<> (make-fc-string-ci-ib*
			   string-ci<>))

;; This function is definitely different to what exactly fontconfig do
(define fc-lang= (make-compare-after-filter-func string=
						 string-downcase))

;; This function is definitely different to what exactly fontconfig do
(define fc-lang-contains? (make-compare-after-filter-func string=
							  (lambda (a)
							    (car (string-split a #\-)))))

(define (fc-config-lex-bool arg)
  (let1 a (if (list? arg)
	      (car arg)
	      arg)
	(if a
	    (let1 f (string-downcase a)
		  (or (string= f "yes") (string= f "true") (string= f "1")))
	    #t)))

(define (fc-xml->sxml file)
  (let1 xml (file->string file)
	(cons file (list (call-with-input-string
			  xml
			  (cut ssax:xml->sxml <> '()))))))

(define (fc-flatten lst)
  (if (pair? lst)
      (append-map fc-flatten lst)
      (list lst)))

(define (fc-init)
  (let1 config (list (cons 'scan (list))
		     (cons 'pattern (list))
		     (cons 'font (list)))
	(fc-config-load config (fc-default-conf))))

(define (fc-config-load config file)
  (fc-if-debug
   (print #`"Reading ,|file|"))
  (let* ((obj (fc-xml->sxml file))
	 (file (car obj))
	 (sxml (assoc-ref (cadr obj) 'fontconfig)))
    (if sxml
	(fold (lambda (o r)
		(let1 elem (car o)
		      (case elem
			((cache cachedir config dir selectfont)
			 ;; It's not used here. ignoring
			 r)
			((match)
			 (let* ((attrs (sxml:attr-list o))
				(tl (assoc-ref attrs 'target))
				(target (string->symbol (if tl
							    (car tl)
							    "pattern"))))
			   (assq-set! r target (append (assoc-ref r target) (list o)))))
			((alias)
			 (assq-set! r 'pattern (append (assoc-ref r 'pattern) (list o))))
			((include)
			 (let* ((attrs (sxml:attr-list o))
				(f (sxml:string-value o))
				(prefix (assoc-ref attrs 'prefix))
				(incfile (if (relative-path? f)
					     (if (and prefix (string= (car prefix) "xdg"))
						 (build-path (fc-xdg-config-dir) f)
						 (build-path (fc-base-dir) f))
					     (regexp-replace #/^~/ f (sys-getenv "HOME")))))
			   (if (file-exists? incfile)
			       (if (file-is-directory? incfile)
				   (fc-config-load-dir r incfile)
				   (fc-config-load r incfile))
			       (if (fc-config-lex-bool (assoc-ref attrs 'ignore_missing))
				   r
				   (error "Unable to open the directory or the file:" incfile)))))
			(else
			 (print #`"Unknown element: ,|elem|")
			 r))))
	      config
	      sxml)
	(error "Unknown file syntax:" file))))

(define (fc-config-load-dir config dir)
  (fold (lambda (o r)
	  (if (file-is-regular? o)
	      (fc-config-load r o)))
	config
	(directory-list dir
			:children? #t
			:add-path? #t
			:filter (cute string-suffix? ".conf" <>))))

(define (fc-name-parse arg)
  (let* ((s (string-split arg #\:))
	 (family (car s))
	 (opts (cdr s))
	 (result (if (< 0 (string-length family))
		     (list (cons 'family (string-split family #\,)))
		     (list))))
    (fold (lambda (o r)
	    (let1 s (string-split o #\=)
		  (if (= 2 (length s))
		      (append r (list (cons (string->symbol (car s))
					    (string-split (cadr s) #\,))))
		      r)))
	  result opts)))

(define (fc-value-get v)
  (fold (lambda (o r)
	  (append r (list (let1 elem (car o)
				(case elem
				  ((string)
				   (sxml:string (list o)))
				  ((int double)
				   (sxml:number (list o)))
				  ((bool)
				   (sxml:boolean (list o)))
				  ((const)
				   (string->symbol (sxml:string-value o)))
				  ((matrix)
				   (error "Not yet supported:" elem))
				  ((charset)
				   (error "Not yet supported:" elem))
				  ((langset)
				   (error "Not yet supported:" elem))
				  (else
				   (error "Unknown data type:" elem)))))))
	'() v))

(define (fc-config-test pat obj)
  (let* ((strcmp_func `((eq . ,(lambda (a b) (fc-string-ci-ib= a b)))
			(contains . ,(lambda (a b) (string-ci= a b)))
			(not_eq . ,(lambda (a b) (fc-string-ci-ib<> a b)))
			(not_contains . ,(lambda (a b) (string-ci<> a b)))))
	 (numcmp_func `((eq . ,(lambda (a b) (= a b)))
			(contains . ,(lambda (a b) (= a b)))
			(not_eq . ,(lambda (a b) (not (= a b))))
			(not_contains . ,(lambda (a b) (not (= a b))))
			(less . ,(lambda (a b) (< a b)))
			(less_eq . ,(lambda (a b) (<= a b)))
			(more . ,(lambda (a b) (> a b)))
			(more_eq (lambda (a b) (>= a b)))))
	 (boolcmp_func `((eq . ,(lambda (a b) (= a b)))
			 (contains . ,(lambda (a b) (= a b)))
			 (not_eq . ,(lambda (a b) (not (= a b))))
			 (not_contains . ,(lambda (a b) (not (= a b))))))
	 (mtxcmp_func `((eq . ,(lambda (a b) (fc-matrix= a b)))
			(contains . ,(lambda (a b) (fc-matrix= a b)))
			(not_eq . ,(lambda (a b) (fc-matrix<> a b)))
			(not_contains . ,(lambda (a b) (fc-matrix<> a b)))))
	 (langcmp_func `((eq . ,(lambda (a b) (fc-lang= a b)))
			 (contains . ,(lambda (a b) (fc-lang-contains? a b)))
			 (not_eq . ,(lambda (a b) (not (fc-lang= a b))))
			 (not_contains . ,(lambda (a b) (not (fc-lang-contains? a b))))))
	 (comp_func `((string . ,strcmp_func)
		      (integer . ,numcmp_func)
		      (double . ,numcmp_func)
		      (bool . ,boolcmp_func)
		      (matrix . ,mtxcmp_func)
		      (lang . ,langcmp_func)
		      ; (charset . ,charsetcmp_func)
		      ; (langset . ,langsetcmp_func)
		      ; (ftface . ,ftfacecmp_func)
		      )))
    (let* ((attrs (sxml:attr-list obj))
	   (cnode (sxml:child-nodes obj))
	   (qual (string->symbol (if-let1 v (assoc-ref attrs 'qual)
					  (car v) "any")))
	   (name (string->symbol (if-let1 v (assoc-ref attrs 'name)
					  (car v) (error "`name' is required for test"))))
	   (target (string->symbol (if-let1 v (assoc-ref attrs 'target)
					    (car v) "default")))
	   (compare (string->symbol (if-let1 v (assoc-ref attrs 'compare)
					     (car v) "eq"))))
      (let ((v1l (assoc-ref pat name))
	    (v2l (fc-value-get cnode))
	    (result #f)
	    (exception (lambda (r)
			 (if (or (eq? compare 'not_eq)
				 (eq? compare 'not_contains))
			     (cons name '())
			     r))))
	(if v1l
	    (let1 func (case name
			 ((family style foundry file rasterizer familylang stylelang fullnamelang capability fontformat)
			  (assoc-ref (assoc-ref comp_func 'string) compare))
			 ((lang)
			  (assoc-ref (assoc-ref comp_func 'lang) compare))
			 (else
			  (print #`"Unable to determine the data type due to the unknown object: ,|name|")
			  #f))
		  (if func
		      (let loop ((rslt result)
				 (lst v1l))
			(if (null? lst)
			    rslt
			    (let1 value (car lst)
				  ;; assuming that no multiple values in <test>
				  (if (func value (car v2l))
				      (loop (or rslt (cons name lst)) (cdr lst))
				      (loop rslt (if (eq? qual 'all) '() (cdr lst)))))))
		      (exception result)))
	    (exception result))))))

(define (fc-config-edit pat obj pos)
  (rlet1 pat pat
	 (let* ((lstname (car pos))
		(lst (cdr pos))
		(attrs (sxml:attr-list obj))
		(name (string->symbol (if-let1 v (assoc-ref attrs 'name)
					       (car v) (error "`name' is required for edit"))))
		(mode (string->symbol (if-let1 v (assoc-ref attrs 'mode)
					       (car v) "assign")))
		(binding (string->symbol (if-let1 v (assoc-ref attrs 'binding)
						  (car v) "weak")))
		(cnode (sxml:child-nodes obj))
		(values (fc-value-get cnode))
		(curval (assoc-ref pat name)))
	   (fc-if-debug
	    (begin
	      (pp obj)
	      (print #`"\n,|mode| before:")
	      (pp curval)))
	   (case mode
	     ((assign)
	      (let ((e (car pos))
		    (v (cdr pos)))
		(if (eq? name e)
		    (begin
		      (set-car! v values)
		      (let ((v (assoc name pat)))
			(set-cdr! v (fc-flatten (cdr v)))))
		    (let ((v (assoc name pat)))
		      (set-cdr! v values)))))
	     ((assign_replace)
	      (let ((v (assoc name pat)))
		(if v
		    (set-cdr! v values)
		    (set! pat (append pat (list (cons name values)))))))
	     ((prepend)
	      (let ((e (car pos))
		    (v (cdr pos)))
		(if (eq? name e)
		    (set-car! v (list values (car v)))
		    (set! pat (append pat (list (cons name (list values curval)))))))
	      (let ((v (assoc name pat)))
		(set-cdr! v (fc-flatten (cdr v)))))
	     ((append)
	      (let* ((e (car pos))
		     (v (cdr pos))
		     (lv (cdr v)))
		(if (eq? name e)
		    (if (null? lv)
			(append! v values)
			(set-cdr! v (append values (cdr v))))
		    (if curval
			(append! curval values)
			(set! pat (append pat (list (cons name values))))))))
	     ((prepend_first)
	      (if curval
		  (let ((v (assoc name pat)))
		    (set-cdr! v (append values (cdr v))))
		  (set! pat (append pat (list (cons name values))))))
	     ((append_last)
	      (if curval
		  (append! curval values)
		  (set! pat (append pat (list (cons name values))))))
	     (else
	      (print #`"Unknown edit mode: ,|mode|")))
	   (fc-if-debug
	    (begin
	      (let ((vv (assoc-ref pat name)))
		(print #`",|mode| after:")
		(pp vv))
	      (print "")
	      (pp pat)
	      (print ""))))))

(define (fc-config-syntax-sugar-convert mode binding values)
  (let* ((strv (tree->string (fold (lambda (o r)
				     (let ((e (car o))
					   (v (sxml:string-value o)))
				       (if (eq? e 'family)
					   (append r (list #`"<string>,|v|</string>"))
					   (begin
					     (print #`"Unexpected element in prefer/accept/default: ,|e|")
					     r))))
				   '() values)))
	 (xml #`"<edit name=\"family\" mode=\",|mode|\" binding=\",|binding|\">,|strv|</edit>"))
    (cadr (call-with-input-string xml (cut ssax:xml->sxml <> '())))))

(define (fc-config-substitute config pat kind)
  (fc-if-debug
   (begin
     (print #`",|kind| has:")
     (pp pat)
     (print "")))
  (let loop ((rules (assoc-ref config kind))
	     (pat pat))
    (if (null? rules)
	pat
	(let* ((rule (car rules))
	       (elem (car rule))
	       (attrs (sxml:attr-list rule))
	       (cnode (sxml:child-nodes rule)))
	  (case elem
	    ((alias)
	     (loop (cdr rules)
		   (let ((binding (string->symbol (if-let1 v (assoc-ref attrs 'binding)
							   (car v) "weak")))
			 (node->ssnode (lambda (node act binding)
					 (let* ((v (sxml:child-nodes node)))
					   (fc-config-syntax-sugar-convert act binding v)))))
		     (let fc-alias-eval ((nodes cnode)
					 (pos #f)
					 (pat pat))
		       (if (null? nodes)
			   pat
			   (let* ((eval_node (car nodes))
				  (e (car eval_node)))
			     (case e
			       ((family)
				(let* ((v (sxml:string-value eval_node))
				       (ssnode (cadr (call-with-input-string
						      #`"<test qual=\"any\" target=\"pattern\" name=\"family\" compare=\"eq\" ignore-blanks=\"true\"><string>,|v|</string></test>"
						      (cut ssax:xml->sxml <> '()))))
				       (pos (fc-config-test pat ssnode)))
				  (fc-if-debug
				   (begin
				     (pp ssnode)
				     (unless pos
					     (print "No match"))))
				  (fc-alias-eval (if pos (cdr nodes) '()) pos pat)))
			       ((prefer)
				(fc-alias-eval (cdr nodes)
					       pos
					       (fc-config-edit pat
							       (node->ssnode eval_node 'prepend binding)
							       pos)))
			       ((accept)
				(fc-alias-eval (cdr nodes)
					       pos
					       (fc-config-edit pat
							       (node->ssnode eval_node 'append binding)
							       pos)))
			       ((default)
				(fc-alias-eval (cdr nodes)
					       pos
					       (fc-config-edit pat
							       (node->ssnode eval_node 'append_last binding)
							       pos)))
			       (else
				(print #`"Unknown element in ,|elem|: ,|e|")
				(fc-alias-eval (cdr nodes)
					       pos
					       pat)))))))))
	    ((match)
	     (loop (cdr rules)
		   (let fc-eval ((nodes cnode)
				 (pos #f)
				 (pat pat))
		     (if (null? nodes)
			 pat
			 (let* ((eval_node (car nodes))
				(e (car eval_node)))
			   (case e
			     ((test)
			      (let1 pos (fc-config-test pat eval_node)
				    (fc-if-debug
				     (begin
				       (pp eval_node)
				       (unless pos
					       (print "No match"))))
				    (fc-eval (if pos (cdr nodes) '()) pos pat)))
			     ((edit)
			      (fc-eval (cdr nodes) pos (fc-config-edit pat eval_node pos)))
			     (else
			      (print #`"Unexpected element in ,|elem|: ,|e|")
			      (fc-eval (cdr nodes) pos pat))))))))
	    (else
	     (print #`"Unexpected elements during applying substitute: ,|elem|")
	     (loop (cdr rules) pat)))))))
    
(define (main args)
  (let* ((config (fc-init))
	 (program (car args))
	 (pat (fc-config-substitute config
				    (if (null? (cdr args))
					(list)
					(fc-name-parse (cadr args)))
				    'pattern)))
    (fc-if-debug
     (begin
       (print "fc-config-substitute done\n")
       (pp pat)))))