Source file ml_bundle.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
open! Core
open! Async

type t =
  { ml          : string
  ; mli         : string option
  ; module_name : string
  }
[@@deriving sexp, compare] [@@sexp.allow_extra_fields]

type tmp_t =
  { mutable tmp_ml  : string option
  ; mutable tmp_mli : string option
  ; tmp_module_name : string
  }

let valid_module_name s =
  not (String.is_empty s) &&
  match s.[0] with
  | 'A'..'Z' ->
    String.for_all s ~f:(function
      | 'a'..'z' | 'A'..'Z' | '_' | '0'..'9' | '\'' -> true
      | _ -> false
    )
  | _ -> false
;;

let module_name ~full_path ~path_no_ext =
  let basename = Filename.basename path_no_ext in
  let unchecked_module_name = String.capitalize basename in
  if valid_module_name unchecked_module_name then
    unchecked_module_name
  else
    invalid_argf "%s is not a valid ocaml filename" full_path ()
;;

let enrich_bundle ({ ml; mli; module_name = _ } as bundle) =
  match mli with
  | Some _ -> return bundle
  | None ->
    let mli = Filename.chop_extension ml ^ ".mli" in
    Sys.file_exists mli >>| function
    | `Yes -> { bundle with mli = Some mli }
    | `No -> bundle
    | `Unknown -> raise_s [%sexp "File_in_unknown_state", (mli : string), [%here]]
;;

let ml_with_mli_reorder filenames =
  let tbl = String.Table.create () in
  let init_bundle acc str =
    let path_no_ext, ext_opt = Filename.split_extension str in
    let ext =
      match ext_opt with
      | None -> `none
      | Some "ml" -> `ml
      | Some "mli" -> `mli
      | Some ext -> invalid_argf "Expected .ml or .mli files, got : %s" ext ()
    in
    (* giving this error after the one about extensions *)
    let module_name = module_name ~full_path:str ~path_no_ext in
    let acc, data =
      match Hashtbl.find tbl module_name with
      | None ->
        let data = { tmp_ml = None; tmp_mli = None; tmp_module_name = module_name } in
        Hashtbl.add_exn tbl ~key:module_name ~data;
        data :: acc, data
      | Some data -> acc, data
    in
    begin match ext, data with
    | (`ml | `none), { tmp_ml = Some old_ml; _ } ->
      invalid_argf "Several implementations provided for %s: %s and %s"
        module_name str old_ml ()
    | `mli, { tmp_mli = Some old_mli; _ } ->
      invalid_argf "Several interfaces provided for %s: %s and %s"
        module_name str old_mli ()
    | `none , { tmp_ml = None; _ } ->
      data.tmp_ml <- Some (str ^ ".ml")
    | `ml, { tmp_ml = None; _ } ->
      data.tmp_ml <- Some str
    | `mli, { tmp_mli = None; _ } ->
      data.tmp_mli <- Some str
    end;
    acc
  in
  let rev_paths = List.fold_left filenames ~init:[] ~f:init_bundle in
  List.rev_map rev_paths ~f:(
    fun { tmp_ml; tmp_mli = mli; tmp_module_name = module_name } ->
      let ml =
        match tmp_ml with
        | None ->
          (* same behaviour as before *)
          Filename.chop_extension (Option.value_exn mli) ^ ".ml"
        | Some ml -> ml
      in
      { ml; mli; module_name }
  )
;;

let from_filenames filenames =
  Deferred.Or_error.try_with ~extract_exn:true (fun () ->
    let pairs = ml_with_mli_reorder filenames in
    Deferred.List.map pairs ~f:enrich_bundle
  )
;;

let to_pathnames { ml; mli; module_name } =
  `ml ml, `mli mli, `module_name module_name
;;

let module_name t = t.module_name
;;