theory Parser

imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp"

begin

atom_decl name

section{* Interface for nominal_datatype *}

text {*

Nominal-Datatype-part:

1nd Arg: (string list * binding * mixfix * (binding * typ list * mixfix) list) list

         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

               type(s) to be defined             constructors list

               (ty args, name, syn)              (name, typs, syn)

Binder-Function-part:

2rd Arg: (binding * typ option * mixfix) list 

         ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^    

            binding function(s)           

              to be defined               

            (name, type, syn)             

3th Arg:  term list 

          ^^^^^^^^^

          the equations of the binding functions

          (Trueprop equations)

*}

text {*****************************************************}

ML {* 

(* nominal datatype parser *)

local

  structure P = OuterParse

  fun tuple ((x, y, z), u) = (x, y, z, u)

in

val _ = OuterKeyword.keyword "bind"

val anno_typ = Scan.option (P.name --| P.$$$ "::") -- P.typ

(* binding specification *)

(* maybe use and_list *)

val bind_parser = 

val constr_parser =

  P.binding -- Scan.repeat anno_typ

(* datatype parser *)

val dt_parser =

(* function equation parser *)

val fun_parser = 

  Scan.optional (P.$$$ "binder" |-- P.fixes -- SpecParse.where_alt_specs) ([],[])

(* main parser *)

val main_parser =

  (P.and_list1 dt_parser) -- fun_parser >> P.triple2

end

*}

(* adds "_raw" to the end of constants and types *)

ML {*

fun add_raw s = s ^ "_raw"

fun add_raws ss = map add_raw ss

fun raw_bind bn = Binding.suffix_name "_raw" bn

fun replace_str ss s = 

  case (AList.lookup (op=) ss s) of 

     SOME s' => s'

   | NONE => s

fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts)

  | replace_typ ty_ss T = T  

fun raw_dts ty_ss dts =

let

  val ty_ss' = ty_ss ~~ (add_raws ty_ss)

  fun raw_dts_aux1 (bind, tys, mx) =

    (raw_bind bind, map (replace_typ ty_ss') tys, mx)

  fun raw_dts_aux2 (ty_args, bind, mx, constrs) =

    (ty_args, raw_bind bind, mx, map raw_dts_aux1 constrs)

in

  map raw_dts_aux2 dts

end

fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T)

  | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T)

  | replace_aterm trm_ss trm = trm

fun replace_term trm_ss ty_ss trm =

  trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) 

*}

ML {*

fun get_constrs dts =

  flat (map (fn (_, _, _, constrs) => constrs) dts)

fun get_typed_constrs dts =

  flat (map (fn (_, bn, _, constrs) => 

   (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts)

fun get_constr_strs dts =

  map (fn (bn, _, _) => Binding.name_of bn) (get_constrs dts)

fun get_bn_fun_strs bn_funs =

  map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs

*}

ML {*

fun raw_dts_decl dt_names dts lthy =

let

  val thy = ProofContext.theory_of lthy

  val conf = Datatype.default_config

  val dt_names' = add_raws dt_names

  val dt_full_names = map (Sign.full_bname thy) dt_names 

  val dts' = raw_dts dt_full_names dts

in

  lthy

  |> Local_Theory.theory_result (Datatype.add_datatype conf dt_names' dts')

end 

*}

ML {*

fun raw_bn_fun_decl dt_names dts bn_funs bn_eqs lthy =

let

  val thy = ProofContext.theory_of lthy

  val dt_names' = add_raws dt_names

  val dt_full_names = map (Sign.full_bname thy) dt_names 

  val dt_full_names' = map (Sign.full_bname thy) dt_names' 

  val dt_env = dt_full_names ~~ dt_full_names'

  val ctrs_names = map (Sign.full_bname thy) (get_constr_strs dts)

  val ctrs_names' = map (fn (x, y) => (Sign.full_bname_path thy (add_raw x) (add_raw y))) 

    (get_typed_constrs dts)

  val ctrs_env = ctrs_names ~~ ctrs_names'

  val bn_fun_strs = get_bn_fun_strs bn_funs

  val bn_fun_strs' = add_raws bn_fun_strs

  val bn_fun_env = bn_fun_strs ~~ bn_fun_strs'

  val bn_eqs' = map (fn trm => 

    (Attrib.empty_binding, replace_term (ctrs_env @ bn_fun_env) dt_env trm)) bn_eqs

in

  if null bn_eqs 

  then (([], []), lthy)

  else Primrec.add_primrec bn_funs' bn_eqs' lthy 

end 

*}

ML {* 

fun nominal_datatype2 dts bn_funs bn_eqs lthy =

let

  val dts_names = map (fn (_, s, _, _) => Binding.name_of s) dts

in

  lthy

  |> raw_dts_decl dts_names dts

  ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs

end

*}

ML {*

let

  (* makes a full named type out of a binding with tvars applied to it *)

  fun mk_type thy bind tvrs =

    Type (Sign.full_name thy bind, map (fn s => TVar ((s, 0), [])) tvrs)

  val dts' = map (fn (tvrs, tname, _, constrs) => (mk_type thy tname tvrs, constrs)) dts

in

  flat (map (fn (ty, constrs) => map (fn (bn, tys, mx) =>  (bn, tys ---> ty, mx)) constrs) dts')

end

*}

ML {*

fun nominal_datatype2_cmd (dt_strs, bn_fun_strs, bn_eq_strs) lthy =

let

  fun prep_typ (tvs, tname, mx, _) = (tname, length tvs, mx);

  (* adding the types for parsing datatypes *)

    |> Local_Theory.theory (Sign.add_types (map prep_typ dt_strs))

  (* parsing the datatypes *)

  (* adding constructors for parsing functions *)

in

end

*}

(* Command Keyword *)

ML {*

let

   val kind = OuterKeyword.thy_decl

in

   OuterSyntax.local_theory "nominal_datatype" "test" kind 

     (main_parser >> nominal_datatype2_cmd)

end

*}

end