Source file meta_parser.ml

(** 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