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 |