Add coercions to make polymorphic variants easier to use.

We coerce variable initialisations, plain assignments,
and function returns, when the type of the variable
or function return are explicitly specified.

Assignments and initialisation ONLY allow polymorphic
variants to be coerced, however function returns use
fully general subtyping coercions, because the code
to insert the coercion in that case is in the desugaring
routine early in the compilation process before binding.

src/compiler/flx_bind/flx_bbind.ml

@@ -214,7 +214,7 @@ print_endline (" &&&&&& bind_type_uses calling BBIND_SYMBOL");
   (* this is the full vs list *)
   let ivs = find_vs state.sym_table bsym_table symbol_index in
   let is_generic vs = List.fold_left (fun acc (name,index,typ) ->
-      acc || match typ with | KND_generic _ -> true | _ -> false) 
+      acc || match typ with | KND_generic -> true | _ -> false) 
       false
       vs
   in
@@ -383,7 +383,7 @@ with _ -> print_endline ("PARENT BINDING FAILED CONTINUING ANYHOW");
 
   | SYMDEF_function (ps,rt,effects,props,exes) ->
 (*
-print_endline ("Binding function " ^ sym.Flx_sym.id);
+print_endline ("Flx_bbind: Binding function " ^ sym.Flx_sym.id);
     print_endline (" ... Binding parameters");
 *)
     let bps = bindps ps in
