(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

open Ty
open Utils_js

let cut_off ?(limit = 1000) str =
  let len = String.length str in
  if len > limit then
    String.sub str 0 (len - 1) ^ " ..."
  else
    str

let dump_bot_upper_bound_kind = function
  | NoUpper -> "NoUpper"
  | SomeKnownUpper _ -> "SomeKnownUpper"
  | SomeUnknownUpper u -> spf "SomeUnknownUpper (%s)" u

let dump_bot_kind = function
  | EmptyType -> "EmptyType"
  | EmptyMatchingPropT -> "EmptyMatchingPropT"
  | EmptyTypeDestructorTriggerT _ -> "EmptyTypeDestructorTriggerT"
  | NoLowerWithUpper u -> spf "NoLowerWithUpper (%s)" (dump_bot_upper_bound_kind u)

let dump_import_mode = function
  | ValueMode -> "value"
  | TypeMode -> "type"
  | TypeofMode -> "typeof"

let dump_import_ident (_, id, mode) = spf "`%s` (%s)" id (dump_import_mode mode)

let ctor_of_provenance = function
  | Local -> "Local"
  | Remote { imported_as = Some ii } -> spf "Imported as %s" (dump_import_ident ii)
  | Remote { imported_as = None } -> "Remote"
  | Library { imported_as = Some _ } -> "Library (Imported)"
  | Library { imported_as = None } -> "Library (Remote)"
  | Builtin -> "Builtin"

let dump_symbol { sym_provenance; sym_def_loc; sym_name; _ } =
  Utils_js.spf
    "%s (%s:%s)"
    sym_name
    (ctor_of_provenance sym_provenance)
    (Reason.string_of_aloc sym_def_loc)

let builtin_value = function
  | FunProto -> "Function.prototype"
  | ObjProto -> "Object.prototype"
  | FunProtoApply -> "Function.prototype.apply"
  | FunProtoBind -> "Function.prototype.bind"
  | FunProtoCall -> "Function.prototype.call"
  | TSymbol s -> dump_symbol s

let rec dump_opt (f : 'a -> string) (o : 'a option) =
  match o with
  | Some t -> f t
  | None -> ""

and dump_any_kind = function
  | Annotated -> "Annotated"
  | AnyError -> "AnyError"
  | Unsound kind -> spf "Unsound (%s)" (dump_any_unsoundness_kind kind)
  | Untyped -> "Untyped"

and dump_any_unsoundness_kind = function
  | BoundFunctionThis -> "BoundFunctionThis"
  | ComputedNonLiteralKey -> "ComputedNonLiteralKey"
  | Constructor -> "Constructor"
  | DummyStatic -> "DummyStatic"
  | Existential -> "Existential"
  | Exports -> "Exports"
  | FunctionPrototype -> "FunctionPrototype"
  | InferenceHooks -> "InferenceHooks"
  | InstanceOfRefinement -> "InstanceOfRefinement"
  | Merged -> "Merged"
  | ResolveSpread -> "ResolveSpread"
  | Unchecked -> "Unchecked"
  | Unimplemented -> "Unimplemented"
  | UnresolvedType -> "UnresolvedType"
  | WeakContext -> "WeakContext"

and dump_list : 'a. ('a -> string) -> ?sep:string -> 'a list -> string =
 (fun f ?(sep = ", ") ls -> Base.List.map ~f ls |> String.concat sep)

and dump_param_opt = function
  | { prm_optional = true } -> "?"
  | _ -> ""

and dump_param ~depth (p : string option * t * fun_param) =
  match p with
  | (Some s, t, o) -> spf "%s%s: %s" s (dump_param_opt o) (dump_t ~depth t)
  | (_, t, o) -> spf "%s%s" (dump_param_opt o) (dump_t ~depth t)

and dump_rest_params ~depth = function
  | Some (o, t) -> spf "...%s" (dump_param ~depth (o, t, { prm_optional = false }))
  | _ -> ""

and dump_bound ~depth = function
  | Some t -> spf " <: %s" (dump_t ~depth t)
  | _ -> ""

and dump_polarity = function
  | Positive -> "+"
  | Negative -> "-"
  | Neutral -> ""

and dump_type_param ~depth { tp_name; tp_bound; tp_polarity; _ } =
  spf "TParam(%s, %s, %s)" (dump_polarity tp_polarity) tp_name (dump_bound ~depth tp_bound)

and dump_type_params ~depth = function
  | Some [] -> ""
  | Some ps -> spf "TypeParams(%s)" (dump_list (dump_type_param ~depth) ps)
  | _ -> ""

