refactor: represent virtual libraries via Lib_kind.t (#12276)

Signed-off-by: Shon Feder <[email protected]>

Author: shonfeder

src/dune_findlib/package0.ml

@@ -44,9 +44,9 @@ let ppx_runtime_deps t =
 
 let kind t : Lib_kind.t =
   match Vars.get t.vars "library_kind" Ps.empty with
-  | Some "ppx_rewriter" -> Ppx_rewriter Lib_kind.Ppx_args.empty
-  | Some "ppx_deriver" -> Ppx_deriver Lib_kind.Ppx_args.empty
-  | None | Some _ -> Normal
+  | Some "ppx_rewriter" -> Dune_file (Ppx_rewriter Lib_kind.Ppx_args.empty)
+  | Some "ppx_deriver" -> Dune_file (Ppx_deriver Lib_kind.Ppx_args.empty)
+  | None | Some _ -> Dune_file Normal
 ;;
 
 let archives t = make_archives t "archive" preds

src/dune_lang/lib_kind.ml

@@ -58,44 +58,77 @@ module Ppx_args = struct
   ;;
 end
 
+module Dune_file = struct
+  type t =
+    | Normal
+    | Ppx_deriver of Ppx_args.t
+    | Ppx_rewriter of Ppx_args.t
+
+  let cstr_name = function
+    | Normal -> "normal"
+    | Ppx_deriver _ -> "ppx_deriver"
+    | Ppx_rewriter _ -> "ppx_rewriter"
+  ;;
+
+  let decode =
+    let open Decoder in
+    sum
+      [ "normal", return Normal
+      ; ( "ppx_deriver"
+        , let+ args = Ppx_args.decode in
+          Ppx_deriver args )
+      ; ( "ppx_rewriter"
+        , let+ args = Ppx_args.decode in
+          Ppx_rewriter args )
+      ]
+  ;;
+
+  let encode t =
+    match
+      match t with
+      | Normal -> Dune_sexp.atom (cstr_name t)
+      | Ppx_deriver x | Ppx_rewriter x ->
+        List (Dune_sexp.atom (cstr_name t) :: Ppx_args.encode x)
+    with
+    | List [ x ] -> x
+    | x -> x
+  ;;
+
+  let to_dyn x =
+    let open Dyn in
+    match x with
+    | Normal -> variant "Normal" []
+    | Ppx_deriver args -> variant "Ppx_deriver" [ Ppx_args.to_dyn args ]
+    | Ppx_rewriter args -> variant "Ppx_rewriter" [ Ppx_args.to_dyn args ]
+  ;;
+end
+
 type t =
-  | Normal
-  | Ppx_deriver of Ppx_args.t
-  | Ppx_rewriter of Ppx_args.t
+  | Virtual
   | Parameter
-
-let equal = Poly.equal
+  | Dune_file of Dune_file.t
 
 let to_dyn x =
   let open Dyn in
   match x with
-  | Normal -> variant "Normal" []
+  | Virtual -> variant "Virtual" []
   | Parameter -> variant "Parameter" []
-  | Ppx_deriver args -> variant "Ppx_deriver" [ Ppx_args.to_dyn args ]
-  | Ppx_rewriter args -> variant "Ppx_rewriter" [ Ppx_args.to_dyn args ]
+  | Dune_file t -> variant "Dune_file" [ Dune_file.to_dyn t ]
 ;;
 
 let decode =
   let open Decoder in
-  sum
-    [ "normal", return Normal
-    ; "parameter", return Parameter
-    ; ( "ppx_deriver"
-      , let+ args = Ppx_args.decode in
-        Ppx_deriver args )
-    ; ( "ppx_rewriter"
-      , let+ args = Ppx_args.decode in
-        Ppx_rewriter args )
-    ]
+  (* TODO: Less code reuse with either? *)
+  map ~f:(fun k -> Dune_file k) Dune_file.decode
+  <|> enum [ "parameter", Parameter; "virtual", Virtual ]
 ;;
 
 let encode t =
   match
     match t with
-    | Normal -> Dune_sexp.atom "normal"
+    | Virtual -> Dune_sexp.atom "virtual"
     | Parameter -> Dune_sexp.atom "parameter"
-    | Ppx_deriver x -> List (Dune_sexp.atom "ppx_deriver" :: Ppx_args.encode x)
-    | Ppx_rewriter x -> List (Dune_sexp.atom "ppx_rewriter" :: Ppx_args.encode x)
+    | Dune_file d -> Dune_file.encode d
   with
   | List [ x ] -> x
   | x -> x

src/dune_lang/lib_kind.mli

@@ -13,13 +13,32 @@ module Ppx_args : sig
   val empty : t
 end
 
+module Dune_file : sig
+  (** Representation of of valid dune lang values for the library [kind]
+      field *)
+  type t =
+    | Normal
+    | Ppx_deriver of Ppx_args.t
+    | Ppx_rewriter of Ppx_args.t
+
+  (** [cstr_name k] is the name of the kind constructor for [k] in dune lang.
+      E.g., [cstr_name Normal = "normal"] *)
+  val cstr_name : t -> string
+
+  include Conv.S with type t := t
+end
+
+(** Internal representation the of the possible kinds of libraries *)
 type t =
-  | Normal
-  | Ppx_deriver of Ppx_args.t
-  | Ppx_rewriter of Ppx_args.t
+  | Virtual
   | Parameter
+  | Dune_file of Dune_file.t
+  (** A kind which is represented explicitly in the [kind] field of a dune
+      library stanza.
+
+      The remaining variants are derived from other fields in the library
+      stanza. *)
 
 val to_dyn : t Dyn.builder
-val equal : t -> t -> bool
 
 include Conv.S with type t := t

src/dune_rules/dune_package.ml

@@ -105,7 +105,6 @@ module Lib = struct
     let melange_runtime_deps = additional_paths (Lib_info.melange_runtime_deps info) in
     let jsoo_runtime = Lib_info.jsoo_runtime info in
     let wasmoo_runtime = Lib_info.wasmoo_runtime info in
-    let virtual_ = Lib_info.virtual_ info in
     let instrumentation_backend = Lib_info.instrumentation_backend info in
     let native_archives =
       match Lib_info.native_archives info with
@@ -124,7 +123,6 @@ module Lib = struct
     record_fields
     @@ [ field "name" Lib_name.encode name
        ; field "kind" Lib_kind.encode kind
-       ; field_b "virtual" virtual_
        ; field_o "synopsis" string synopsis
        ; field_o "orig_src_dir" path orig_src_dir
        ; mode_paths "archives" archives
@@ -192,7 +190,20 @@ module Lib = struct
        let+ synopsis = field_o "synopsis" string
        and+ loc = loc
        and+ modes = field_l "modes" Lib_mode.decode
-       and+ kind = field "kind" Lib_kind.decode
+       and+ kind =
+         let* kind = field "kind" Lib_kind.decode in
+         let+ virtual_ = field_b "virtual" in
+         match kind with
+         | (Dune_file Normal | Virtual) when virtual_ ->
+           (* Backward compatible support for dune-project files
+              that include the [(virtual)] field. *)
+           Lib_kind.Virtual
+         | incompatible_kind when virtual_ ->
+           Code_error.raise
+             "invalid combination of 'kind' and 'virtual' fields in library stanza of \
+              dune-package file"
+             [ "kind", Lib_kind.to_dyn incompatible_kind; "virtual", Dyn.Bool virtual_ ]
+         | otherwise -> otherwise
        and+ archives = mode_paths "archives"
        and+ plugins = mode_paths "plugins"
        and+ foreign_objects = paths "foreign_objects"
@@ -218,7 +229,6 @@ module Lib = struct
        and+ melange_runtime_deps = paths "melange_runtime_deps"
        and+ requires = field_l "requires" (Lib_dep.decode ~allow_re_export:true)
        and+ ppx_runtime_deps = libs "ppx_runtime_deps"
-       and+ virtual_ = field_b "virtual"
        and+ sub_systems = Sub_system_info.record_parser
        and+ orig_src_dir = field_o "orig_src_dir" path
        and+ modules = field "modules" (Modules.decode ~src_dir:base)
@@ -284,7 +294,6 @@ module Lib = struct
            ~enabled
            ~virtual_deps
            ~dune_version
-           ~virtual_
            ~entry_modules
            ~implements
            ~default_implementation

src/dune_rules/dune_package.mli

@@ -1,4 +1,7 @@
-(** Representation of dune-package files *)
+(** Representation of dune-package files.
+
+    dune-package files record package data for the purposes of installation.
+    They are not intended to be written or read by human users. *)
 
 open Import
 

src/dune_rules/findlib.ml

@@ -168,7 +168,6 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
     let wasmoo_runtime = Findlib.Package.wasmoo_runtime t in
     let melange_runtime_deps = Lib_info.File_deps.External [] in
     let preprocess = Preprocess.Per_module.no_preprocessing () in
-    let virtual_ = false in
     let default_implementation = None in
     let wrapped = None in
     let foreign_archives, native_archives =
@@ -268,7 +267,6 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc
       ~enabled
       ~virtual_deps
       ~dune_version
-      ~virtual_
       ~entry_modules
       ~implements
       ~default_implementation

src/dune_rules/gen_meta.ml

@@ -76,8 +76,8 @@ let gen_lib pub_name lib ~version =
   in
   let preds =
     match kind with
-    | Normal | Parameter -> []
-    | Ppx_rewriter _ | Ppx_deriver _ -> [ Pos "ppx_driver" ]
+    | Virtual | Parameter | Dune_file Normal -> []
+    | Dune_file (Ppx_rewriter _ | Ppx_deriver _) -> [ Pos "ppx_driver" ]
   in
   let name lib =
     let name = Lib.name lib in
@@ -127,8 +127,8 @@ let gen_lib pub_name lib ~version =
          ; ppx_runtime_deps ppx_rt_deps
          ])
     ; (match kind with
-       | Normal | Parameter -> []
-       | Ppx_rewriter _ | Ppx_deriver _ ->
+       | Virtual | Parameter | Dune_file Normal -> []
+       | Dune_file (Ppx_rewriter _ | Ppx_deriver _) ->
          (* Deprecated ppx method support *)
          let no_ppx_driver = Neg "ppx_driver"
          and no_custom_ppx = Neg "custom_ppx" in
@@ -139,12 +139,12 @@ let gen_lib pub_name lib ~version =
              ; requires ~preds:[ no_ppx_driver ] ppx_runtime_deps_for_deprecated_method
              ]
            ; (match kind with
-              | Normal | Parameter -> assert false
-              | Ppx_rewriter _ ->
+              | Virtual | Parameter | Dune_file Normal -> assert false
+              | Dune_file (Ppx_rewriter _) ->
                 [ rule "ppx" [ no_ppx_driver; no_custom_ppx ] Set "./ppx.exe --as-ppx"
                 ; rule "library_kind" [] Set "ppx_rewriter"
                 ]
-              | Ppx_deriver _ ->
+              | Dune_file (Ppx_deriver _) ->
                 [ rule "requires" [ no_ppx_driver; no_custom_ppx ] Add "ppx_deriving"
                 ; rule
                     "ppxopt"

src/dune_rules/install_rules.ml

@@ -79,8 +79,8 @@ module Stanzas_to_entries : sig
 end = struct
   let lib_ppxs ctx ~scope ~(lib : Library.t) =
     match lib.kind with
-    | Normal | Parameter | Ppx_deriver _ -> Memo.return []
-    | Ppx_rewriter _ ->
+    | Virtual | Parameter | Dune_file (Normal | Ppx_deriver _) -> Memo.return []
+    | Dune_file (Ppx_rewriter _) ->
       Library.best_name lib
       |> Ppx_driver.ppx_exe ctx ~scope
       |> Resolve.Memo.read_memo

src/dune_rules/lib.ml

@@ -1454,7 +1454,7 @@ end = struct
             let open Resolve.O in
             let* lib = lib in
             (match allow_only_ppx_deps, Lib_info.kind lib.info with
-             | true, Normal -> Error.only_ppx_deps_allowed ~loc lib.info
+             | true, Dune_file Normal -> Error.only_ppx_deps_allowed ~loc lib.info
              | _ -> Resolve.return (Some lib)))
         >>= linking_closure_with_overlap_checks None ~forbidden_libraries:Map.empty
       in

src/dune_rules/lib_info.ml

@@ -324,7 +324,6 @@ type 'path t =
   ; virtual_deps : (Loc.t * Lib_name.t) list
   ; dune_version : Dune_lang.Syntax.Version.t option
   ; sub_systems : Sub_system_info.t Sub_system_name.Map.t
-  ; virtual_ : bool
   ; entry_modules : (Module_name.t list, User_message.t) result Source.t
   ; implements : (Loc.t * Lib_name.t) option
   ; default_implementation : (Loc.t * Lib_name.t) option
@@ -368,7 +367,7 @@ let status t = t.status
 let kind t = t.kind
 let default_implementation t = t.default_implementation
 let obj_dir t = t.obj_dir
-let virtual_ t = t.virtual_
+let virtual_ t = t.kind = Virtual
 let is_parameter t = t.kind = Parameter
 let implements t = t.implements
 let synopsis t = t.synopsis
@@ -420,7 +419,6 @@ let create
       ~enabled
       ~virtual_deps
       ~dune_version
-      ~virtual_
       ~entry_modules
       ~implements
       ~default_implementation
@@ -460,7 +458,6 @@ let create
   ; virtual_deps
   ; dune_version
   ; sub_systems
-  ; virtual_
   ; entry_modules
   ; implements
   ; default_implementation
@@ -557,7 +554,6 @@ let to_dyn
       ; virtual_deps
       ; dune_version
       ; sub_systems
-      ; virtual_
       ; implements
       ; default_implementation
       ; modes
@@ -598,7 +594,6 @@ let to_dyn
     ; "virtual_deps", list (snd Lib_name.to_dyn) virtual_deps
     ; "dune_version", option Dune_lang.Syntax.Version.to_dyn dune_version
     ; "sub_systems", Sub_system_name.Map.to_dyn Dyn.opaque sub_systems
-    ; "virtual_", bool virtual_
     ; ( "entry_modules"
       , Source.to_dyn
           (Result.to_dyn (list Module_name.to_dyn) string)