<commit_before>open Prelude
open Full_idl_syntax
open Format
open FormatExt
open Typedjs_syntax
open TypImpl
open ListExt

let sort_defs defs = List.stable_sort (fun d1 d2 -> 
  let order def = match def with
    | Include _ -> 0
    | Typedef _ -> 1
    | ForwardInterface _ -> 2
    | Enum _ -> 3
    | Callback _ -> 4
    | Const _ -> 5
    | Exception _ -> 6
    | Dictionary _ -> 7
    | Module _ -> 8
    | Interface _ -> 9
    | PartialInterface _ -> 10
    | Implements _ -> 11
  in match d1, d2 with
  | Module (_, _, id1, _), Module (_, _, id2, _) 
  | Typedef (_, _, _, id1), Typedef (_, _, _, id2)
  | Interface (_, _, id1, _, _, _), Interface (_, _, id2, _, _, _)
  | ForwardInterface (_, _, id1), ForwardInterface (_, _, id2)
  | Exception (_, _, id1, _, _), Exception (_, _, id2, _, _)
  | Implements (_, _, id1, _), Implements (_, _, id2, _)
  | Const (_, _, _, id1, _), Const (_, _, _, id2, _)
  | Dictionary (_, _, id1, _, _), Dictionary (_, _, id2, _, _)
  | PartialInterface (_, _, id1, _), PartialInterface (_, _, id2, _)
  | Callback (_, _, id1, _, _), Callback (_, _, id2, _, _)
  | Enum (_, _, id1, _), Enum (_, _, id2, _) -> compare (Id.string_of_id id1) (Id.string_of_id id2)
  | Include (_, _, file1), Include (_, _, file2) -> compare file1 file2
  | _, _ -> compare (order d1) (order d2)
) defs


