anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
1(** Dune project file parsing. *)
2
3type source_info =
4 | Github of { user : string; repo : string }
5 | Gitlab of { user : string; repo : string }
6 | Tangled of { host : string; repo : string } (** tangled.org style sources *)
7 | Uri of { url : string; branch : string option }
8
9type t = {
10 name : string;
11 source : source_info option;
12 homepage : string option;
13 packages : string list;
14}
15
16module Sexp = Sexplib0.Sexp
17
18(** Extract string from a Sexp.Atom, or None if it's a List *)
19let atom_string = function
20 | Sexp.Atom s -> Some s
21 | Sexp.List _ -> None
22
23(** Parse source stanza: (source (github user/repo)) or (source (uri "url")) *)
24let parse_source_inner sexp =
25 match sexp with
26 | Sexp.List [ Sexp.Atom "github"; Sexp.Atom user_repo ] -> (
27 match String.split_on_char '/' user_repo with
28 | [ user; repo ] -> Some (Github { user; repo })
29 | _ -> None)
30 | Sexp.List [ Sexp.Atom "gitlab"; Sexp.Atom user_repo ] -> (
31 match String.split_on_char '/' user_repo with
32 | [ user; repo ] -> Some (Gitlab { user; repo })
33 | _ -> None)
34 | Sexp.List [ Sexp.Atom "tangled"; Sexp.Atom host_repo ] -> (
35 (* tangled sources: (tangled host.domain/repo) *)
36 match String.index_opt host_repo '/' with
37 | Some i ->
38 let host = String.sub host_repo 0 i in
39 let repo = String.sub host_repo (i + 1) (String.length host_repo - i - 1) in
40 Some (Tangled { host; repo })
41 | None -> None)
42 | Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] ->
43 (* Check for branch in URI fragment *)
44 let uri = Uri.of_string url in
45 let branch = Uri.fragment uri in
46 let url_without_fragment =
47 Uri.with_fragment uri None |> Uri.to_string
48 in
49 Some (Uri { url = url_without_fragment; branch })
50 | Sexp.Atom url ->
51 (* Single atom URL (unlikely but handle it) *)
52 let uri = Uri.of_string url in
53 let branch = Uri.fragment uri in
54 let url_without_fragment =
55 Uri.with_fragment uri None |> Uri.to_string
56 in
57 Some (Uri { url = url_without_fragment; branch })
58 | _ -> None
59
60(** Find name in (package (name foo) ...) stanza *)
61let rec find_package_name = function
62 | [] -> None
63 | Sexp.List [ Sexp.Atom "name"; Sexp.Atom name ] :: _ -> Some name
64 | _ :: rest -> find_package_name rest
65
66(** Extract all package names from parsed sexps *)
67let extract_packages sexps =
68 List.filter_map
69 (function
70 | Sexp.List (Sexp.Atom "package" :: rest) -> find_package_name rest
71 | _ -> None)
72 sexps
73
74(** Find a simple string field like (name foo) or (homepage "url") *)
75let find_string_field name sexps =
76 List.find_map
77 (function
78 | Sexp.List [ Sexp.Atom n; value ] when n = name -> atom_string value
79 | _ -> None)
80 sexps
81
82(** Find source field: (source ...) *)
83let find_source sexps =
84 List.find_map
85 (function
86 | Sexp.List [ Sexp.Atom "source"; inner ] -> parse_source_inner inner
87 | _ -> None)
88 sexps
89
90let parse content =
91 match Parsexp.Many.parse_string content with
92 | Error err ->
93 Error (Printf.sprintf "S-expression parse error: %s"
94 (Parsexp.Parse_error.message err))
95 | Ok sexps -> (
96 match find_string_field "name" sexps with
97 | None -> Error "dune-project missing (name ...) stanza"
98 | Some name ->
99 let source = find_source sexps in
100 let homepage = find_string_field "homepage" sexps in
101 let packages = extract_packages sexps in
102 Ok { name; source; homepage; packages })
103
104(** Normalize a URL to have git+ prefix *)
105let normalize_git_url url =
106 if String.starts_with ~prefix:"git+" url then url
107 else if String.starts_with ~prefix:"git@" url then "git+" ^ url
108 else if String.starts_with ~prefix:"https://" url then "git+" ^ url
109 else if String.starts_with ~prefix:"http://" url then
110 "git+https" ^ String.sub url 4 (String.length url - 4)
111 else "git+" ^ url
112
113(** Ensure URL ends with .git *)
114let ensure_git_suffix url =
115 if String.ends_with ~suffix:".git" url then url
116 else url ^ ".git"
117
118let dev_repo_url t =
119 match t.source with
120 | Some (Github { user; repo }) ->
121 Ok (Printf.sprintf "git+https://github.com/%s/%s.git" user repo)
122 | Some (Gitlab { user; repo }) ->
123 Ok (Printf.sprintf "git+https://gitlab.com/%s/%s.git" user repo)
124 | Some (Tangled { host; repo }) ->
125 (* Tangled sources: https://tangled.sh/@handle/repo *)
126 Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo)
127 | Some (Uri { url; _ }) ->
128 Ok (normalize_git_url (ensure_git_suffix url))
129 | None -> (
130 match t.homepage with
131 | Some homepage ->
132 Ok (normalize_git_url (ensure_git_suffix homepage))
133 | None ->
134 Error
135 (Printf.sprintf
136 "Package %s must declare source or homepage in dune-project"
137 t.name))
138
139let url_with_branch t =
140 match dev_repo_url t with
141 | Error e -> Error e
142 | Ok url ->
143 let branch =
144 match t.source with
145 | Some (Uri { branch = Some b; _ }) -> b
146 | _ -> "main"
147 in
148 Ok (url ^ "#" ^ branch)