fmt

flap/src/hopix/hopixTypechecker.ml

@@ -214,7 +214,6 @@ and pattern_tagval
   -> HopixTypes.aty * HopixTypes.typing_environment
   =
   fun tenv cons tlist plist ->
-
   let cons_scheme =
     try HopixTypes.lookup_type_scheme_of_constructor cons.position cons.value tenv with
     | HopixTypes.Unbound (pos, Constructor (KId c)) ->
@@ -233,31 +232,30 @@ and pattern_tagval
       invalid_instantiation cons.position expected given
   in
   let p_args, tenv = synth_list_pattern tenv plist in
-  (
+  ( (let expected_args, result =
-  let expected_args, result =
+       HopixTypes.destruct_function_type_maximally cons.position tcons
-    HopixTypes.destruct_function_type_maximally cons.position tcons
+     in
-  in
+     (try
-  (try
+        List.iter2
-     List.iter2
+          (fun expected given -> check_equal_types cons.position ~expected ~given)
-       (fun expected given -> check_equal_types cons.position ~expected ~given)
+          expected_args
-       expected_args
+          p_args
-       p_args
+      with
-   with
+      | Invalid_argument _ ->
-   | Invalid_argument _ ->
+        (* 35-bad *)
-     (* 35-bad *)
+        check_equal_types
-     check_equal_types
+          cons.position
-       cons.position
+          ~expected:result
-       ~expected:result
+          ~given:(HopixTypes.ATyArrow (result, result)));
-       ~given:(HopixTypes.ATyArrow (result, result)));
+     result)
-  result
+  , tenv )
-  ),tenv
 
 and synth_list_pattern tenv = function
-| [] -> [], tenv
+  | [] -> [], tenv
-| p :: plist ->
+  | p :: plist ->
-  let ty, tenv = synth_pattern tenv p in 
+    let ty, tenv = synth_pattern tenv p in
-  let tys, tenv = synth_list_pattern tenv plist in
+    let tys, tenv = synth_list_pattern tenv plist in
-  ty::tys, tenv
+    ty :: tys, tenv
 
 and pattern_record
   :  HopixTypes.typing_environment
@@ -265,40 +263,44 @@ and pattern_record
   -> HopixAST.ty Position.located list option
   -> HopixTypes.aty * HopixTypes.typing_environment
   =
-  fun tenv plist tlist -> 
+  fun tenv plist tlist ->
-    let label = fst(List.hd plist) in
+  let label = fst (List.hd plist) in
-    let type_cons,_,labels = 
+  let type_cons, _, labels =
-    let LId label_name = label.value in
+    let (LId label_name) = label.value in
     try HopixTypes.lookup_type_constructor_of_label label.position label.value tenv with
     | HopixTypes.Unbound (pos, Label (LId i)) ->
-      HopixTypes.type_error pos (Printf.sprintf "There is no type definition for label `%s'." label_name )  
+      HopixTypes.type_error
+        pos
+        (Printf.sprintf "There is no type definition for label `%s'." label_name)
   in
   let tlist' =
     match tlist with
     | Some tlist -> List.map (fun t -> HopixTypes.internalize_ty tenv t) tlist
     | None -> HopixTypes.type_error label.position "No types found."
   in
-  let tenv = 
+  let tenv =
-  List.fold_left (
+    List.fold_left
-    fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
+      (fun tenv (Position.{ position = label_pos; value = label_val }, pat) ->
-      let label_scheme =
+        let label_scheme =
-        try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
+          try HopixTypes.lookup_type_scheme_of_label label_pos label_val tenv with
-        | HopixTypes.Unbound (pos, Label (LId i)) ->
+          | HopixTypes.Unbound (pos, Label (LId i)) ->
-          HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
+            HopixTypes.type_error pos (Printf.sprintf "Unbound label `%s'." i)
-      in
+        in
-      let instance_type_scheme =
+        let instance_type_scheme =
-        try HopixTypes.instantiate_type_scheme label_scheme tlist' with
+          try HopixTypes.instantiate_type_scheme label_scheme tlist' with
-        | HopixTypes.InvalidInstantiation { expected; given } ->
+          | HopixTypes.InvalidInstantiation { expected; given } ->
-          invalid_instantiation (Position.position pat) expected given
+            invalid_instantiation (Position.position pat) expected given
-      in
+        in
-      let _,expected = HopixTypes.destruct_function_type label_pos instance_type_scheme in
+        let _, expected =
-      let (given,tenv) = synth_pattern tenv pat in
+          HopixTypes.destruct_function_type label_pos instance_type_scheme
-      check_equal_types label_pos ~expected ~given; tenv
+        in
-  ) tenv plist;
+        let given, tenv = synth_pattern tenv pat in
-    in 
+        check_equal_types label_pos ~expected ~given;
-  ATyCon(type_cons, tlist'),tenv
+        tenv)
-
+      tenv
-
+      plist
+  in
+  ATyCon (type_cons, tlist'), tenv
 
 and synth_variable
   :  HopixTypes.typing_environment -> identifier Position.located