bsb_parse_sources.ml

(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P.
 * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * In addition to the permissions granted to you by the LGPL, you may combine
 * or link a "work that uses the Library" with a publicly distributed version
 * of this file to produce a combined library or application, then distribute
 * that combined work under the terms of your choosing, with no requirement
 * to comply with the obligations normally placed on you by section 4 of the
 * LGPL version 3 (or the corresponding section of a later version of the LGPL
 * should you choose to use a later version).
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)

type build_generator = Bsb_file_groups.build_generator

let ( .?() ) = Map_string.find_opt

(* type file_group = Bsb_file_groups.file_group *)

type t = Bsb_file_groups.t

let is_input_or_output (xs : build_generator list) (x : string) =
  Ext_list.exists xs (fun {input; output} ->
      let it_is y = y = x in
      Ext_list.exists input it_is || Ext_list.exists output it_is)

let errorf x fmt = Bsb_exception.errorf ~loc:(Ext_json.loc_of x) fmt

type cxt = {
  package_kind: Bsb_package_kind.t;
  is_dev: bool;
  cwd: string;
  root: string;
  cut_generators: bool;
  traverse: bool;
  (* namespace : string option; *)
  ignored_dirs: Set_string.t;
}

(** [public] has a list of modules, we do a sanity check to see if all the listed 
    modules are indeed valid module components
*)
let collect_pub_modules (xs : Ext_json_types.t array) (cache : Bsb_db.map) :
    Set_string.t =
  let set = ref Set_string.empty in
  for i = 0 to Array.length xs - 1 do
    let v = Array.unsafe_get xs i in
    match v with
    | Str {str; loc} ->
      if Map_string.mem cache str then set := Set_string.add !set str
      else
        Bsb_exception.errorf ~loc "%S in public is not an existing module" str
    | _ ->
      Bsb_exception.errorf ~loc:(Ext_json.loc_of v)
        "public expects a list of strings"
  done;
  !set

let extract_pub (input : Ext_json_types.t Map_string.t)
    (cur_sources : Bsb_db.map) : Bsb_file_groups.public =
  match input.?(Bsb_build_schemas.public) with
  | Some (Str {str = s} as x) ->
    if s = Bsb_build_schemas.export_all then Export_all
    else if s = Bsb_build_schemas.export_none then Export_none
    else errorf x "invalid str for %s " s
  | Some (Arr {content}) -> Export_set (collect_pub_modules content cur_sources)
  | Some config -> Bsb_exception.config_error config "expect array or string"
  | None -> Export_all

let extract_resources (input : Ext_json_types.t Map_string.t) : string list =
  match input.?(Bsb_build_schemas.resources) with
  | Some (Arr x) -> Bsb_build_util.get_list_string x.content
  | Some config -> Bsb_exception.config_error config "expect array "
  | None -> []

let extract_input_output (edge : Ext_json_types.t) : string list * string list =
  let error () =
    errorf edge {| invalid edge format, expect  ["output" , ":", "input" ]|}
  in
  match edge with
  | Arr {content} -> (
    match
      Ext_array.find_and_split content
        (fun x () ->
          match x with
          | Str {str = ":"} -> true
          | _ -> false)
        ()
    with
    | No_split -> error ()
    | Split (output, input) ->
      ( Ext_array.to_list_map output (fun x ->
            match x with
            | Str {str = ":"} -> error ()
            | Str {str} -> Some str
            | _ -> None),
        Ext_array.to_list_map input (fun x ->
            match x with
            | Str {str = ":"} -> error ()
            | Str {str} ->
              Some str
              (* More rigirous error checking: It would trigger a ninja syntax error *)
            | _ -> None) ))
  | _ -> error ()

type json_map = Ext_json_types.t Map_string.t

