From 17f4de0b3c3b8ffdce70cc381e8ac8b1b2ed7a6b Mon Sep 17 00:00:00 2001
From: teague hansen <thanse23@asu.edu>
Date: Thu, 25 Jul 2024 13:01:30 -0400
Subject: [PATCH] rework source kind types to provide strict creation

Signed-off-by: teague hansen <thanse23@asu.edu>
---
 src/dune_lang/package_info.ml |   6 +-
 src/dune_lang/source_kind.ml  | 167 ++++++++++++++++++----------------
 src/dune_lang/source_kind.mli |  23 ++---
 3 files changed, 101 insertions(+), 95 deletions(-)

diff --git a/src/dune_lang/package_info.ml b/src/dune_lang/package_info.ml
index d513f3ece48c..177ff173101f 100644
--- a/src/dune_lang/package_info.ml
+++ b/src/dune_lang/package_info.ml
@@ -43,11 +43,7 @@ let empty =
 
 let example =
   { source =
-      Some
-        (Host
-           { repo = Source_kind.Host.User_repo { user = "username"; repo = "reponame" }
-           ; kind = Source_kind.Host.Github
-           })
+      Some (Host (Source_kind.Host.Github { user = "username"; repo = "reponame" }))
   ; license = Some [ "LICENSE" ]
   ; authors = Some [ "Author Name" ]
   ; maintainers = Some [ "Maintainer Name" ]
diff --git a/src/dune_lang/source_kind.ml b/src/dune_lang/source_kind.ml
index 8645eda1d2df..79c7cae3fb5d 100644
--- a/src/dune_lang/source_kind.ml
+++ b/src/dune_lang/source_kind.ml
@@ -2,24 +2,13 @@ open Stdune
 open Dune_sexp
 
 module Host = struct
-  type kind =
-    | Github
-    | Bitbucket
-    | Gitlab
-    | Sourcehut
-
-  let to_string = function
-    | Github -> "github"
-    | Bitbucket -> "bitbucket"
-    | Gitlab -> "gitlab"
-    | Sourcehut -> "sourcehut"
-  ;;
+  type user_repo =
+    { user : string
+    ; repo : string
+    }
 
-  type repo =
-    | User_repo of
-        { user : string
-        ; repo : string
-        }
+  type gitlab_repo =
+    | User_repo of user_repo
     | Org_repo of
         { org : string
         ; proj : string
@@ -27,77 +16,99 @@ module Host = struct
         }
 
   type t =
-    { repo : repo
-    ; kind : kind
-    }
-
-  let dyn_of_kind kind = kind |> to_string |> Dyn.string
+    | Github of user_repo
+    | Bitbucket of user_repo
+    | Gitlab of gitlab_repo
+    | Sourcehut of user_repo
+
+  let kind_string = function
+    | Github _ -> "github"
+    | Bitbucket _ -> "bitbucket"
+    | Gitlab _ -> "gitlab"
+    | Sourcehut _ -> "sourcehut"
+  ;;
 
-  let to_dyn { repo; kind } =
+  let dyn_of_user_repo kind { user; repo } =
     let open Dyn in
+    record [ "kind", kind; "user", string user; "repo", string repo ]
+  ;;
+
+  let dyn_of_gitlab_repo kind repo =
     match repo with
-    | User_repo { user; repo } ->
-      record [ "kind", dyn_of_kind kind; "user", string user; "repo", string repo ]
+    | User_repo user_repo -> dyn_of_user_repo kind user_repo
     | Org_repo { org; proj; repo } ->
-      record
-        [ "kind", dyn_of_kind kind
-        ; "org", string org
-        ; "proj", string proj
-        ; "repo", string repo
-        ]
+      let open Dyn in
+      record [ "kind", kind; "org", string org; "proj", string proj; "repo", string repo ]
+  ;;
+
+  let to_dyn repo =
+    let kind = Dyn.string (kind_string repo) in
+    match repo with
+    | Gitlab gitlab_repo -> dyn_of_gitlab_repo kind gitlab_repo
+    | Github user_repo | Bitbucket user_repo | Sourcehut user_repo ->
+        dyn_of_user_repo kind user_repo
   ;;
 
-  let host_of_kind = function
-    | Github -> "github.com"
-    | Bitbucket -> "bitbucket.org"
-    | Gitlab -> "gitlab.com"
-    | Sourcehut -> "sr.ht"
+  let host_of_repo = function
+    | Github _ -> "github.com"
+    | Bitbucket _ -> "bitbucket.org"
+    | Gitlab _ -> "gitlab.com"
+    | Sourcehut _ -> "sr.ht"
   ;;
 
-  let base_uri { repo; kind } =
-    let host = host_of_kind kind in
+  let base_uri repo =
+    let host = host_of_repo repo in
     match repo with
-    | User_repo { user; repo } ->
-      sprintf
-        "%s/%s/%s"
-        host
-        (match kind with
-         | Sourcehut -> "~" ^ user
-         | _ -> user)
-        repo
-    | Org_repo { org; proj; repo } -> sprintf "%s/%s/%s/%s" host org proj repo
+    | Gitlab (Org_repo {org; proj; repo}) -> sprintf "%s/%s/%s/%s" host org proj repo
+    | Sourcehut {user; repo} -> sprintf "%s/~%s/%s" host user repo
+    | Gitlab (User_repo {user; repo}) | Github {user; repo} | Bitbucket {user; repo} ->
+        sprintf "%s/%s/%s" host user repo
   ;;
 
   let add_https s = "https://" ^ s
   let homepage t = add_https (base_uri t)
 
-  let bug_reports t =
-    match t.kind with
-    | Sourcehut -> add_https ("todo." ^ base_uri t)
-    | _ ->
-      homepage t
-      ^
-        (match t.kind with
-        | Sourcehut -> assert false
-        | Bitbucket | Github -> "/issues"
-        | Gitlab -> "/-/issues")
+  let bug_reports = function
+    | Gitlab _ as repo -> homepage repo ^ "/-/issues"
+    | Github _ as repo -> homepage repo ^ "/issues"
+    | Bitbucket _ as repo -> homepage repo ^ "/issues"
+    | Sourcehut _ as repo -> add_https ("todo." ^ base_uri repo)
   ;;
 
+  (* todo -- @H-ANSEN
+     currently each forge in the list is evaluated in order, since 'gitlab' 
+     now has the option to specifiy a organization style repo we need some way
+     to identify this type and present a error in the case that the dune version
+     is not supported. Currently no error is thrown *)
   let enum k =
-    [ "GitHub", Github, None
-    ; "Bitbucket", Bitbucket, Some (2, 8)
-    ; "Gitlab", Gitlab, Some (2, 8)
-    ; "Sourcehut", Sourcehut, Some (3, 1)
+    let stub_user_repo = { user = ""; repo = "" } in
+    let stub_org_repo = Org_repo { org = ""; proj = ""; repo = "" } in
+    [ "Github", Github stub_user_repo, None
+    ; "Bitbucket", Bitbucket stub_user_repo, Some (2, 8)
+    ; "Sourcehut", Sourcehut stub_user_repo, Some (3, 1)
+    ; "Gitlab", Gitlab (User_repo stub_user_repo), Some (2, 8)
+    ; "Gitlab", Gitlab stub_org_repo, Some (3, 17)
     ]
     |> List.map ~f:(fun (name, kind, since) ->
-      let of_string ~loc s =
-        match String.split ~on:'/' s with
-        | [ user; repo ] -> k { repo = User_repo { user; repo }; kind }
-        | [ org; proj; repo ] -> k { repo = Org_repo { org; proj; repo }; kind }
-        | _ ->
+      let of_string ~loc str =
+        match kind, String.split ~on:'/' str with
+        | Gitlab _, [ user; repo ] -> k @@ Gitlab (User_repo { user; repo })
+        | Gitlab _, [ org; proj; repo ] -> k @@ Gitlab (Org_repo { org; proj; repo })
+        | Github _, [ user; repo ] -> k @@ Github { user; repo }
+        | Bitbucket _, [ user; repo ] -> k @@ Bitbucket { user; repo }
+        | Sourcehut _, [ user; repo ] -> k @@ Sourcehut { user; repo }
+        | _, [ _; _; _ ] ->
           User_error.raise
             ~loc
-            [ Pp.textf "%s repository must be of form user/repo or org/proj/repo" name ]
+            ~hints:
+              [ Pp.textf
+                  "The provided form 'org/proj/repo' is specific to Gitlab projects"
+              ]
+            [ Pp.textf "%s repository must be of form user/repo" name ]
+        | _, _ ->
+          User_error.raise
+            ~loc
+            [ Pp.textf "%s repository must be of form user/repo" name ]
       in
       let decode =
         let open Decoder in
@@ -106,26 +117,28 @@ module Host = struct
          | Some v -> Syntax.since Stanza.syntax v)
         >>> plain_string of_string
       in
-      let constr = to_string kind in
-      constr, decode)
+      kind_string kind, decode)
   ;;
 
