add 'Load{Single,Collection}Font', 'FontType', etc.

src/frontend/bytecomp/ir.cppo.ml

@@ -571,6 +571,12 @@ and transform_1 (env : frame) (ast : abstract_tree) : ir * frame =
   | ASTCodeSymbol(_symb) ->
       report_bug_ir "transform_1: ASTCodeSymbol at stage 1"
 
+  | LoadSingleFont(_) ->
+      failwith "TODO: LoadSingleFont"
+
+  | LoadCollectionFont(_, _) ->
+      failwith "TODO: LoadCollectionFont"
+
 #include "__ir_1.gen.ml"
 
 
@@ -756,4 +762,10 @@ and transform_0 (env : frame) (ast : abstract_tree) : ir * frame =
   | ASTCodeSymbol(symb) ->
       return (IRConstant(CodeSymbol(symb)))
 
+  | LoadSingleFont(_) ->
+      failwith "TODO: LoadSingleFont"
+
+  | LoadCollectionFont(_, _) ->
+      failwith "TODO: LoadCollectionFont"
+
 #include "__ir_0.gen.ml"

src/frontend/display.ml

@@ -220,6 +220,7 @@ let show_base_type = function
   | PathType        -> "path"
   | GraphicsType    -> "graphics"
   | ImageType       -> "image"
+  | FontType        -> "font"
   | DocumentType    -> "document"
   | RegExpType      -> "regexp"
   | TextInfoType    -> "text-info"

src/frontend/evaluator.cppo.ml

@@ -413,6 +413,12 @@ and interpret_0 (env : environment) (ast : abstract_tree) : syntactic_value =
   | ASTCodeSymbol(_symb) ->
       report_bug_ast "ASTCodeSymbol(_) at stage 0" ast
 
+  | LoadSingleFont(_abspath_font) ->
+      failwith "TODO: LoadSingleFont"
+
+  | LoadCollectionFont(_abspath_font, _index) ->
+      failwith "TODO: LoadCollectionFont"
+
 #include "__evaluator_0.gen.ml"
 
 
@@ -586,6 +592,12 @@ and interpret_1 (env : environment) (ast : abstract_tree) : code_value =
   | ASTCodeSymbol(symb) ->
       CdContentOf(Range.dummy "ASTCodeSymbol", symb)
 
+  | LoadSingleFont(_abspath_font) ->
+      failwith "TODO: LoadSingleFont"
+
+  | LoadCollectionFont(_abspath_font, _index) ->
+      failwith "TODO: LoadCollectionFont"
+
 #include "__evaluator_1.gen.ml"
 
 

src/frontend/packageChecker.ml

@@ -114,8 +114,44 @@ let check_library_package (tyenv_prim : Typeenv.t) (genv : global_type_environme
   | None       -> err @@ NoMainModule(main_module_name)
 
 
-let check_font_package (_main_module_name : module_name) (_font_files : (abs_path * font_file_contents) list) =
-  failwith "TODO: check_font_package"
+let check_font_package (_main_module_name : module_name) (font_files : (abs_path * font_file_contents) list) =
+  let open ResultMonad in
+  let stage = Persistent0 in
+  let (ssig, libacc) =
+    font_files |> List.fold_left (fun (ssig, libacc) (abspath_font, font_file_contents) ->
+      match font_file_contents with
+      | OpentypeSingle(varnm) ->
+          let evid = EvalVarID.fresh (Range.dummy "font-package 1", varnm) in
+          let bind = Bind(stage, NonRec(evid, LoadSingleFont(abspath_font))) in
+          let ventry =
+            {
+              val_name  = Some(evid);
+              val_type  = Poly(Range.dummy "font-package 2", BaseType(FontType));
+              val_stage = stage;
+            }
+          in
+          (ssig |> StructSig.add_value varnm ventry, Alist.extend libacc (abspath_font, [ bind ]))
+
+      | OpentypeCollection(varnms) ->
+          let (ssig, bindacc, _) =
+            varnms |> List.fold_left (fun (ssig, bindacc, index) varnm ->
+              let evid = EvalVarID.fresh (Range.dummy "font-package 3", varnm) in
+              let bind = Bind(stage, NonRec(evid, LoadCollectionFont(abspath_font, index))) in
+              let ventry =
+                {
+                  val_name  = Some(evid);
+                  val_type  = Poly(Range.dummy "font-package 4", BaseType(FontType));
+                  val_stage = stage;
+                }
+              in
+              (ssig |> StructSig.add_value varnm ventry, Alist.extend bindacc bind, index + 1)
+            ) (ssig, Alist.empty, 0)
+          in
+          (ssig, Alist.extend libacc (abspath_font, Alist.to_list bindacc))
+
+    ) (StructSig.empty, Alist.empty)
+  in
+  return (ssig, Alist.to_list libacc)
 
 
 let main (tyenv_prim : Typeenv.t) (genv : global_type_environment) (package : untyped_package) : (StructSig.t * (abs_path * binding list) list) ok =

src/frontend/types.cppo.ml

@@ -128,6 +128,7 @@ type base_type =
   | PathType
   | GraphicsType
   | ImageType
+  | FontType
   | DocumentType
   | RegExpType
   | TextInfoType
@@ -182,6 +183,7 @@ let base_type_map : base_type TypeNameMap.t =
     ("path"          , PathType);
     ("graphics"      , GraphicsType);
     ("image"         , ImageType);
+    ("font"          , FontType);
     ("document"      , DocumentType);
     ("regexp"        , RegExpType);
     ("text-info"     , TextInfoType);
@@ -1031,6 +1033,9 @@ and abstract_tree =
   | Persistent            of Range.t * EvalVarID.t
   | Lift                  of abstract_tree
   | ASTCodeSymbol         of CodeSymbol.t
+(* Fonts: *)
+  | LoadSingleFont        of abs_path
+  | LoadCollectionFont    of abs_path * int
 (* Primitive applications: *)
 #include "__attype.gen.ml"