open! Dune_rules__
open Import

module Inherited = struct
  type 'a t =
    | This of 'a
    | From of (Loc.t * Lib_name.t)

  let to_dyn f x =
    let open Dyn in
    match x with
    | This x -> variant "This" [ f x ]
    | From (_, name) -> variant "From" [ Lib_name.to_dyn name ]
  ;;
end

module Main_module_name = struct
  type t = Module_name.t option Inherited.t

  let to_dyn x = Inherited.to_dyn (Dyn.option Module_name.to_dyn) x
end

type _ path =
  | Local : Path.Build.t path
  | External : Path.t path

module Special_builtin_support = struct
  let api_version_field supported_api_versions =
    let open Dune_lang.Decoder in
    field
      "api_version"
      (let+ loc = loc
       and+ ver = int in
       match List.assoc supported_api_versions ver with
       | Some x -> x
       | None ->
         User_error.raise
           ~loc
           [ Pp.textf
               "API version %d is not supported. Only the following versions are \
                currently supported:"
               ver
           ; Pp.enumerate supported_api_versions ~f:(fun (n, _) -> Pp.textf "%d" n)
           ])
  ;;

  module Build_info = struct
    type api_version = V1

    let api_version_to_dyn = function
      | V1 -> Dyn.variant "V1" []
    ;;

    let supported_api_versions = [ 1, V1 ]

    type t =
      { data_module : Module_name.t
      ; api_version : api_version
      }

    let to_dyn { data_module; api_version } =
      let open Dyn in
      record
        [ "data_module", Module_name.to_dyn data_module
        ; "api_version", api_version_to_dyn api_version
        ]
    ;;

    let decode =
      let open Dune_lang.Decoder in
      fields
        (let+ data_module = field "data_module" Module_name.decode
         and+ api_version = api_version_field supported_api_versions in
         { data_module; api_version })
    ;;

    let encode { data_module; api_version } =
      let open Dune_lang.Encoder in
      record_fields
        [ field "data_module" Module_name.encode data_module
        ; field
            "api_version"
            int
            (match api_version with
             | V1 -> 1)
        ]
    ;;
  end

  module Configurator = struct
    type api_version = V1

    let api_version_to_dyn = function
      | V1 -> Dyn.variant "V1" []
    ;;

    let supported_api_versions = [ 1, V1 ]

    type t = { api_version : api_version }

    let to_dyn { api_version } =
      let open Dyn in
      record [ "api_version", api_version_to_dyn api_version ]
    ;;

    let decode =
      let open Dune_lang.Decoder in
      fields
        (let+ api_version = api_version_field supported_api_versions in
         { api_version })
    ;;

    let encode { api_version } =
      let open Dune_lang.Encoder in
      record_fields
        [ field
            "api_version"
            int
            (match api_version with
             | V1 -> 1)
        ]
    ;;
  end

  module Dune_site = struct
    type t =
      { data_module : Module_name.t
      ; plugins : bool
      }

    let to_dyn { data_module; plugins } =
      let open Dyn in
      record [ "data_module", Module_name.to_dyn data_module; "plugins", bool plugins ]
    ;;

    let decode =
      let open Dune_lang.Decoder in
      fields
        (let+ data_module = field "data_module" Module_name.decode
         and+ plugins = field_b "plugins" in
         { data_module; plugins })
    ;;

    let encode { data_module; plugins } =
      let open Dune_lang.Encoder in
      record_fields
        [ field "data_module" Module_name.encode data_module; field_b "plugins" plugins ]
    ;;
  end

  type t =
    | Findlib_dynload
    | Build_info of Build_info.t
    | Configurator of Configurator.t
    | Dune_site of Dune_site.t

  let to_dyn x =
    let open Dyn in
    match x with
    | Findlib_dynload -> variant "Findlib_dynload" []
    | Build_info info -> variant "Build_info" [ Build_info.to_dyn info ]
    | Configurator info -> variant "Configurator" [ Configurator.to_dyn info ]
    | Dune_site info -> variant "Dune_site" [ Dune_site.to_dyn info ]
  ;;

  let decode =
    let open Dune_lang.Decoder in
    sum
      [ "findlib_dynload", return Findlib_dynload
      ; ( "build_info"
        , let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 11)
          and+ info = Build_info.decode in
          Build_info info )
      ; ( "configurator"
        , let+ () = Dune_lang.Syntax.since Stanza.syntax (2, 3)
          and+ info = Configurator.decode in
          Configurator info )
      ; ( "dune_site"
        , let+ () = Dune_lang.Syntax.since Stanza.syntax (2, 8)
          and+ info = Dune_site.decode in
          Dune_site info )
      ]
  ;;

  let encode t =
    match t with
    | Findlib_dynload -> Dune_lang.atom "findlib_dynload"
    | Build_info x -> Dune_lang.List (Dune_lang.atom "build_info" :: Build_info.encode x)
    | Configurator x ->
      Dune_lang.List (Dune_lang.atom "configurator" :: Configurator.encode x)
    | Dune_site x -> Dune_lang.List (Dune_lang.atom "dune_site" :: Dune_site.encode x)
  ;;
