diff --git a/fontland/fontland/font-path.rkt b/fontland/fontland/font-path.rkt new file mode 100644 index 00000000..80528b73 --- /dev/null +++ b/fontland/fontland/font-path.rkt @@ -0,0 +1,63 @@ +#lang debug racket/base +(require racket/promise + racket/string + "unsafe/fontconfig.rkt") +(provide (all-defined-out)) + +(define fontsets-promise + (delay + (define font-dirs + (case (system-type 'os) + [(macosx) + ;; https://support.apple.com/en-us/HT201722 + (list "/System/Library/Fonts" + "/Library/Fonts" + (expand-user-path "~/Library/Fonts"))] + ;; https://wiki.ubuntu.com/Fonts#Manually + [(unix) (list "/usr/share/fonts" + "/usr/local/share/fonts" + (expand-user-path "~/.fonts"))] + [else ;; windows + ;; https://support.microsoft.com/en-us/help/314960/how-to-install-or-remove-a-font-in-windows + ;; on my windows 10 VM, the 'sys-dir is C:\\Windows\system32 + ;; though I'm suspicious that it's always like this + (list (build-path (find-system-path 'sys-dir) 'up "fonts"))])) + (define (path->fontset path-or-path-string) + (define bytepath (path->bytes (if (string? path-or-path-string) + (string->path path-or-path-string) + path-or-path-string))) + ((cond + [(fc-file-is-dir bytepath) fc-dir-scan] + [else fc-file-scan]) bytepath)) + (map path->fontset font-dirs))) + +(define (probably-successful-match? family-name result) + ;; fontconfig does its best to find a match using fuzzy logic + ;; so there's no official failure condition, it seems. + ;; this test checks if the first letters (up to 6) of the family name + ;; appear somewhere in the font filename. + (define-values (dir name _) (split-path result)) + (define name-string (path->string name)) + (regexp-match (string-downcase (substring family-name 0 (min 6 (string-length family-name)))) (string-downcase name-string))) + +(define (family->path family-name #:bold [bold? #f] #:italic [italic? #f]) + ;; create a configuration & invoke it + (fc-config-set-current (fc-config-create)) + (define fontsets (force fontsets-promise)) + (cond + [(ormap values fontsets) + ;; query pattern syntax + ;; https://www.freedesktop.org/software/fontconfig/fontconfig-user.html#AEN36 + (define query-pattern (fc-name-parse (string->bytes/utf-8 (format "~a:weight=~a:slant=~a" family-name (if bold? 200 80) (if italic? 100 0))))) + (fc-config-substitute query-pattern 'FcMatchPattern) + ;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcdefaultsubstitute.html + ;; Supplies default values for underspecified font patterns + (fc-default-substitute query-pattern) + (define result-pattern (fc-font-set-match fontsets query-pattern)) + (define result + (and result-pattern (bytes->path (fc-pattern-get-string result-pattern #"file" 0)))) + (cond + [(and result (probably-successful-match? family-name result)) result] + [else #false])] + [else #false])) + \ No newline at end of file diff --git a/fontland/fontland/font.rkt b/fontland/fontland/font.rkt index 1434de6e..7fa9a38b 100644 --- a/fontland/fontland/font.rkt +++ b/fontland/fontland/font.rkt @@ -8,13 +8,13 @@ "woff-directory.rkt" "struct.rkt" "table-stream.rkt" + "font-path.rkt" xenomorph racket/match racket/list racket/string sugar/unstable/dict "unsafe/harfbuzz.rkt" - #;"unsafe/fontconfig.rkt" "glyph-position.rkt" sugar/list racket/promise) @@ -165,15 +165,12 @@ Fontconfig provides a textual representation for patterns that the library can b [(? string->number) (string->number v)] [val val]))])))) -#;(define (family->path fam #:bold [bold #f] #:italic [italic #f]) - (string->path (hash-ref (query-fontconfig fam bold italic) 'file))) - (define (open-font str-or-path #:bold [bold #f] #:italic [italic #f]) ;; rather than use a `probe` function, ;; just try making a font with each format and see what happens (define str (if (path? str-or-path) (path->string str-or-path) str-or-path)) (or - (for*/or ([path-string (in-list (list str #(family->path str #:bold bold #:italic italic)))] + (for*/or ([path-string (in-list (list str (family->path str #:bold bold #:italic italic)))] #:when (and path-string (file-exists? path-string)) [port (in-value (open-input-file path-string))] [font-constructor (in-list (list +ttf-font +woff-font))]) diff --git a/fontland/fontland/unsafe/fontconfig.rkt b/fontland/fontland/unsafe/fontconfig.rkt index dc1084bf..bacabd25 100644 --- a/fontland/fontland/unsafe/fontconfig.rkt +++ b/fontland/fontland/unsafe/fontconfig.rkt @@ -1,14 +1,21 @@ #lang racket/base - (require ffi/unsafe ffi/unsafe/define ffi/unsafe/define/conventions (for-syntax racket/base - racket/string - racket/syntax syntax/parse)) -(define fc-lib (ffi-lib "libfontconfig")) +;; header file +;; https://github.com/servo/libfontconfig/blob/master/fontconfig/fontconfig.h + +;; fontconfig docs +;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/x102.html + +;; racket-installed fontconfig +(define fc-lib (ffi-lib "libfontconfig" '("1" #f))) + +;; system fontconfig (for opportunistic testing. Not necessarily available) +#;(define fc-lib (ffi-lib "libfontconfig")) (define-ffi-definer define-fc fc-lib #:make-c-id convention:hyphen->camelcase @@ -50,23 +57,29 @@ fc-result-type-mismatch fc-result-no-id fc-result-out-of-memory))) + +(define _FcMatchKind (_enum '(FcMatchPattern + FcMatchFont + FcMatchScan))) + (define _FcLangResult (_enum '(fc-lang-equal = 0 fc-lang-different-country fc-lang-different-territory fc-lang-different-lang))) -(define _FcMatchKind (_enum '(FcMatchPattern = 0 - FcMatchFont))) -(define _FcBool (_enum '(FcFalse = 0 - FcTrue))) - (define-cstruct _FcMatrix ([xx _double] [xy _double] [yx _double] [yy _double])) + +(define _FcValue-union (_union _bytes + _int + _bool + _double + _FcMatrix-pointer + _FcCharSet + _FcLangSet)) (define-cstruct _FcValue ([type _FcType] - [u (_union _bytes _int _bool _double - _FcMatrix-pointer - _FcCharSet - _FcLangSet)])) + [u _FcValue-union])) + (define-syntax (define-fc-functions stx) (syntax-parse stx @@ -93,19 +106,24 @@ [fc-pattern-hash (_fun _FcPattern -> _int32)] [fc-pattern-add (_fun _FcPattern _bytes _FcValue _bool -> _bool)] [fc-pattern-add-weak (_fun _FcPattern _bytes _FcValue _bool -> _bool)] - [fc-pattern-get (_fun _FcPattern _bytes _int _FcValue -> _FcResult)] + [fc-pattern-get (_fun _FcPattern + _bytes + _int + [val : (_ptr o _FcValue)] + -> _FcResult + -> val)] + [fc-pattern-get-string (_fun _FcPattern + _bytes + _int + [val : (_ptr o _bytes)] + -> _FcResult + -> val)] ;; TODO: vararg ;fc-pattern-build [fc-pattern-del (_fun _FcPattern _bytes -> _bool)] [fc-pattern-remove (_fun _FcPattern _bytes _int -> _bool)] [fc-pattern-print (_fun _FcPattern -> _void)] - [fc-config-substitute (_fun _FcConfig - _FcPattern - _FcMatchKind - -> - _FcBool)] - [fc-default-substitute (_fun _FcPattern -> _void)] - [fc-name-parse (_fun _bytes -> _FcPattern)] + [fc-name-parse (_fun _bytes -> _FcPattern/null)] [fc-name-unparse (_fun _FcPattern -> _bytes)] [fc-pattern-format (_fun _FcPattern _bytes -> _string)] @@ -119,7 +137,9 @@ _FcObjectSet -> _FcFontSet)] - [fc-font-set-match (_fun _FcConfig/null + ;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcfontsetmatch.html + ;; If config is NULL, the current configuration is used + [fc-font-set-match (_fun [_FcConfig/null = #false] [set : (_list i _FcFontSet)] [_int = (length set)] _FcPattern @@ -127,14 +147,7 @@ -> [pat : _FcPattern] -> - (values res pat))] - [fc-font-match (_fun _FcConfig/null - _FcPattern - [res : (_ptr o _FcResult)] - -> - [pat : _FcPattern] - -> - (values res pat))] + (and (eq? res 'fc-result-match) pat))] [fc-font-set-print (_fun _FcFontSet -> _void)] [fc-font-set-sort (_fun _FcConfig/null [set : (_list i _FcFontSet)] @@ -220,23 +233,30 @@ [fc-config-create (_fun -> _FcConfig)] [fc-config-reference (_fun _FcConfig/null -> _void)] [fc-config-destroy (_fun _FcConfig -> _void)] - [fc-config-set-current (_fun _FcConfig -> _bool)] + [fc-config-set-current (_fun _FcConfig -> _bool -> (void))] [fc-config-get-current (_fun -> _FcConfig)] [fc-config-upto-date (_fun _FcConfig/null -> _bool)] - [fc-config-home (_fun _FcConfig -> _path)] + [fc-config-home (_fun -> _path)] [fc-config-enable-home (_fun _bool -> _bool)] [fc-config-build-fonts (_fun _FcConfig/null -> _bool)] [fc-config-get-config-dirs (_fun _FcConfig/null -> _FcStrList)] [fc-config-get-font-dirs (_fun _FcConfig/null -> _FcStrList)] [fc-config-get-config-files (_fun _FcConfig/null -> _FcStrList)] [fc-config-get-cache-dirs (_fun _FcConfig/null -> _FcStrList)] - [fc-config-get-fonts (_fun _FcConfig _FcSetName -> _FcFontSet/null)] - [fc-config-get-blanks (_fun _FcConfig/null -> _FcBlanks)] + [fc-config-get-fonts (_fun _FcConfig/null _FcSetName -> _FcFontSet/null)] + [fc-config-get-blanks (_fun _FcConfig/null -> _FcBlanks/null)] [fc-config-get-rescan-interval (_fun _FcConfig/null -> _int)] [fc-config-set-rescan-interval (_fun _FcConfig/null _int -> _bool)] - [fc-config-app-font-add-file (_fun _FcConfig _path -> _bool)] - [fc-config-app-font-add-dir (_fun _FcConfig _path -> _bool)] - [fc-config-app-font-clear (_fun _FcConfig -> _void)] + [fc-config-app-font-add-file (_fun _FcConfig/null _path -> _bool)] + [fc-config-app-font-add-dir (_fun _FcConfig/null _path -> _bool)] + ;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcconfigsubstitute.html + ;; "If config is NULL, the current configuration is used" + [fc-config-substitute (_fun [_FcConfig/null = #false] + _FcPattern + _FcMatchKind + -> _bool)] + [fc-default-substitute (_fun _FcPattern -> _void)] + [fc-config-app-font-clear (_fun _FcConfig/null -> _void)] [fc-name-get-object-type (_fun _bytes -> _FcObjectType)] @@ -246,7 +266,7 @@ -> [b : _bool] -> (values b res))] - [fc-blanks-create (_fun -> _FcBlanks)] + [fc-blanks-create (_fun -> _FcBlanks/null)] [fc-blanks-destroy (_fun _FcBlanks -> _void)] [fc-blanks-add (_fun _FcBlanks _int -> _bool)] [fc-blanks-is-member (_fun _FcBlanks _int -> _bool)] @@ -260,15 +280,26 @@ [fc-atomic-unlock (_fun _FcAtomic -> _void)] [fc-atomic-destroy (_fun _FcAtomic -> _void)] - [fc-file-scan (_fun _FcFontSet _FcStrSet - _FcFileCache _FcBlanks - _bytes _bool - -> _bool)] + [fc-file-scan (_fun [fs : _FcFontSet = (fc-font-set-create)] + [_FcStrSet = (fc-str-set-create)] + (_ptr o _FcFileCache) + (_ptr o _FcBlanks/null) + _bytes + [force : _bool = #true] + -> [res : _bool] + -> (and res fs))] + ;; https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcdirscan.html + ;; "If cache is not zero or if force is FcFalse, this function currently returns FcFalse." + ;; therefore always pass 0 for cache argument + [fc-dir-scan (_fun [fs : _FcFontSet = (fc-font-set-create)] + [_FcStrSet = (fc-str-set-create)] + [_int = 0] + (_ptr o _FcBlanks/null) + _bytes + [force : _bool = #true] + -> [res : _bool] + -> (and res fs))] [fc-file-is-dir (_fun _bytes -> _bool)] - [fc-dir-scan (_fun _FcFontSet _FcStrSet - _FcFileCache _FcBlanks - _bytes _bool - -> _bool)] [fc-dir-cache-unlink (_fun _bytes _FcConfig -> _bool)] [fc-dir-cache-valid (_fun _bytes -> _bool)] [fc-dir-cache-load (_fun _bytes _FcConfig @@ -295,7 +326,7 @@ [fc-str-set-del (_fun _FcStrSet _bytes -> _bool)] [fc-str-set-destroy (_fun _FcStrSet -> _void)] [fc-str-list-create (_fun _FcStrSet -> _FcStrList)] - [fc-str-list-first (_fun _FcStrList -> _bytes)] + [fc-str-list-first (_fun _FcStrList -> _void)] [fc-str-list-next (_fun _FcStrList -> _bytes)] [fc-str-list-done (_fun _FcStrList -> _void)]