unikernel/duniverse/dune_/otherlibs/dune-private-libs/meta_parser/dune

@@ -0,0 +1,6 @@
+(library
+ (name dune_meta_parser)
+ (public_name dune-private-libs.meta_parser)
+ (synopsis "[Internal] findlib META parser"))
+
+(ocamllex meta_lexer)

unikernel/duniverse/dune_/otherlibs/dune-private-libs/meta_parser/meta_lexer.mli

@@ -0,0 +1,14 @@
+type token =
+  | Name of string
+  | String of string
+  | Minus
+  | Lparen
+  | Rparen
+  | Comma
+  | Equal
+  | Plus_equal
+  | Eof
+
+type user_error = { user_error : 'a. Lexing.lexbuf -> string -> 'a }
+
+val token : user_error -> Lexing.lexbuf -> token

unikernel/duniverse/dune_/otherlibs/dune-private-libs/meta_parser/meta_lexer.mll

@@ -0,0 +1,49 @@
+{
+type token =
+  | Name   of string
+  | String of string
+  | Minus
+  | Lparen
+  | Rparen
+  | Comma
+  | Equal
+  | Plus_equal
+  | Eof
+
+type user_error = { user_error : 'a. Lexing.lexbuf -> string -> 'a }
+
+let escaped_buf = Buffer.create 256
+}
+
+rule token user_error = parse
+  | [' ' '\t' '\r']* { token user_error lexbuf }
+  | '#' [^ '\n']* { token user_error lexbuf }
+  | '\n' { Lexing.new_line lexbuf; token user_error lexbuf }
+
+  | ['A'-'Z' 'a'-'z' '0'-'9' '_' '.']+ as s { Name s }
+  | '"'
+      { Buffer.clear escaped_buf;
+        string user_error escaped_buf lexbuf }
+  | '-' { Minus }
+  | '(' { Lparen }
+  | ')' { Rparen }
+  | ',' { Comma }
+  | '=' { Equal }
+  | "+=" { Plus_equal }
+  | eof { Eof }
+  | _ { user_error.user_error lexbuf "invalid character" }
+
+and string user_error buf = parse
+  | '"'
+      { String (Buffer.contents buf) }
+  | "\\\n"
+  | '\n'
+      { Lexing.new_line lexbuf;
+        Buffer.add_char buf '\n';
+        string user_error buf lexbuf }
+  | '\\' (_ as c)
+  | (_ as c)
+      { Buffer.add_char buf c;
+        string user_error buf lexbuf }
+  | eof
+      { user_error.user_error lexbuf "unterminated string" }

unikernel/duniverse/dune_/otherlibs/dune-private-libs/meta_parser/meta_parser.ml

