src/Pure/Tools/codegen_consts.ML

added concept for term constructors

(*  Title:      Pure/Tools/codegen_consts.ML
    ID:         $Id$
    Author:     Florian Haftmann, TU Muenchen

Identifying constants by name plus normalized type instantantiation schemes.
Convenient data structures for constants.  Auxiliary.
*)

signature CODEGEN_CONSTS =
sig
  type const = string * typ list (*type instantiations*)
  val const_ord: const * const -> order
  val eq_const: const * const -> bool
  structure Consttab: TABLE
  val inst_of_typ: theory -> string * typ -> const
  val typ_of_inst: theory -> const -> string * typ
  val norm: theory -> const -> const
  val norm_of_typ: theory -> string * typ -> const
  val typ_sort_inst: Sorts.algebra -> typ * sort
    -> sort Vartab.table -> sort Vartab.table
  val typargs: theory -> string * typ -> typ list
  val co_of_const: theory -> const
    -> string * ((string * sort) list * (string * typ list))
  val co_of_const': theory -> const
    -> (string * ((string * sort) list * (string * typ list))) option
  val cos_of_consts: theory -> const list
    -> string * ((string * sort) list * (string * typ list) list)
  val const_of_co: theory -> string -> (string * sort) list
    -> string * typ list -> const
  val consts_of_cos: theory -> string -> (string * sort) list
    -> (string * typ list) list -> const list
  val find_def: theory -> const -> (string (*theory name*) * thm) option
  val consts_of: theory -> term -> const list
  val read_const: theory -> string -> const
  val string_of_const: theory -> const -> string
  val raw_string_of_const: const -> string
  val string_of_const_typ: theory -> string * typ -> string
  val string_of_typ: theory -> typ -> string
end;

structure CodegenConsts: CODEGEN_CONSTS =
struct


(* basic data structures *)

type const = string * typ list (*type instantiations*);
val const_ord = prod_ord fast_string_ord (list_ord Term.typ_ord);
val eq_const = is_equal o const_ord;

structure Consttab =
  TableFun(
    type key = string * typ list;
    val ord = const_ord;
  );


(* type instantiations, overloading, dictionary values *)

fun string_of_typ thy = setmp show_sorts true (Sign.string_of_typ thy);

fun inst_of_typ thy (c_ty as (c, ty)) =
  (c, Sign.const_typargs thy c_ty);

fun typ_of_inst thy (c_tys as (c, tys)) =
  (c, Sign.const_instance thy c_tys);

fun find_def thy (c, tys) =
  let
    val specs = Defs.specifications_of (Theory.defs_of thy) c;
    val typ_instance = case AxClass.class_of_param thy c
     of SOME _ => let
          fun instance_tycos (Type (tyco1, _), Type (tyco2, _)) = tyco1 = tyco2
            | instance_tycos (_ , TVar _) = true
            | instance_tycos ty_ty = Sign.typ_instance thy ty_ty;
        in instance_tycos end
      | NONE =>  Sign.typ_instance thy;
    fun get_def (_, { is_def, thyname, name, lhs, rhs }) =
      if is_def andalso forall typ_instance (tys ~~ lhs) then
        case try (Thm.get_axiom_i thy) name
         of SOME thm => SOME (thyname, thm)
          | NONE => NONE
      else NONE
  in
    get_first get_def specs
  end;

fun norm thy (c, insts) =
  let
    fun disciplined class [ty as Type (tyco, _)] =
          let
            val sorts = Sorts.mg_domain (Sign.classes_of thy) tyco [class]
              handle CLASS_ERROR => error ("No such instance: " ^ tyco ^ " :: " ^ class
                ^ ",\nrequired for overloaded constant " ^ c);
            val vs = Name.invents Name.context "'a" (length sorts);
          in
            (c, [Type (tyco, map (fn v => TVar ((v, 0), [])) vs)])
          end
      | disciplined class _ =
          (c, [TVar (("'a", 0), [class])]);
  in case AxClass.class_of_param thy c
   of SOME class => disciplined class insts
    | NONE => inst_of_typ thy (c, Sign.the_const_type thy c)
  end;

