advanced_error_handling.ml

(* https://keleshev.com/advanced-error-handling-in-ocaml *)

let failwithf f = Printf.ksprintf failwith f

(*

  t -> bool | int

  e -> true | false
     | 0 | 1 | 2 | …
     | e : t
     | if e then e else e

*)

module Type = struct
  type t = Bool | Int

  let to_string = function Bool -> "bool" | Int -> "int"
end

module Term = struct
  type t =
    | Bool of bool
    | Int of int
    | Annotation of t * Type.t
    | If of {conditional: t; consequence: t; alternative: t}
end

open Term

module Using_exceptions = struct
  let rec infer = function
    | Bool _ -> Type.Bool
    | Int _ -> Type.Int
    | Annotation (term, annotated_t) ->
        let term_t = infer term in
        if term_t <> annotated_t then
          failwithf "Expected %s, but got %s"
            (Type.to_string annotated_t) 
            (Type.to_string term_t)
        else
          annotated_t
    | If {conditional; consequence; alternative} ->
        let conditional_t = infer conditional in
        let consequence_t = infer consequence in
        let alternative_t = infer alternative in
        if conditional_t <> Type.Bool then
          failwithf "If condition must be boolean"
        else if consequence_t <> alternative_t then
          failwithf "If branches must match: %s vs. %s"
            (Type.to_string consequence_t) 
            (Type.to_string alternative_t)
        else
          consequence_t
end

module Using_result_with_polymorphic_variant = struct
  let return x = Ok x
  let error x = Error x

  let (let*) = Result.bind
  (* or *)
  let (let*) body callback = match body with
    | Ok ok -> callback ok
    | Error e -> Error e

  let rec infer = function
    | Bool _ -> return Type.Bool
    | Int _ -> return Type.Int
    | Annotation (term, annotated_t) ->
        let* term_t = infer term in
        if term_t <> annotated_t then
          error (`Expected_x_got_y (annotated_t, term_t))
        else
          return annotated_t
    | If {conditional; consequence; alternative} ->
        let* conditional_t = infer conditional in
        let* consequence_t = infer consequence in
        let* alternative_t = infer alternative in
        if conditional_t <> Type.Bool then
          error `If_conditional_must_be_boolean
        else if consequence_t <> alternative_t then
          error (`If_branches_must_match (consequence_t,
                                          alternative_t))
        else
          return consequence_t
end

module Multiple_errors_example = struct
  let return x = Ok x
  let error x = Error [x]
  let (let*) = Result.bind

  let (and*) left right = match left, right with
    | Ok left, Ok right -> Ok (left, right)
    | Error left, Error right -> Error (left @ right)
    | Error e, _ | _, Error e -> Error e

  let rec infer = function
    | Bool _ -> return Type.Bool
    | Int _ -> return Type.Int
    | Annotation (term, annotated_t) ->
        let* term_t = infer term in
        if term_t <> annotated_t then
          error (`Expected_x_got_y (annotated_t, term_t))
        else
          return annotated_t
    | If {conditional; consequence; alternative} ->
        let* () =
          let* conditional_t = infer conditional in
            if conditional_t <> Type.Bool then
              error `If_conditional_must_be_boolean
            else
              return ()
        and* result_t =
          let* consequence_t = infer consequence
          and* alternative_t = infer alternative in
          if consequence_t <> alternative_t then
            error (`If_branches_must_match (consequence_t, alternative_t))
          else
            return consequence_t
        in
        return result_t

  module Test = struct
    assert (infer (If {
      conditional=Bool true;
      consequence=Int 1;
      alternative=Int 2;
    }) = Ok Type.Int);

    (* if 1 then 2 else true *)
    assert (infer (If {
      conditional=Int 1;
      consequence=Int 2;
      alternative=Bool true;
    }) = Error [
      `If_conditional_must_be_boolean;
      `If_branches_must_match (Type.Int, Type.Bool);
    ]);

    (* if (1: bool) then (2: bool) else (true: int) *)
    assert (infer (If {
      conditional=Annotation (Int 1, Type.Bool);
      consequence=Annotation (Int 2, Type.Bool);
      alternative=Annotation (Bool true, Type.Int);
    }) = Error [
      `Expected_x_got_y (Type.Bool, Type.Int);
      `Expected_x_got_y (Type.Bool, Type.Int);
      `Expected_x_got_y (Type.Int, Type.Bool);
    ]);
  end
end

module Error_recovery_example = struct

  (* invariant: match outcome with {result=None; errors=[]} -> false | _ -> true *)
  type ('ok, 'error) outcome = {
    result: 'ok option;
    errors: 'error list;
  }

  module Outcome = struct
    type ('ok, 'error) t = ('ok, 'error) outcome = {
      result: 'ok option;
      errors: 'error list;
    }

    let return x = {result=Some x; errors=[]}
    let error x = {result=None; errors=[x]}
    let recoverable_error x = {result=Some (); errors=[x]}

    let (let*) body callback = match body with
      | {result=None; errors} as e -> e
      | {result=Some ok; errors=previous_errors} ->
          let {result; errors} = callback ok in
          {result; errors=previous_errors @ errors}

    let (and*) left right =
      let result = match left.result, right.result with
        | Some left, Some right -> Some (left, right)
        | _ -> None
      in
      {result; errors=left.errors @ right.errors}
  end

  open Outcome

  let rec infer = function
    | Bool _ -> return Type.Bool
    | Int _ -> return Type.Int
    | Annotation (term, annotated_t) ->
        let* term_t = infer term in
        let* () = 
          if term_t <> annotated_t then
            recoverable_error (
              `Expected_x_got_y (annotated_t, term_t))
          else 
            return ()
        in
        return annotated_t
    | If {conditional; consequence; alternative} ->
        let* () =
          let* conditional_t = infer conditional in
            if conditional_t <> Type.Bool then
              error `If_conditional_must_be_boolean
            else
              return ()
        and* result_t =
          let* consequence_t = infer consequence
          and* alternative_t = infer alternative in
          if consequence_t <> alternative_t then
            error (`If_branches_must_match (consequence_t, 
                                            alternative_t))
          else
            return consequence_t
        in
        return result_t

  module Test = struct
    assert (infer (If {
      conditional=Bool true;
      consequence=Int 1;
      alternative=Int 2;
    }) = {
      result=Some Type.Int;
      errors=[];
    });

    (* if (1: bool) then (2: bool) else (true: int) *)
    assert (infer (If {
      conditional=Annotation (Int 1, Type.Bool);
      consequence=Annotation (Int 2, Type.Bool);
      alternative=Annotation (Bool true, Type.Int);
    }) = {
      result=None;
      errors=[
        `Expected_x_got_y (Type.Bool, Type.Int);
        `Expected_x_got_y (Type.Bool, Type.Int);
        `Expected_x_got_y (Type.Int, Type.Bool);
        `If_branches_must_match (Type.Bool, Type.Int);
      ];
    });

    assert (infer (If {
      conditional=Int 1;
      consequence=Int 2;
      alternative=Bool true;
    }) = {
      result=None;
      errors=[
        `If_conditional_must_be_boolean;
        `If_branches_must_match (Type.Int, Type.Bool);
      ];
    });

    (* if true then (false: int) else 42 *)
    assert (infer (If {
      conditional=Bool true;
      consequence=Annotation (Bool false, Type.Int);
      alternative=Int 42;
    }) = {
      result=Some Type.Int;
      errors=[
        `Expected_x_got_y (Type.Int, Type.Bool);
      ];
    });
  end
end


(* Bonus: warnings *)
module Multiple_errors_and_warnings_example = struct

  module Warned = struct
    type ('ok, 'error, 'warning) t = {
      result: ('ok, 'error list) result; 
      warnings: 'warning list;
    }

    let return x = {result=Ok x; warnings=[]}
    let error x = {result=Error [x]; warnings=[]}
    let warn warning = {result=Ok (); warnings=[warning]}

    let (let*) body callback = match body with
      | {result=Error e; warnings} as w -> w
      | {result=Ok ok; warnings=previous_warnings} ->
          let {result; warnings} = callback ok in
          {result; warnings=previous_warnings @ warnings}

    let (and*) left right =
      let warnings = left.warnings @ right.warnings in
      let result = match left.result, right.result with
        | Ok left, Ok right -> Ok (left, right)
        | Error left, Error right -> Error (left @ right)
        | Error e, _ | _, Error e -> Error e in
      {result; warnings}

(*
    let product left right = match left, right with
      | Ok left, Ok right -> Ok (left, right)
      | Error left, Error right -> Error (left @ right)
      | (Error _ as e), _ | _, (Error _ as e) -> e

    let (and* ) left right =
      let result = product left.result right.result in
      {result; warnings=left.warnings @ right.warnings}
*)
  end

  open Warned

  let rec infer = function
    | Bool _ -> return Type.Bool
    | Int _ -> return Type.Int
    | Annotation (term, annotated_t) ->
        let* term_t = infer term in
        if term_t <> annotated_t then
          error (`Expected_x_got_y (annotated_t, term_t))
        else
          return annotated_t
    | If {conditional; consequence; alternative} ->
        let* () =
          let* conditional_t = infer conditional in
            if conditional_t <> Type.Bool then
              error `If_conditional_must_be_boolean
            else
              match conditional with
              | Bool value ->
                  warn (`Conditional_always value)
              | _ ->
                  return ()
        and* result_t =
          let* consequence_t = infer consequence
          and* alternative_t = infer alternative in
          if consequence_t <> alternative_t then
            error (`If_branches_must_match (consequence_t,
                                            alternative_t))
          else
            return consequence_t
        in
        return result_t

  module Test = struct
    assert (infer (If {
      conditional=Bool true;
      consequence=Int 1;
      alternative=Int 2;
    }) = {
     result=Ok Type.Int;
     warnings=[`Conditional_always true];
    });

    assert (infer (If {
      conditional=Annotation (Int 1, Type.Bool);
      consequence=Annotation (Int 1, Type.Bool);
      alternative=Annotation (Bool true, Type.Int);
    }) = {
      result=Error [
        `Expected_x_got_y (Type.Bool, Type.Int);
        `Expected_x_got_y (Type.Bool, Type.Int);
        `Expected_x_got_y (Type.Int, Type.Bool);
      ];
      warnings=[];
    });

    assert (infer (If {
      conditional=Int 1;
      consequence=Int 2;
      alternative=Bool true;
    }) = {
      result=Error ([
        `If_conditional_must_be_boolean;
        `If_branches_must_match (Type.Int, Type.Bool);
      ]);
      warnings=[];
    });
  end
end

let () = print_endline "."