end

module Status = struct
  type t =
    | Installed_private
    | Installed
    | Public of Dune_project.t * Package.t
    | Private of Dune_project.t * Package.t option

  let to_dyn x =
    let open Dyn in
    match x with
    | Installed_private -> variant "Installed_private" []
    | Installed -> variant "Installed" []
    | Public (project, package) ->
      variant "Public" [ Dune_project.to_dyn project; Package.to_dyn package ]
    | Private (proj, package) ->
      variant "Private" [ Dune_project.to_dyn proj; option Package.to_dyn package ]
  ;;

  let is_private = function
    | Installed_private | Private _ -> true
    | Installed | Public _ -> false
  ;;

  let project = function
    | Installed_private | Installed -> None
    | Private (project, _) | Public (project, _) -> Some project
  ;;

  let relative_to_package t name =
    match t with
    | Private (_, None) -> None
    | _ ->
      (let _, subdir = Lib_name.split name in
       match t with
       | Private (_, Some _) ->
         Lib_name.Local.mangled_path_under_package (Lib_name.to_local_exn name) @ subdir
       | _ -> subdir)
      |> String.concat ~sep:"/"
      |> Path.Local.of_string
      |> Option.some
  ;;
end

module Source = struct
  type 'a t =
    | Local
    | External of 'a

  let to_dyn f x =
    let open Dyn in
    match x with
    | Local -> variant "Local" []
    | External x -> variant "External" [ f x ]
  ;;

  let map t ~f =
    match t with
    | Local -> Local
    | External a -> External (f a)
  ;;
end

module Enabled_status = struct
  type t =
    | Normal
    | Optional
    | Disabled_because_of_enabled_if
end

type 'path native_archives =
  | Needs_module_info of 'path
  | Files of 'path list

let dyn_of_native_archives path =
  let open Dyn in
  function
  | Needs_module_info f -> variant "Needs_module_info" [ path f ]
  | Files files -> variant "Files" [ (list path) files ]
;;

module File_deps = struct
  type 'a t =
    | Local of Loc.t * Dep_conf.t list
    | External of 'a list

  let map t ~f =
    match t with
    | Local (loc, x) -> Local (loc, x)
    | External xs -> External (List.map ~f xs)
  ;;

  let to_dyn f x =
    let open Dyn in
    match x with
    | Local (_loc, depconf) -> variant "Local" (List.map ~f:Dep_conf.to_dyn depconf)
    | External x -> variant "External" (List.map ~f x)
  ;;
end

(** {1 Lib_info_invariants}

    Many of the fields here are optional and are "entangled" in the sense that
    they are all either set to [None] (for external libraries) or to [Some] (for
    local libraries). This record used to be a sum type, to distinguish between
    these two cases more cleanly, but was later refactored into a single record
    for the sake of convenience. We might revisit this decision in future. *)