and dump_fun_t ~depth { fun_params; fun_rest_param; fun_return; fun_type_params; fun_static } =
  spf
    "Fun(%s, %s, %s, %s, out: %s)"
    (dump_type_params ~depth fun_type_params)
    (dump_list (dump_param ~depth) fun_params)
    (dump_rest_params ~depth fun_rest_param)
    (dump_t ~depth fun_static)
    (dump_t ~depth fun_return)

and dump_field ~depth x t polarity optional =
  spf
    "%s%s%s: %s"
    (dump_polarity polarity)
    x
    ( if optional then
      "?"
    else
      "" )
    (dump_t ~depth t)

and dump_prop ~depth = function
  | NamedProp { name; prop; _ } -> dump_named_prop ~depth name prop
  | CallProp f -> dump_fun_t ~depth f
  | SpreadProp t -> dump_spread ~depth t

and dump_named_prop ~depth x = function
  | Field { t; polarity; optional } -> dump_field ~depth x t polarity optional
  | Method t -> dump_fun_t ~depth t
  | Get t -> spf "get %s" (dump_t ~depth t)
  | Set t -> spf "get %s" (dump_t ~depth t)

and dump_dict ~depth { dict_polarity; dict_name; dict_key; dict_value } =
  spf
    "%s[%s%s]: %s"
    (dump_polarity dict_polarity)
    (match dict_name with
    | Some n -> spf "%s: " n
    | _ -> "")
    (dump_t ~depth dict_key)
    (dump_t ~depth dict_value)

and dump_spread ~depth t = spf "...%s" (dump_t ~depth t)

and dump_obj ~depth { obj_kind; obj_props; _ } =
  match obj_kind with
  | ExactObj -> spf "{|%s|}" (dump_list (dump_prop ~depth) obj_props)
  | InexactObj -> spf "{%s, ...}" (dump_list (dump_prop ~depth) obj_props)
  | IndexedObj d ->
    let dict = dump_dict ~depth d in
    spf "{%s, %s}" (dump_list (dump_prop ~depth) obj_props) dict

and dump_arr ~depth { arr_readonly; arr_elt_t; _ } =
  let ctor =
    if arr_readonly then
      "$ReadOnlyArray"
    else
      "Array"
  in
  spf "%s<%s>" ctor (dump_t ~depth arr_elt_t)

and dump_generic ~depth (s, kind, ts) =
  spf
    "Generic (%s, kind= %s, params=%s)"
    (dump_symbol s)
    (Ty.debug_string_of_generic_kind kind)
    (dump_generics ~depth ts)

and dump_generics ~depth = function
  | Some ts -> "<" ^ dump_list (dump_t ~depth) ts ^ ">"
  | _ -> ""

and dump_tvar (RVar i) = spf "T_%d" i

and dump_utility ~depth u =
  let ctor = Ty.string_of_utility_ctor u in
  match Ty.types_of_utility u with
  | Some ts -> Base.List.map ~f:(dump_t ~depth) ts |> String.concat ", " |> spf "%s (%s)" ctor
  | None -> ctor

and dump_t ?(depth = 10) t =
  if depth < 0 then
    "..."
  else
    let depth = depth - 1 in
    match t with
    | TVar (v, ts) -> spf "TVAR(%s, params=%s)" (dump_tvar v) (dump_generics ~depth ts)
    | Bound (_, s) -> spf "Bound(%s)" s
    | Generic g -> dump_generic ~depth g
    | Any kind -> spf "Any (%s)" (dump_any_kind kind)
    | Top -> "Top"
    | Bot k -> spf "Bot (%s)" (dump_bot_kind k)
    | Void -> "Void"
    | Null -> "Null"
    | Symbol -> "Symbol"
    | Num (Some x) -> spf "Num (%s)" x
    | Num None -> "Num"
    | NumLit s -> spf "\"%s\"" s
    | Str (Some x) -> spf "Str (%s)" x
    | Str None -> "Str"
    | StrLit s -> spf "\"%s\"" s
    | Bool (Some x) -> spf "Bool (%b)" x
    | Bool None -> "Bool"
    | BoolLit b -> spf "\"%b\"" b
    | Fun f -> dump_fun_t ~depth f
    | Obj o -> dump_obj ~depth o
    | Arr a -> dump_arr ~depth a
    | Tup ts -> spf "Tup (%s)" (dump_list (dump_t ~depth) ~sep:"," ts)
    | Union (t1, t2, ts) ->
      spf "Union (%s)" (dump_list (dump_t ~depth) ~sep:", " (ListUtils.first_n 10 (t1 :: t2 :: ts)))
    | Inter (t1, t2, ts) -> spf "Inter (%s)" (dump_list (dump_t ~depth) ~sep:", " (t1 :: t2 :: ts))
    | InlineInterface { if_extends; if_props; if_dict } ->
      let dict =
        match if_dict with
        | None -> ""
        | Some d -> dump_dict ~depth d
      in
      spf
        "InlineInterface (%s, %s)"
        (dump_list (dump_generic ~depth) if_extends)
        (spf "{ %s %s }" (dump_list (dump_prop ~depth) if_props) dict)
    | TypeOf v -> spf "Typeof (%s)" (builtin_value v)
    | Utility u -> dump_utility ~depth u
    | Mu (i, t) -> spf "Mu (%d, %s)" i (dump_t ~depth t)
    | CharSet s -> spf "CharSet (%s)" s

