Source file `spdx_licenses.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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
(* SPDX-License-Identifier: MIT *)

type user_defined_license = Types.user_defined_license = {
  document_ref : string option;
  license_ref : string;
}

type simple_license = Types.simple_license =
  | LicenseID of string
  | LicenseIDPlus of string
  | LicenseRef of user_defined_license

type user_defined_addition = Types.user_defined_addition = {
  document_ref : string option;
  addition_ref : string;
}

type addition = Types.addition =
  | Exception of string
  | AdditionRef of user_defined_addition

type t = Types.t =
  | Simple of simple_license
  | WITH of simple_license * addition
  | AND of t * t
  | OR of t * t

type error = [
  | `InvalidLicenseID of string
  | `InvalidExceptionID of string
  | `ParseError
]

let ( >>= ) = Result.bind
let ( >|= ) x f = Result.map f x

let valid_license_ids = LicenseIDs.list
let valid_exception_ids = ExceptionIDs.list

let uppercased_valid_license_ids =
  List.map (fun x -> (x, String.uppercase_ascii x)) valid_license_ids

let uppercased_valid_exception_ids =
  List.map (fun x -> (x, String.uppercase_ascii x)) valid_exception_ids

let normalize_license_id id =
  let eq = String.equal (String.uppercase_ascii id) in
  match List.find (fun (_, up) -> eq up) uppercased_valid_license_ids with
  | (x, _) -> Ok x
  | exception Not_found -> Error (`InvalidLicenseID id)

let normalize_exception_id id =
  let eq = String.equal (String.uppercase_ascii id) in
  match List.find (fun (_, up) -> eq up) uppercased_valid_exception_ids with
  | (x, _) -> Ok x
  | exception Not_found -> Error (`InvalidExceptionID id)

let normalize_simple = function
  | LicenseID id -> normalize_license_id id >|= fun id -> LicenseID id
  | LicenseIDPlus id -> normalize_license_id id >|= fun id -> LicenseIDPlus id
  | LicenseRef _ as x -> Ok x

let normalize_addition = function
  | Exception exc -> normalize_exception_id exc >|= fun exc -> Exception exc
  | AdditionRef _ as x -> Ok x

let rec normalize = function
  | Simple license ->
      normalize_simple license >|= fun license ->
      Simple license
  | WITH (simple, addition) ->
      normalize_simple simple >>= fun simple ->
      normalize_addition addition >|= fun addition ->
      WITH (simple, addition)
  | AND (x, y) ->
      normalize x >>= fun x ->
      normalize y >|= fun y ->
      AND (x, y)
  | OR (x, y) ->
      normalize x >>= fun x ->
      normalize y >|= fun y ->
      OR (x, y)

let parse s =
  let lexbuf = Lexing.from_string s in
  match Parser.main Lexer.main lexbuf with
  | license -> normalize license
  | exception (Lexer.Error | Parsing.Parse_error) -> Error `ParseError

let user_defined_license_to_string = function
  | {document_ref = None; license_ref} ->
      "LicenseRef-"^license_ref
  | {document_ref = Some document_ref; license_ref} ->
      "DocumentRef-"^document_ref^":"^"LicenseRef-"^license_ref

let simple_to_string = function
  | LicenseID x -> x
  | LicenseIDPlus x -> x^"+"
  | LicenseRef user_def -> user_defined_license_to_string user_def

let user_defined_addition_to_string = function
  | {document_ref = None; addition_ref} ->
      "AdditionRef-"^addition_ref
  | {document_ref = Some document_ref; addition_ref} ->
      "DocumentRef-"^document_ref^":"^"AdditionRef-"^addition_ref

let addition_to_string = function
  | Exception x -> x
  | AdditionRef user_def -> user_defined_addition_to_string user_def

let to_string =
  let rec aux ~prev = function
    | Simple x -> simple_to_string x
    | WITH (x, addition) ->
        simple_to_string x^" WITH "^addition_to_string addition
    | AND (x, y) ->
        let s = aux ~prev:`AND x^" AND "^aux ~prev:`AND y in
        begin match prev with
        | (`None | `AND) -> s
        | `OR -> "("^s^")"
        end
    | OR (x, y) ->
        let s = aux ~prev:`OR x^" OR "^aux ~prev:`OR y in
        begin match prev with
        | (`None | `OR) -> s
        | `AND -> "("^s^")"
        end
  in
  aux ~prev:`None