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 ((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-wrapped-pointer-type <pattern>
  pattern?
  wrap-pattern unwrap-pattern
  (lambda (pattern port) (format port "#<pattern>")))

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

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

(define* (make-pattern #:optional (args '()))
  (define bool? (cute member <> %bool-attrs))
  (define int? (cute member <> %integer-attrs))
  (define double? (cute member <> %double-attrs))
  (define string? (cute member <> %string-attrs))
  (let* ((ptr (ffi:fontconfig-pattern-create))
         (pattern
          (if (null-pointer? ptr)
              (error "make-pattern" "failed to create pattern")
              (wrap-pattern ptr))))
    (set-pointer-finalizer! ptr ffi:fontconfig-pattern-destroy)
    (map (lambda (args)
           (apply (match args
                    (((? bool? attr) value) pattern-add-bool)
                    (((? int? attr) value) pattern-add-integer)
                    (((? double? attr) value) pattern-add-double)
                    (((? string? attr) value) pattern-add-string))
                  pattern args))
         args)
    pattern))

(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))))
    (if (null-pointer? ptr)
        (error "pattern->format" "invalid format")
        (pointer->string ptr))
    ;; FIXME: How to FREE ptr!
    ))

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