(* $Id: deepcheck.ml,v 1.5 1999/12/16 16:30:57 freek Exp $ *)

open Pfedit
open Names
open Trad
open Mach
open Pp
open Printer
open Vernacinterp
open Std
open Term
open Generic
open Impuniv
open Ast

let print_section_path p =
  (* [< 'sTR "#\"" ; print_id (basename p) ; 'sTR "\"" >] *)
  [< 'sTR "\"" ; 'sTR (string_of_path p) ; 'sTR "\"" >]

let print_name = function
    Name i -> [< 'sTR "\"" ; print_id i ; 'sTR "\"" >]
  | Anonymous -> [< 'sTR "_" >]

let rec print_int_list = function
    [ ] -> [< >]
  | [ n ] -> [< 'iNT n >]
  | m :: (n :: a) -> [< 'iNT m ; 'sTR "," ; print_int_list (n :: a) >]

let rec print_ast_list = function
    [ ] -> [< >]
  | [ n ] -> [< print_ast n >]
  | m :: (n :: a) -> [< print_ast m ; 'sTR "," ; 'bRK(0, 0) ;
			print_ast_list (n :: a) >]

let print_oper = function
    Meta n -> [< 'sTR "Meta{" ; 'iNT n ; 'sTR "}" >]
  | XTRA(s, a) ->
      hOV 1
	[< 'sTR "XTRA{\"" ; 'sTR s ; 'sTR "\"," ; 'bRK(0, 0) ;
	   print_ast_list a ; 'sTR "}" >]
  | Sort (Prop Pos) -> [< 'sTR "Sort{Set}" >]
  | Sort (Prop Null) -> [< 'sTR "Sort{Prop}" >]
  | Sort (Type u) ->
      hOV 1
	[< 'sTR "Sort{Type{" ; 
	   print_section_path u.u_sp ; 'sTR "," ; 'bRK(0, 0) ;
	   'iNT u.u_num ; 'sTR "}}" >]
  | Implicit -> [< 'sTR "Implicit" >]
  | Cast -> [< 'sTR "Cast" >]
  | Prod -> [< 'sTR "Prod" >]
  | Lambda -> [< 'sTR "Lambda" >]
  | AppL -> [< 'sTR "AppL" >]
  | Const p -> [< 'sTR "Const{" ; print_section_path p ; 'sTR "}" >]
  | Abst p -> [< 'sTR "Abst{" ; print_section_path p ; 'sTR "}" >]
  | MutInd(p, n) ->
      hOV 1
	[< 'sTR "MutInd{" ; print_section_path p ; 'sTR "," ; 'bRK(0, 0) ;
	     'iNT n ; 'sTR "}" >]
  | MutConstruct((p, m), n) ->
      hOV 1
	[< 'sTR "MutConstruct{" ;
	   print_section_path p ; 'sTR "," ; 'bRK(0, 0) ;
	   'iNT m ; 'sTR "," ; 'bRK(0, 0) ; 'iNT n ; 'sTR "}" >]
  | MutCase (Some (p, n)) ->
      hOV 1
	[< 'sTR "MutCase{" ; print_section_path p ; 'sTR "," ; 'bRK(0, 0) ;
	   'iNT n ; 'sTR "}" >]
  | MutCase (None) -> [< 'sTR "MutCase" >]
  | Fix(a, n) ->
      hOV 1
	[< 'sTR "Fix{" ;
	   print_int_list (Array.to_list a) ; 'sTR "," ; 'bRK(0, 0) ;
	   'iNT n ; 'sTR "}" >]
  | CoFix n -> [< 'sTR "CoFix{" ; 'iNT n ; 'sTR "}" >]

let rec print_constr_list_inner x = function
    [ ] -> [< >]
  | [ t ] -> [< print_constr t >]
  | t :: (u :: a) ->
      [< print_constr t ; x ; print_constr_list_inner x (u :: a) >]

and print_constr_list = function
    [ ] -> [< >]
  | a -> [< 'sTR "{" ;
	    print_constr_list_inner [< 'sTR "," ; 'bRK(0, 0) >] a ;
	    'sTR "}" >]

and print_constr_array a = print_constr_list (Array.to_list a) 

and print_constr = function

    DOPN(Const p, [| |]) ->
      [< print_id (basename p) >]
      (* [< 'sTR (string_of_path p) >] *)
      
  | DOPN(AppL, a) ->
      hOV 1 [< 'sTR "(" ;
	       print_constr_list_inner [< 'bRK(1, 0) >] (Array.to_list a) ;
	       'sTR ")" >]

  | DOP0 t -> [< 'sTR "<" ; print_oper t ; 'sTR ">" >]
  | DOP1(t, u) ->
      [< 'sTR "<" ; print_oper t ; 'sTR ">{" ; print_constr u ; 'sTR "}">]
  | DOP2(t, u, v) ->
      hOV 1
	[< 'sTR "<" ; print_oper t ; 'sTR ">{" ;
	   print_constr u ; 'sTR "," ; 'bRK(0, 0) ;
	   print_constr v ; 'sTR "}" >]
  | DOPN(t, a) ->
      [< 'sTR "<" ; print_oper t ; 'sTR ">'" ; print_constr_array a >]
  | DOPL(t, a) ->
      [< 'sTR "<" ; print_oper t ; 'sTR ">''" ; print_constr_list a >]
  | DLAM(n, t) ->
      [< 'sTR "[" ; print_name n ; 'sTR "]{" ; print_constr t ; 'sTR "}" >]
  | DLAMV(n, a) ->
      [< 'sTR "[" ; print_name n ; 'sTR "]'" ; print_constr_array a >]
  | VAR i -> [< 'sTR "\"" ; print_id i ; 'sTR "\"" >]
  | Rel n -> [< 'sTR "$" ; 'iNT n >]

let deepcheck (a : CoqAst.t) =
  let (ev, si) = get_evmap_sign None in
  let t = (constr_of_com ev si a) in
  let tt = (type_of ev si t) in
    (mSG [<
       prterm t ; 'fNL ;
       print_constr t ; 'fNL ;
       'sTR "     : "; prterm tt ; 'fNL ;
       'sTR "     : "; print_constr tt ; 'fNL
	 >])

let _ =
  vinterp_add
    ("DeepCheck",
     function [VARG_COMMAND c] -> (fun () -> deepcheck c)
       | _ -> anomaly "DeepCheck")