-  let encode { repo; kind } =
-    let forge = to_string kind in
+  let encode repo =
     let path =
       match repo with
-      | User_repo { user; repo } -> sprintf "%s/%s" user repo
-      | Org_repo { org; proj; repo } -> sprintf "%s/%s/%s" org proj repo
+      | Gitlab (Org_repo { org; proj; repo }) -> sprintf "%s/%s/%s" org proj repo
+      | Gitlab (User_repo { user; repo }) -> sprintf "%s/%s" user repo
+      | Sourcehut { user; repo } -> sprintf "%s/%s" user repo
+      | Github { user; repo } -> sprintf "%s/%s" user repo
+      | Bitbucket { user; repo } -> sprintf "%s/%s" user repo
     in
     let open Encoder in
+    let forge = kind_string repo in
     pair string string (forge, path)
   ;;
 
-  let to_string t =
+  let to_string repo =
     let base_uri =
-      let base = base_uri t in
-      match t.kind with
-      | Sourcehut -> "git." ^ base
+      let base = base_uri repo in
+      match repo with
+      | Sourcehut _ -> "git." ^ base
       | _ -> base ^ ".git"
     in
     "git+https://" ^ base_uri
diff --git a/src/dune_lang/source_kind.mli b/src/dune_lang/source_kind.mli
index 0b8821ae3bf3..768d5ebf9dd3 100644
--- a/src/dune_lang/source_kind.mli
+++ b/src/dune_lang/source_kind.mli
@@ -1,15 +1,11 @@
 module Host : sig
-  type kind =
-    | Github
-    | Bitbucket
-    | Gitlab
-    | Sourcehut
+  type user_repo =
+    { user : string
+    ; repo : string
+    }
 
-  type repo =
-    | User_repo of
-        { user : string
-        ; repo : string
-        }
+  type gitlab_repo =
+    | User_repo of user_repo
     | Org_repo of
         { org : string
         ; proj : string
@@ -17,9 +13,10 @@ module Host : sig
         }
 
   type t =
-    { repo : repo
-    ; kind : kind
-    }
+    | Github of user_repo
+    | Bitbucket of user_repo
+    | Gitlab of gitlab_repo
+    | Sourcehut of user_repo
 
   val homepage : t -> string
   val bug_reports : t -> string