and dump_class_decl ~depth (name, ps) =
  spf "Class (name=%s, params= %s)" (dump_symbol name) (dump_type_params ~depth ps)

and dump_interface_decl ~depth (name, ps) =
  spf "Interface (name=%s, params= %s)" (dump_symbol name) (dump_type_params ~depth ps)

and dump_module ~depth name exports _default =
  let name =
    match name with
    | Some name -> dump_symbol name
    | None -> "<no name>"
  in
  let exports = dump_list (dump_decl ~depth) ~sep:", " exports in
  spf "Module(%s, %s)" name exports

and dump_decl ~depth = function
  | VariableDecl (name, t) -> spf "VariableDecl (%s, %s)" name (dump_t ~depth t)
  | TypeAliasDecl { import; name; tparams; type_ } ->
    spf
      "TypeAlias (import=%b, %s, %s, %s)"
      import
      (dump_symbol name)
      (dump_type_params ~depth tparams)
      (Base.Option.value_map type_ ~default:"" ~f:(fun t -> cut_off (dump_t ~depth t)))
  | ClassDecl (s, ps) -> spf "ClassDecl (%s) (%s)" (dump_symbol s) (dump_type_params ~depth ps)
  | InterfaceDecl (s, ps) ->
    spf "InterfaceDecl (%s) (%s)" (dump_symbol s) (dump_type_params ~depth ps)
  | EnumDecl name -> spf "Enum(%s)" (dump_symbol name)
  | ModuleDecl { name; exports; default } -> dump_module ~depth name exports default

and dump_elt ~depth = function
  | Type t -> spf "Type (%s)" (dump_t ~depth t)
  | Decl d -> spf "Decl (%s)" (dump_decl ~depth d)

let dump_binding (v, ty) = Utils_js.spf "type %s = %s" (dump_tvar v) (dump_t ty)

let dump_env_t s = Base.List.map ~f:dump_binding s |> String.concat "\n"

let string_of_polarity = function
  | Negative -> "Negative"
  | Neutral -> "Neutral"
  | Positive -> "Positive"

let string_of_ctor_t = function
  | TVar (RVar _, _) -> "RecVar"
  | Bound _ -> "Bound"
  | Generic _ -> "Generic"
  | Any Annotated -> "Explicit Any"
  | Any _ -> "Implicit Any"
  | Top -> "Top"
  | Bot _ -> "Bot"
  | Void -> "Void"
  | Null -> "Null"
  | Symbol -> "Symbol"
  | Num _ -> "Num"
  | Str _ -> "Str"
  | Bool _ -> "Bool"
  | NumLit _ -> "NumLit"
  | StrLit _ -> "StrLit"
  | BoolLit _ -> "BoolLit"
  | Fun _ -> "Fun"
  | Obj _ -> "Obj"
  | Arr _ -> "Arr"
  | Tup _ -> "Tup"
  | Union _ -> "Union"
  | Inter _ -> "Inter"
  | InlineInterface _ -> "InlineInterface"
  | TypeOf _ -> "Typeof"
  | Utility _ -> "Utility"
  | Mu _ -> "Mu"
  | CharSet _ -> "CharSet"

let string_of_ctor_decl = function
  | TypeAliasDecl _ -> "TypeAlias"
  | ClassDecl _ -> "ClassDecl"
  | InterfaceDecl _ -> "InterfaceDecl"
  | ModuleDecl _ -> "Module"
  | VariableDecl _ -> "VariableDecl"
  | EnumDecl _ -> "EnumDecl"

