Split type functions off from type aliases.

src/compiler/flx_bind/flx_bbind.ml

@@ -323,6 +323,7 @@ with _ -> print_endline ("PARENT BINDING FAILED CONTINUING ANYHOW");
    * pure declarations of functions.
    *)
 
+  | SYMDEF_kindvar _ -> ()
   | SYMDEF_typevar _ -> ()
 
   (* the root module doesn't generate anything YET. After the complete 
@@ -804,6 +805,33 @@ print_endline (" &&&&&& SYMDEF_instance calling BBIND_SYMBOL");
     let t = bt t in
     add_bsym None (bbdcl_newtype (bvs, t))
 
+  | SYMDEF_type_function (ks,t) -> 
+(*
+print_endline ("Binding type function .. ");
+*)
+    if get_structural_typedefs state then begin 
+(*
+print_endline ("NOT **** Adding typefun " ^ sym.Flx_sym.id ^"<"^ si symbol_index ^ "> = " ^ Flx_print.string_of_typecode t ^ " to bsym_table");
+*)
+       () 
+    end else begin
+(*
+print_endline ("TRYING TO BIND typefun " ^ sym.Flx_sym.id ^"<"^ si symbol_index ^ "> = " ^ Flx_print.string_of_typecode t );
+*)
+    let t = 
+      try bt t 
+      with exn ->
+        print_endline ("BINDING typedef " ^ sym.Flx_sym.id ^"<"^ si symbol_index ^ "> = " ^ 
+          Flx_print.string_of_typecode t ^ "  FAILED with " ^ Printexc.to_string exn);
+        raise exn
+    in
+(*
+print_endline ("Adding typefun " ^ sym.Flx_sym.id ^"<"^ si symbol_index ^ "> = " ^ Flx_btype.st t ^ " to bsym_table");
+*)
+    add_bsym None (bbdcl_nominal_type_alias (bvs, t))
+   end
+
+
   | SYMDEF_type_alias t ->
 (*
 print_endline ("Binding type alias .. ");
@@ -908,29 +936,45 @@ print_endline ("\n====================\nSetting type aliases to nominal\n=======
 print_endline ("[flx_bbind] bind_symbol " ^ sym.Flx_sym.id ^ "??");
 *)
       begin match sym.Flx_sym.symdef with
+      | Flx_types.SYMDEF_type_function  (_,t) 
+      ->
+        begin try
+(*
+        print_endline ("Binding typefun " ^ sym.Flx_sym.id ^ "<"^string_of_int i^"> = " ^ string_of_typecode t);
+*)
+                begin try bbind_symbol state bsym_table_dummy i parent sym
+                with Not_found ->
+                  try match hfind "bbind" state.sym_table i with { Flx_sym.id=id } ->
+                    print_endline ("Binding error, Not_found thrown binding " ^ id ^ " index " ^
+                      string_of_bid i ^ " parent " ^ (match parent with | None -> "NONE" | Some p -> string_of_int p))
+                  with Not_found ->
+                    failwith ("Binding error, Not_found thrown binding unknown id with index " ^ string_of_bid i)
+                end
+        with _ -> ()
+        end
+
       | Flx_types.SYMDEF_type_alias  t
       ->
-begin try
-(*
-print_endline ("Binding typedef " ^ sym.Flx_sym.id ^ "<"^string_of_int i^"> = " ^ string_of_typecode t);
-*)
-        begin try bbind_symbol state bsym_table_dummy i parent sym
-        with Not_found ->
-          try match hfind "bbind" state.sym_table i with { Flx_sym.id=id } ->
-            print_endline ("Binding error, Not_found thrown binding " ^ id ^ " index " ^
-              string_of_bid i ^ " parent " ^ (match parent with | None -> "NONE" | Some p -> string_of_int p))
-          with Not_found ->
-            failwith ("Binding error, Not_found thrown binding unknown id with index " ^ string_of_bid i)
+        begin try
+(*
+        print_endline ("Binding typedef " ^ sym.Flx_sym.id ^ "<"^string_of_int i^"> = " ^ string_of_typecode t);
+*)
+                begin try bbind_symbol state bsym_table_dummy i parent sym
+                with Not_found ->
+                  try match hfind "bbind" state.sym_table i with { Flx_sym.id=id } ->
+                    print_endline ("Binding error, Not_found thrown binding " ^ id ^ " index " ^
+                      string_of_bid i ^ " parent " ^ (match parent with | None -> "NONE" | Some p -> string_of_int p))
+                  with Not_found ->
+                    failwith ("Binding error, Not_found thrown binding unknown id with index " ^ string_of_bid i)
+                end
+        with _ -> ()
         end
-with _ -> ()
-end
       | _ -> ()
       end
     end;
     incr counter
   done
   ;
-
 (*
   print_endline ("\n=====================\n TYPEDEFS before expansion\n=====================\n");
   Flx_bsym_table.iter (fun bid parent bsym ->
@@ -942,6 +986,7 @@ end
   ) bsym_table_dummy;  
   print_endline ("\n==========================================\n");
 *)
+
   Flx_bsym_table.iter (fun bid parent bsym ->
     let bbdcl = Flx_bsym.bbdcl bsym in
     let sr = Flx_bsym.sr bsym in
@@ -954,7 +999,6 @@ end
 
     | _ -> ()
   ) bsym_table_dummy;
-
 (*
   print_endline ("\n=====================\n TYPEDEFS after expansion\n=====================\n");
   Flx_bsym_table.iter (fun bid parent bsym ->
@@ -965,7 +1009,6 @@ end
     | _ -> ()
   ) bsym_table_dummy;  
 *)
-
 (*
   print_endline ("\n=====================\n VAR CACHE (function codomains) \n=====================\n");
   Hashtbl.iter (fun i t ->
@@ -1008,7 +1051,6 @@ end
 (*
   print_endline ("\n===================\nSetting type aliases to structura\n=======================\n");
 *)
-
   (* PASS 1, TYPE ONLY *)
   set_structural_typedefs state;
 
@@ -1029,7 +1071,6 @@ print_endline ("Fixing typeofs");
 (*
 print_endline ("Done fixing typeofs");
 *)
-
   let counter = ref start_counter in
   while !counter < !ref_counter do
     let i = !counter in

src/compiler/flx_bind/flx_bind_expression.ml

@@ -455,6 +455,8 @@ print_endline ("Bound tuple head " ^ sbe bsym_table x ^ " has type " ^ sbt bsym_
        | _ -> typ
     in
     let base = unfold "flx_lookup2" base in
+    let base = Flx_beta.beta_reduce "flx_bind_expression-xxx" state.counter bsym_table sr base in
+
     match base with
     | BTYP_array (t,BTYP_unitsum len)  ->
       let n = if n = -1 then n + len else n in

src/compiler/flx_bind/flx_bind_type_index.ml

@@ -162,6 +162,7 @@ print_endline ("flx_lookup: bind-type-index returning fixated " ^ sbt bsym_table
       );
     *)
     match entry with
+    | SYMDEF_kindvar _ -> assert false
     | SYMDEF_typevar mt ->
       (* HACK! We will assume metatype are entirely algebraic,
         that is, they cannot be named and referenced, we also
@@ -227,6 +228,40 @@ print_endline ("Flx_bind_type_index.Binding type variable " ^ si index ^ ", kind
       t
 
 
+    | SYMDEF_type_function (iks,t) -> 
+(*
+print_endline ("Bind type index, trying to bind type function " ^id ^ "<" ^string_of_int index ^ "> = " ^ string_of_typecode t);
+*)
+    begin try
+      let bsym = Flx_bsym_table.find bsym_table index in
+      let bbdcl = Flx_bsym.bbdcl bsym in
+      begin match bbdcl with
+      | BBDCL_structural_type_alias (bvs, alias) ->
+        let salias = Flx_btype_subst.tsubst sr bvs ts alias in
+(*
+        print_endline ("Bind type index: STRUCTURAL Unravelling type alias " ^ id ^ " index=" ^ si index ^ " to " ^ Flx_btype.st salias);
+*)
+        salias
+      | BBDCL_nominal_type_alias (bvs, alias) ->
+(*
+        print_endline ("Bind type index: NOMINAL bind type alias " ^ id ^ " index=" ^ si index ^ " to " ^ Flx_btype.st alias);
+*)
+        let k = Flx_btype_kind.metatype sr alias in
+        let t = btyp_inst (index,ts,k) in
+        t
+
+      | _ -> failwith ("Flx_bind_type expected type alias in bound symbol table " ^ id);
+      end
+    with Not_found ->
+      let k = Flx_guess_meta_type.guess_metatype sr t in
+print_endline ("Flx_bind_type_index: btyp_inst, meta type calculated by guess_metatype!"); 
+      let t = btyp_inst (index,ts,k) in 
+      print_endline ("Bind type index: INITIAL nominalising type alias " ^ id ^ 
+       " index=" ^ si index ^ " to " ^ Flx_btype.st t ^ ", kind=" ^ Flx_kind.sk k);
+      t
+    end
+
+
     | SYMDEF_type_alias t ->
 (*
 print_endline ("Bind type index, trying to bind " ^id ^ "<" ^string_of_int index ^ "> = " ^ string_of_typecode t);

src/compiler/flx_bind/flx_guess_meta_type.ml

@@ -143,6 +143,10 @@ let guess_meta_type state bsym_table bt index : kind =
   match data with { Flx_sym.id=id; sr=sr; vs=vs; dirs=dirs; symdef=entry } ->
     match entry with
     | SYMDEF_instance_type t
+    | SYMDEF_type_function (_,t)  -> 
+      print_endline ("Guess meta type of type function...");
+      guess_metatype sr t
+
     | SYMDEF_type_alias t  -> 
       guess_metatype sr t
     | _ -> print_endline ("Dunno, assume a type " ^ string_of_symdef entry id vs); assert false

src/compiler/flx_bind/flx_inner_type_of_index.ml

@@ -85,6 +85,14 @@ if index = 37461 then print_env env;
       failwith ("Woops inner_type_of_index found inherit fun!! " ^
         string_of_bid index)
   | SYMDEF_instance_type t
+  | SYMDEF_type_function (_,t) ->
+(*
+print_endline ("bind_type_index finds: Type alias name " ^ sym.Flx_sym.id);
+  NOTE: this routine is finding the type of a type, that is, a metatype,
+  its a bit of a hack!
+*)
+print_endline ("Inner type of index trying to calculate meta type of type function");
+assert false
   | SYMDEF_type_alias t ->
 (*
 print_endline ("bind_type_index finds: Type alias name " ^ sym.Flx_sym.id);

src/compiler/flx_bind/flx_lookup_name_itdws.ml

@@ -71,6 +71,10 @@ if debug then
 print_endline ("flx_lookup.handle_function.bexpr_closure");
       bexpr_closure t (index,ts)
 
+  | SYMDEF_type_function (_,t) ->
+    print_endline ("Flx_lookup_name_itdws: SYMDEF_type_function");
+    assert false
+
   | SYMDEF_type_alias (`TYP_typefun _) ->
       (* THIS IS A HACK .. WE KNOW THE TYPE IS NOT NEEDED BY THE CALLER .. *)
       let t = btyp_function (btyp_none (), btyp_none ()) in

src/compiler/flx_bind/flx_lookup_type_name_itdws.ml

@@ -48,6 +48,9 @@ print_endline ("Handle type " ^ name ^ " ... bound type is " ^ sbt bsym_table t)
 *)
       t
 
+  | SYMDEF_type_function _ -> assert false
+
+  | SYMDEF_type_function _ 
   | SYMDEF_type_alias _ ->
 (*
 print_endline ("Lookup_type_name_in_table_dirs_with_sig: Handle type alias " ^ name ^ " ... binding type index " ^ string_of_int index);
@@ -125,6 +128,8 @@ let lookup_type_name_in_table_dirs_with_sig
    and the check needed here is on kinds. The only real solution is
    a special lookup_type_function_name_itdws routine
 *)
+    | SYMDEF_kindvar _ -> assert false
+
     | SYMDEF_typevar mt ->
       let mt = bmt "lookup_type_name_itdws" mt in
 (*
@@ -164,6 +169,10 @@ let lookup_type_name_in_table_dirs_with_sig
     | SYMDEF_instance_type t ->
       Some (bt sr t)
 
+    | SYMDEF_type_function _ ->  
+      print_endline ("flx_lookup_type_name_itdws BUG");
+      assert false
+
     (* the effect of the binding depends on the mode for aliases, nominal or structural *)
     | SYMDEF_type_alias t -> 
 (*

src/compiler/flx_bind/flx_lookup_type_qn_with_sig.ml

@@ -269,6 +269,7 @@ print_endline "Found function entry";
 
         let sym = get_data state.sym_table index in
         begin match sym.Flx_sym.symdef with
+        | SYMDEF_type_function (_,(`TYP_typefun (args,ret,body) as tf))
         | SYMDEF_type_alias (`TYP_typefun (args,ret,body) as tf)->
           print_endline ("Got type function " ^ string_of_typecode body); 
           let btf = 

src/compiler/flx_bind/flx_sig_of_symdef.ml

@@ -71,6 +71,7 @@ let sig_of_symdef symdef sr name i : typecode_t * typecode_t * ((string * expr_t
 
   | SYMDEF_const_ctor (_,r,_,_) -> `TYP_void sr,r,None
   | SYMDEF_nonconst_ctor (_,r,_,_,t) -> t,r,None
+  | SYMDEF_type_function (_,t) 
   | SYMDEF_type_alias t ->
 (*
     print_endline ("[sig_of_symdef] Found a typedef " ^ name);

src/compiler/flx_bind/flx_symtab.ml

@@ -181,6 +181,23 @@ let full_add_typevar counter_ref sym_table sr table key value =
   with Not_found ->
     Hashtbl.add table key (NonFunctionEntry (mkentry counter_ref dfltivs value))
 
+let full_add_kindvar counter_ref sym_table sr table key value =
+  try
+    let entry = Hashtbl.find table key in
+    match entry with
+    | NonFunctionEntry (idx)
+    | FunctionEntry (idx :: _ ) ->
+        let sym = Flx_sym_table.find sym_table (Flx_typing.sye idx) in
+        Flx_exceptions.clierr2 sr sym.Flx_sym.sr (
+         "[build_tables] Duplicate non-function " ^ key ^ "<" ^
+         Flx_print.string_of_bid (Flx_typing.sye idx) ^ ">")
+
+    | FunctionEntry [] -> assert false
+  with Not_found ->
+    Hashtbl.add table key (NonFunctionEntry (mkentry counter_ref dfltivs value))
+
+
+
 
 let full_add_function counter_ref sym_table sr (vs:ivs_list_t) table key value =
 (*
@@ -246,6 +263,15 @@ Flx_print.string_of_tcon con);
   in
   ivs, con
 
+let make_iks ?(print=false) level counter_ref (ks: ks_list_t):iks_list_t = 
+  List.map (fun (kid,srt) ->
+    let n = fresh_bid counter_ref in
+    if print then
+      print_endline ("//  " ^ Flx_util.spaces level ^
+        Flx_print.string_of_bid n ^ " -> " ^ kid ^ 
+        " (kind variable) sort =" ^ Flx_print.str_of_sortcode srt);
+    kid,n,srt
+  ) ks
 
 (* this routine takes a partially filled unbound definition table,
   'sym_table' and a counter 'counter', and adds entries to the table
@@ -384,6 +410,7 @@ and build_table_for_dcl
   (* Make some shorthand functions *)
   let spc = Flx_util.spaces level in
   let make_ivs = make_ivs ~print:print_flag level counter_ref in
+  let make_iks = make_iks ~print:print_flag level counter_ref in
 
   if print_flag then
     print_endline (Flx_print.string_of_dcl level id seq vs dcl);
@@ -543,6 +570,16 @@ print_endline ("Adding type variable 7141!");
   in
   let add_tvars table = add_tvars' (Some symbol_index) table ivs in
 
+  let add_kvars' parent table (iks: iks_list_t) =
+    List.iter begin fun (kvid, index, srt) ->
+      let mt = srt in
+      (* Add the type variable to the symbol table. *)
+      add_symbol ~ivs:dfltivs index kvid sr (SYMDEF_kindvar mt);
+      full_add_kindvar counter_ref sym_table sr table kvid index;
+    end iks
+  in
+  let add_kvars table ks = add_kvars' (Some symbol_index) table ks in
+
   (* adds parameter to symbol table and lookup table as side effect
      returning original parameter
   *)
@@ -1202,6 +1239,22 @@ print_endline ("Has vs = " ^ string_of_bool (not has_novs));
       (* Add the type variables to the private symbol table. *)
       add_tvars privtab
 
+  | DCL_type_function (ks,t) ->
+(*
+print_endline ("Flx_symtab: add DCL_type_function " ^ id ^ "<" ^ string_of_int symbol_index^ ">["^Flx_print.string_of_ks ks^"] type=" ^ Flx_print.string_of_typecode t); 
+*)
+      let iks = make_iks ks in
+
+      (* Add the type alias to the sym_table. *)
+      add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_type_function (iks,t));
+
+      if access = `Public then add_unique pub_name_map id symbol_index;
+      add_unique priv_name_map id symbol_index;
+
+      (* Add the kind variables to the private symbol table. *)
+      add_kvars privtab iks
+
+
   | DCL_inherit qn ->
       (* Add the inherited typeclass to the dnfs. *)
       add_symbol ~pubtab ~privtab symbol_index id sr (SYMDEF_inherit qn);