let extract_generators (input : json_map) : build_generator list =
  match input.?(Bsb_build_schemas.generators) with
  | Some (Arr {content; loc_start = _}) ->
    (* Need check is dev build or not *)
    Ext_array.fold_left content [] (fun acc x ->
        match x with
        | Obj {map} -> (
          match
            (map.?(Bsb_build_schemas.name), map.?(Bsb_build_schemas.edge))
          with
          | Some (Str command), Some edge ->
            let output, input = extract_input_output edge in
            {Bsb_file_groups.input; output; command = command.str} :: acc
          | _ -> errorf x "Invalid generator format")
        | _ -> errorf x "Invalid generator format")
  | Some x -> errorf x "Invalid generator format"
  | None -> []

let extract_predicate (m : json_map) : string -> bool =
  let excludes =
    match m.?(Bsb_build_schemas.excludes) with
    | None -> []
    | Some (Arr {content = arr}) -> Bsb_build_util.get_list_string arr
    | Some x -> Bsb_exception.config_error x "excludes expect array "
  in
  let slow_re = m.?(Bsb_build_schemas.slow_re) in
  match (slow_re, excludes) with
  | Some (Str {str = s}), [] ->
    let re = Str.regexp s in
    fun name -> Str.string_match re name 0
  | Some (Str {str = s}), _ :: _ ->
    let re = Str.regexp s in
    fun name ->
      Str.string_match re name 0 && not (Ext_list.mem_string excludes name)
  | Some config, _ ->
    Bsb_exception.config_error config
      (Bsb_build_schemas.slow_re ^ " expect a string literal")
  | None, _ -> fun name -> not (Ext_list.mem_string excludes name)

(** [parsing_source_dir_map cxt input]
    Major work done in this function, 
    assume [not toplevel && not (Bsb_dir_index.is_lib_dir dir_index)]      
    is already checked, so we don't need check it again    
*)

(** This is the only place where we do some removal during scanning,
    configurabl
*)

(********************************************************************)
(* starts parsing *)
let rec parsing_source_dir_map ({cwd = dir} as cxt)
    (input : Ext_json_types.t Map_string.t) : Bsb_file_groups.t =
  if Set_string.mem cxt.ignored_dirs dir then Bsb_file_groups.empty
  else
    let cur_globbed_dirs = ref false in
    let has_generators =
      match cxt with
      | {cut_generators = false; package_kind = Toplevel | Pinned_dependency _}
        ->
        true
      | {cut_generators = false; package_kind = Dependency _}
      | {cut_generators = true; _} ->
        false
    in
    let scanned_generators = extract_generators input in
    let sub_dirs_field = input.?(Bsb_build_schemas.subdirs) in
    let base_name_array =
      lazy
        (cur_globbed_dirs := true;
         Sys.readdir (Filename.concat cxt.root dir))
    in
    let output_sources =
      Ext_list.fold_left
        (Ext_list.flat_map scanned_generators (fun x -> x.output))
        Map_string.empty
        (fun acc o -> Bsb_db_util.add_basename ~dir acc o)
    in
    let sources =
      match input.?(Bsb_build_schemas.files) with
      | None ->
        (* We should avoid temporary files *)
        Ext_array.fold_left (Lazy.force base_name_array) output_sources
          (fun acc basename ->
            if is_input_or_output scanned_generators basename then acc
            else Bsb_db_util.add_basename ~dir acc basename)
      | Some (Arr basenames) ->
        Ext_array.fold_left basenames.content output_sources
          (fun acc basename ->
            match basename with
            | Str {str = basename; loc} ->
              Bsb_db_util.add_basename ~dir acc basename
                ~error_on_invalid_suffix:loc
            | _ -> acc)
      | Some (Obj {map; loc = _}) ->
        (* { excludes : [], slow_re : "" }*)
        let predicate = extract_predicate map in
        Ext_array.fold_left (Lazy.force base_name_array) output_sources
          (fun acc basename ->
            if
              is_input_or_output scanned_generators basename
              || not (predicate basename)
            then acc
            else Bsb_db_util.add_basename ~dir acc basename)
      | Some x ->
        Bsb_exception.config_error x "files field expect array or object "
    in
    let resources = extract_resources input in
    let public = extract_pub input sources in
    (* Doing recursive stuff *)
    let children =
      match (sub_dirs_field, cxt.traverse) with
      | None, true | Some (True _), _ ->
        let root = cxt.root in
        let parent = Filename.concat root dir in
        Ext_array.fold_left (Lazy.force base_name_array) Bsb_file_groups.empty
          (fun origin x ->
            if
              (not (Set_string.mem cxt.ignored_dirs x))
              && Ext_sys.is_directory_no_exn (Filename.concat parent x)
            then
              Bsb_file_groups.merge
                (parsing_source_dir_map
                   {
                     cxt with
                     cwd =
                       Ext_path.concat cxt.cwd
                         (Ext_path.simple_convert_node_path_to_os_path x);
                     traverse = true;
                   }
                   Map_string.empty)
                origin
            else origin)
      (* readdir parent avoiding scanning twice *)
      | None, false | Some (False _), _ -> Bsb_file_groups.empty
      | Some s, _ -> parse_sources cxt s
    in
    (* Do some clean up *)
    (* prune_staled_bs_js_files cxt sources ; *)
    Bsb_file_groups.cons
      ~file_group:
        {
          dir;
          sources;
          resources;
          public;
          is_dev = cxt.is_dev;
          generators = (if has_generators then scanned_generators else []);
        }
      ?globbed_dir:(if !cur_globbed_dirs then Some dir else None)
      children