type 'path t =
  { loc : Loc.t
  ; name : Lib_name.t
  ; lib_id : Lib_id.t
  ; kind : Lib_kind.t
  ; status : Status.t
  ; src_dir : 'path
  ; orig_src_dir : 'path option
  ; obj_dir : 'path Obj_dir.t
  ; version : Package_version.t option
  ; synopsis : string option
  ; archives : 'path list Mode.Dict.t
  ; plugins : 'path list Mode.Dict.t
  ; foreign_objects : 'path list Source.t
  ; public_headers : 'path File_deps.t
  ; foreign_archives : 'path Mode.Map.Multi.t
  ; native_archives : 'path native_archives
  ; foreign_dll_files : 'path list
  ; jsoo_runtime : 'path list
  ; wasmoo_runtime : 'path list
  ; requires : Lib_dep.t list Compilation_mode.By_mode.t
  ; parameters : (Loc.t * Lib_name.t) list
  ; ppx_runtime_deps : (Loc.t * Lib_name.t) list Compilation_mode.By_mode.t
  ; allow_unused_libraries : (Loc.t * Lib_name.t) list
  ; preprocess :
      Preprocess.With_instrumentation.t Preprocess.Per_module.t Compilation_mode.By_mode.t
  ; enabled : Enabled_status.t Memo.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
  ; entry_modules :
      (Module_name.t list option Compilation_mode.By_mode.t, User_message.t) result
        Source.t
  ; implements : (Loc.t * Lib_name.t) option
  ; default_implementation : (Loc.t * Lib_name.t) option
  ; wrapped : Wrapped.t Inherited.t option
  ; main_module_name : Main_module_name.t
  ; local_main_module_name : Module_name.t option
  ; modes : Lib_mode.Map.Set.t
  ; modules : Modules.With_vlib.t option Compilation_mode.By_mode.t Source.t
  ; special_builtin_support : (Loc.t * Special_builtin_support.t) option
  ; exit_module : Module_name.t option
  ; instrumentation_backend : (Loc.t * Lib_name.t) option
  ; path_kind : 'path path
  ; melange_runtime_deps : 'path File_deps.t
  ; root_module : Module_name.t option
  }

let name t = t.name
let lib_id t = t.lib_id
let version t = t.version
let dune_version t = t.dune_version
let loc t = t.loc
let parameters t = t.parameters
let requires t ~for_ = Compilation_mode.By_mode.get t.requires ~for_
let requires_by_mode t = t.requires
let preprocess t ~for_ = Compilation_mode.By_mode.get t.preprocess ~for_
let ppx_runtime_deps t = t.ppx_runtime_deps
let allow_unused_libraries t = t.allow_unused_libraries
let sub_systems t = t.sub_systems
let modes t = t.modes
let modules t ~for_ = Source.map t.modules ~f:(Compilation_mode.By_mode.get ~for_)
let modules_by_mode t = t.modules
let archives t = t.archives
let foreign_archives t = t.foreign_archives
let native_archives t = t.native_archives
let foreign_dll_files t = t.foreign_dll_files
let foreign_objects t = t.foreign_objects
let public_headers t = t.public_headers
let exit_module t = t.exit_module
let instrumentation_backend t = t.instrumentation_backend
let melange_runtime_deps t = t.melange_runtime_deps
let root_module t = t.root_module
let plugins t = t.plugins
let src_dir t = t.src_dir
let enabled t = t.enabled
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.kind = Virtual
let implements t = t.implements
let synopsis t = t.synopsis
let wrapped t = t.wrapped
let special_builtin_support t = t.special_builtin_support
let jsoo_runtime t = t.jsoo_runtime
let wasmoo_runtime t = t.wasmoo_runtime
let main_module_name t = t.main_module_name
let local_main_module_name t = t.local_main_module_name
let orig_src_dir t = t.orig_src_dir
let best_src_dir t = Option.value ~default:t.src_dir t.orig_src_dir
let set_version t version = { t with version }