fun norm_of_typ thy (c, ty) =
  norm thy (c, Sign.const_typargs thy (c, ty));

fun consts_of thy t =
  fold_aterms (fn Const c => cons (norm_of_typ thy c) | _ => I) t []

fun typ_sort_inst algebra =
  let
    val inters = Sorts.inter_sort algebra;
    fun match _ [] = I
      | match (TVar (v, S)) S' = Vartab.map_default (v, []) (fn S'' => inters (S, inters (S', S'')))
      | match (Type (a, Ts)) S =
          fold2 match Ts (Sorts.mg_domain algebra a S)
  in uncurry match end;

fun typargs thy (c_ty as (c, ty)) =
  let
    val opt_class = AxClass.class_of_param thy c;
    val tys = Sign.const_typargs thy (c, ty);
  in case (opt_class, tys)
   of (SOME _, [Type (_, tys')]) => tys'
    | _ => tys
  end;


(* printing *)

fun string_of_const thy (c, tys) =
  space_implode " " (Sign.extern_const thy c
    :: map (enclose "[" "]" o Sign.string_of_typ thy) tys);

fun raw_string_of_const (c, tys) =
  space_implode " " (c
    :: map (enclose "[" "]" o Display.raw_string_of_typ) tys);

fun string_of_const_typ thy (c, ty) =
  string_of_const thy (c, Consts.typargs (Sign.consts_of thy) (c, ty));


(* conversion between constants and datatype constructors *)

fun const_of_co thy tyco vs (co, tys) =
  norm_of_typ thy (co, tys ---> Type (tyco, map TFree vs));

fun consts_of_cos thy tyco vs cos =
  let
    val dty = Type (tyco, map TFree vs);
    fun mk_co (co, tys) = norm_of_typ thy (co, tys ---> dty);
  in map mk_co cos end;

local

exception BAD of string;

fun gen_co_of_const thy const =
  let
    val (c, ty) = (apsnd Logic.unvarifyT o typ_of_inst thy) const;
    fun err () = raise BAD
     ("Illegal type for datatype constructor: " ^ Sign.string_of_typ thy ty);
    val (tys, ty') = strip_type ty;
    val (tyco, vs) = ((apsnd o map) dest_TFree o dest_Type) ty'
      handle TYPE _ => err ();
    val sorts = if has_duplicates (eq_fst op =) vs then err ()
      else map snd vs;
    val vs_names = Name.invent_list [] "'a" (length vs);
    val vs_map = map fst vs ~~ vs_names;
    val vs' = vs_names ~~ sorts;
    val tys' = (map o map_type_tfree) (fn (v, sort) =>
      (TFree ((the o AList.lookup (op =) vs_map) v, sort))) tys
      handle Option => err ();
  in (tyco, (vs', (c, tys'))) end;

in

fun co_of_const thy const = gen_co_of_const thy const handle BAD msg => error msg;
fun co_of_const' thy const = SOME (gen_co_of_const thy const) handle BAD msg => NONE;

end;

fun cos_of_consts thy consts =
  let
    val raw_cos  = map (co_of_const thy) consts;
    val (tyco, (vs_names, sorts_cos)) = if (length o distinct (eq_fst op =)) raw_cos = 1
      then ((fst o hd) raw_cos, ((map fst o fst o snd o hd) raw_cos,
        map ((apfst o map) snd o snd) raw_cos))
      else error ("Term constructors not referring to the same type: "
        ^ commas (map (string_of_const thy) consts));
    val sorts = foldr1 ((uncurry o map2 o curry o Sorts.inter_sort) (Sign.classes_of thy))
      (map fst sorts_cos);
    val cos = map snd sorts_cos;
    val vs = vs_names ~~ sorts;
  in (tyco, (vs, cos)) end;


(* reading constants as terms *)

fun read_const_typ thy raw_t =
  let
    val t = Sign.read_term thy raw_t
  in case try dest_Const t
   of SOME c_ty => (typ_of_inst thy o norm_of_typ thy) c_ty
    | NONE => error ("Not a constant: " ^ Sign.string_of_term thy t)
  end;

fun read_const thy =
  norm_of_typ thy o read_const_typ thy;


end;