src/HOL/Tools/BNF/bnf_gfp_rec_sugar.ML
changeset 59605 bd66d9b93a6b
parent 59604 b44f128d24f2
child 59606 28f53c1b3568
equal deleted inserted replaced
59604:b44f128d24f2 59605:bd66d9b93a6b
   655     val ctr_no' =
   655     val ctr_no' =
   656       if is_none disc' then the eq_ctr0 else find_index (curry (op =) (head_of (the disc'))) discs;
   656       if is_none disc' then the eq_ctr0 else find_index (curry (op =) (head_of (the disc'))) discs;
   657     val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
   657     val ctr_no = if not_disc then 1 - ctr_no' else ctr_no';
   658     val {ctr, disc, ...} = nth basic_ctr_specs ctr_no;
   658     val {ctr, disc, ...} = nth basic_ctr_specs ctr_no;
   659 
   659 
   660     val catch_all = (try (fst o dest_Free o the_single) prems0 = SOME Name.uu_);
   660     fun is_catch_all_prem (Free (s, _)) = s = Name.uu_
       
   661       | is_catch_all_prem _ = false;
       
   662 
       
   663     val catch_all =
       
   664       (case prems0 of
       
   665         [prem] => is_catch_all_prem prem
       
   666       | _ =>
       
   667         if exists is_catch_all_prem prems0 then error_at ctxt [concl] "Superfluous premises"
       
   668         else false);
   661     val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
   669     val matchedss = AList.lookup (op =) matchedsss fun_name |> the_default [];
   662     val prems = map (abstract (List.rev fun_args)) prems0;
   670     val prems = map (abstract (List.rev fun_args)) prems0;
   663     val actual_prems =
   671     val actual_prems =
   664       (if catch_all orelse sequential then maps s_not_conj matchedss else []) @
   672       (if catch_all orelse sequential then maps s_not_conj matchedss else []) @
   665       (if catch_all then [] else prems);
   673       (if catch_all then [] else prems);
   786     val head = concl
   794     val head = concl
   787       |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
   795       |> perhaps (try HOLogic.dest_not) |> perhaps (try (fst o HOLogic.dest_eq))
   788       |> head_of;
   796       |> head_of;
   789 
   797 
   790     val rhs_opt = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd);
   798     val rhs_opt = concl |> perhaps (try HOLogic.dest_not) |> try (HOLogic.dest_eq #> snd);
   791     val _ = is_none rhs_opt orelse not (can dest_funT (fastype_of (the rhs_opt))) orelse
   799 
   792       error_at ctxt [eqn] "Expected more arguments to function on left-hand side";
   800     fun check_num_args () =
       
   801       is_none rhs_opt orelse not (can dest_funT (fastype_of (the rhs_opt))) orelse
       
   802         error_at ctxt [eqn] "Expected more arguments to function on left-hand side";
   793 
   803 
   794     val discs = maps (map #disc) basic_ctr_specss;
   804     val discs = maps (map #disc) basic_ctr_specss;
   795     val sels = maps (maps #sels) basic_ctr_specss;
   805     val sels = maps (maps #sels) basic_ctr_specss;
   796     val ctrs = maps (map #ctr) basic_ctr_specss;
   806     val ctrs = maps (map #ctr) basic_ctr_specss;
   797   in
   807   in
   798     if member (op =) discs head orelse
   808     if member (op =) discs head orelse
   799        (is_some rhs_opt andalso
   809        (is_some rhs_opt andalso
   800         member (op =) (map SOME fun_names) (try (fst o dest_Free) head) andalso
   810         member (op =) (map SOME fun_names) (try (fst o dest_Free) head) andalso
   801         member (op =) (filter (null o binder_types o fastype_of) ctrs) (the rhs_opt)) then
   811         member (op =) (filter (null o binder_types o fastype_of) ctrs) (the rhs_opt)) then
   802       dissect_coeqn_disc ctxt fun_names sequentials basic_ctr_specss eqn_pos NONE NONE prems concl
   812       (check_num_args ();
   803         matchedsss
   813        dissect_coeqn_disc ctxt fun_names sequentials basic_ctr_specss eqn_pos NONE NONE prems concl
   804       |>> single
   814          matchedsss
       
   815        |>> single)
   805     else if member (op =) sels head then
   816     else if member (op =) sels head then
   806       (null prems orelse error_at ctxt [eqn] "Unexpected condition in selector formula";
   817       (null prems orelse error_at ctxt [eqn] "Unexpected condition in selector formula";
       
   818        check_num_args ();
   807        ([dissect_coeqn_sel ctxt fun_names basic_ctr_specss eqn_pos NONE NONE eqn0 of_spec_opt
   819        ([dissect_coeqn_sel ctxt fun_names basic_ctr_specss eqn_pos NONE NONE eqn0 of_spec_opt
   808            concl], matchedsss))
   820            concl], matchedsss))
   809     else if is_some rhs_opt andalso is_Free head andalso is_free_in fun_names head then
   821     else if is_some rhs_opt andalso is_Free head andalso is_free_in fun_names head then
   810       if member (op =) ctrs (head_of (unfold_lets_splits (the rhs_opt))) then
   822       if member (op =) ctrs (head_of (unfold_lets_splits (the rhs_opt))) then
   811         dissect_coeqn_ctr ctxt fun_names sequentials basic_ctr_specss eqn_pos eqn0
   823         (check_num_args ();
   812           (if null prems then
   824          dissect_coeqn_ctr ctxt fun_names sequentials basic_ctr_specss eqn_pos eqn0
   813              SOME (snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Logic.strip_assums_concl eqn0))))
   825            (if null prems then
   814            else
   826               SOME (snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Logic.strip_assums_concl eqn0))))
   815              NONE)
   827             else
   816           prems concl matchedsss
   828               NONE)
       
   829            prems concl matchedsss)
   817       else if null prems then
   830       else if null prems then
   818         dissect_coeqn_code ctxt has_call fun_names basic_ctr_specss eqn_pos eqn0 concl matchedsss
   831         (check_num_args ();
   819         |>> flat
   832          dissect_coeqn_code ctxt has_call fun_names basic_ctr_specss eqn_pos eqn0 concl matchedsss
       
   833          |>> flat)
   820       else
   834       else
   821         error_at ctxt [eqn] "Cannot mix constructor and code views"
   835         error_at ctxt [eqn] "Cannot mix constructor and code views"
   822     else if is_some rhs_opt then
   836     else if is_some rhs_opt then
   823       error_at ctxt [eqn] ("Unexpected equation head: " ^ quote (Syntax.string_of_term ctxt head))
   837       error_at ctxt [eqn] ("Unexpected equation head: " ^ quote (Syntax.string_of_term ctxt head))
   824     else
   838     else