let entry_modules t ~for_ =
  Source.map t.entry_modules ~f:(fun entry_modules ->
    Result.map entry_modules ~f:(fun entry_modules ->
      Compilation_mode.By_mode.get entry_modules ~for_ |> Option.value_exn))
;;

let dynlink_supported t = Mode.Dict.get t.plugins Native <> []

let eval_native_archives_exn (type path) (t : path t) ~modules =
  match t.native_archives, modules with
  | Files f, _ -> f
  | Needs_module_info _, None -> Code_error.raise "missing module information" []
  | Needs_module_info f, Some modules ->
    if Modules.With_vlib.has_impl modules then [ f ] else []
;;

let create
      ~loc
      ~path_kind
      ~name
      ~lib_id
      ~kind
      ~status
      ~src_dir
      ~orig_src_dir
      ~obj_dir
      ~version
      ~synopsis
      ~main_module_name
      ~local_main_module_name
      ~sub_systems
      ~requires
      ~parameters
      ~foreign_objects
      ~public_headers
      ~plugins
      ~archives
      ~ppx_runtime_deps
      ~allow_unused_libraries
      ~foreign_archives
      ~native_archives
      ~foreign_dll_files
      ~jsoo_runtime
      ~wasmoo_runtime
      ~preprocess
      ~enabled
      ~virtual_deps
      ~dune_version
      ~entry_modules
      ~implements
      ~default_implementation
      ~modes
      ~modules
      ~wrapped
      ~special_builtin_support
      ~exit_module
      ~instrumentation_backend
      ~melange_runtime_deps
      ~root_module
  =
  { loc
  ; name
  ; lib_id
  ; kind
  ; status
  ; src_dir
  ; orig_src_dir
  ; obj_dir
  ; version
  ; synopsis
  ; requires
  ; parameters
  ; main_module_name
  ; local_main_module_name
  ; foreign_objects
  ; public_headers
  ; plugins
  ; archives
  ; ppx_runtime_deps
  ; allow_unused_libraries
  ; foreign_archives
  ; native_archives
  ; foreign_dll_files
  ; jsoo_runtime
  ; wasmoo_runtime
  ; preprocess
  ; enabled
  ; virtual_deps
  ; dune_version
  ; sub_systems
  ; entry_modules
  ; implements
  ; default_implementation
  ; modes
  ; modules
  ; wrapped
  ; special_builtin_support
  ; exit_module
  ; instrumentation_backend
  ; path_kind
  ; melange_runtime_deps
  ; root_module
  }
;;

type external_ = Path.t t
type local = Path.Build.t t

let map t ~path_kind ~f_path ~f_obj_dir ~f_public_deps =
  let f_dir = f_path ~kind:Install.Entry.Expanded.Directory in
  let f = f_path ~kind:File in
  let list = List.map ~f in
  let mode_list = Mode.Dict.map ~f:list in
  let native_archives =
    match t.native_archives with
    | Needs_module_info t -> Needs_module_info (f t)
    | Files t -> Files (list t)
  in
  { t with
    src_dir = f_dir t.src_dir
  ; orig_src_dir = Option.map ~f:f_dir t.orig_src_dir
  ; obj_dir = f_obj_dir t.obj_dir
  ; archives = mode_list t.archives
  ; plugins = mode_list t.plugins
  ; foreign_objects = Source.map ~f:list t.foreign_objects
  ; public_headers = File_deps.map ~f:f_public_deps t.public_headers
  ; foreign_archives = Mode.Map.Multi.map t.foreign_archives ~f
  ; foreign_dll_files = list t.foreign_dll_files
  ; native_archives
  ; jsoo_runtime = list t.jsoo_runtime
  ; wasmoo_runtime = list t.wasmoo_runtime
  ; melange_runtime_deps = File_deps.map ~f:f_public_deps t.melange_runtime_deps
  ; path_kind
  }
