#lang debug racket/base
(require racket/path
         racket/match
         racket/runtime-path
         racket/list
         racket/string
         fontland/font-path
         "quad.rkt"
         "pipeline.rkt"
         "attr.rkt")
(provide (all-defined-out))

(define :font-family 'font-family)
(define :font-path 'font-path)
(define :font-bold 'font-bold)
(define :font-italic 'font-italic)

(define-runtime-path quad2-fonts-dir "default-fonts")
(define-runtime-path default-font-face "default-fonts/default/SourceSerifPro-Regular.otf")
(define top-font-directory "fonts")
(define font-file-extensions '(#".otf" #".ttf" #".woff" #".woff2"))
(define default-font-family "text")

(define (fonts-in-directory dir)
  (for/list ([font-path (in-directory dir)]
             #:when (member (path-get-extension font-path) font-file-extensions))
    font-path))

(define (setup-font-path-table [base-path (current-directory)])
  ;; create a table of font paths that we can use to resolve references to font names.
  ;; rules for font naming
  ;; "fonts" subdirectory on top
  ;; family directories inside: each named with font family name
  ;; this makes it possible to give font families generic names (e.g., "body-text")
  ;; and change the font files without disturbing anything else.
  (define doc-fonts-dir
    (simple-form-path
     (build-path (match/values (split-path base-path)
                               [(base name #true) (build-path base name)]
                               [(dir _ _) dir]) top-font-directory)))
  ;; run doc-fonts-dir first because earlier fonts take precedence (using hash-ref! below)
  (define font-paths (make-hash))
  (for* ([fonts-dir (in-list (list doc-fonts-dir quad2-fonts-dir))]
         #:when (directory-exists? fonts-dir)
         [font-family-subdir (in-list (directory-list fonts-dir #:build? #t))]
         #:when (directory-exists? font-family-subdir)
         [fonts-in-this-directory (in-value (fonts-in-directory font-family-subdir))]
         [font-path (in-list fonts-in-this-directory)])
    (match-define (list font-path-string family-name)
      (for/list ([x (list font-path font-family-subdir)])
        (path->string (find-relative-path fonts-dir x))))
    (define path-parts (for/list ([part (in-list (explode-path (string->path (string-downcase font-path-string))))])
                         (path->string part)))
    (define key
      (cons (string-downcase family-name)
            (cond
              ;; special case: if there's only one style in the family directory,
              ;; treat it as the regular style, regardless of name
              [(= (length fonts-in-this-directory) 1) 'r]
              ;; cases where fonts are in subdirectories named by style
              ;; infer style from subdir name
              [(member "bold-italic" path-parts) 'bi]
              [(member "bold" path-parts) 'b]
              [(member "italic" path-parts) 'i]
              [else
               ;; try to infer from filename alone
               ;; TODO: what happens when there is no regular style?
               (define filename (string-downcase (last path-parts)))
               (define filename-contains-bold? (string-contains? filename "bold"))
               (define filename-contains-italic? (string-contains? filename "italic"))
               (cond
                 [(and filename-contains-bold? filename-contains-italic?) 'bi]
                 [filename-contains-bold? 'b]
                 [filename-contains-italic? 'i]
                 [else 'r])])))
    ;; only set value if there's not one there already.
    ;; this means that we only use the first eligible font we find.
    (hash-ref! font-paths key font-path))
  font-paths)

(define (make-key font-family [bold #f] [italic #f])
  (cons (string-downcase font-family)
        (cond
          [(and bold italic) 'bi]
          [bold 'b]
          [italic 'i]
          [else 'r])))

(define (font-attrs->path font-paths font-family bold italic)
  ;; find the font-path corresponding to a certain family name and style.
  (define regular-key (make-key font-family))
  
  ;; if it's not already in font paths, it might be a system font
  ;; we use `family->path` to try to resolve the ribbi styles
  ;; if the font is a system font, we will end up with paths.
  ;; if it's not, we will end up with #false for those entries in `font-paths`,
  ;; and fall through to the default font when we do the `cond` below.
  ;; TODO: family->path doesn't work because it relies on ffi into fontconfig
  ;; which has broken in cs, I guess
  #|
(unless (hash-has-key? font-paths regular-key)
    (for* ([bold (in-list (list #false #true))]
           [italic (in-list (list #false #true))])
      (hash-set! font-paths
                 (make-key font-family bold italic)
                 (family->path font-family #:bold bold #:italic italic))))
|#
  (cond
    [(hash-ref font-paths (make-key font-family bold italic) #false)]
    ;; try regular style if style-specific key isn't there for b i or bi
    [(and (or bold italic) (hash-ref font-paths regular-key #false))]
    ;; otherwise use default
    [else default-font-face]))

(define (font-path-string? x)
  (and (path-string? x)
       (member (path-get-extension (string->path x)) font-file-extensions)
       #true))

(define (resolve-font-path font-paths val attrs)
  ;; convert references to a font family and style to an font path on disk
  ;; we trust it exists because we used `setup-font-path-table` earlier,
  ;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
  (define this-font-family (hash-ref! attrs :font-family default-font-family))
  (match (string-downcase this-font-family)
    [(? font-path-string? ps) (path->complete-path ps)]
    [_
     (define this-bold (hash-ref! attrs :font-bold #false))
     (define this-italic (hash-ref! attrs :font-italic #false))
     (font-attrs->path font-paths this-font-family this-bold this-italic)]))

(define-pass (resolve-font-paths qs)
  ;; convert references to a font family and style to an font path on disk
  ;; we trust it exists because we used `setup-font-path-table!` earlier,
  ;; but if not, fallback fonts will kick in, on the idea that a missing font shouldn't stop the show
  #:pre (list-of quad?)
  #:post (list-of quad?)
  (define font-paths (setup-font-path-table))
  (do-attr-iteration qs
                     #:which-key :font-family
                     #:value-proc (λ (val attrs) (resolve-font-path font-paths val attrs))))

(module+ test
  (require rackunit)
  (define q (make-quad #:attrs (make-hasheq '((font-family . "Heading")))))
  (define qs (list q))
  (define (resolved-font-for-family val #:bold [bold #f] #:italic [italic #f])
    (last (explode-path (quad-ref (car (resolve-font-paths (list (make-quad #:attrs (make-hasheq (list (cons :font-family val) (cons :font-bold bold)
                                                                                                       (cons :font-italic italic))))))) :font-family))))
  (check-equal? (resolved-font-for-family "Heading") (string->path "fira-sans-light.otf"))
  (check-equal? (resolved-font-for-family "CODE") (string->path "fira-mono.otf"))
  (check-equal? (resolved-font-for-family "blockquote" #:bold #t) (string->path "fira-sans-bold.otf"))
  (check-equal? (resolved-font-for-family "nonexistent-fam") (string->path "SourceSerifPro-Regular.otf")))