and parsing_single_source ({package_kind; is_dev; cwd} as cxt)
    (x : Ext_json_types.t) : t =
  match x with
  | Str {str = dir} -> (
    match (package_kind, is_dev) with
    | Dependency _, true -> Bsb_file_groups.empty
    | Dependency _, false | (Toplevel | Pinned_dependency _), _ ->
      parsing_source_dir_map
        {
          cxt with
          cwd =
            Ext_path.concat cwd
              (Ext_path.simple_convert_node_path_to_os_path dir);
        }
        Map_string.empty)
  | Obj {map} -> (
    let current_dir_index =
      match map.?(Bsb_build_schemas.type_) with
      | Some (Str {str = "dev"}) -> true
      | Some _ ->
        Bsb_exception.config_error x {|type field expect "dev" literal |}
      | None -> is_dev
    in
    match (package_kind, current_dir_index) with
    | Dependency _, true -> Bsb_file_groups.empty
    | Dependency _, false | (Toplevel | Pinned_dependency _), _ ->
      let dir =
        match map.?(Bsb_build_schemas.dir) with
        | Some (Str {str}) ->
          if str = Literals.library_file then
            Bsb_exception.config_error x
              (Printf.sprintf "dir field should be different from `%s`"
                 Literals.library_file)
          else Ext_path.simple_convert_node_path_to_os_path str
        | Some x -> Bsb_exception.config_error x "dir expected to be a string"
        | None ->
          Bsb_exception.config_error x
            ("required field :" ^ Bsb_build_schemas.dir ^ " missing")
      in

      parsing_source_dir_map
        {cxt with is_dev = current_dir_index; cwd = Ext_path.concat cwd dir}
        map)
  | _ -> Bsb_file_groups.empty

and parsing_arr_sources cxt (file_groups : Ext_json_types.t array) =
  Ext_array.fold_left file_groups Bsb_file_groups.empty (fun origin x ->
      Bsb_file_groups.merge (parsing_single_source cxt x) origin)

and parse_sources (cxt : cxt) (sources : Ext_json_types.t) =
  match sources with
  | Arr file_groups -> parsing_arr_sources cxt file_groups.content
  | _ -> parsing_single_source cxt sources

