From 0e484f5bc14cc5e2f3b7895765d6fef9263fa342 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@nomadic-labs.com>
Date: Mon, 3 Jun 2019 14:56:11 +0200
Subject: [PATCH] Started matching errors in typechecker

---
 src/ast_simplified/PP.ml | 16 ++++++++++++++++
 src/typer/typer.ml       | 12 ++++++++++--
 2 files changed, 26 insertions(+), 2 deletions(-)

diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml
index 5cd46827c..e136988d2 100644
--- a/src/ast_simplified/PP.ml
+++ b/src/ast_simplified/PP.ml
@@ -113,6 +113,22 @@ and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> u
     | Match_option {match_none ; match_some = (some, match_some)} ->
         fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some
 
+(* Shows the type expected for the matched value *)
+and matching_type ppf m = match m with
+  | Match_tuple _ ->
+      fprintf ppf "tuple"
+  | Match_variant lst ->
+      fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst
+  | Match_bool _ ->
+      fprintf ppf "boolean"
+  | Match_list _ ->
+      fprintf ppf "list"
+  | Match_option _ ->
+      fprintf ppf "option"
+
+and matching_variant_case_type ppf ((c,n),_a) =
+  fprintf ppf "| %s %s" c n
+
 let declaration ppf (d:declaration) = match d with
   | Declaration_type (type_name , te) ->
       fprintf ppf "type %s = %a" type_name type_expression te
diff --git a/src/typer/typer.ml b/src/typer/typer.ml
index 65dbc66d2..d3523a3d0 100644
--- a/src/typer/typer.ml
+++ b/src/typer/typer.ml
@@ -46,6 +46,14 @@ module Errors = struct
         I.PP.expression ae
     in
     error title full ()
+
+  let match_error : type a . expected: a I.Types.matching -> actual: O.Types.type_value -> unit -> _ =
+    fun ~expected ~actual () ->
+    let title = (thunk "typing match") in
+    let full () = Format.asprintf "expected %a but got %a"
+      I.PP.matching_type expected
+      O.PP.type_value actual in
+    error title full ()
 end
 open Errors
 
@@ -81,14 +89,14 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
   fun f e t i -> match i with
     | Match_bool {match_true ; match_false} ->
       let%bind _ =
-        trace_strong (simple_error "Matching bool on not-a-bool")
+        trace_strong (match_error ~expected:i ~actual:t)
         @@ get_t_bool t in
       let%bind match_true = f e match_true in
       let%bind match_false = f e match_false in
       ok (O.Match_bool {match_true ; match_false})
   | Match_option {match_none ; match_some} ->
       let%bind t_opt =
-        trace_strong (simple_error "Matching option on not-an-option")
+        trace_strong (match_error ~expected:i ~actual:t)
         @@ get_t_option t in
       let%bind match_none = f e match_none in
       let (n, b) = match_some in