2021-01-17 12:15:53 +01:00
|
|
|
;;; guile-fontconfig --- FFI bindings for FontConfig
|
|
|
|
;;; Copyright © 2021 Nicolò Balzarotti <nicolo@nixo.xyz>
|
|
|
|
;;;
|
|
|
|
;;; This file is part of guile-fontconfig.
|
|
|
|
;;;
|
|
|
|
;;; Guile-fontconfig is free software; you can redistribute it and/or
|
|
|
|
;;; modify it under the terms of the GNU Lesser General Public License
|
|
|
|
;;; as published by the Free Software Foundation; either version 3 of
|
|
|
|
;;; the License, or (at your option) any later version.
|
|
|
|
;;;
|
|
|
|
;;; Guile-fontconfig is distributed in the hope that it will be
|
|
|
|
;;; useful, but WITHOUT ANY WARRANTY; without even the implied
|
|
|
|
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
;;; See the GNU General Public License for more details.
|
|
|
|
;;;
|
|
|
|
;;; You should have received a copy of the GNU Lesser General Public
|
|
|
|
;;; License along with guile-fontconfig. If not, see
|
|
|
|
;;; <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
(define-module (fontconfig pattern)
|
|
|
|
#:use-module (ice-9 match)
|
2021-01-18 10:23:12 +01:00
|
|
|
#:use-module (ice-9 optargs)
|
2021-01-17 12:15:53 +01:00
|
|
|
#:use-module ((fontconfig bindings) #:prefix ffi:)
|
|
|
|
#:use-module (fontconfig object-set)
|
|
|
|
#:use-module (rnrs bytevectors)
|
|
|
|
#:use-module (srfi srfi-26)
|
|
|
|
#:use-module (system foreign)
|
|
|
|
#:export (make-pattern
|
|
|
|
pattern-get
|
|
|
|
pattern-list pattern->string pattern->format))
|
|
|
|
|
|
|
|
(define %string-attrs
|
|
|
|
'(family
|
|
|
|
style foundry file lang
|
|
|
|
fullname familylang stylelang fullnamelang
|
|
|
|
compatibility fontformat fontfeatures namelang
|
|
|
|
prgname hash postscriptname))
|
|
|
|
|
|
|
|
(define %double-attrs
|
|
|
|
'(size aspect pixelsize scale dpi))
|
|
|
|
|
|
|
|
(define %integer-attrs
|
|
|
|
'(slant weight spacing hintstyle width index rgba fontversion lcdfilter))
|
|
|
|
|
|
|
|
(define %bool-attrs
|
|
|
|
'(antialias
|
|
|
|
histing verticallayout autohint outline scalable
|
|
|
|
minspace embolden embeddedbitmap decorative))
|
|
|
|
|
2021-01-18 10:24:39 +01:00
|
|
|
(define <pattern>
|
|
|
|
(make-record-type '<pattern> '(ptr)))
|
|
|
|
(define %make-pattern (record-constructor <pattern>))
|
|
|
|
(define unwrap-pattern (record-accessor <pattern> 'ptr))
|
|
|
|
|
|
|
|
(define (wrap-pattern ptr)
|
|
|
|
(%make-pattern
|
|
|
|
(make-pointer (pointer-address ptr) ffi:fontconfig-pattern-destroy)))
|
2021-01-17 12:15:53 +01:00
|
|
|
|
2021-01-18 22:46:53 +01:00
|
|
|
(define keyword->pointer
|
|
|
|
(compose string->pointer symbol->string keyword->symbol))
|
2021-01-17 12:15:53 +01:00
|
|
|
|
|
|
|
(define (pattern-add-string pattern attr value)
|
|
|
|
(ffi:fontconfig-pattern-add-string
|
2021-01-18 22:46:53 +01:00
|
|
|
(unwrap-pattern pattern) (keyword->pointer attr) (string->pointer value)))
|
|
|
|
|
2021-01-17 12:15:53 +01:00
|
|
|
(define (pattern-add-double pattern attr value)
|
|
|
|
(ffi:fontconfig-pattern-add-double
|
2021-01-18 22:46:53 +01:00
|
|
|
(unwrap-pattern pattern) (keyword->pointer attr) value))
|
2021-01-17 12:15:53 +01:00
|
|
|
(define (pattern-add-integer pattern attr value)
|
|
|
|
(ffi:fontconfig-pattern-add-integer
|
2021-01-18 22:46:53 +01:00
|
|
|
(unwrap-pattern pattern) (keyword->pointer attr) value))
|
2021-01-17 12:15:53 +01:00
|
|
|
(define (pattern-add-bool pattern attr value)
|
|
|
|
(ffi:fontconfig-pattern-add-bool
|
2021-01-18 22:46:53 +01:00
|
|
|
(unwrap-pattern pattern) (keyword->pointer attr) (if value 1 0)))
|
2021-01-18 10:23:12 +01:00
|
|
|
|
|
|
|
(define (make-pattern . args)
|
2021-01-18 22:46:53 +01:00
|
|
|
(define (attr? list)
|
|
|
|
(compose (cute member <> list) keyword->symbol))
|
|
|
|
(define bool-attr? (attr? %bool-attrs))
|
|
|
|
(define integer-attr? (attr? %integer-attrs))
|
|
|
|
(define double-attr? (attr? %double-attrs))
|
|
|
|
(define string-attr? (attr? %string-attrs))
|
|
|
|
|
2021-01-17 12:15:53 +01:00
|
|
|
(let* ((ptr (ffi:fontconfig-pattern-create))
|
2021-01-18 22:46:53 +01:00
|
|
|
(pattern (if (null-pointer? ptr)
|
|
|
|
(error "make-pattern" "failed to create pattern")
|
|
|
|
(wrap-pattern ptr))))
|
|
|
|
(let loop ((args args))
|
|
|
|
(match args
|
|
|
|
(() pattern)
|
|
|
|
(((? string-attr? kwd) value . rest)
|
|
|
|
(pattern-add-string pattern kwd value)
|
|
|
|
(loop rest))
|
|
|
|
(((? integer-attr? kwd) value . rest)
|
|
|
|
(pattern-add-integer pattern kwd value)
|
|
|
|
(loop rest))
|
|
|
|
(((? bool-attr? kwd) value . rest)
|
|
|
|
(pattern-add-bool pattern kwd value)
|
|
|
|
(loop rest))
|
|
|
|
(((? double-attr? kwd) value . rest)
|
|
|
|
(pattern-add-double pattern kwd value)
|
|
|
|
(loop rest))
|
|
|
|
(((? string-attr? kwd) value . rest)
|
|
|
|
(pattern-add-integer pattern kwd value)
|
|
|
|
(loop rest))))))
|
2021-01-17 12:15:53 +01:00
|
|
|
|
|
|
|
(define (font-list pattern os)
|
|
|
|
(ffi:fontconfig-font-list
|
|
|
|
%null-pointer (unwrap-pattern pattern) (unwrap-object-set os)))
|
|
|
|
|
|
|
|
(define (char*->pointer pointer offset)
|
|
|
|
(dereference-pointer
|
|
|
|
(bytevector->pointer
|
|
|
|
(pointer->bytevector pointer int (* int offset)))))
|
|
|
|
|
|
|
|
(define (pattern->string pattern)
|
|
|
|
(pointer->string
|
|
|
|
(ffi:fontconfig-name-unparse (unwrap-pattern pattern))))
|
|
|
|
|
|
|
|
(define (make-font-list nfont sfont fonts)
|
|
|
|
(map (compose wrap-pattern (cute char*->pointer fonts <>))
|
|
|
|
(iota nfont)))
|
|
|
|
|
|
|
|
;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcpatternformat.html
|
|
|
|
(define* (pattern->format pattern #:optional (format "%{=fclist}"))
|
2021-01-18 12:15:38 +01:00
|
|
|
(let* ((ptr (ffi:fontconfig-pattern-format
|
|
|
|
(unwrap-pattern pattern) (string->pointer format)))
|
|
|
|
(formatted
|
|
|
|
(if (null-pointer? ptr)
|
|
|
|
(error "pattern->format" "invalid format")
|
|
|
|
(pointer->string ptr))))
|
|
|
|
(ffi:libc-free ptr)
|
|
|
|
formatted))
|
2021-01-17 12:15:53 +01:00
|
|
|
|
|
|
|
(define %fc-types
|
|
|
|
'(fc-unknown ; -1
|
|
|
|
fc-void
|
|
|
|
fc-integer
|
|
|
|
fc-double
|
|
|
|
fc-string
|
|
|
|
fc-bool
|
|
|
|
fc-matrix
|
|
|
|
fc-charset
|
|
|
|
fc-ftface
|
|
|
|
fc-langset
|
|
|
|
fc-range))
|
|
|
|
|
|
|
|
(define (int->fc-type int)
|
|
|
|
(list-ref %fc-types (1+ int)))
|
|
|
|
|
|
|
|
(define (fontconfig-value ptr)
|
|
|
|
(match-let* (((type ptr) (parse-c-struct ptr `(,int *)))
|
|
|
|
(type (int->fc-type type)))
|
|
|
|
(match type
|
|
|
|
;; Other types are not implemented
|
|
|
|
('fc-void *unspecified*)
|
|
|
|
('fc-string (pointer->string ptr))
|
|
|
|
(_ (error "fontconfig-value" "NOT IMPLEMENTED YET!")))))
|
|
|
|
|
|
|
|
(define (pattern-get pattern attr)
|
|
|
|
(let ((out (bytevector->pointer (make-bytevector (* int 2)))))
|
|
|
|
(ffi:fontconfig-pattern-get
|
2021-01-18 23:17:43 +01:00
|
|
|
(unwrap-pattern pattern)
|
|
|
|
(string->pointer (symbol->string attr))
|
|
|
|
0 out)
|
2021-01-17 12:15:53 +01:00
|
|
|
(fontconfig-value out)))
|
|
|
|
|
|
|
|
(define (pointer->font-list ptr)
|
|
|
|
(apply make-font-list (parse-c-struct ptr `(,int ,int *))))
|
|
|
|
|
|
|
|
(define (pattern-list pattern)
|
|
|
|
(let ((os (make-object-set)))
|
|
|
|
(for-each (cute object-set-add! os <>)
|
|
|
|
'("family" "style" "file"))
|
|
|
|
(pointer->font-list (font-list pattern os))))
|