;;

let map_path t ~f =
  map t ~path_kind:External ~f_path:f ~f_obj_dir:Fun.id ~f_public_deps:Fun.id
;;

let of_local =
  map
    ~path_kind:External
    ~f_path:(fun ~kind:_ -> Path.build)
    ~f_obj_dir:Obj_dir.of_local
    ~f_public_deps:Path.build
;;

let as_local_exn =
  map
    ~path_kind:Local
    ~f_path:(fun ~kind:_ -> Path.as_in_build_dir_exn)
    ~f_obj_dir:Obj_dir.as_local_exn
    ~f_public_deps:Path.as_in_build_dir_exn
;;

let to_dyn
      path
      { loc
      ; path_kind = _
      ; name
      ; lib_id
      ; kind
      ; status
      ; src_dir
      ; orig_src_dir
      ; obj_dir
      ; version
      ; synopsis
      ; requires
      ; parameters
      ; main_module_name
      ; local_main_module_name
      ; foreign_objects
      ; public_headers
      ; plugins
      ; archives
      ; ppx_runtime_deps
      ; allow_unused_libraries = _
      ; foreign_archives
      ; native_archives
      ; foreign_dll_files
      ; jsoo_runtime
      ; wasmoo_runtime
      ; preprocess = _
      ; enabled = _
      ; virtual_deps
      ; dune_version
      ; sub_systems
      ; implements
      ; default_implementation
      ; modes
      ; modules
      ; wrapped
      ; special_builtin_support
      ; exit_module
      ; instrumentation_backend
      ; melange_runtime_deps
      ; entry_modules
      ; root_module
      }
  =
  let open Dyn in
  let snd f (_, x) = f x in
  record
    [ "loc", Loc.to_dyn_hum loc
    ; "name", Lib_name.to_dyn name
    ; "lib_id", Lib_id.to_dyn lib_id
    ; "kind", Lib_kind.to_dyn kind
    ; "status", Status.to_dyn status
    ; "src_dir", path src_dir
    ; "orig_src_dir", option path orig_src_dir
    ; "obj_dir", Obj_dir.to_dyn obj_dir
    ; "version", option Package_version.to_dyn version
    ; "synopsis", option string synopsis
    ; "archives", Mode.Dict.to_dyn (list path) archives
    ; "plugins", Mode.Dict.to_dyn (list path) plugins
    ; "foreign_objects", Source.to_dyn (list path) foreign_objects
    ; "public_headers", File_deps.to_dyn path public_headers
    ; "foreign_archives", Mode.Map.Multi.to_dyn path foreign_archives
    ; "native_archives", dyn_of_native_archives path native_archives
    ; "foreign_dll_files", list path foreign_dll_files
    ; "jsoo_runtime", list path jsoo_runtime
    ; "wasmoo_runtime", list path wasmoo_runtime
    ; "parameters", list (snd Lib_name.to_dyn) parameters
    ; "requires", Compilation_mode.By_mode.to_dyn (list Lib_dep.to_dyn) requires
    ; ( "ppx_runtime_deps"
      , Compilation_mode.By_mode.to_dyn (list (snd Lib_name.to_dyn)) ppx_runtime_deps )
    ; "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
    ; ( "entry_modules"
      , Source.to_dyn
          (Result.to_dyn
             (Compilation_mode.By_mode.to_dyn (option (list Module_name.to_dyn)))
             string)
          (Source.map entry_modules ~f:(Result.map_error ~f:User_message.to_string)) )
    ; "implements", option (snd Lib_name.to_dyn) implements
    ; "default_implementation", option (snd Lib_name.to_dyn) default_implementation
    ; "wrapped", option (Inherited.to_dyn Wrapped.to_dyn) wrapped
    ; "main_module_name", Main_module_name.to_dyn main_module_name
    ; "local_main_module_name", Dyn.option Module_name.to_dyn local_main_module_name
    ; "modes", Lib_mode.Map.Set.to_dyn modes
    ; ( "modules"
      , Source.to_dyn
          (Compilation_mode.By_mode.to_dyn (option Modules.With_vlib.to_dyn))
          modules )
    ; ( "special_builtin_support"
      , option (snd Special_builtin_support.to_dyn) special_builtin_support )
    ; "exit_module", option Module_name.to_dyn exit_module
    ; "instrumentation_backend", option (snd Lib_name.to_dyn) instrumentation_backend
    ; "melange_runtime_deps", File_deps.to_dyn path melange_runtime_deps
    ; "root_module", option Module_name.to_dyn root_module
    ]
