Support for type quote and splice

Author: art-w

src/document/generator.ml

@@ -471,6 +471,10 @@ module Make (Syntax : SYNTAX) = struct
             (Link.from_path (path :> Paths.Path.t))
       | Poly (polyvars, t) ->
           O.txt ("'" ^ String.concat " '" polyvars ^ ". ") ++ type_expr t
+      | Quote t ->
+          O.span (O.txt "<[ " ++ O.box_hv (type_expr t) ++ O.txt " ]>")
+      | Splice t ->
+          O.span (O.txt "$" ++ type_expr ~needs_parentheses:true t)
       | Package pkg ->
           enclose ~l:"(" ~r:")"
             (O.keyword "module" ++ O.txt " "

src/loader/cmi.ml

@@ -529,8 +529,8 @@ let rec read_type_expr env typ =
       | Tsubst (typ,_) -> read_type_expr env typ
 #endif
 #if OCAML_VERSION = (5,2,0)
-      | Tquote typ -> read_type_expr env typ
-      | Tsplice typ -> read_type_expr env typ
+      | Tquote typ -> Quote (read_type_expr env typ)
+      | Tsplice typ -> Splice (read_type_expr env typ)
 #endif
       | Tlink _ -> assert false
       | Tof_kind _ -> assert false

src/loader/cmti.ml

@@ -170,8 +170,8 @@ let rec read_core_type env container ctyp =
       read_core_type env container t
 #endif
 #if OCAML_VERSION = (5,2,0)
-    | Ttyp_quote typ -> read_core_type env container typ
-    | Ttyp_splice typ -> read_core_type env container typ
+    | Ttyp_quote typ -> Quote (read_core_type env container typ)
+    | Ttyp_splice typ -> Splice (read_core_type env container typ)
 #endif
     | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, [])
     | Ttyp_of_kind _ -> assert false

src/model/lang.ml

@@ -481,6 +481,8 @@ and TypeExpr : sig
     | Object of TypeExpr.Object.t
     | Class of Path.ClassType.t * t list
     | Poly of string list * t
+    | Quote of t
+    | Splice of t
     | Package of TypeExpr.Package.t
 end =
   TypeExpr

src/model_desc/lang_desc.ml

@@ -665,6 +665,8 @@ and typeexpr_t =
     | Class (x1, x2) ->
         C ("Class", ((x1 :> Paths.Path.t), x2), Pair (path, List typeexpr_t))
     | Poly (x1, x2) -> C ("Poly", (x1, x2), Pair (List string, typeexpr_t))
+    | Quote x -> C ("Quote", x, typeexpr_t)
+    | Splice x -> C ("Splice", x, typeexpr_t)
     | Package x -> C ("Package", x, typeexpr_package))
 
 (** {3 Compilation_unit} *)

src/xref2/compile.ml

@@ -945,6 +945,8 @@ and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
           Class (`Resolved p, ts')
       | _ -> Class (path, ts'))
   | Poly (strs, t) -> Poly (strs, type_expression env parent t)
+  | Quote t -> Quote (type_expression env parent t)
+  | Splice t -> Splice (type_expression env parent t)
   | Package p -> Package (type_expression_package env parent p)
 
 let compile ~filename env compilation_unit =

src/xref2/component.ml

@@ -130,6 +130,8 @@ and TypeExpr : sig
     | Object of TypeExpr.Object.t
     | Class of Cpath.class_type * t list
     | Poly of string list * t
+    | Quote of t
+    | Splice of t
     | Package of TypeExpr.Package.t
 end =
   TypeExpr
@@ -1199,6 +1201,8 @@ module Fmt = struct
     | Object x -> type_object c ppf x
     | Class (x, y) -> type_class c ppf (x, y)
     | Poly (_ss, _t) -> Format.fprintf ppf "(poly)"
+    | Quote t -> Format.fprintf ppf "(quote %a)" (type_expr c) t
+    | Splice t -> Format.fprintf ppf "(splice %a)" (type_expr c) t
     | Package x -> type_package c ppf x
 
   and resolved_module_path :
@@ -2340,6 +2344,8 @@ module Of_Lang = struct
         Class
           (class_type_path ident_map p, List.map (type_expression ident_map) ts)
     | Object o -> Object (type_object ident_map o)
+    | Quote t -> Quote (type_expression ident_map t)
+    | Splice t -> Splice (type_expression ident_map t)
     | Package p -> Package (type_package ident_map p)
 
   and module_decl ident_map m =

src/xref2/component.mli

@@ -125,6 +125,8 @@ and TypeExpr : sig
     | Object of TypeExpr.Object.t
     | Class of Cpath.class_type * t list
     | Poly of string list * t
+    | Quote of t
+    | Splice of t
     | Package of TypeExpr.Package.t
 end
 

src/xref2/expand_tools.ml

@@ -65,6 +65,8 @@ let rec type_expr map t =
   | Class (path, ts) -> Class (path, List.map (type_expr map) ts)
   | Poly (s, t) -> Poly (s, type_expr map t)
   | Package p -> Package (package map p)
+  | Quote t -> Quote (type_expr map t)
+  | Splice t -> Splice (type_expr map t)
 
 and polymorphic_variant map pv =
   let open Lang.TypeExpr.Polymorphic_variant in

src/xref2/lang_of.ml

@@ -1041,6 +1041,8 @@ and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t)
     | Class (p, ts) ->
         Class (Path.class_type map p, List.map (type_expr map parent) ts)
     | Poly (strs, t) -> Poly (strs, type_expr map parent t)
+    | Quote t -> Quote (type_expr map parent t)
+    | Splice t -> Splice (type_expr map parent t)
     | Package p -> Package (type_expr_package map parent p)
   with e ->
     let bt = Printexc.get_backtrace () in