src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML
changeset 59873 2d929c178283
parent 59859 f9d1442c70f3
child 59936 b8ffc3dc9e24
equal deleted inserted replaced
59872:db4000b71fdb 59873:2d929c178283
   962     val bad = fold (add_extra_frees ctxt [] []) corec_args [];
   962     val bad = fold (add_extra_frees ctxt [] []) corec_args [];
   963     val _ = null bad orelse
   963     val _ = null bad orelse
   964       (if exists has_call corec_args then nonprimitive_corec ctxt []
   964       (if exists has_call corec_args then nonprimitive_corec ctxt []
   965        else extra_variable ctxt [] (hd bad));
   965        else extra_variable ctxt [] (hd bad));
   966 
   966 
   967     fun currys [] t = t
       
   968       | currys Ts t = t $ mk_tuple1_balanced (List.rev Ts) (map Bound (length Ts - 1 downto 0))
       
   969           |> fold_rev (Term.abs o pair Name.uu) Ts;
       
   970 
       
   971     val excludess' =
   967     val excludess' =
   972       disc_eqnss
   968       disc_eqnss
   973       |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
   969       |> map (map (fn x => (#fun_args x, #ctr_no x, #prems x, #auto_gen x))
   974         #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
   970         #> fst o (fn xs => fold_map (fn x => fn ys => ((x, ys), ys @ [x])) xs [])
   975         #> maps (uncurry (map o pair)
   971         #> maps (uncurry (map o pair)
   978             ||> map_prod (map HOLogic.mk_Trueprop) HOLogic.mk_Trueprop
   974             ||> map_prod (map HOLogic.mk_Trueprop) HOLogic.mk_Trueprop
   979             ||> Logic.list_implies
   975             ||> Logic.list_implies
   980             ||> curry Logic.list_all (map dest_Free fun_args))));
   976             ||> curry Logic.list_all (map dest_Free fun_args))));
   981   in
   977   in
   982     map (Term.list_comb o rpair corec_args) corecs
   978     map (Term.list_comb o rpair corec_args) corecs
   983     |> map2 (fn Ts => fn t => if length Ts = 0 then t $ HOLogic.unit else t) arg_Tss
   979     |> map2 abs_curried_balanced arg_Tss
   984     |> map2 currys arg_Tss
       
   985     |> (fn ts => Syntax.check_terms ctxt ts
   980     |> (fn ts => Syntax.check_terms ctxt ts
   986       handle ERROR _ => nonprimitive_corec ctxt [])
   981       handle ERROR _ => nonprimitive_corec ctxt [])
   987     |> @{map 3} (fn b => fn mx => fn t => ((b, mx), ((Binding.concealed (Thm.def_binding b), []), t)))
   982     |> @{map 3} (fn b => fn mx => fn t => ((b, mx), ((Binding.concealed (Thm.def_binding b), []), t)))
   988       bs mxs
   983       bs mxs
   989     |> rpair excludess'
   984     |> rpair excludess'