start fallback logic

quad/qtest/emoji.rkt

@@ -0,0 +1,5 @@
+#lang quadwriter/markdown
+
+
+😂 Hel😂lo 😂
+

quad/quad/atomize.rkt

@@ -7,9 +7,12 @@
          txexpr
          sugar/list
          racket/function
+         "unicode/emoji.rkt"
+         fontland
          "quad.rkt"
          "qexpr.rkt"
-         "param.rkt")
+         "param.rkt"
+         "util.rkt")
 (provide (all-defined-out))
 
 (module+ test
@@ -51,44 +54,87 @@
 (define (same-run? qa qb)
   (eq? (quad-ref qa run-key) (quad-ref qb run-key)))
 
-(define (atomize qx #:attrs-proc [attrs-proc values])
+(define handle-fallback
+  (let ([font-cache (make-hash)]
+        [gid-cache (make-hash)])
+    (λ (missing-glyph-action str attrs fallback-font emoji-font)
+      (match missing-glyph-action
+        ;; #false = no op
+        [#false (list (cons attrs str))]
+        [action
+         (define font-path (hash-ref attrs 'font-path))
+         (define f (hash-ref! font-cache font-path (λ () (open-font font-path))))
+         (define glyph-ids+chars
+           (for/list ([c (in-string str)])
+             (define glyph-id
+               (hash-ref! gid-cache (cons c font-path)
+                          (λ () (glyph-id (vector-ref (glyphrun-glyphs (layout f (string c))) 0)))))
+             (define fallback-result (and (zero? glyph-id) (if (emoji? c) 'emoji 'fallback)))
+             (cons fallback-result c)))
+         (for*/list ([cprs (in-list (contiguous-group-by car glyph-ids+chars eq?))]
+                     [fallback-val (in-value (car (car cprs)))]
+                     #:unless (and fallback-val (eq? action 'omit)))
+           (define str (list->string (map cdr cprs)))
+           (define maybe-fallback-attrs
+             (cond 
+               [(not fallback-val) attrs]
+               [(eq? action 'warning) 
+                (displayln (format "warning: glyph ~a is not available in font ~a" str (path->string font-path)))
+                attrs]
+               [(eq? action 'error)
+                (raise-argument-error 'quad (format "glyph that exists in font ~a" (path->string font-path)) str)]
+               [(eq? fallback-val 'emoji) (let ([h (hash-copy attrs)])
+                                            (hash-set! h 'font-path emoji-font)
+                                            h)]
+               [(eq? fallback-val 'fallback) (let ([h (hash-copy attrs)])
+                                               (hash-set! h 'font-path fallback-font)
+                                               h)]))
+           (cons maybe-fallback-attrs str))]))))
+
+
+(define (atomize qx #:attrs-proc [attrs-proc values]
+                 #:fallback [fallback-font #f]
+                 #:emoji [emoji-font #f])
   ;; atomize a quad by reducing it to the smallest indivisible formatting units.
   ;; which are multi-character quads with the same formatting.
-  (define atomized-qs
-    (let loop ([x (make-quad qx)]
-               [attrs (hash-copy (current-default-attrs))]
-               [key (eq-hash-code (current-default-attrs))])
-      (match-define-values (next-key next-attrs)
-        ;; make a new run when we encounter non-empty attrs
-        (match (quad-attrs x)
-          [(? hash-empty?) (values key attrs)]
-          [this-attrs (define next-key (eq-hash-code this-attrs))
-                      (define next-attrs (attrs . update-with . this-attrs))
-                      (hash-set! next-attrs run-key next-key)
-                      (attrs-proc next-attrs)
-                      (values next-key next-attrs)]))
-      (match (quad-elems x)
-        [(? null?) ((quad-attrs x) . update-with! . next-attrs) (list x)]
-        [_
-         ;; we don't use `struct-copy` here because it needs to have the structure id at compile time.
-         ;; whereas with this technique, we can extract a constructor for any structure type.
-         ;; notice that the technique depends on
-         ;; 1) we only need to update attrs and elems
-         ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail
-         (define x-constructor (derive-quad-constructor x))
-         (define x-tail (drop (struct->list x) 2))
-         (match (merge-adjacent-strings (quad-elems x) 'isolate-white)
-           [(? pair? merged-elems)
-            (append* 
-             (for/list ([elem (in-list merged-elems)])
-               (match elem
-                 [(? string? str) (list (apply x-constructor next-attrs (list str) x-tail))]
-                 [_ (loop elem next-attrs next-key)])))]
-           ;; if merged elements are empty (for instance, series of empty strings)
-           ;; then zero out the elements in the quad.
-           [_ (list (apply x-constructor next-attrs null x-tail))])])))
-  #;(trimf atomized-qs (λ (q) (equal? (quad-elems q) '(" "))))
-  atomized-qs)
+  (define missing-glyph-action (current-missing-glyph-action))
+  
+  (let loop ([x (make-quad qx)]
+             [attrs (hash-copy (current-default-attrs))]
+             [key (eq-hash-code (current-default-attrs))])
+    (match-define-values (next-key next-attrs)
+      ;; make a new run when we encounter non-empty attrs
+      (match (quad-attrs x)
+        [(? hash-empty?) (values key attrs)]
+        [this-attrs (define next-key (eq-hash-code this-attrs))
+                    (define next-attrs (attrs . update-with . this-attrs))
+                    (hash-set! next-attrs run-key next-key)
+                    (attrs-proc next-attrs)
+                    (values next-key next-attrs)]))
+    (match (quad-elems x)
+      [(? null?) ((quad-attrs x) . update-with! . next-attrs) (list x)]
+      [_
+       ;; we don't use `struct-copy` here because it needs to have the structure id at compile time.
+       ;; whereas with this technique, we can extract a constructor for any structure type.
+       ;; notice that the technique depends on
+       ;; 1) we only need to update attrs and elems
+       ;; 2) we make them the first two fields, so we know to drop the first two fields of x-tail
+       (define x-constructor (derive-quad-constructor x))
+       (define x-tail (drop (struct->list x) 2))
+       (match (merge-adjacent-strings (quad-elems x) 'isolate-white)
+         [(? pair? merged-elems)
+          (append* 
+           (for/list ([elem (in-list merged-elems)])
+             (match elem
+               [(? string? str)
+                (for/list ([attrstr (in-list
+                                     (handle-fallback missing-glyph-action str next-attrs fallback-font emoji-font))])
+                  (match-define (cons attrs str) attrstr)
+                  (apply x-constructor attrs (list str) x-tail))]
+               [_ (loop elem next-attrs next-key)])))]
+         ;; if merged elements are empty (for instance, series of empty strings)
+         ;; then zero out the elements in the quad.
+         [_ (list (apply x-constructor next-attrs null x-tail))])])))
 
 (module+ test
   (define (filter-private-keys qs)

quad/quad/main.rkt

@@ -5,11 +5,13 @@
 "qexpr.rkt"
 "wrap.rkt"
 "position.rkt"
-"param.rkt")
+"param.rkt"
+"util.rkt")
 
 (provide (all-from-out "atomize.rkt"
 "quad.rkt"
 "qexpr.rkt"
 "wrap.rkt"
 "position.rkt"
-"param.rkt"))
+"param.rkt"
+"util.rkt"))

quad/quad/param.rkt

@@ -3,4 +3,5 @@
 
 (define current-default-attrs (make-parameter (make-hasheq)))
 (define current-wrap-distance (make-parameter 1))
-(define current-default-font-size (make-parameter 12))
+(define current-default-font-size (make-parameter 12))
+(define current-missing-glyph-action (make-parameter #f)) ; #f or 'error or 'warning or 'fallback or 'omit

quad/quad/unicode/emoji-prep.rkt

@@ -19,7 +19,7 @@
               (string->symbol (string-trim tag)))))
     (strip-context
      (with-syntax ([LINES lines])
-       #'(module _ quadwriter/unicode/emoji-prep
+       #'(module _ quad/unicode/emoji-prep
            . LINES)))))
 
 (define-syntax (make-cond stx)

quad/quad/unicode/emoji.rkt

@@ -1,4 +1,4 @@
-#lang quadwriter/unicode/emoji-prep
+#lang quad/unicode/emoji-prep
 
 # emoji-sequences.txt
 # Date: 2019-01-15, 12:17:16 GMT

quad/quad/util.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require racket/match racket/list)
+(provide (all-defined-out))
+
+(define (contiguous-group-by pred xs [equality equal?])
+  ;; like `group-by`, but only groups together contiguous xs with the same pred value.
+  (let loop ([xs xs][groups null])
+    (match xs
+      [(== empty equality) (reverse groups)]
+      [(cons first-x other-xs)
+       (define equivalence-val (pred first-x))
+       (define-values (group-members rest) (splitf-at other-xs (λ (x) (equal? (pred x) equivalence-val))))
+       (define new-group (cons first-x group-members)) ; group-members might be empty
+       (loop rest (cons new-group groups))])))
+
+(module+ test
+  (require rackunit)
+  (check-equal?
+   (contiguous-group-by values '(1 1 2 2 2 3 4 5 5 6 6 7 8 9))
+   '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9))))

quad/quadwriter/core.rkt

@@ -178,6 +178,7 @@
                             #:id 'hrbr))
 
 (module+ test
+  (require rackunit)
   (check-true (line-break? (second (quad-elems (q "foo" pbr "bar")))))
   (check-true (line-break? (second (atomize (q "foo" pbr "bar"))))))
 
@@ -492,23 +493,6 @@
                     (λ (q doc) (draw-debug q doc "#6c6" "#9c9"))
                     void))) 
 
-(define (contiguous-group-by pred xs)
-  ;; like `group-by`, but only groups together contiguous xs with the same pred value.
-  (let loop ([xs xs][groups null])
-    (match xs
-      [(== empty) (reverse groups)]
-      [(cons first-x other-xs)
-       (define equivalence-val (pred first-x))
-       (define-values (group-members rest) (splitf-at other-xs (λ (x) (equal? (pred x) equivalence-val))))
-       (define new-group (cons first-x group-members)) ; group-members might be empty
-       (loop rest (cons new-group groups))])))
-
-(module+ test
-  (require rackunit)
-  (check-equal?
-   (contiguous-group-by values '(1 1 2 2 2 3 4 5 5 6 6 7 8 9))
-   '((1 1) (2 2 2) (3) (4) (5 5) (6 6) (7) (8) (9))))
-
 (define/match (from-parent qs [where #f])
   ;; doesn't change any positioning. doesn't depend on state. can happen anytime.
   ;; can be repeated without damage.
@@ -610,7 +594,10 @@
                     [qx (qexpr->quad  `(q ((font-family ,default-font-family)
                                            (font-size ,(number->string default-font-size))) ,qx))])
                (setup-font-path-table! pdf-path)
-               (atomize qx #:attrs-proc handle-cascading-attrs)))
+               (parameterize ([current-missing-glyph-action 'fallback])
+                 (time-name atomize (atomize qx #:attrs-proc handle-cascading-attrs
+                                             #:fallback (hash-ref font-paths (cons "default-fallback" 'r) #f)
+                                             #:emoji (hash-ref font-paths (cons "default-emoji" 'r) #f))))))
   
   ;; page size can be specified by name, or measurements.
   ;; explicit measurements from page-height and page-width supersede those from page-size.
@@ -648,7 +635,7 @@
                            (quad-ref (car qs) 'page-margin-top (λ () (quad-ref (car qs) 'page-margin-bottom default-y-margin))))]
            [bottom-margin (let ([vert-optical-adjustment 10])
                             (or (debug-y-margin)
-                              (quad-ref (car qs) 'page-margin-bottom (λ () (+ vert-optical-adjustment (quad-ref (car qs) 'page-margin-top default-y-margin))))))]
+                                (quad-ref (car qs) 'page-margin-bottom (λ () (+ vert-optical-adjustment (quad-ref (car qs) 'page-margin-top default-y-margin))))))]
            [page-wrap-size (- (pdf-height pdf) top-margin bottom-margin)]
            [page-quad (struct-copy quad q:page
                                    [shift (pt left-margin top-margin)]

quad/quadwriter/fonts/default-fallback/LICENSE_OFL.txt

@@ -0,0 +1,92 @@
+This Font Software is licensed under the SIL Open Font License,
+Version 1.1.
+
+This license is copied below, and is also available with a FAQ at:
+http://scripts.sil.org/OFL
+
+-----------------------------------------------------------
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+-----------------------------------------------------------
+
+PREAMBLE
+The goals of the Open Font License (OFL) are to stimulate worldwide
+development of collaborative font projects, to support the font
+creation efforts of academic and linguistic communities, and to
+provide a free and open framework in which fonts may be shared and
+improved in partnership with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and
+redistributed freely as long as they are not sold by themselves. The
+fonts, including any derivative works, can be bundled, embedded,
+redistributed and/or sold with any software provided that any reserved
+names are not used by derivative works. The fonts and derivatives,
+however, cannot be released under any other type of license. The
+requirement for fonts to remain under this license does not apply to
+any document created using the fonts or their derivatives.
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright
+Holder(s) under this license and clearly marked as such. This may
+include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the
+copyright statement(s).
+
+"Original Version" refers to the collection of Font Software
+components as distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to,
+deleting, or substituting -- in part or in whole -- any of the
+components of the Original Version, by changing formats or by porting
+the Font Software to a new environment.
+
+"Author" refers to any designer, engineer, programmer, technical
+writer or other person who contributed to the Font Software.
+
+PERMISSION & CONDITIONS
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of the Font Software, to use, study, copy, merge, embed,
+modify, redistribute, and sell modified and unmodified copies of the
+Font Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components, in
+Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled,
+redistributed and/or sold with any software, provided that each copy
+contains the above copyright notice and this license. These can be
+included either as stand-alone text files, human-readable headers or
+in the appropriate machine-readable metadata fields within text or
+binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font
+Name(s) unless explicit written permission is granted by the
+corresponding Copyright Holder. This restriction only applies to the
+primary font name as presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
+Software shall not be used to promote, endorse or advertise any
+Modified Version, except to acknowledge the contribution(s) of the
+Copyright Holder(s) and the Author(s) or with their explicit written
+permission.
+
+5) The Font Software, modified or unmodified, in part or in whole,
+must be distributed entirely under this license, and must not be
+distributed under any other license. The requirement for fonts to
+remain under this license does not apply to any document created using
+the Font Software.
+
+TERMINATION
+This license becomes null and void if any of the above conditions are
+not met.
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
+COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
+OTHER DEALINGS IN THE FONT SOFTWARE.