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)

*}

ML {*

*}

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

ML {* 

(* nominal datatype parser *)

local

  structure P = OuterParse

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

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

in

val _ = OuterKeyword.keyword "bind"

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

(* binding specification *)

(* maybe use and_list *)

val bind_parser = 

  P.enum "," ((P.$$$ "bind" |-- P.term) -- (P.$$$ "in" |-- P.name) >> swap)

val constr_parser =

  P.binding -- Scan.repeat anno_typ

(* datatype parser *)

val dt_parser =

  (P.type_args -- P.binding -- P.opt_mixfix >> P.triple1) -- 

    (P.$$$ "=" |-- P.enum1 "|" (constr_parser -- bind_parser -- P.opt_mixfix >> tswap)) >> tuple

(* 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

  fun raw_dts_aux1 (bind, 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 {*

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

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

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

fun get_bn_fun_strs bn_funs =

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

*}

ML {*

let

  val raw_dt_names = add_raws dt_names

in

  (raw_dt_names, raw_dts)

end 

*}

ML {*

let

  val thy = ProofContext.theory_of lthy

  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'

in

end

*}

ML {* 

(* parsing the datatypes and declaring *)

(* constructors in the local theory    *)

fun prepare_dts dt_strs lthy = 

let

  val thy = ProofContext.theory_of lthy

  fun mk_type full_tname tvrs =

    Type (full_tname, map (fn a => TVar ((a, 0), [])) tvrs)

  fun prep_cnstr lthy full_tname tvs (cname, anno_tys, mx, _) =

  let

    val tys = map (Syntax.read_typ lthy o snd) anno_tys

    val ty = mk_type full_tname tvs

  in

    ((cname, tys ---> ty, mx), (cname, tys, mx))

  end

  fun prep_dt lthy (tvs, tname, mx, cnstrs) = 

  let

    val full_tname = Sign.full_name thy tname

    val (cnstrs', cnstrs'') = 

      split_list (map (prep_cnstr lthy full_tname tvs) cnstrs)

  in

    (cnstrs', (tvs, tname, mx, cnstrs''))

  end 

  val (cnstrs, dts) = 

    split_list (map (prep_dt lthy) dt_strs)

in

  lthy

  |> Local_Theory.theory (Sign.add_consts_i (flat cnstrs))

  |> pair dts

end

*}

ML {*

(* parsing the binding function specification and *)

(* declaring the functions in the local theory    *)

fun prepare_bn_funs bn_fun_strs bn_eq_strs lthy =

let

  fun prep_bn_fun ((bn, T), mx) = (bn, T, mx) 

  val ((bn_funs, bn_eqs), _) = 

    Specification.read_spec bn_fun_strs bn_eq_strs lthy

  val bn_funs' = map prep_bn_fun bn_funs

in

  lthy

  |> Local_Theory.theory (Sign.add_consts_i bn_funs')

  |> pair (bn_funs', bn_eqs) 

end 

*}

ML {*

fun forth (_, _, _, x) = x

fun find_all eq xs k' = 

  maps (fn (k, v) => if eq (k, k') then [v] else []) xs

*}

ML {*

(* associates every SOME with the index in the list *)

fun mk_env xs =

  let

    fun mapp (_: int) [] = []

      | mapp i (a :: xs) = 

         case a of

           NONE => mapp (i + 1) xs

         | SOME x => (x, i) :: mapp (i + 1) xs

  in mapp 0 xs end

*}

ML {*

fun env_lookup xs x =

  case AList.lookup (op =) xs x of

    SOME x => x

  | NONE => error ("cannot find " ^ x ^ " in the binding specification.");

*}

ML {*

fun prepare_binds dt_strs lthy = 

let

  fun extract_annos_binds dt_strs =

    map ((map (fn (_, antys, _, bns) => (map fst antys, bns))) o forth) dt_strs

  fun prep_bn env bn_str =

    case (Syntax.read_term lthy bn_str) of

       Free (x, _) => (env_lookup env x, NONE)

     | Const (a, T) $ Free (x, _) => (env_lookup env x, SOME (Const (a, T)))

     | _ => error (bn_str ^ " not allowed as binding specification.");  

  fun prep_typ env opt_name = 

    case opt_name of

      NONE => []

    | SOME x => find_all (op=) env x;

  (* annos - list of annotation for each type (either NONE or SOME fo a type *)

  fun prep_binds (annos, bind_strs) = 

  let

    val env = mk_env annos (* for ever label the index *)

    val binds = map (fn (x, y) => (x, prep_bn env y)) bind_strs  

  in

    map (prep_typ binds) annos

  end

in

  map (map prep_binds) (extract_annos_binds dt_strs)

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)

  val ((dts, (bn_fun, bn_eq)), binds) = 

    lthy 

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

    |> prepare_dts dt_strs

    ||>> prepare_bn_funs bn_fun_strs bn_eq_strs

    ||> prepare_binds dt_strs

in

  nominal_datatype2 dts bn_fun bn_eq binds lthy |> snd

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