guile-fontconfig/fontconfig/pattern.scm

;;; 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)
  #:use-module (ice-9 optargs)
  #: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))

(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)))

(define keyword->pointer
  (compose string->pointer symbol->string keyword->symbol))

(define (pattern-add-string pattern attr value)
  (ffi:fontconfig-pattern-add-string
   (unwrap-pattern pattern) (keyword->pointer attr) (string->pointer value)))

(define (pattern-add-double pattern attr value)
  (ffi:fontconfig-pattern-add-double
   (unwrap-pattern pattern) (keyword->pointer attr) value))
(define (pattern-add-integer pattern attr value)
  (ffi:fontconfig-pattern-add-integer
   (unwrap-pattern pattern) (keyword->pointer attr) value))
(define (pattern-add-bool pattern attr value)
  (ffi:fontconfig-pattern-add-bool
   (unwrap-pattern pattern) (keyword->pointer attr) (if value 1 0)))

(define (make-pattern . args)
  (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))

  (let* ((ptr (ffi:fontconfig-pattern-create))
         (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))))))

(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}"))
  (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))

(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
     (unwrap-pattern pattern)
     (string->pointer (symbol->string attr))
     0 out)
    (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))))