Cleanup per review

Author: WardBrian

src/frontend/Semantic_error.ml

@@ -137,17 +137,17 @@ module TypeError = struct
           ( name
           , arg_tys
           , ([((UnsizedType.ReturnType return_type, args), error)], false) )
-    | AmbiguousFunctionPromotion (s, arg_tys, signatures) ->
+    | AmbiguousFunctionPromotion (name, arg_tys, signatures) ->
         let pp_sig ppf (rt, args) =
           Fmt.pf ppf "@[<hov>(@[<hov>%a@]) => %a@]"
             Fmt.(list ~sep:comma UnsizedType.pp_fun_arg)
             args UnsizedType.pp_returntype rt in
         Fmt.pf ppf
-          "No unique minimum promotion found for function \"%s\".@ Overloaded \
+          "No unique minimum promotion found for function '%s'.@ Overloaded \
            functions must not have multiple equally valid promotion paths.@ %a \
            function has several:@ @[<v>%a@]@ Consider defining a new signature \
            for the exact types needed or@ re-thinking existing definitions."
-          s
+          name
           (Fmt.option
              ~none:(fun ppf () -> Fmt.pf ppf "This")
              (fun ppf tys ->
@@ -362,7 +362,7 @@ module StatementError = struct
     | TransformedParamsInt
     | FuncOverloadRtOnly of
         string * UnsizedType.returntype * UnsizedType.returntype
-    | FuncDeclRedefined of string * UnsizedType.t
+    | FuncDeclRedefined of string * UnsizedType.t * bool
     | FunDeclExists of string
     | FunDeclNoDefn
     | FunDeclNeedsBlock
@@ -436,9 +436,11 @@ module StatementError = struct
           "Function '%s' cannot be overloaded by return type only. Previously \
            used return type %a"
           name UnsizedType.pp_returntype rt'
-    | FuncDeclRedefined (name, ut) ->
-        Fmt.pf ppf "Function '%s' has already been declared to for signature %a"
-          name UnsizedType.pp ut
+    | FuncDeclRedefined (name, ut, stan_math) ->
+        Fmt.pf ppf "Function '%s' %s signature %a" name
+          ( if stan_math then "is already declared in the Stan Math library with"
+          else "has already been declared to for" )
+          UnsizedType.pp ut
     | FunDeclExists name ->
         Fmt.pf ppf
           "Function '%s' has already been declared. A definition is expected."
@@ -701,8 +703,8 @@ let transformed_params_int loc =
 let fn_overload_rt_only loc name rt1 rt2 =
   StatementError (loc, StatementError.FuncOverloadRtOnly (name, rt1, rt2))
 
-let fn_decl_redefined loc name ut =
-  StatementError (loc, StatementError.FuncDeclRedefined (name, ut))
+let fn_decl_redefined loc name ~stan_math ut =
+  StatementError (loc, StatementError.FuncDeclRedefined (name, ut, stan_math))
 
 let fn_decl_exists loc name =
   StatementError (loc, StatementError.FunDeclExists name)

src/frontend/Semantic_error.mli

@@ -142,7 +142,9 @@ val fn_overload_rt_only :
   -> UnsizedType.returntype
   -> t
 
-val fn_decl_redefined : Location_span.t -> string -> UnsizedType.t -> t
+val fn_decl_redefined :
+  Location_span.t -> string -> stan_math:bool -> UnsizedType.t -> t
+
 val fn_decl_exists : Location_span.t -> string -> t
 val fn_decl_without_def : Location_span.t -> t
 val fn_decl_needs_block : Location_span.t -> t

src/frontend/SignatureMismatch.ml

@@ -205,16 +205,19 @@ let promotion_cost p =
   | RealToComplexPromotion | IntToRealPromotion -> 1
   | IntToComplexPromotion -> 2
 
-let unique_minimum_promotion ps =
+let unique_minimum_promotion promotion_options =
   let size (_, p) =
     List.fold ~init:0 ~f:(fun acc p -> acc + promotion_cost p) p in
-  let sizes = List.map ~f:size ps in
-  let min_promotions = List.min_elt ~compare:Int.compare sizes in
-  let ps = List.zip_exn sizes ps in
-  match min_promotions with
-  | Some n -> (
+  let sizes = List.map ~f:size promotion_options in
+  let min_promotion = List.min_elt ~compare:Int.compare sizes in
+  let sizes_and_promotons = List.zip_exn sizes promotion_options in
+  match min_promotion with
+  | Some min_depth -> (
     match
-      List.filter_map ~f:(fun (x, y) -> if x = n then Some y else None) ps
+      List.filter_map
+        ~f:(fun (depth, promotion) ->
+          if depth = min_depth then Some promotion else None )
+        sizes_and_promotons
     with
     | [ans] -> Ok ans
     | _ :: _ as lst -> Error (Some (List.map ~f:fst lst))
@@ -227,8 +230,8 @@ let matching_function env name args =
   let function_types =
     Environment.find env name
     |> List.filter_map ~f:extract_function_types
-    |> List.sort ~compare:(fun (x, _, _, _) (y, _, _, _) ->
-           UnsizedType.compare_returntype x y ) in
+    |> List.sort ~compare:(fun (ret1, _, _, _) (ret2, _, _, _) ->
+           UnsizedType.compare_returntype ret1 ret2 ) in
   let matches, errors =
     List.partition_map function_types
       ~f:(fun (rt, tys, funkind_constructor, _) ->
@@ -238,7 +241,9 @@ let matching_function env name args =
   match unique_minimum_promotion matches with
   | Ok (((rt, _), funkind_constructor), p) ->
       UniqueMatch (rt, funkind_constructor, p)
-  | Error (Some e) -> AmbiguousMatch (List.map ~f:fst e)
+  | Error (Some e) ->
+      AmbiguousMatch (List.map ~f:fst e)
+      (* return the return types and argument types of ambiguous matches *)
   | Error None ->
       let errors =
         List.sort errors ~compare:(fun (_, e1) (_, e2) -> compare_errors e1 e2)

src/frontend/SignatureMismatch.mli

@@ -60,6 +60,10 @@ val matching_function :
   -> string
   -> (UnsizedType.autodifftype * UnsizedType.t) list
   -> match_result
+(** Searches for a function of the given name which can
+    support the required argument types.
+    Requires a unique minimum option under type promotion
+*)
 
 val check_variadic_args :
      bool

src/frontend/Typechecker.ml

@@ -434,35 +434,34 @@ let check_normal_fn ~is_cond_dist loc tenv id es =
             (Env.nearest_ident tenv id.name) )
       |> error
   | _ (* a function *) -> (
-      let
-      (* NB: At present, [SignatureMismatch.matching_function] cannot handle overloaded function types.
-         This is not needed until UDFs can be higher-order, as it is special cased for
-         variadic functions
-      *)
-      open
-        SignatureMismatch in
-      match matching_function tenv id.name (get_arg_types es) with
-      | UniqueMatch (Void, _, _) ->
-          Semantic_error.returning_fn_expected_nonreturning_found loc id.name
-          |> error
-      | UniqueMatch (ReturnType ut, fnk, promotions) ->
-          mk_typed_expression
-            ~expr:
-              (mk_fun_app ~is_cond_dist
-                 ( fnk (Fun_kind.suffix_from_name id.name)
-                 , id
-                 , SignatureMismatch.promote es promotions ) )
-            ~ad_level:(expr_ad_lub es) ~type_:ut ~loc
-      | AmbiguousMatch sigs ->
-          Semantic_error.ambiguous_function_promotion loc id.name
-            (Some (List.map ~f:type_of_expr_typed es))
-            sigs
-          |> error
-      | SignatureErrors (l, b) ->
-          es
-          |> List.map ~f:(fun e -> e.emeta.type_)
-          |> Semantic_error.illtyped_fn_app loc id.name (l, b)
-          |> error )
+    (* NB: At present, [SignatureMismatch.matching_function] cannot handle overloaded function types.
+       This is not needed until UDFs can be higher-order, as it is special cased for
+       variadic functions
+    *)
+    match
+      SignatureMismatch.matching_function tenv id.name (get_arg_types es)
+    with
+    | UniqueMatch (Void, _, _) ->
+        Semantic_error.returning_fn_expected_nonreturning_found loc id.name
+        |> error
+    | UniqueMatch (ReturnType ut, fnk, promotions) ->
+        mk_typed_expression
+          ~expr:
+            (mk_fun_app ~is_cond_dist
+               ( fnk (Fun_kind.suffix_from_name id.name)
+               , id
+               , SignatureMismatch.promote es promotions ) )
+          ~ad_level:(expr_ad_lub es) ~type_:ut ~loc
+    | AmbiguousMatch sigs ->
+        Semantic_error.ambiguous_function_promotion loc id.name
+          (Some (List.map ~f:type_of_expr_typed es))
+          sigs
+        |> error
+    | SignatureErrors (l, b) ->
+        es
+        |> List.map ~f:(fun e -> e.emeta.type_)
+        |> Semantic_error.illtyped_fn_app loc id.name (l, b)
+        |> error )
 
 (** Given a constraint function [matches], find any signature which exists
     Returns the first [Ok] if any exist, or else [Error]
@@ -1444,8 +1443,9 @@ and verify_unique_signature tenv loc id arg_tys rt =
   | [] -> ()
   | {type_= UFun (_, rt', _, _); _} :: _ when rt <> rt' ->
       Semantic_error.fn_overload_rt_only loc id.name rt rt' |> error
-  | _ ->
+  | {kind; _} :: _ ->
       Semantic_error.fn_decl_redefined loc id.name
+        ~stan_math:(kind = `StanMath)
         (UnsizedType.UFun (arg_tys, rt, Fun_kind.suffix_from_name id.name, AoS))
       |> error