let parseType typStr =
  let open Lexing in
  let start_pos = { pos_fname = "<string>"; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in
  let len = String.length typStr in
  let end_pos = { pos_fname = "<string>"; pos_lnum = 1; pos_bol = len; pos_cnum = len } in
  match Typedjs_fromExpr.parse_annotation (start_pos, end_pos) typStr with
  | Typedjs_syntax.ATyp typ ->
    Sb_desugar.desugar_typ (start_pos, end_pos) typ
  | _ -> raise (Invalid_argument "Didn't get a valid type")


type cachedInterface = 
  | Raw of Full_idl_syntax.definition * bool
  | Comp of TypImpl.typ * (TypImpl.typ -> TypImpl.typ) option (* interface type, type as a [function] *)
let create_env defs = 
  let ifaceHash : (Id.t, cachedInterface) Hashtbl.t = Hashtbl.create 1200 in
  let implementsHash : (Id.t, Id.t) Hashtbl.t = Hashtbl.create 200 in
  let idToPat id = P.singleton (Id.string_of_id id) in
  let find_in_list l v = List.exists (fun m -> m = v) l in
  let isNoScript metas = find_in_list metas NoScript || find_in_list metas NotXPCOM in
  let isArray metas = find_in_list metas (AttrNoArgs (Id.id_of_string "array")) in
  let isScriptable metas = find_in_list metas Scriptable in
  let isPrivateBrowsingCheck metas = find_in_list metas PrivateBrowsingCheck  in
  let isUnsafe metas = find_in_list metas Unsafe in
  let isGetter metas = find_in_list metas (AttrNoArgs (Id.id_of_string "getter")) in
  let isFunction metas = find_in_list metas (AttrNoArgs (Id.id_of_string "function")) in
  let isOptional metas = find_in_list metas Optional in
  let isQueryInterfaceType metas = find_in_list metas QueryInterfaceType in
  let isQueryElementAtType metas = 
    try Some (List.find (fun m -> match m with QueryElementAtType _ -> true | _ -> false) metas)
    with Not_found -> None in
  let isUseType metas =
    try Some (List.find (fun m -> match m with AttrArgList(id, _) -> id = Id.id_of_string "UseType" | _ -> false) metas)
    with Not_found -> None in
  let isRetval metas = List.exists (fun m -> m = Retval) metas in
  let rec trans_toplevel defs =
    let (iidsAndConstants, componentsAndCID, compType, queryInterfaceType) = build_components (defs) in
    List.iter (fun i -> match i with
    | Interface (_, metas, name, parent, members, _) -> Hashtbl.add ifaceHash name (Raw (i, isFunction metas))
    | Implements (_, _, id1, id2) -> Hashtbl.add implementsHash id1 id2
    | _ -> ()) defs;
    let interfaces = filter_map (trans_def TBot queryInterfaceType) (defs) in
    let iids = filter_map (fun (iid, constants) ->
      let iid_hashname = Id.id_of_string ("##" ^ (iid) ^ "##") in
      let iid_iface = Interface(Lexing.dummy_pos, [], Id.id_of_string iid, 
                                Some (RelativeName [Id.id_of_string "nsIJSIID"]),
                                ((Attribute(Lexing.dummy_pos, [], NoReadOnly, IsNormal, Any, iid_hashname)) 
                                 :: constants), 
                                IsNormalInterface) in
      Hashtbl.add ifaceHash (Id.id_of_string iid) (Raw (iid_iface, false));
      trans_interface TBot queryInterfaceType (Id.id_of_string iid)
    ) iidsAndConstants in
    ((componentsAndCID :: iids @ interfaces), TId "Components", queryInterfaceType (TId "nsISupports") 0)
  (* and trans_defs tt defs =  *)
  (*   let (_, componentsAndCID, _, queryInterfaceType) = build_components (defs) in *)
  (*   let interfaces = (filter_map (trans_def tt queryInterfaceType) (defs)) in *)
  (*   let allFields = componentsAndCID :: interfaces in *)
  (*   let catchallPat = match allFields with *)
  (*     | [] -> P.all *)
  (*     | hd::tl -> P.negate (List.fold_left P.union (fst3 hd) (List.map fst3 tl)) in *)
  (*   (\*TSource*\)TRef ((\* TRef *\) (TObject (mk_obj_typ allFields catchallPat))) *)
  and wrapArrow mutability t =
    let codePat = P.singleton "-*- code -*-" in
    let prototypePat = P.singleton "prototype" in
    let obj = (TObject(mk_obj_typ [(codePat, Present, t);
                                   (proto_pat, Present, TId "Object");
                                   (prototypePat, Present, TId "Ext");
                                   ((P.negate (P.union (P.union codePat prototypePat) proto_pat)), 
                                    Maybe, TId "Ext")]
                   P.empty)) in
    match mutability with
    | RefCell -> TRef (None, obj)
    | SourceCell -> TSource (None, obj)
    | SinkCell -> TSink (None, obj)
  and build_components defs = 
    let interfaceToIIDFieldAndFun def =
      match def with
      | Interface (_, metas, name, _, members, _) ->
        if (not (isScriptable metas))
        then None
        else let iidName = (Id.string_of_id name) ^ "_IID" in
             let constants = filter_map (fun m -> match m with ConstMember _ -> Some m | _ -> None) members in
             Some ((iidName, constants),
                   (idToPat name, Present, TId iidName),
                   (fun tself n -> 
                     TArrow (((TThis (TId "nsISupports")) :: (ListExt.create n TTop) @ [TId iidName]),
                                           None, (TApp(TPrim "Mutable", [TId (Id.string_of_id name)])))))
      | _ -> None in
    let unzip3 abcs =
      let rec helper abcs aas bbs ccs =
        match abcs with
        | [] -> (List.rev aas, List.rev bbs, List.rev ccs)
        | (a,b,c) :: abcs' -> helper abcs' (a :: aas) (b :: bbs) (c :: ccs) in
      helper abcs [] [] [] in
    let (iids, fields, funs) = unzip3 (filter_map interfaceToIIDFieldAndFun defs) in
    let proto = (proto_pat, Present, TId "Object") in
    let compInterface = TSource(*TRef*) (Some "Components.interfaces", 
                                         TObject (mk_obj_typ (proto::fields) P.empty)) in
    let compUtils = TSource(*TRef*) (Some "Components.utils",
                                     TObject (mk_obj_typ [(P.singleton "import", Present, 
                                                           wrapArrow SourceCell (TArrow([TTop; TRegex P.all], None, TPrim "Undef")))] P.empty)) in
    let compID = wrapArrow SourceCell (TArrow([TTop; TRegex P.all], None, TId "Ext")) in
    let allOthers = P.negate proto_pat in
    (* NOTE: This should be Maybe, not Present, but the type system complains if I do that... *)<commit_msg>adding Components.utils.reportError<commit_after>open Prelude
open Full_idl_syntax
open Format
open FormatExt
open Typedjs_syntax
open TypImpl
open ListExt

let sort_defs defs = List.stable_sort (fun d1 d2 -> 
  let order def = match def with
    | Include _ -> 0
    | Typedef _ -> 1
    | ForwardInterface _ -> 2
    | Enum _ -> 3
    | Callback _ -> 4
    | Const _ -> 5
    | Exception _ -> 6
    | Dictionary _ -> 7
    | Module _ -> 8
    | Interface _ -> 9
    | PartialInterface _ -> 10
    | Implements _ -> 11
  in match d1, d2 with
  | Module (_, _, id1, _), Module (_, _, id2, _) 
  | Typedef (_, _, _, id1), Typedef (_, _, _, id2)
  | Interface (_, _, id1, _, _, _), Interface (_, _, id2, _, _, _)
  | ForwardInterface (_, _, id1), ForwardInterface (_, _, id2)
  | Exception (_, _, id1, _, _), Exception (_, _, id2, _, _)
  | Implements (_, _, id1, _), Implements (_, _, id2, _)
  | Const (_, _, _, id1, _), Const (_, _, _, id2, _)
  | Dictionary (_, _, id1, _, _), Dictionary (_, _, id2, _, _)
  | PartialInterface (_, _, id1, _), PartialInterface (_, _, id2, _)
  | Callback (_, _, id1, _, _), Callback (_, _, id2, _, _)
  | Enum (_, _, id1, _), Enum (_, _, id2, _) -> compare (Id.string_of_id id1) (Id.string_of_id id2)
  | Include (_, _, file1), Include (_, _, file2) -> compare file1 file2
  | _, _ -> compare (order d1) (order d2)
) defs


let parseType typStr =
  let open Lexing in
  let start_pos = { pos_fname = "<string>"; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in
  let len = String.length typStr in
  let end_pos = { pos_fname = "<string>"; pos_lnum = 1; pos_bol = len; pos_cnum = len } in
  match Typedjs_fromExpr.parse_annotation (start_pos, end_pos) typStr with
  | Typedjs_syntax.ATyp typ ->
    Sb_desugar.desugar_typ (start_pos, end_pos) typ
  | _ -> raise (Invalid_argument "Didn't get a valid type")


type cachedInterface = 
  | Raw of Full_idl_syntax.definition * bool
  | Comp of TypImpl.typ * (TypImpl.typ -> TypImpl.typ) option (* interface type, type as a [function] *)
let create_env defs = 
  let ifaceHash : (Id.t, cachedInterface) Hashtbl.t = Hashtbl.create 1200 in
  let implementsHash : (Id.t, Id.t) Hashtbl.t = Hashtbl.create 200 in
  let idToPat id = P.singleton (Id.string_of_id id) in
  let find_in_list l v = List.exists (fun m -> m = v) l in
  let isNoScript metas = find_in_list metas NoScript || find_in_list metas NotXPCOM in
  let isArray metas = find_in_list metas (AttrNoArgs (Id.id_of_string "array")) in
  let isScriptable metas = find_in_list metas Scriptable in
  let isPrivateBrowsingCheck metas = find_in_list metas PrivateBrowsingCheck  in
  let isUnsafe metas = find_in_list metas Unsafe in
  let isGetter metas = find_in_list metas (AttrNoArgs (Id.id_of_string "getter")) in
  let isFunction metas = find_in_list metas (AttrNoArgs (Id.id_of_string "function")) in
  let isOptional metas = find_in_list metas Optional in
  let isQueryInterfaceType metas = find_in_list metas QueryInterfaceType in
  let isQueryElementAtType metas = 
    try Some (List.find (fun m -> match m with QueryElementAtType _ -> true | _ -> false) metas)
    with Not_found -> None in
  let isUseType metas =
    try Some (List.find (fun m -> match m with AttrArgList(id, _) -> id = Id.id_of_string "UseType" | _ -> false) metas)
    with Not_found -> None in
  let isRetval metas = List.exists (fun m -> m = Retval) metas in
  let rec trans_toplevel defs =
    let (iidsAndConstants, componentsAndCID, compType, queryInterfaceType) = build_components (defs) in
    List.iter (fun i -> match i with
    | Interface (_, metas, name, parent, members, _) -> Hashtbl.add ifaceHash name (Raw (i, isFunction metas))
    | Implements (_, _, id1, id2) -> Hashtbl.add implementsHash id1 id2
    | _ -> ()) defs;
    let interfaces = filter_map (trans_def TBot queryInterfaceType) (defs) in
    let iids = filter_map (fun (iid, constants) ->
      let iid_hashname = Id.id_of_string ("##" ^ (iid) ^ "##") in
      let iid_iface = Interface(Lexing.dummy_pos, [], Id.id_of_string iid, 
                                Some (RelativeName [Id.id_of_string "nsIJSIID"]),
                                ((Attribute(Lexing.dummy_pos, [], NoReadOnly, IsNormal, Any, iid_hashname)) 
                                 :: constants), 
                                IsNormalInterface) in
      Hashtbl.add ifaceHash (Id.id_of_string iid) (Raw (iid_iface, false));
      trans_interface TBot queryInterfaceType (Id.id_of_string iid)
    ) iidsAndConstants in
    ((componentsAndCID :: iids @ interfaces), TId "Components", queryInterfaceType (TId "nsISupports") 0)
  (* and trans_defs tt defs =  *)
  (*   let (_, componentsAndCID, _, queryInterfaceType) = build_components (defs) in *)
  (*   let interfaces = (filter_map (trans_def tt queryInterfaceType) (defs)) in *)
  (*   let allFields = componentsAndCID :: interfaces in *)
  (*   let catchallPat = match allFields with *)
  (*     | [] -> P.all *)
  (*     | hd::tl -> P.negate (List.fold_left P.union (fst3 hd) (List.map fst3 tl)) in *)
  (*   (\*TSource*\)TRef ((\* TRef *\) (TObject (mk_obj_typ allFields catchallPat))) *)
  and wrapArrow mutability t =
    let codePat = P.singleton "-*- code -*-" in
    let prototypePat = P.singleton "prototype" in
    let obj = (TObject(mk_obj_typ [(codePat, Present, t);
                                   (proto_pat, Present, TId "Object");
                                   (prototypePat, Present, TId "Ext");
                                   ((P.negate (P.union (P.union codePat prototypePat) proto_pat)), 
                                    Maybe, TId "Ext")]
                   P.empty)) in
    match mutability with
    | RefCell -> TRef (None, obj)
    | SourceCell -> TSource (None, obj)
    | SinkCell -> TSink (None, obj)
  and build_components defs = 
    let interfaceToIIDFieldAndFun def =
      match def with
      | Interface (_, metas, name, _, members, _) ->
        if (not (isScriptable metas))
        then None
        else let iidName = (Id.string_of_id name) ^ "_IID" in
             let constants = filter_map (fun m -> match m with ConstMember _ -> Some m | _ -> None) members in
             Some ((iidName, constants),
                   (idToPat name, Present, TId iidName),
                   (fun tself n -> 
                     TArrow (((TThis (TId "nsISupports")) :: (ListExt.create n TTop) @ [TId iidName]),
                                           None, (TApp(TPrim "Mutable", [TId (Id.string_of_id name)])))))
      | _ -> None in
    let unzip3 abcs =
      let rec helper abcs aas bbs ccs =
        match abcs with
        | [] -> (List.rev aas, List.rev bbs, List.rev ccs)
        | (a,b,c) :: abcs' -> helper abcs' (a :: aas) (b :: bbs) (c :: ccs) in
      helper abcs [] [] [] in
    let (iids, fields, funs) = unzip3 (filter_map interfaceToIIDFieldAndFun defs) in
    let proto = (proto_pat, Present, TId "Object") in
    let compInterface = TSource(*TRef*) (Some "Components.interfaces", 
                                         TObject (mk_obj_typ (proto::fields) P.empty)) in
    let compUtils = TSource(*TRef*) (Some "Components.utils",
                                     TObject (mk_obj_typ [(P.singleton "import", Present, 
                                                           wrapArrow SourceCell (TArrow([TTop; TRegex P.all], 
                                                                                        None, TPrim "Undef")));
                                                          (P.singleton "reportError", Present,
                                                          wrapArrow SourceCell (TArrow([TTop; TTop], 
                                                                                       None, TPrim "Undef")))]
                                                P.empty)) in
    let compID = wrapArrow SourceCell (TArrow([TTop; TRegex P.all], None, TId "Ext")) in
    let allOthers = P.negate proto_pat in
    (* NOTE: This should be Maybe, not Present, but the type system complains if I do that... *)
{'fraction_non_alphanumeric': 0.11879853667928887, 'fraction_numerical': 0.00872857968037995, 'mean_word_length': 2.3741879601559117, 'pattern_counts': {'":': 0, '<': 7, '<?xml version=': 0, '>': 101, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 38, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1828415', 'n_tokens_mistral': 5184, 'n_tokens_neox': 5028, 'n_words': 1457}