(*---------------------------------------------------------------------------
 * Packaging principles of definition into one structure. As well, the
 * principle of constant definition does some pre-and-postprocessing so
 * that redefinition can happen in the current theory.
 *---------------------------------------------------------------------------*)
structure PoD :> PoD =
struct


open Exception Term Dsyntax Thm

type term   = Term.term
type thm    = Thm.thm
type fixity = Term.fixity;


fun PoD_ERR s1 s2 = HOL_ERR{origin_structure = "PoD",
                            origin_function = s1, message = s2};

fun newTypeDefinition s th =
  let val P = rator(#Body(dest_exists(concl th)))
  in Type_def.new_type_definition{name=s, pred=P, inhab_thm=th}
  end;


fun newSpecification s L th =
  Const_spec.new_specification
     {name=s, sat_thm=th,
      consts = map (fn (s,f) => {const_name=s, fixity=f}) L};


fun find_const tm = #1(strip_comb(#lhs(dest_eq(#2(strip_forall tm)))));
   
(*---------------------------------------------------------------------------
 * When we redefine a constant, we need to find the relevant definition
 * in the current theory, find the constant in it, hide the constant from
 * the parser, invoke the parser, unhide the constant. and finally, 
 * call Const_def.new_definition.
 *---------------------------------------------------------------------------*)
fun newDefinition q s f =
  case (Lib.assoc1 s (Theory.definitions ()))
  of NONE => Const_def.new_gen_definition
                 {name=s, def=Parse.term_parser q, fixity=f}
   | SOME(_,prev_def) =>
       let val c = find_const (concl prev_def)
           val {Name,...} = dest_const c
           val _ = Parse_support.hide Name
           val _ = Parse_support.hide ("$"^Name)
           val def' = Parse.term_parser q
           val _ = Parse_support.reveal Name
           val _ = Parse_support.reveal ("$"^Name)
       in 
        Const_def.new_gen_definition {name=s, def=def', fixity=f}
       end;


end;