@@ -394,6 +394,10 @@ print_endline ("Binding function " ^ sym.Flx_sym.id);
 
     (* We don't need to bind the intermediary type. *)
     let brt = bt' rt in
+(*
+print_endline ("Flx_bbind: Calculate return type " ^ string_of_typecode rt ^
+  " ==> " ^ sbt bsym_table brt);
+*)
     let beffects = bt' effects in
 (*
 if sym.Flx_sym.id = "hhhhh" then
@@ -411,7 +415,7 @@ print_endline ("Effects = " ^ Flx_btype.st beffects);
         else btyp_effector (d,beffects,brt)
       in
       let t = Flx_fold.fold bsym_table state.counter ft in
-if debug then
+ if debug then 
 print_endline ("Flx_bbind: Adding type of index " ^ si symbol_index ^ " to cache, type=" ^ Flx_btype.st t);
       Hashtbl.add state.ticache symbol_index t
     end;

src/compiler/flx_bind/flx_bind_bexe.ml

@@ -233,6 +233,8 @@ let rec bind_exe' (state: Flx_bexe_state.bexe_state_t) bsym_table (sr, exe) : be
 (*
 print_endline ("Bind_exe, return type " ^ Flx_print.sbt bsym_table state.ret_type);
   print_endline ("EXE="^string_of_exe 1 exe);
+*)
+(*
   if not state.reachable then
   begin
     match exe with
@@ -610,7 +612,33 @@ print_endline ("Function return value has MINIMISED type " ^ sbt bsym_table t');
       end
 *)
     end
-    else clierrx "[flx_bind/flx_bind_bexe.ml:593: E30] " sr
+    (* coerce type of return value to specified function return type if
+       they're polymorphic variants, and the return value type
+       is a subtype of the specified function return type
+    *)
+    else begin match unfold "bind_exe_v2" t', unfold "bind_exe_v1" state.ret_type with
+    | BTYP_variant ts, BTYP_variant rs ->
+      begin try List.iter (fun (name,t) ->
+         let r = List.assoc name rs in
+         if not (type_eq bsym_table state.counter r t) then raise Not_found
+      ) ts;
+(*
+      print_endline ("Coercing return value");
+*)
+      [(bexe_fun_return (sr,bexpr_coerce ((e',t'), state.ret_type)))]
+      with Not_found -> 
+      clierrx "[flx_bind/flx_bind_bexe.ml:593: E30] " sr
+        (
+          "[bind_exe: fun_return ] return expression \n" ^
+          sbe bsym_table e ^
+          "\nof type\n" ^
+          sbt bsym_table t' ^
+          "\nis not a subtype of the function return type:\n" ^ 
+          sbt bsym_table state.ret_type
+        )
+      end
+    | _ ->
+    clierrx "[flx_bind/flx_bind_bexe.ml:593: E30] " sr
       (
         "[bind_exe: fun_return ] return expression \n" ^
         sbe bsym_table e ^
@@ -619,6 +647,7 @@ print_endline ("Function return value has MINIMISED type " ^ sbt bsym_table t');
         "\ndoes not agree with the function return type:\n" ^ 
         sbt bsym_table state.ret_type
       )
+    end
 
   | EXE_yield e ->
     state.return_count <- state.return_count + 1;
@@ -658,10 +687,14 @@ print_endline ("Function return value has MINIMISED type " ^ sbt bsym_table t');
         sbt bsym_table t
       )
 
+  (* this instruction appears to be ONLY created by the desugaring
+     of a pattern match, it is similar to EXE_init, except the first
+     argument also contains the string name of the variable. It is used
+     to hold the evaluated match arument which this instruction assigns.
+     At present this code does NOT do the polymorphic variant subtyping
+     implicit coercion. I dont know if it should or not.
+  *)
   | EXE_iinit ((s,index),e) ->
-(*
-print_endline ("Bind EXE_iinit "^s);
-*)
       let e',rhst = be e in 
       (* a type variable in executable code just has to be of kind TYPE *)
       let parent_ts = map
@@ -737,7 +770,31 @@ print_endline ("Bind EXE_init "^s);
             print_endline ("Index = " ^ si index ^ " initexpr=" ^ sbe bsym_table (e',rhst) ^ " type of variable is " ^ sbt bsym_table rhst);
 *)
             [bexe]
-          end else clierrx "[flx_bind/flx_bind_bexe.ml:724: E35] " sr
+          end 
+        else begin match unfold "bind_exe_v2" rhst, unfold "bind_exe_v1" lhst with
+        | BTYP_variant ts, BTYP_variant rs ->
+          begin try List.iter (fun (name,t) ->
+             let r = List.assoc name rs in
+             if not (type_eq bsym_table state.counter r t) then raise Not_found
+          ) ts;
+    (*
+          print_endline ("Coercing init value");
+    *)
+          let bexe = bexe_init (sr,index,bexpr_coerce ((e',rhst), lhst)) in
+          [bexe]
+          with Not_found -> 
+          clierrx "[flx_bind/flx_bind_bexe.ml:782: E30A] " sr
+            (
+              "[bind_exe: init] initialising expression \n" ^
+              sbe bsym_table (e',rhst) ^
+              "\nof type\n" ^
+              sbt bsym_table rhst ^
+              "\nis not a supertype of the declared variable type:\n" ^ 
+              sbt bsym_table lhst 
+            )
+          end (* try *)
+        | _ ->
+          clierrx "[flx_bind/flx_bind_bexe.ml:793: E35] " sr
           (
             "[bind_exe: init] LHS[" ^ s ^ "<" ^ string_of_bid index ^ ">]:\n" ^
             sbt bsym_table lhst^
@@ -749,6 +806,7 @@ print_endline ("Bind EXE_init "^s);
             print_vs state.parent_vs
             else "")
           )
+        end (* variant check *)
       end
 
   | EXE_assign (l,r) ->
@@ -787,7 +845,30 @@ print_endline ("assign after beta-reduction: RHST = " ^ sbt bsym_table rhst);
 *)
       if type_match bsym_table state.counter lhst rhst
       then [(bexe_assign (sr,lx,rx))]
-      else clierrx "[flx_bind/flx_bind_bexe.ml:765: E36] " sr
+      else begin match unfold "bind_exe_v2" rhst, unfold "bind_exe_v1" lhst with
+      | BTYP_variant ts, BTYP_variant rs ->
+        begin try List.iter (fun (name,t) ->
+           let r = List.assoc name rs in
+           if not (type_eq bsym_table state.counter r t) then raise Not_found
+        ) ts;
+  (*
+        print_endline ("Coercing init value");
+  *)
+        let bexe = bexe_assign (sr,lx,bexpr_coerce (rx, lhst)) in
+        [bexe]
+        with Not_found -> 
+        clierrx "[flx_bind/flx_bind_bexe.ml:856: E30B] " sr
+          (
+            "[bind_exe: assign] RHS expression \n" ^
+            sbe bsym_table rx ^
+            "\nof type\n" ^
+            sbt bsym_table rhst ^
+            "\nis not a supertype of the LHS type:\n" ^ 
+            sbt bsym_table lhst 
+          )
+        end (* try *)
+      | _ ->
+      clierrx "[flx_bind/flx_bind_bexe.ml:867: E36] " sr
       (
         "[bind_exe: assign ] Assignment "^
           sbe bsym_table lx^"="^
@@ -797,6 +878,7 @@ print_endline ("assign after beta-reduction: RHST = " ^ sbt bsym_table rhst);
         "RHS type: " ^ sbt bsym_table rhst ^
         record_field_diag bsym_table lhst rhst
       )
+      end (* variant check *)
 
   | EXE_storeat (l,r) ->
     let _,lhst as lx = be l in

src/compiler/flx_bind/flx_cal_ret_type.ml

@@ -46,6 +46,10 @@ print_endline ("Cal ret type of " ^ id ^ "<" ^ string_of_int index ^ "> at " ^ F
 *)
     let rt = bind_type' state bsym_table env rs sr rt args mkenv in
     let rt = beta_reduce "flx_lookup: cal_ret_type" state.counter bsym_table sr rt in
+    let pvtype = match rt with BTYP_variant _ -> true | _ -> false in
+(*
+    if pvtype then print_endline (id ^ " has pv type " ^ sbt bsym_table rt);
+*)
     let ret_type = ref rt in
     let return_counter = ref 0 in
 (*
@@ -121,16 +125,19 @@ print_endline "Flx_lookup: about to check calculated and registered return type"
 print_endline ("Return type = " ^ Flx_btype.st !ret_type);
 print_endline ("Return expression type = " ^ Flx_btype.st t);
 *)
+        if pvtype then
+          () (* use the declared return type, let the coercion be inserted later *) 
+        else
         let result = Flx_do_unify.do_unify
-          state.counter
-          state.varmap
-          state.sym_table
-          bsym_table
-          !ret_type
-          t
+           state.counter
+           state.varmap
+           state.sym_table
+           bsym_table
+           !ret_type
+           t
           (* the argument order is crucial *)
         in 
-       if result then
+        if result then
           let t' = varmap_subst state.varmap !ret_type in
 (*
 print_endline (" %%%%% Setting return type to " ^ sbt bsym_table t');