Skip to content

Instantly share code, notes, and snippets.

@tagoh tagoh/fontconfig.scm
Created Jun 25, 2012

Embed
What would you like to do?
Fontconfig in scheme
#! /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)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.