;;

let package t =
  match t.status with
  | Installed_private | Installed -> Some (Lib_name.package_name t.name)
  | Public (_, p) -> Some (Package.name p)
  | Private (_, p) -> Option.map p ~f:Package.name
;;

let for_dune_package
      t
      ~name
      ~ppx_runtime_deps
      ~requires
      ~foreign_objects
      ~obj_dir
      ~implements
      ~parameters
      ~default_implementation
      ~sub_systems
      ~melange_runtime_deps
      ~public_headers
      ~(modules : Modules.With_vlib.t option Compilation_mode.By_mode.t)
  =
  let foreign_objects = Source.External foreign_objects in
  let orig_src_dir =
    match !Clflags.store_orig_src_dir with
    | false -> t.orig_src_dir
    | true ->
      Some
        (match t.orig_src_dir with
         | Some src_dir -> src_dir
         | None ->
           (match Path.drop_build_context t.src_dir with
            | None -> t.src_dir
            | Some src_dir ->
              Path.source src_dir |> Path.to_absolute_filename |> Path.of_string))
  in
  let native_archives = Files (eval_native_archives_exn t ~modules:modules.ocaml) in
  let modules = Source.External modules in
  let melange_runtime_deps = File_deps.External melange_runtime_deps in
  let public_headers = File_deps.External public_headers in
  { t with
    ppx_runtime_deps
  ; name
  ; requires
  ; foreign_objects
  ; obj_dir
  ; implements
  ; parameters
  ; default_implementation
  ; sub_systems
  ; orig_src_dir
  ; native_archives
  ; modules
  ; melange_runtime_deps
  ; public_headers
  }
  |> map_path
       ~f:
         (let dir = Obj_dir.dir obj_dir in
          fun ~kind p ->
            if Path.is_managed p
            then (
              match kind with
              | Install.Entry.Expanded.File -> Path.relative dir (Path.basename p)
              | Directory -> dir)
            else p)
;;

let for_instance ~dir ~ext_lib t =
  let obj_dir =
    Obj_dir.make_lib
      ~dir
      ~has_private_modules:false
      ~private_lib:false
      (Lib_name.Local.of_string "instance")
  in
  let archives =
    Mode.Dict.mapi t.archives ~f:(fun m _ ->
      [ Path.Build.relative
          dir
          ("archive" ^ Filename.Extension.to_string (Mode.compiled_lib_ext m))
      ])
  in
  let native_archives =
    match ext_lib with
    | None -> Files []
    | Some ext_lib ->
      let ext_lib = Filename.Extension.to_string ext_lib in
      Files [ Path.Build.relative dir ("archive" ^ ext_lib) ]
  in
  { t with
    obj_dir
  ; archives
  ; native_archives
  ; modules = External (Compilation_mode.By_mode.both None)
  ; src_dir = dir
  ; orig_src_dir = None
  ; plugins = Mode.Dict.make ~byte:[] ~native:[]
  ; foreign_objects = Local
  ; public_headers = File_deps.External []
  ; foreign_archives = Mode.Map.empty
  ; foreign_dll_files = []
  ; jsoo_runtime = []
  ; wasmoo_runtime = []
  ; path_kind = Local
  ; melange_runtime_deps = File_deps.External []
  }
;;
