PDFSharp OS X font resolver

gistfile1.txt

module PDFSharp.OSX

open PdfSharp
open PdfSharp.Fonts
open PdfSharp.Pdf
open PdfSharp.Drawing
open System
open System.Drawing
open System.Drawing.Text
open System.Globalization
open System.IO

type FontInfo =
  { file : FileInfo
    pfc : PrivateFontCollection
    family : string }

  /// File name without extension
  member x.normalised =
    Path
      .GetFileNameWithoutExtension(x.file.FullName)
      .ToLowerInvariant()

  interface IDisposable with 
    member x.Dispose() =
      x.pfc.Dispose()

module OSXFonts =

  let cache fn =
    let c = ref Map.empty
    fun input ->
      let m = !c
      match m |> Map.tryFind input with
      | None ->
        let res = fn input
        c := m |> Map.add input res
        res
      | Some res ->
        res

  let env key : string option =
    match Environment.GetEnvironmentVariable key with
    | null ->
      None
    | value ->
      Some value

  let envForce key : string =
    env key |> Option.get

  type OSXFontsConfig =
    { fontLocations : string list }

  let defaultConfig =
    { fontLocations =
        [ sprintf "%s/Library/Fonts/" (envForce "HOME")
          "/Library/Fonts/"
          "/Network/Library/Fonts/"
          "/System/Library/Fonts/"
        ] |> List.filter Directory.Exists }

  let tryCreateFontInfo (file : FileInfo) =
    let pfc = new PrivateFontCollection()
    pfc.AddFontFile file.FullName

    if Array.isEmpty pfc.Families then
      printfn "Font %s has no families??" file.FullName
      None
    elif Array.length pfc.Families > 1 then
      let families =
        (String.concat ", " (pfc.Families |> Array.map (fun fam -> sprintf "'%s'" fam.Name)))
      printfn "2: Adding font '%s' with more than one family: %s" file.FullName families
      Some [|
        for fam in pfc.Families |> Array.distinctBy (fun fm -> fm.Name) do
          yield { file = file; pfc = pfc; family = fam.Name }
      |]
    else
      let font = { file = file; pfc = pfc; family = pfc.Families.[0].Name }
      printfn "3: Adding font '%s' with family: %s" font.file.FullName font.family
      Some [| font |]

  let allFonts =
    cache (fun fontLocations ->
      fontLocations
      |> List.collect (fun (location : string) ->
        let di = new DirectoryInfo(location)
        di.GetFiles("*")
        |> Array.choose tryCreateFontInfo
        |> Array.concat
        |> Array.map (fun font -> font.family, font)
        |> List.ofArray
      ))

  /// Returns index into the `FontInfo array`, found by the passed `familyName`.
  let resolveTypeFace (fontsByFamily: Map<_, FontInfo list>) familyName isBold isItalic =
    let contains (s: string) sub = s.Contains(sub)
    match fontsByFamily |> Map.tryFind familyName with
    | None ->
      failwithf "Font family '%s' not found." familyName
    | Some fonts when List.length fonts = 1 ->
      0, fonts.[0]
    | Some fonts ->
      fonts
      |> List.mapi (fun index font -> index, font, 0u)
      |> List.map (fun (index, font, score) ->
        if contains font.normalised "italic" && isItalic then
          index, font, score + 1u
        else
          index, font, score)
      |> List.map (fun (index, font, score) ->
        if contains font.normalised "bold" && isBold then
          index, font, score + 1u
        else
          index, font, score)
      |> List.map (fun (index, font, score) ->
        if contains font.normalised "regular" && not isBold && not isItalic then
          index, font, score + 1u
        else
          index, font, score)
      |> List.maxBy (fun (index, font, score) -> score)
      |> fun (index, font, _) -> index, font

  let resolver config =
    let allFonts = allFonts config.fontLocations

    let fontsByFamily: Map<string, FontInfo list> =
      let reducer (acc : Map<_, _>) (fontFamily: string, font: FontInfo) =
        let m =
          match acc |> Map.tryFind fontFamily with
          | Some prev ->
            acc |> Map.add fontFamily (font :: prev)
          | None ->
            acc |> Map.add fontFamily [font]
        let fn = Path.GetFileNameWithoutExtension font.file.FullName
        m |> Map.add fn [font]

      allFonts |> List.fold reducer Map.empty

    let fontsByPath =
      allFonts
      |> List.map (fun (name, font) -> font.file.FullName, font)
      |> Map.ofList

    { new IFontResolver with
        member x.GetFont resolveName =
          printfn "GetFont(%s)" resolveName
          let family, index = let s = resolveName.Split('|') in s.[0], int s.[1]
          let font = let fonts = fontsByFamily |> Map.find family in fonts.[index]
          printfn "=> %A" font
          File.ReadAllBytes font.file.FullName

        member x.ResolveTypeface(familyName, isBold, isItalic) =
          printfn "ResolveTypeface(%s, %b, %b)" familyName isBold isItalic
          // this function may be called with its own computed values, meaning we need
          // to check for it and return the input value - assume font names do not contain
          // the bar (|) character:
          if familyName.Contains("|") then
            FontResolverInfo(familyName, XStyleSimulations.None)
          else
            let index, font = resolveTypeFace fontsByFamily familyName isBold isItalic
            FontResolverInfo(sprintf "%s|%i" font.family index, XStyleSimulations.None)
    }

MIT license for the above.