Fix last bugged regression test

src/compiler/flx_bind/flx_bind_type.ml

@@ -337,7 +337,9 @@ print_endline ("\n+++++++++Bound recursive type is " ^ Flx_btype.st t^"\n\n");
         let fixdepth = outer_depth -rs.depth in
 (* HACK metatype guess : expressions generally ARE of kind TYPE, it just might be
 an over-generalisation *)
+(*
 print_endline ("Flx_bind_type. structural mode: TYP_typeof fixpoint metatype hack! Expression " ^ string_of_expr e);
+*)
         btyp_fix fixdepth (Flx_kind.KIND_type)
       end else begin
         let t = snd (bind_expression' state bsym_table env rs e []) in
@@ -529,13 +531,17 @@ print_endline ("Binding `TYP_name " ^s^ " via params to " ^ sbt bsym_table t);
      btyp_instancetype sr
 
   | `TYP_fname (sr, name, ks) ->
+(*
 print_endline ("Lookup type function name " ^ name ^ " unbound ks=" ^ Flx_util.catmap ", " Flx_print.str_of_kindcode ks);
+*)
     let hackname : qualified_name_t  = (`AST_name (sr, name, []) :> qualified_name_t) in
 (*
 print_endline ("Munged qualified name " ^ Flx_print.string_of_qualified_name hackname);
 *)
     let {base_sym=index; spec_vs=spec_vs; sub_ts=sub_ts} , ts = lookup_qn_in_env' state bsym_table env rs hackname in