let json_of_elt ~strip_root =
  let json_of_provenance loc p =
    Hh_json.(
      JSON_Object
        [
          ("kind", JSON_String (ctor_of_provenance p));
          ("loc", JSON_String (Reason.string_of_aloc ~strip_root loc));
        ])
  in
  let json_of_symbol { sym_provenance; sym_def_loc; sym_name; _ } =
    Hh_json.(
      JSON_Object
        [
          ("provenance", json_of_provenance sym_def_loc sym_provenance);
          ("name", JSON_String sym_name);
        ])
  in
  let json_of_builtin_value =
    Hh_json.(
      function
      | FunProto -> JSON_String "Function.prototype"
      | ObjProto -> JSON_String "Object.prototype"
      | FunProtoApply -> JSON_String "Function.prototype.apply"
      | FunProtoBind -> JSON_String "Function.prototype.bind"
      | FunProtoCall -> JSON_String "Function.prototype.call"
      | TSymbol s -> json_of_symbol s)
  in
  let rec json_of_t t =
    Hh_json.(JSON_Object (("kind", JSON_String (string_of_ctor_t t)) :: json_of_t_list t))
  and json_of_t_list t =
    Hh_json.(
      match t with
      | TVar (v, ts) -> json_of_tvar v @ json_of_targs ts
      | Bound (_, name) -> [("bound", JSON_String name)]
      | Generic g -> json_of_generic g
      | Any Annotated -> [("any", JSON_String "explicit")]
      | Any _ -> [("any", JSON_String "implicit")]
      | Top
      | Bot _
      | Void
      | Null
      | Symbol
      | Num _
      | Str _
      | Bool _ ->
        []
      | NumLit s
      | StrLit s ->
        [("literal", JSON_String s)]
      | BoolLit b -> [("literal", JSON_Bool b)]
      | Fun f -> json_of_fun_t f
      | Obj o -> json_of_obj_t o
      | Arr { arr_readonly; arr_literal; arr_elt_t } ->
        [
          ("readonly", JSON_Bool arr_readonly);
          ("literal", Base.Option.value_map arr_literal ~f:(fun t -> JSON_Bool t) ~default:JSON_Null);
          ("type", json_of_t arr_elt_t);
        ]
      | Tup ts -> [("types", JSON_Array (Base.List.map ~f:json_of_t ts))]
      | Union (t0, t1, ts) -> [("types", JSON_Array (Base.List.map ~f:json_of_t (t0 :: t1 :: ts)))]
      | Inter (t0, t1, ts) -> [("types", JSON_Array (Base.List.map ~f:json_of_t (t0 :: t1 :: ts)))]
      | InlineInterface { if_extends; if_props; if_dict } ->
        Hh_json.(
          let extends = Base.List.map ~f:(fun g -> JSON_Object (json_of_generic g)) if_extends in
          [
            ("extends", JSON_Array extends);
            ("body", JSON_Array (Base.List.map ~f:json_of_prop if_props));
            ("dict", Base.Option.value_map if_dict ~f:(fun d -> json_of_dict d) ~default:JSON_Null);
          ])
      | TypeOf b -> [("name", json_of_builtin_value b)]
      | Utility u -> json_of_utility u
      | Mu (i, t) -> [("mu_var", int_ i); ("type", json_of_t t)]
      | CharSet s -> [("literal", JSON_String s)])
  and json_of_tvar (RVar i) = Hh_json.[("id", int_ i)]
  and json_of_generic (s, k, targs_opt) =
    json_of_targs targs_opt
    @ [
        ("type", json_of_symbol s); ("kind", Hh_json.JSON_String (Ty.debug_string_of_generic_kind k));
      ]
  and json_of_fun_t { fun_params; fun_rest_param; fun_return; fun_type_params; fun_static } =
    let open Hh_json in
    [
      ("typeParams", json_of_type_params fun_type_params);
      ("paramTypes", JSON_Array (Base.List.map ~f:(fun (_, t, _) -> json_of_t t) fun_params));
      ( "paramNames",
        JSON_Array
          (List.rev_map
             (function
               | (Some n, _, _) -> JSON_String n
               | (None, _, _) -> JSON_String "_")
             fun_params) );
      ( "restParam",
        match fun_rest_param with
        | None -> JSON_Null
        | Some (name, t) ->
          JSON_Object
            ( [("restParamType", json_of_t t)]
            @
            match name with
            | None -> []
            | Some name -> [("restParamName", JSON_String name)] ) );
      ("returnType", json_of_t fun_return);
      ("staticType", json_of_t fun_static);
    ]
  and json_of_obj_t o =
    Hh_json.(
      let { obj_kind; obj_props; obj_literal; obj_frozen } = o in
      let obj_kind =
        match obj_kind with
        | ExactObj -> JSON_String "Exact"
        | InexactObj -> JSON_String "Inexact"
        | IndexedObj d -> json_of_dict d
      in
      [
        ("obj_kind", obj_kind);
        ("frozen", JSON_Bool obj_frozen);
        ("literal", Base.Option.value_map obj_literal ~f:(fun t -> JSON_Bool t) ~default:JSON_Null);
        ("props", JSON_Array (Base.List.map ~f:json_of_prop obj_props));
      ])
  and json_of_type_params ps =
    Hh_json.(
      match ps with
      | None -> JSON_Null
      | Some tparams -> JSON_Array (Base.List.map ~f:json_of_typeparam tparams))
  and json_of_targs targs_opt =
    Hh_json.(
      match targs_opt with
      | Some targs -> [("typeArgs", JSON_Array (Base.List.map ~f:json_of_t targs))]
      | None -> [])
  and json_of_typeparam
      { tp_name : string; tp_bound : t option; tp_polarity : polarity; tp_default : t option } =
    Hh_json.(
      JSON_Object
        ( [
            ("name", JSON_String tp_name);
            ("bound", Base.Option.value_map tp_bound ~f:json_of_t ~default:JSON_Null);
            ("polarity", json_of_polarity tp_polarity);
          ]
        @ Base.Option.value_map tp_default ~default:[] ~f:(fun t -> [("default", json_of_t t)]) ))
  and json_of_polarity polarity = Hh_json.JSON_String (string_of_polarity polarity)
  and json_of_prop prop =
    Hh_json.(
      JSON_Object
        (match prop with
        | NamedProp { name; prop; from_proto } ->
          [
            ("kind", JSON_String "NamedProp");
            ( "prop",
              JSON_Object
                [
                  ("name", JSON_String name);
                  ("prop", json_of_named_prop prop);
                  ("from_proto", JSON_Bool from_proto);
                ] );
          ]
        | CallProp ft ->
          [("kind", JSON_String "NamedProp"); ("prop", JSON_Object (json_of_fun_t ft))]
        | SpreadProp t -> [("kind", JSON_String "SpreadProp"); ("prop", json_of_t t)]))
  and json_of_dict { dict_polarity; dict_name; dict_key; dict_value } =
    Hh_json.(
      JSON_Object
        [
          ("polarity", json_of_polarity dict_polarity);
          ("name", JSON_String (Base.Option.value dict_name ~default:"_"));
          ("key", json_of_t dict_key);
          ("value", json_of_t dict_value);
        ])
  and json_of_named_prop p =
    Hh_json.(
      JSON_Object
        (match p with
        | Field { t; polarity; optional } ->
          [
            ("kind", JSON_String "field");
            ("type", json_of_t t);
            ("polarity", json_of_polarity polarity);
            ("optional", JSON_Bool optional);
          ]
        | Method t -> [("kind", JSON_String "Method"); ("funtype", JSON_Object (json_of_fun_t t))]
        | Get t -> [("kind", JSON_String "Get"); ("type", json_of_t t)]
        | Set t -> [("kind", JSON_String "Set"); ("type", json_of_t t)]))
  and json_of_utility u =
    Hh_json.(
      let ctor = Ty.string_of_utility_ctor u in
      let ts = json_of_targs (Ty.types_of_utility u) in
      ("kind", JSON_String ctor) :: ts)
  in
  let json_of_class_decl (name, tparams) =
    [("name", json_of_symbol name); ("typeParams", json_of_type_params tparams)]
  in
  let json_of_interface_decl (name, tparams) =
    [("name", json_of_symbol name); ("typeParams", json_of_type_params tparams)]
  in
  let json_of_module name _ _ =
    Hh_json.[("name", Base.Option.value_map ~f:json_of_symbol ~default:JSON_Null name)]
  in
  let json_of_decl =
    let open Hh_json in
    function
    | VariableDecl (name, t) -> [("name", JSON_String name); ("type_", json_of_t t)]
    | TypeAliasDecl { name; tparams; type_; _ } ->
      [
        ("name", json_of_symbol name);
        ("typeParams", json_of_type_params tparams);
        ("body", Base.Option.value_map ~f:json_of_t ~default:JSON_Null type_);
      ]
    | ClassDecl (s, ps) -> json_of_class_decl (s, ps)
    | InterfaceDecl (s, ps) -> json_of_interface_decl (s, ps)
    | EnumDecl name -> [("name", json_of_symbol name)]
    | ModuleDecl { name; exports; default } -> json_of_module name exports default
  in
  fun elt ->
    let payload =
      match elt with
      | Type t -> json_of_t_list t
      | Decl d -> json_of_decl d
    in
    let kind =
      match elt with
      | Type t -> string_of_ctor_t t
      | Decl d -> string_of_ctor_decl d
    in
    Hh_json.(JSON_Object (("kind", JSON_String kind) :: payload))