@@ -0,0 +1,191 @@
+(** Used inside Dune and in the outside library dune_site.plugin *)
+
+module Make (Stdune : sig
+    module Loc : sig
+      type t
+
+      val of_lexbuf : Lexing.lexbuf -> t
+    end
+
+    module Lib_name : sig
+      type t
+
+      val parse_string_exn : Loc.t * string -> t
+    end
+
+    module Pp : sig
+      type +'tag t
+
+      val text : string -> _ t
+    end
+
+    module User_message : sig
+      module Style : sig
+        type t
+      end
+
+      module Annots : sig
+        type t
+      end
+    end
+
+    module User_error : sig
+      val raise
+        :  ?loc:Loc.t
+        -> ?hints:User_message.Style.t Pp.t list
+        -> ?annots:User_message.Annots.t
+        -> User_message.Style.t Pp.t list
+        -> _
+    end
+  end) =
+struct
+  open Stdune
+
+  type t =
+    { name : Lib_name.t option
+    ; entries : entry list
+    }
+
+  and entry =
+    | Comment of string
+    | Rule of rule
+    | Package of t
+
+  and rule =
+    { var : string
+    ; predicates : predicate list
+    ; action : action
+    ; value : string
+    }
+
+  and action =
+    | Set
+    | Add
+
+  and predicate =
+    | Pos of string
+    | Neg of string
+
+  let add_versions t ~get_version =
+    let rec map_entries ~rev_path ~has_version ~has_rules = function
+      | [] ->
+        if has_version || not has_rules
+        then []
+        else (
+          match get_version (List.rev rev_path) with
+          | None -> []
+          | Some v ->
+            [ Rule { var = "version"; predicates = []; action = Set; value = v } ])
+      | entry :: entries ->
+        (match entry with
+         | Comment _ -> entry :: map_entries entries ~rev_path ~has_version ~has_rules
+         | Rule rule ->
+           entry
+           :: map_entries
+                entries
+                ~rev_path
+                ~has_version:(has_version || String.equal rule.var "version")
+                ~has_rules:true
+         | Package t ->
+           Package (map_package t ~rev_path)
+           :: map_entries entries ~rev_path ~has_version ~has_rules)
+    and map_package t ~rev_path =
+      let rev_path =
+        match t.name with
+        | None -> rev_path
+        | Some n -> n :: rev_path
+      in
+      { t with
+        entries = map_entries t.entries ~rev_path ~has_version:false ~has_rules:false
+      }
+    in
+    map_package t ~rev_path:[]
+  ;;
+
+  module Parse = struct
+    let error lexbuf msg = User_error.raise ~loc:(Loc.of_lexbuf lexbuf) [ Pp.text msg ]
+
+    let next =
+      let user_error lexbuf msg =
+        Stdune.User_error.raise ~loc:(Stdune.Loc.of_lexbuf lexbuf) [ Stdune.Pp.text msg ]
+      in
+      Meta_lexer.token { user_error }
+    ;;
+
+    let package_name lb =
+      match next lb with
+      | String s ->
+        if String.contains s '.' then error lb "'.' not allowed in sub-package names";
+        let loc = Loc.of_lexbuf lb in
+        Lib_name.parse_string_exn (loc, s)
+      | _ -> error lb "package name expected"
+    ;;
+
+    let string lb =
+      match next lb with
+      | String s -> s
+      | _ -> error lb "string expected"
+    ;;
+
+    let lparen lb =
+      match next lb with
+      | Lparen -> ()
+      | _ -> error lb "'(' expected"
+    ;;
+
+    let action lb =
+      match next lb with
+      | Equal -> Set
+      | Plus_equal -> Add
+      | _ -> error lb "'=' or '+=' expected"
+    ;;
+
+    let rec predicates_and_action lb acc =
+      match next lb with
+      | Rparen -> List.rev acc, action lb
+      | Name n -> after_predicate lb (Pos n :: acc)
+      | Minus ->
+        let n =
+          match next lb with
+          | Name p -> p
+          | _ -> error lb "name expected"
+        in
+        after_predicate lb (Neg n :: acc)
+      | _ -> error lb "name, '-' or ')' expected"
+
+    and after_predicate lb acc =
+      match next lb with
+      | Rparen -> List.rev acc, action lb
+      | Comma -> predicates_and_action lb acc
+      | _ -> error lb "')' or ',' expected"
+    ;;
+
+    let rec entries lb depth acc =
+      match next lb with
+      | Rparen ->
+        if depth > 0
+        then List.rev acc
+        else error lb "closing parenthesis without matching opening one"
+      | Eof ->
+        if depth = 0
+        then List.rev acc
+        else error lb (Printf.sprintf "%d closing parentheses missing" depth)
+      | Name "package" ->
+        let name = package_name lb in
+        lparen lb;
+        let sub_entries = entries lb (depth + 1) [] in
+        entries lb depth (Package { name = Some name; entries = sub_entries } :: acc)
+      | Name var ->
+        let predicates, action =
+          match next lb with
+          | Equal -> [], Set
+          | Plus_equal -> [], Add
+          | Lparen -> predicates_and_action lb []
+          | _ -> error lb "'=', '+=' or '(' expected"
+        in
+        let value = string lb in
+        entries lb depth (Rule { var; predicates; action; value } :: acc)
+      | _ -> error lb "'package' or variable name expected"
+    ;;
+  end
+end

unikernel/duniverse/dune_/otherlibs/dune-private-libs/section/dune

@@ -0,0 +1,4 @@
+(library
+ (name dune_section)
+ (public_name dune-private-libs.dune-section)
+ (synopsis "[Internal] section definition"))

unikernel/duniverse/dune_/otherlibs/dune-private-libs/section/dune_section.ml

@@ -0,0 +1,42 @@
+type t =
+  | Lib
+  | Lib_root
+  | Libexec
+  | Libexec_root
+  | Bin
+  | Sbin
+  | Toplevel
+  | Share
+  | Share_root
+  | Etc
+  | Doc
+  | Stublibs
+  | Man
+  | Misc
+
+let all =
+  [ Lib, "lib"
+  ; Lib_root, "lib_root"
+  ; Libexec, "libexec"
+  ; Libexec_root, "libexec_root"
+  ; Bin, "bin"
+  ; Sbin, "sbin"
+  ; Toplevel, "toplevel"
+  ; Share, "share"
+  ; Share_root, "share_root"
+  ; Etc, "etc"
+  ; Doc, "doc"
+  ; Stublibs, "stublibs"
+  ; Man, "man"
+  ; Misc, "misc"
+  ]
+;;
+
+let to_string t = List.assoc t all
+
+let rec of_string x = function
+  | [] -> None
+  | (s, x') :: xs -> if x' = x then Some s else of_string x xs
+;;
+
+let of_string x = of_string x all

unikernel/duniverse/dune_/otherlibs/dune-private-libs/section/dune_section.mli

@@ -0,0 +1,19 @@
+type t =
+  | Lib
+  | Lib_root
+  | Libexec
+  | Libexec_root
+  | Bin
+  | Sbin
+  | Toplevel
+  | Share
+  | Share_root
+  | Etc
+  | Doc
+  | Stublibs
+  | Man
+  | Misc
+
+val all : (t * string) list
+val of_string : string -> t option
+val to_string : t -> string