+(*
 print_endline ("Found it " ^ name ^ "="^ string_of_int index);
+*)
     (* we have a problem now: we've found a view of the typefunction, this can happen
     if the type function is inside a polymorphic class which is opened. The substitution
     of ts in the view with the vs of the environment must be done, but it cannot be done
@@ -579,7 +585,9 @@ print_endline ("Bound ks = " ^ Flx_util.catmap ", " Flx_kind.sk ks);
       | _ -> assert false
     in 
     let t = btyp_finst (index, ks, dom, cod) in
+(*
     print_endline ("Bound reference " ^ Flx_btype.st t);
+*)
     t
 
   | `TYP_flookup _ ->

src/compiler/flx_bind/flx_bind_type_index.ml

@@ -115,7 +115,9 @@ print_endline ("Bind type index ts adjusted");
   if List.mem_assoc index rs.type_alias_fixlist
   then begin
     let mt = Flx_guess_meta_type.guess_meta_type state bsym_table bt index in
+(*
     print_endline ("Flx_bind_type_index: fixpoint, meta type calculated by guess_meta_type!"); 
+*)
     let fixated = btyp_fix ((List.assoc index rs.type_alias_fixlist)-rs.depth) mt in
     fixated
   end

src/compiler/flx_bind/flx_guess_meta_type.ml

@@ -175,7 +175,9 @@ let guess_meta_type state bsym_table bt index : kind =
     | SYMDEF_instance_type t
     | SYMDEF_type_function (_,t)  -> 
       let k = guess_metatype sr t in
+(*
       print_endline ("Guess meta type of type function... " ^ Flx_kind.sk k);
+*)
       k
 
     | SYMDEF_type_alias t  -> 

src/compiler/flx_bind/flx_lookup_qn_with_sig.ml

@@ -100,8 +100,10 @@ in
       | SYMDEF_cstruct _
       | SYMDEF_struct _ ->
         let sign = try List.hd signs with _ -> assert false in
+(*
         print_endline ("Lookup qn with sig' found a struct "^ id ^
         ", looking for constructor"); 
+*)
         (* this doesn't work, we need to do overload resolution to
            fix type variables
         let t = type_of_index_with_ts' state bsym_table rs sra index ts in

src/compiler/flx_core/flx_beta.ml

@@ -252,6 +252,7 @@ print_endline ("Beta reduce failed with Failure");
 (*
   print_endline ("============" ^ calltag^ "   reduced= " ^ sbt bsym_table t2 ^ "=" ^ Flx_btype.st t2);
 *)
+  let t2 = Flx_fold.minimise bsym_table counter t2 in
   t2
 
 and beta_reduce' calltag counter bsym_table sr depth (termlist: (Flx_btype.t * int) list) t =

src/compiler/flx_core/flx_type_fun.ml

@@ -100,6 +100,7 @@ Unfortunately this means the trail comparison must use alpha equivalance, not eq
 NOTE: alpha equiv is easy, we alph convert both terms using the SAME initial counter then 
 do normal comparison .. but I think maybe the type equality routine should do this.
 *)
+if not (Flx_btype.complete_type arg) then print_endline ("Type lambda argument is not complete! \n" ^ Flx_btype.st arg);
       let f = Flx_alpha.alpha_convert counter f in
       (* I think this is wrong but it is essential in some case if the argument
          must be a type tuple, and is actually an application that produces one.
@@ -125,6 +126,7 @@ do normal comparison .. but I think maybe the type equality routine should do th
               print_endline ("Flx_beta:"^calltag ^": Expected Argument to type function to be type tuple, got " ^ Flx_print.sbt bsym_table arg);
               Flx_exceptions.clierr sr ("Flx_beta:"^calltag ^": Expected Argument to type function to be type tuple, got " ^ Flx_print.sbt bsym_table arg)
         in
+if not (Flx_btype.complete_type body) then print_endline ("Type lambda body is not complete! \n" ^ Flx_btype.st body);
         let t' = list_subst counter params' body in
         let t' = beta_reduce' calltag counter bsym_table sr depth ((appl,depth)::termlist) t' in
         t'

src/compiler/flx_frontend/flx_build_tctab.ml

@@ -297,8 +297,8 @@ let check_instance
   inst_ts
 =
 (*
-if debug && inst_id = "X" then
-  print_endline ("Check instance " ^ inst_id ^ 
+if inst_id = "Str" && inst == 79372 then
+  print_endline ("Check instance " ^ inst_id ^ "<" ^ string_of_int inst ^ ">" ^ 
    ", vs = " ^ catmap "," (fun (s,j,k) -> s ^ "<" ^ string_of_int j ^ ">:" ^ Flx_kind.sk k) inst_vs ^ 
    ", inst_constraint=" ^ sbt bsym_table inst_constraint);
 *)
@@ -308,14 +308,14 @@ if debug && inst_id = "X" then
   match Flx_bsym.bbdcl tc_bsym with
   | BBDCL_typeclass (tc_props, tc_bvs) ->
 (*
-if debug && inst_id = "X" then
+if inst_id = "Str" && inst == 79372 then
 begin
     print_endline ("Found " ^ inst_id ^ "<"^si inst ^ ">" ^
     "[" ^ catmap "," (sbt bsym_table) inst_ts ^ "]" ^
     " to be instance of typeclass " ^ tc_id ^ "<"^si tc^">")
     ;
     print_endline ("Typeclass vs = " ^
-      catmap "," (fun (s,j) -> s^"<"^si j^">") tc_bvs
+      catmap "," (fun (s,j,knd) -> s^"<"^si j^">") tc_bvs
     );
 end;
 *)
@@ -338,7 +338,7 @@ end;
       with Not_found -> BidSet.empty
     in
 (*
-if debug && inst_id = "X" then 
+if inst_id = "Str" && inst == 79372 then
 begin
   print_string ("Typeclass has children " );
   BidSet.iter (fun i-> print_string (si i ^ ",")) tc_kids;
@@ -351,19 +351,20 @@ end;
       with Not_found -> BidSet.empty
     in
 (*
-if debug && inst_id = "X" then
+if inst_id = "Str" && inst == 79372 then
 begin
   print_string ("Instance has children ");
   BidSet.iter (fun i-> print_string (si i ^ ",")) inst_kids;
   print_endline "";
 end;
 *)
-(* transform the instance kid list into an associatiion list
+(* transform the instance kid list into an association list
   mapping the function name to the index and function type
 *)
     let inst_map = build_inst_map bsym_table inst_kids in
+
 (*
-if debug && inst_id = "X" then
+if inst_id = "Str" && inst == 79372 then
 begin
   print_endline ("Instance map for " ^ inst_id ^ "[" ^ catmap "," (sbt bsym_table) inst_ts ^ "]");
   List.iter (fun (name,(index,(bvs,typ))) ->
@@ -387,11 +388,12 @@ end;
 (* PASS 1, map virtual types to instance types *)
     BidSet.iter begin fun tck ->
       let tck_bsym = Flx_bsym_table.find bsym_table tck in
+(*
 if debug && inst_id = "X" then
 begin
   print_endline ("   type class child " ^ Flx_bsym.id tck_bsym);
 end;
-
+*)
       match Flx_bsym.bbdcl tck_bsym with
       | BBDCL_virtual_type bvs -> 
 (*
@@ -502,7 +504,7 @@ print_endline "BUILD TYPECLASS TO INSTANCE MAPPING";
 
     let inst_id = Flx_bsym.id bsym in
 (*
-    if debug && inst_id = "X" then
+    if inst_id = "Str" && i == 79372 then
     print_endline ("Typeclass: " ^ Flx_bsym.id bsym ^"<"^ si tc ^ "> instance " ^ si i );
 *)
       check_instance

src/compiler/flx_frontend/flx_shareinit.ml

@@ -570,7 +570,8 @@ end;
   (* Ignore non-function *)
   | _ -> ()
 
-let shareinit_bsym_table phase bsym_table counter = 
+let shareinit_bsym_table phase bsym_table counter = ()
+(*
   try
 (*
 print_endline "Doing share init";
@@ -583,4 +584,4 @@ print_endline "Doing share init";
   | exn ->
     print_endline ("ERROR in init share variable before use verification phase " ^ phase);
     raise exn
-
+*)

src/compiler/flx_frontend/flx_typeclass.ml

@@ -60,8 +60,9 @@ let tcinst_chk syms bsym_table id sr i (ts: Flx_btype.t list)
   ((inst_vs:Flx_kind.bvs_t), inst_constraint, inst_ts, j) 
  =
 (*
-print_endline ("TYPECLASS: " ^ id ^ 
-   ", vs = " ^ catmap "," (fun (s,j,k) -> s ^ "<" ^ string_of_int j ^ ">:" ^ Flx_kind.sk k) inst_vs ^ 
+if  id = "str" then 
+print_endline ("Inst " ^ string_of_int j ^" function: " ^ id ^ 
+   ", vs = " ^ catmap "," (fun (s,j',k) -> s ^ "<" ^ string_of_int j' ^ ">:" ^ Flx_kind.sk k) inst_vs ^ 
    ": inst_constraint = " ^ sbt bsym_table inst_constraint);
 *)
      if length inst_ts > length ts then
@@ -215,7 +216,7 @@ print_endline ("TYPECLASS(mgu found), constraint = " ^ sbt bsym_table con);
 let fixup_typeclass_instance' syms bsym_table sr i ts =
   let id = Flx_bsym.id (Flx_bsym_table.find bsym_table i) in
 (*
-if id="unsafe_get" then
+if id = "str" then
 print_endline ("Trying to instantiate virtual " ^ id ^ "<" ^ si i ^ ">[" ^ 
 catmap "," (sbt bsym_table) ts ^ "]");
 *)
@@ -243,7 +244,7 @@ if id="unsafe_get" then
 
   | Some entries ->
 (*
-if id="unsafe_get" then
+if id="str" then
 print_endline ("Found " ^ si (List.length entries) ^ " functions for virtual " ^ id ^"<"^si i^">");
 *)
   let parent,bsym = try Flx_bsym_table.find_with_parent bsym_table i with Not_found -> assert false in
@@ -267,7 +268,7 @@ print_endline ("Found " ^ si (List.length entries) ^ " functions for virtual " ^
      [] entries
   in
 (*
-if id="g" then
+if id="str" then
 print_endline ("Number of matches left is " ^ string_of_int (List.length entries));
 *)
   match entries with
@@ -424,14 +425,18 @@ let id x = x
 
 let tcsubst syms bsym_table sr i ts =
 (*
-if i = 14871 then
+if i = 17759 then
   print_endline ("tcsubst trying to instantiate " ^ si i ^ " with ts = " ^ catmap "," (sbt bsym_table) ts);
 *)
   let ts = List.map (Flx_remap_vtypes.remap_virtual_types syms bsym_table) ts in
   match fixup_typeclass_instance' syms bsym_table sr i ts with
   | `NonVirtual,i,ts->i,ts
-  | `MatchesNow,i,ts->
-     i,ts
+  | `MatchesNow,j,ts->
+(*
+if i = 17759 then
+print_endline ("Matches " ^ string_of_int j);
+*)
+     j,ts
   | `CannotMatch, i,ts ->
      let bsym = Flx_bsym_table.find bsym_table i in
      let id = Flx_bsym.id bsym in