let scan ~package_kind ~root ~cut_generators ~(* ~namespace  *)
                                              ignored_dirs x : t =
  parse_sources
    {
      ignored_dirs;
      package_kind;
      is_dev = false;
      cwd = Filename.current_dir_name;
      root;
      cut_generators;
      (* namespace; *)
      traverse = false;
    }
    x

(* Walk through to do some work *)
type walk_cxt = {
  cwd: string;
  root: string;
  traverse: bool;
  ignored_dirs: Set_string.t;
  gentype_language: string;
}

let rec walk_sources (cxt : walk_cxt) (sources : Ext_json_types.t) =
  match sources with
  | Arr {content} -> Ext_array.iter content (fun x -> walk_single_source cxt x)
  | x -> walk_single_source cxt x

and walk_single_source cxt (x : Ext_json_types.t) =
  match x with
  | Str {str = dir} ->
    let dir = Ext_path.simple_convert_node_path_to_os_path dir in
    walk_source_dir_map {cxt with cwd = Ext_path.concat cxt.cwd dir} None
  | Obj {map} -> (
    match map.?(Bsb_build_schemas.dir) with
    | Some (Str {str}) ->
      let dir = Ext_path.simple_convert_node_path_to_os_path str in
      walk_source_dir_map
        {cxt with cwd = Ext_path.concat cxt.cwd dir}
        map.?(Bsb_build_schemas.subdirs)
    | _ -> ())
  | _ -> ()

and walk_source_dir_map (cxt : walk_cxt) sub_dirs_field =
  let working_dir = Filename.concat cxt.root cxt.cwd in
  if not (Set_string.mem cxt.ignored_dirs cxt.cwd) then (
    let file_array = Sys.readdir working_dir in
    (* Remove .gen.js/.gen.tsx during clean up *)
    Ext_array.iter file_array (fun file ->
        let is_typescript = cxt.gentype_language = "typescript" in
        if
          (not is_typescript)
          && Ext_string.ends_with file Literals.suffix_gen_js
          || (is_typescript && Ext_string.ends_with file Literals.suffix_gen_tsx)
        then Sys.remove (Filename.concat working_dir file));
    let cxt_traverse = cxt.traverse in
    match (sub_dirs_field, cxt_traverse) with
    | None, true | Some (True _), _ ->
      Ext_array.iter file_array (fun f ->
          if
            (not (Set_string.mem cxt.ignored_dirs f))
            && Ext_sys.is_directory_no_exn (Filename.concat working_dir f)
          then
            walk_source_dir_map
              {
                cxt with
                cwd =
                  Ext_path.concat cxt.cwd
                    (Ext_path.simple_convert_node_path_to_os_path f);
                traverse = true;
              }
              None)
    | None, _ | Some (False _), _ -> ()
    | Some s, _ -> walk_sources cxt s)

(* It makes use of the side effect when [walk_sources], removing suffix_re_js,
   TODO: make it configurable
*)
let clean_re_js root =
  match
    Ext_json_parse.parse_json_from_file
      (Filename.concat root Literals.bsconfig_json)
  with
  | Obj {map} ->
    let ignored_dirs =
      match map.?(Bsb_build_schemas.ignored_dirs) with
      | Some (Arr {content = x}) ->
        Set_string.of_list (Bsb_build_util.get_list_string x)
      | Some _ | None -> Set_string.empty
    in
    let gentype_language =
      match map.?(Bsb_build_schemas.gentypeconfig) with
      | None -> ""
      | Some (Obj {map}) -> (
        match map.?(Bsb_build_schemas.language) with
        | None -> ""
        | Some (Str {str}) -> str
        | Some _ -> "")
      | Some _ -> ""
    in
    Ext_option.iter map.?(Bsb_build_schemas.sources) (fun config ->
        try
          walk_sources
            {
              root;
              traverse = true;
              cwd = Filename.current_dir_name;
              ignored_dirs;
              gentype_language;
            }
            config
        with _ -> ())
  | _ -> ()
  | exception _ -> ()