Merge branch 'jalon3' of gaufre.informatique.univ-paris-diderot.fr:Anri/compilation-m1-2023 into jalon3

flap/src/hopix/hopixTypechecker.ml

@@ -2,6 +2,8 @@
 
 open HopixAST
 
+let get_aty (HopixTypes.Scheme (_, aty_value)) : HopixTypes.aty = aty_value
+
 (** Error messages *)
 
 let invalid_instantiation pos given expected =
@@ -43,11 +45,9 @@ let check_type_scheme
   fun env pos (ForallTy (ts, ty)) ->
   let ts = List.map Position.value ts in
   let env = HopixTypes.bind_type_variables pos env ts in
-    (HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env)
+  HopixTypes.Scheme (ts, HopixTypes.internalize_ty env ty), env
 ;;
 
-
-
 let rec check_pattern
   :  HopixTypes.typing_environment -> HopixAST.pattern Position.located -> HopixTypes.aty
   -> HopixTypes.typing_environment
@@ -111,17 +111,17 @@ and synth_apply
   :  HopixTypes.typing_environment -> expression Position.located
   -> expression Position.located -> HopixTypes.aty
   =
-  fun tenv f x -> (*failwith "Students! This is your job! (synth_apply)"*)
+  fun tenv f x ->
+  (*failwith "Students! This is your job! (synth_apply)"*)
   let f_type = synth_expression tenv f in
   match f_type with
-  | HopixTypes.ATyArrow (gauche,droit) -> (*  a' -> b' *)
+  | HopixTypes.ATyArrow (gauche, droit) ->
-  (
+    (*  a' -> b' *)
     let x_type = synth_expression tenv x in
-    check_equal_types x.position  gauche x_type; droit
+    check_equal_types x.position gauche x_type;
-  )
+    droit
   | _ -> failwith ""
 
-
 and synth_record
   :  HopixTypes.typing_environment
   -> (label Position.located * expression Position.located) list
@@ -215,7 +215,6 @@ and synth_for
   =
   fun tenv id estart eend expr -> failwith "Students! This is your job! (synth_for)"
 
-
 and check_expression
   :  HopixTypes.typing_environment -> HopixAST.expression Position.located
   -> HopixTypes.aty -> unit
@@ -223,7 +222,9 @@ and check_expression
   fun env (Position.{ value = e; position = pos } as exp) expected ->
   match e with
   | Fun df -> failwith "Students! This is your job! Fun check"
-  | _ -> failwith "Students! This is your job! check_expression wildcard"
+  | _ ->
+    let given = synth_expression env exp in
+    check_equal_types pos ~expected ~given
 
 and check_value_definition
   :  HopixTypes.typing_environment -> HopixAST.value_definition
@@ -232,10 +233,11 @@ and check_value_definition
   fun env -> function
   | SimpleValue (id, ty, ex) ->
     (match ty with
-     | None -> failwith "Type missing."
+     | None -> failwith "A type is missing."
      | Some ty' ->
        (*failwith "Students! This is your job! (check_value_definition | SimpleValue)"*)
-       let tys,_ = Position.located_pos (check_type_scheme env) ty' in
+       let tys, tenv = Position.located_pos (check_type_scheme env) ty' in
+       check_expression tenv ex (get_aty tys);
        HopixTypes.bind_value (Position.value id) tys env)
   | RecFunctions _ ->
     (* Je crois que c'est galère et donc c'est pas grave si on arrive pas