ENHANCED: Improve 'sweeprolog-extract-region-to-predicate'

Teach 'sweeprolog-extract-region-to-predicate' about existentially
quantified goals and lambda terms.

* sweep.pl (sweep_term_variable_names/2): Remove from export list.
* sweep.pl (sweep_extract_goal/2): New public predicate.
* sweeprolog.el (sweeprolog-extract-region-to-predicate): Use it.
* sweeprolog-tests.el: Test it.
* sweep.texi (Extract Goal): Update documentation.

diff --git a/sweep.pl b/sweep.pl
index 6fbf5d7fddc2fcfe7a834a75cee01b885a55e88b..f1129f467496af4b870a17581fb4fa2dbeec33bb 100644 (file)
--- a/sweep.pl
+++ b/sweep.pl
@@ -93,12 +93,12 @@
             sweep_head_functors_collection/2,
             sweep_functors_collection/2,
             sweep_compound_functors_collection/2,
-            sweep_term_variable_names/2,
             sweep_goal_may_cut/2,
             sweep_top_level_start_pty/2,
             sweep_cleanup_threads/2,
             sweep_kill_thread/2,
-            sweep_list_threads/2
+            sweep_list_threads/2,
+            sweep_extract_goal/2
           ]).
 
 :- use_module(library(pldoc)).
@@ -1670,7 +1670,7 @@ sweep_variable_start_code(C, _) :- code_type(C, prolog_var_start).
 
 sweep_term_variable_names(String, Names) :-
     term_string(_, String, [variable_names(VarNames)]),
-    maplist([Atom=_,Name]>>atom_string(Atom, Name), VarNames, Names).
+    maplist([Atom=_,Atom]>>true, VarNames, Names).
 
 sweep_goal_may_cut(String, _) :-
     term_string(Goal, String),
@@ -1693,3 +1693,316 @@ sweep_goal_may_cut_(!) =>
     true.
 sweep_goal_may_cut_(_) =>
     false.
+
+strip_parens(parentheses_term_position(_,_,Pos0), Pos, _, Pri) :-
+    !,
+    strip_parens(Pos0, Pos, 1200, Pri).
+strip_parens(Pos, Pos, Pri, Pri).
+
+clause_body_pos_neck(C,P0,B,BP,N,R) :-
+    strip_parens(P0,P,1199,R),
+    clause_body_pos_neck_(C,P,B,BP,N).
+
+clause_body_pos_neck_((:-B), term_position(_,_,_,_,[BP]), B, BP,0) :- !.
+clause_body_pos_neck_((_:-B), term_position(_,_,_,_,[_,BP]), B, BP,0) :- !.
+clause_body_pos_neck_((_=>B), term_position(_,_,_,_,[_,BP]), B, BP,0) :- !.
+clause_body_pos_neck_((_-->B), term_position(_,_,_,_,[_,BP]), B, BP,//).
+
+sweep_extract_goal([ClauseString,GoalBeg,GoalEnd,Functor0,FileName0],
+                   [Call,Head,Neck,Body,Safe,Functor,Arity,Exists]) :-
+    Result = result(Call, Head, Body, Safe, Arity, Neck, Exists),
+    atom_string(Functor1, Functor0),
+    term_string(Functor1, Functor),
+    atom_string(FileName, FileName0),
+    xref_source(FileName),
+    sweep_module_path_(Mod, FileName),
+    term_string(Clause, ClauseString, [subterm_positions(Pos0),
+                                       variable_names(ClauseVarNames),
+                                       module(Mod)]),
+    clause_body_pos_neck(Clause, Pos0, Body0, Pos, Meta, Pri),
+    pos_bounds(Pos, PosBeg, PosEnd),
+    (   GoalBeg =< PosBeg, PosEnd =< GoalEnd
+    ->  sweep_extract_this_goal(ClauseString, ClauseVarNames, Functor1, Body0, Pos, 0, false, Meta, Mod, Pri, Result)
+    ;   sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Functor1, Body0, Pos, 0, false, Meta, Mod, Pri, Result)
+    ).
+
+sweep_extract_goal_r(_, _, _, _, _, _, _,
+                     Pos, _, _, _, _, _, _) :-
+    var(Pos),
+    !,
+    fail.
+sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, {Goal},
+                     brace_term_position(_, _, Pos), Offset, Safe0, '//', Mod, _Pri, Result) :-
+    !,
+    Pri = 1199,
+    pos_bounds(Pos, PosBeg, PosEnd),
+    (   GoalBeg =< PosBeg, PosEnd =< GoalEnd
+    ->  sweep_extract_this_goal(ClauseString, ClauseVarNames, Func, Goal, Pos, Offset, Safe0, 0, Mod, Pri, Result)
+    ;   sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal, Pos, Offset, Safe0, 0, Mod, Pri, Result)
+    ).
+sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal,
+                     parentheses_term_position(_, _, Pos), Offset, Safe0, Meta, Mod, _Pri, Result) :-
+    !,
+    Pri = 1199,
+    pos_bounds(Pos, PosBeg, PosEnd),
+    (   GoalBeg =< PosBeg, PosEnd =< GoalEnd
+    ->  sweep_extract_this_goal(ClauseString, ClauseVarNames, Func, Goal, Pos, Offset, Safe0, Meta, Mod, Pri, Result)
+    ;   sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal, Pos, Offset, Safe0, Meta, Mod, Pri, Result)
+    ).
+sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal,
+                     term_position(Beg,End,_,_,PosList), Offset, Safe0, Meta, Mod, Pri, Result) :-
+    !,
+    (   @(predicate_property(Goal, meta_predicate(Spec)), Mod)
+    ->  true
+    ;   ignore(catch(infer_meta_predicate(Goal, Spec),
+                     error(permission_error(access, private_procedure, _),
+                           context(system:clause/2, _)),
+                     false))
+    ),
+    sweep_extract_goal_term(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal, 1, Beg, End, Spec, PosList, PosList, Offset, Safe0, Meta, Mod, Pri, Result).
+
+sweep_extract_goal_term(FileName, ClauseString0, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal, ArgIndex, Beg, End, Spec,
+                        [Pos|Tail], PosList, Offset0, Safe0, Meta0, Mod0, Pri0, Result) :-
+    arg(ArgIndex, Goal, Arg),
+    pos_bounds(Pos, PosBeg, PosEnd),
+    (   GoalBeg =< PosBeg, PosEnd =< GoalEnd
+    ->  sweep_extract_goal_update_state(FileName, Goal, ArgIndex, PosBeg, PosEnd, PosList, Beg, End, Spec,
+                                        ClauseString0, Offset0, Safe0, Meta0, Mod0,
+                                        ClauseString, Offset, Safe1, Meta, Mod, Pri),
+        sweep_extract_this_goal(ClauseString, ClauseVarNames, Func, Arg, Pos, Offset, Safe1, Meta, Mod, Pri, Result)
+    ;   PosBeg =< GoalBeg, GoalEnd =< PosEnd
+    ->  sweep_extract_goal_update_state(FileName, Goal, ArgIndex, PosBeg, PosEnd, PosList, Beg, End, Spec,
+                                        ClauseString0, Offset0, Safe0, Meta0, Mod0,
+                                        ClauseString, Offset, Safe1, Meta, Mod, Pri),
+        sweep_extract_goal_r(FileName, ClauseString, ClauseVarNames, GoalBeg, GoalEnd, Func, Arg, Pos, Offset, Safe1, Meta, Mod, Pri, Result)
+    ;   ArgIndex1 is ArgIndex + 1,
+        sweep_extract_goal_term(FileName, ClauseString0, ClauseVarNames, GoalBeg, GoalEnd, Func, Goal, ArgIndex1, Beg, End, Spec,
+                                Tail, PosList, Offset0, Safe0, Meta0, Mod0, Pri0, Result)
+    ).
+
+sweep_extract_goal_update_state(FileName, Goal, ArgIndex, ArgBeg, ArgEnd, PosList, Beg, End, Spec,
+                                ClauseString0, Offset0, Safe0, Meta0, Mod0,
+                                ClauseString, Offset, Safe, Meta, Mod, Pri) :-
+    sweep_extract_goal_update_module(Goal, ArgIndex, Mod0, Mod),
+    sweep_extract_goal_update_meta(Spec, ArgIndex, Meta0, Meta),
+    sweep_extract_goal_update_precedence(FileName, Goal, ArgIndex, ArgBeg, ArgEnd, Beg, End, Pri),
+    sweep_extract_goal_update_safety(Goal, ArgIndex, Safe0, Safe),
+    sweep_extract_goal_update_clause_string(Goal, ArgIndex, PosList, ClauseString0, Offset0, ClauseString, Offset).
+
+sweep_extract_goal_update_clause_string((_;_), 1, [_,AltPos], ClauseString0, Offset, ClauseString, Offset) :-
+    !,
+    pos_bounds(AltPos, AltBeg, AltEnd),
+    sub_string(ClauseString0, 0, AltBeg, _, ClauseBeforeAlt),
+    sub_string(ClauseString0, AltEnd, _, 0, ClauseAfterAlt),
+    string_concat(ClauseBeforeAlt, "true", ClauseString1),
+    string_concat(ClauseString1, ClauseAfterAlt, ClauseString).
+sweep_extract_goal_update_clause_string((_;_), 2, [AltPos,_], ClauseString0, Offset0, ClauseString, Offset) :-
+    !,
+    pos_bounds(AltPos, AltBeg, AltEnd),
+    Offset is Offset0 + AltEnd - AltBeg - 4,
+    sub_string(ClauseString0, 0, AltBeg, _, ClauseBeforeAlt),
+    sub_string(ClauseString0, AltEnd, _, 0, ClauseAfterAlt),
+    string_concat(ClauseBeforeAlt, "true", ClauseString1),
+    string_concat(ClauseString1, ClauseAfterAlt, ClauseString).
+sweep_extract_goal_update_clause_string(_, _, _, ClauseString, Offset, ClauseString, Offset).
+
+sweep_extract_goal_update_safety((_,_), _, Safe, Safe) :-
+    !.
+sweep_extract_goal_update_safety((_;_), _, Safe, Safe) :-
+    !.
+sweep_extract_goal_update_safety((_->_), 2, Safe, Safe) :-
+    !.
+sweep_extract_goal_update_safety(_, _, _, true).
+
+sweep_extract_goal_update_module(Mod1:_, ArgIndex, _Mod0, Mod) :-
+    atom(Mod1),
+    !,
+    ArgIndex == 2,
+    Mod = Mod1.
+sweep_extract_goal_update_module(_, _, Mod, Mod).
+
+sweep_extract_goal_update_meta(Spec, 2, ^, ^) :-
+    var(Spec),
+    !.
+sweep_extract_goal_update_meta(Spec, _, _, _) :-
+    var(Spec),
+    !,
+    fail.
+sweep_extract_goal_update_meta(Spec, ArgIndex, //, Meta) :-
+    !,
+    arg(ArgIndex, Spec, Meta0),
+    (   Meta0 == 0
+    ->  Meta = '//'
+    ;   Meta = Meta0
+    ).
+sweep_extract_goal_update_meta(Spec, ArgIndex, _Meta0, Meta) :-
+    arg(ArgIndex, Spec, Meta).
+
+sweep_extract_goal_update_precedence(FileName, Goal, ArgIndex, ArgBeg, ArgEnd, Beg, End, Pri) :-
+    compound_name_arity(Goal, F, N),
+    sweep_extract_goal_update_precedence_(FileName, F, N, ArgIndex, ArgBeg, ArgEnd, Beg, End, Pri).
+
+sweep_extract_goal_update_precedence_(FileName, F, 1, 1, Beg, _ArgEnd, Beg, _End, Precedence) :-
+    (   xref_op(FileName, op(Precedence0, Assoc, F))
+    ;   current_op(Precedence0, Assoc, F)
+    ),
+    memberchk(Assoc, [xf,yf]),
+    !,
+    (   Assoc == xf
+    ->  Precedence is Precedence0 - 1
+    ;   Precedence = Precedence0
+    ).
+sweep_extract_goal_update_precedence_(FileName, F, 1, 1, _ArgBeg, End, _Beg, End, Precedence) :-
+    (   xref_op(FileName, op(Precedence0, Assoc, F))
+    ;   current_op(Precedence0, Assoc, F)
+    ),
+    memberchk(Assoc, [fx,fy]),
+    !,
+    (   Assoc == fx
+    ->  Precedence is Precedence0 - 1
+    ;   Precedence = Precedence0
+    ).
+sweep_extract_goal_update_precedence_(FileName, F, 2, 1, Beg, _ArgEnd, Beg, _End, Precedence) :-
+    (   xref_op(FileName, op(Precedence0, Assoc, F))
+    ;   current_op(Precedence0, Assoc, F)
+    ),
+    memberchk(Assoc, [xfx, xfy, yfy, yfx]),
+    !,
+    (   Assoc == xfx
+    ->  Precedence is Precedence0 - 1
+    ;   Assoc == xfy
+    ->  Precedence is Precedence0 - 1
+    ;   Assoc == yfx
+    ->  Precedence = Precedence0
+    ;   Assoc == yfy
+    ->  Precedence = Precedence0
+    ).
+sweep_extract_goal_update_precedence_(FileName, F, 2, 2, _ArgBeg, End, _Beg, End, Precedence) :-
+    (   xref_op(FileName, op(Precedence0, Assoc, F))
+    ;   current_op(Precedence0, Assoc, F)
+    ),
+    memberchk(Assoc, [xfx, xfy, yfy, yfx]),
+    !,
+    (   Assoc == xfx
+    ->  Precedence is Precedence0 - 1
+    ;   Assoc == xfy
+    ->  Precedence is Precedence0
+    ;   Assoc == yfx
+    ->  Precedence = Precedence0 - 1
+    ;   Assoc == yfy
+    ->  Precedence = Precedence0
+    ).
+sweep_extract_goal_update_precedence_(_, _, _, _, _, _, _, _, 999).
+
+sweep_extract_this_goal(Clause, ClauseVarNames, Func, Term, Pos, Offset, Safe0, ^, Mod, Pri, Result) :-
+    !,
+    sweep_extract_ext_goal([], Clause, ClauseVarNames, Func, Term, Pos, Offset, Safe0, Mod, Pri, Result).
+sweep_extract_this_goal(Clause, ClauseVarNames, Func, Bindings>>_Goal, Pos, Offset, _Safe0, Meta, Mod, Pri, result(Call, Head, Body, "true", Arity, ":-", Exists)) :-
+    !,
+    sweep_extract_lambda(Clause, ClauseVarNames, Func, Bindings, Pos, Offset, Meta, Mod, Pri, Call, Head, Body, Arity, Exists).
+sweep_extract_this_goal(Clause, _ClauseVarNames, Func, Term, Pos, Offset, Safe0, Meta, Mod, Pri, Result) :-
+    sweep_extract_this_goal_([], Clause, Func, Term, Pos, Offset, Safe0, Meta, Mod, Pri, Result).
+
+sweep_extract_this_goal_(Exts, Clause, Func, Term, Pos, Offset, Safe0, Meta, Mod, Pri, result(Call, Head, Body, Safe, Arity, Neck, Exists)) :-
+    pos_bounds(Pos, BodyBeg0, BodyEnd0),
+    BodyLength is BodyEnd0 - BodyBeg0,
+    BodyBeg is BodyBeg0 - Offset,
+    BodyEnd is BodyEnd0 - Offset,
+    sub_string(Clause, BodyBeg, BodyLength, _, Body),
+    sub_string(Clause, 0, BodyBeg, _, ClauseBeforeBody),
+    sub_string(Clause, BodyEnd, _, 0, ClauseAfterBody),
+    string_concat(ClauseBeforeBody, Func, ClauseWithoutBody0),
+    string_concat(ClauseWithoutBody0, ClauseAfterBody, ClauseWithoutBody),
+    sweep_term_variable_names(ClauseWithoutBody, OtherVars0),
+    subtract(OtherVars0, Exts, OtherVars),
+    sweep_term_variable_names(Body, BodyVars),
+    intersection(OtherVars, BodyVars, CommonVars),
+    maplist([A,A=V,V]>>true,CommonVars, VarNames, Args),
+    length(Args, Arity),
+    CallTerm =.. [Func|Args],
+    term_string(CallTerm, Call, [quoted(true),
+                                 character_escapes(true),
+                                 spacing(next_argument),
+                                 variable_names(VarNames),
+                                 module(Mod),
+                                 priority(Pri)]),
+    (   Meta == '//'
+    ->  Extra = 2
+    ;   integer(Meta)
+    ->  Extra = Meta
+    ;   Extra = 0
+    ),
+    FullArity is Arity + Extra,
+    pi_head(Func/FullArity, H),
+    (   sweep_predicate_location_(Mod, H, _, _)
+    ->  Exists = "true"
+    ;   Exists = []
+    ),
+    % TODO - adjust Head and Body when Meta > 0
+    Head = Call,
+    (   Safe0
+    ->  Safe = "true"
+    ;   (   sweep_goal_may_cut_(Term)
+        ->  Safe = []
+        ;   Safe = "true"
+        )
+    ),
+    (   Meta == '//'
+    ->  Neck = "-->"
+    ;   Neck = ":-"
+    ).
+
+sweep_extract_ext_goal(Exts, ClauseString, ClauseVarNames, Func, Var^Term, term_position(_,_,_,_,[_,Pos]), Offset, Safe0, Mod, _Pri, Result) :-
+    !,
+    (   member(Name=V, ClauseVarNames),
+        V == Var
+    ->  true
+    ;   Name = '_'
+    ),
+    sweep_extract_ext_goal([Name|Exts], ClauseString, ClauseVarNames, Func, Term, Pos, Offset, Safe0, Mod, 200, Result).
+sweep_extract_ext_goal(Exts, ClauseString, _ClauseVarNames, Func, Term, Pos, Offset, Safe0, Mod, Pri, Result) :-
+    sweep_extract_this_goal_(Exts, ClauseString, Func, Term, Pos, Offset, Safe0, 0, Mod, Pri, Result).
+
+sweep_extract_lambda(Clause, ClauseVarNames, Func, Bindings, Pos0, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists) :-
+    strip_parens(Pos0, term_position(_,_,_,_,[_BindingsPos0, GoalPos0]), Pri0, _Pri),
+    strip_parens(GoalPos0, GoalPos, 399, _GoalPri),
+    sweep_extract_lambda_(Clause, ClauseVarNames, Func, Bindings, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists).
+
+
+sweep_extract_lambda_(Clause, ClauseVarNames, Func, {Shared0}/Args, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists) :-
+    comma_list(Shared0, Shared),
+    sweep_extract_lambda_1(Clause, ClauseVarNames, Func, Shared, Args, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists).
+sweep_extract_lambda_(Clause, ClauseVarNames, Func, Args, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists) :-
+    sweep_extract_lambda_1(Clause, ClauseVarNames, Func, [], Args, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists).
+
+sweep_extract_lambda_1(Clause, ClauseVarNames, Func, Shared, Args, GoalPos, Offset, Meta, Mod, Pri0, Call, Head, Body, Arity, Exists) :-
+    pos_bounds(GoalPos, BodyBeg0, BodyEnd0),
+    BodyLength is BodyEnd0 - BodyBeg0,
+    BodyBeg is BodyBeg0 - Offset,
+    sub_string(Clause, BodyBeg, BodyLength, _, Body),
+    length(Args, ArgsLen),
+    (   integer(Meta)
+    ->  ArgsLen == Meta
+    ;   ArgsLen == 0
+    ),
+    CallTerm =.. [Func|Shared],
+    term_string(CallTerm, Call, [quoted(true),
+                                 character_escapes(true),
+                                 spacing(next_argument),
+                                 variable_names(ClauseVarNames),
+                                 module(Mod),
+                                 priority(Pri0)]),
+    append(Shared, Args, HeadArgs),
+    HeadTerm =.. [Func|HeadArgs],
+    term_string(HeadTerm, Head, [quoted(true),
+                                 character_escapes(true),
+                                 spacing(next_argument),
+                                 variable_names(ClauseVarNames),
+                                 module(Mod),
+                                 priority(Pri0)]),
+    length(HeadArgs, Arity),
+    pi_head(Func/Arity, H),
+    (   sweep_predicate_location_(Mod, H, _, _)
+    ->  Exists = "true"
+    ;   Exists = []
+    ).

diff --git a/sweep.texi b/sweep.texi
index 9e581ce39d441b6e63bf7d3614e5faa00ba86436..3f1f9c8ce612d4bbb24bc009dc79c944580732f8 100644 (file)
--- a/sweep.texi
+++ b/sweep.texi
@@ -2714,7 +2714,10 @@ that the goal to extract shares with the containing clause.
 If the selected goal contains a cut whose scope would change as a
 result of being extracted from the current clause,
 @code{sweeprolog-extract-region-to-predicate} warns you about it and
-asks you to confirm before continuing.
+asks you to confirm before continuing.  If your code already includes
+a definition for the predicate that
+@code{sweeprolog-extract-region-to-predicate} would define, this
+command similarly warns you and asks for confirmation.
 
 If you call @code{sweeprolog-extract-region-to-predicate} when the
 region does not contain a valid Prolog term, this command complains

diff --git a/sweeprolog-tests.el b/sweeprolog-tests.el
index 06f9ec24f30614e22118f9cc5f22bb76b55e9685..ea62e743ccea642f7138b18b7485862d0f075258 100644 (file)
--- a/sweeprolog-tests.el
+++ b/sweeprolog-tests.el
@@ -35,7 +35,7 @@ The second argument is ignored."
            (progn . ,body)
          (set-buffer-modified-p nil)
          (kill-buffer)
-         (sweeprolog-restart)
+         ;; (sweeprolog-restart)
          (setq-default sweeprolog-enable-flymake enable-flymake-flag)))))
 
 (defconst sweeprolog-tests-greeting
@@ -1783,4 +1783,282 @@ foo((A,B)) =>
   (call-interactively #'up-list)
   (should (= (point) 51)))
 
+(sweeprolog-deftest extract-region-to-predicate ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, B, C, D, bar(bar), bar{bar:bar}, [bar,bar|bar]) :-
+    A = B,
+    C = D.
+"
+  (sweeprolog-extract-region-to-predicate 85 101 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, B, C, D, bar(bar), bar{bar:bar}, [bar,bar|bar]) :-
+    bbb(A, B, C, D).
+
+bbb(A, B, C, D) :-
+    A = B,
+    C = D.
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-parens ()
+  "Test `sweeprolog-extract-region-to-predicate' with parentheses."
+  ""
+  (should (equal (sweeprolog--extract-goal "bar :-
+    (   A = B,
+        C = D
+    )."
+                                           11 41 "foo")
+                 (list "foo" "foo" ":-" "(   A = B,
+        C = D
+    )"
+                       "true" "foo" 0 nil)))
+  (should (equal (sweeprolog--extract-goal "bar :-
+    (   A = B,
+        C = D
+    )."
+                                           15 35 "foo")
+                 (list "foo" "foo" ":-" "A = B,
+        C = D"
+                       "true" "foo" 0 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-cut ()
+  "Test `sweeprolog-extract-region-to-predicate' in presence of a cut."
+  ""
+  (should (equal (sweeprolog--extract-goal "bar :-
+    A = B,
+    !,
+    C = D."
+                                           11 34 "foo")
+                 (list "foo" "foo" ":-" "A = B,
+    !,
+    C = D"
+                       nil "foo" 0 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-clean-cut ()
+  "Test `sweeprolog-extract-region-to-predicate' in presence of a clean cut."
+  ""
+  (should (equal (sweeprolog--extract-goal "bar :-
+    A = B,
+    call(!),
+    C = D."
+                                           11 40 "foo")
+                 (list "foo" "foo" ":-" "A = B,
+    call(!),
+    C = D"
+                       "true" "foo" 0 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-dcg ()
+                    "Test `sweeprolog-extract-region-to-predicate'."
+                    ""
+                    (should (equal (sweeprolog--extract-goal "bar(A,D) -->
+    foo1(A, B),
+    foo2(C, D)."
+                                                             17 43 "foo")
+                                   (list "foo(A, D)" "foo(A, D)" "-->" "foo1(A, B),
+    foo2(C, D)"
+                                         "true" "foo" 2 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-dcg-to-reg-1 ()
+  "Test `sweeprolog-extract-region-to-predicate' with \"{}/1\" in DCG."
+  ""
+  (should (equal (sweeprolog--extract-goal "bar(A,D) -->
+    {foo1(A, B), foo2(C, D)}."
+                                           17 41 "foo")
+                 (list "foo(A, D)" "foo(A, D)" "-->" "{foo1(A, B), foo2(C, D)}"
+                       "true" "foo" 2 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-dcg-to-reg-2 ()
+  "Test `sweeprolog-extract-region-to-predicate' with \"{}/1\" in DCG."
+  ""
+  (should (equal (sweeprolog--extract-goal "bar(A,D) -->
+    {foo1(A, B), foo2(C, D)}."
+                                           18 40 "foo")
+                 (list "foo(A, D)" "foo(A, D)" ":-" "foo1(A, B), foo2(C, D)"
+                       "true" "foo" 2 nil))))
+
+(sweeprolog-deftest extract-region-to-predicate-dcg-in-use ()
+  "Test `sweeprolog-extract-region-to-predicate' with DCG that's in use."
+  ":- module(baz, []).
+
+bar(A,D) -->
+    foo1(A, B),
+    foo2(C, D).
+
+foo(_,_) --> [].
+"
+  (should (equal (sweeprolog--extract-goal "bar(A,D) -->
+    foo1(A, B),
+    foo2(C, D)."
+                                           17 43 "foo")
+                 (list "foo(A, D)" "foo(A, D)" "-->" "foo1(A, B),
+    foo2(C, D)"
+                       "true" "foo" 2 "true"))))
+
+
+(sweeprolog-deftest extract-region-to-predicate-1 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, B, C, D, bar(bar), bar{bar:bar}, [bar,bar|bar]) :-
+    A = B,
+    C = D.
+"
+  (sweeprolog-extract-region-to-predicate 85 90 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, B, C, D, bar(bar), bar{bar:bar}, [bar,bar|bar]) :-
+    bbb(A, B),
+    C = D.
+
+bbb(A, B) :-
+    A = B.
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-2 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, B) :-
+    (   A = C,
+        B = D
+    ;   A = C,
+        B = D
+    ).
+"
+  (sweeprolog-extract-region-to-predicate 44 64 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, B) :-
+    (   bbb(A, B)
+    ;   A = C,
+        B = D
+    ).
+
+bbb(A, B) :-
+    A = C,
+    B = D.
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-3 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, B) :-
+    (   A = C,
+        B = D
+    ;   A = C,
+        B = D
+    ).
+"
+  (sweeprolog-extract-region-to-predicate 73 93 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, B) :-
+    (   A = C,
+        B = D
+    ;   bbb(A, B)
+    ).
+
+bbb(A, B) :-
+    A = C,
+    B = D.
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-ext-1 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    setof(X, Y^member(X, Y), Y).
+"
+  (sweeprolog-extract-region-to-predicate 49 63 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    setof(X, bbb(X), Y).
+
+bbb(X) :-
+    member(X, Y).
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-ext-2 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    setof(X, Y^(member(X, Y), X = Z), Y).
+"
+  (sweeprolog-extract-region-to-predicate 51 72 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    setof(X, Y^bbb(Y, X), Y).
+
+bbb(Y, X) :-
+    (member(X, Y), X = Z).
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-lambda-1 ()
+  "Test `sweeprolog-extract-region-to-predicate'."
+  "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    maplist([VarName]>>ignore(memberchk(VarName, GoalVarNames)),
+            TemplateVarNames).
+"
+  (sweeprolog-extract-region-to-predicate 48 99 "bbb")
+  (should (string= (buffer-string)
+                   "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    maplist(bbb,
+            TemplateVarNames).
+
+bbb(VarName) :-
+    ignore(memberchk(VarName, GoalVarNames)).
+")))
+
+(sweeprolog-deftest extract-region-to-predicate-lambda-2 ()
+                    "Test `sweeprolog-extract-region-to-predicate'."
+                    "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    maplist({GoalVarNames}/[VarName]>>ignore(memberchk(VarName, GoalVarNames)),
+            TemplateVarNames).
+"
+                    (sweeprolog-extract-region-to-predicate 48 114 "bbb")
+                    (should (string= (buffer-string)
+                                     "
+:- module(bbb, []).
+
+bar(A, Y) :-
+    maplist(bbb(GoalVarNames),
+            TemplateVarNames).
+
+bbb(GoalVarNames, VarName) :-
+    ignore(memberchk(VarName, GoalVarNames)).
+")))
 ;;; sweeprolog-tests.el ends here

diff --git a/sweeprolog.el b/sweeprolog.el
index c1dfd235181c19693da1ac181c1544fe78d2e449..e3cb3bb27066adb385553aec0225a0cd5437e1a5 100644 (file)
--- a/sweeprolog.el
+++ b/sweeprolog.el
@@ -7105,6 +7105,11 @@ This function is used as a `add-log-current-defun-function' in
 
 ;;;; Extract goals to separate predicates
 
+(defun sweeprolog--extract-goal (str beg end new &optional file-name)
+  (sweeprolog--query-once "sweep" "sweep_extract_goal"
+                          (list str beg end new (or file-name
+                                                    (buffer-file-name)))))
+
 (defun sweeprolog-extract-region-to-predicate (beg end new &optional all)
   "Extract the Prolog goal from BEG to END into a new predicate, NEW.
 
@@ -7124,73 +7129,68 @@ clause.
 
 The user option `sweeprolog-new-predicate-location-function' says
 where in the buffer to insert the newly created predicate."
-  (interactive "r\nsNew predicate functor: \np" sweeprolog-mode)
-  ;; TODO - check that NEW isn't already used
-  (let* ((name (sweeprolog-format-string-as-atom new))
-         (head nil)
-         (neck nil)
-         (body (buffer-substring-no-properties beg end))
-         (vars (condition-case nil
-                   (sweeprolog--query-once "sweep" "sweep_term_variable_names"
-                                           body)
-                 (prolog-exception
-                  (user-error "Region does not contain a valid Prolog term"))))
-         (def-end nil))
-    (if (and (sweeprolog--query-once "sweep" "sweep_goal_may_cut" body)
-             (not (y-or-n-p (concat
-                             "The selected goal contains a cut whose "
-                             "scope would change as a result of this "
-                             "operation.  Continue?"))))
-        (message "Canceled.")
-      (goto-char beg)
-      (combine-after-change-calls
-        (delete-region beg end)
-        (insert name)
-        (let* ((clause-beg (save-excursion
-                             (sweeprolog-beginning-of-top-term)
-                             (point)))
-               (clause-end (save-excursion
-                             (sweeprolog-end-of-top-term)
-                             (point)))
-               (clause-vars
-                (condition-case nil
-                    (sweeprolog--query-once "sweep" "sweep_term_variable_names"
-                                            (buffer-substring-no-properties
-                                             clause-beg clause-end))
-                  (prolog-exception (sweeprolog-local-variables-collection))))
-               (args (seq-intersection vars clause-vars #'string=))
-               (args-string (when args
-                              (concat "("
-                                      (mapconcat #'identity args ", ")
-                                      ")"))))
-          (setq head (concat name args-string)
-                neck (or (nth 4 (sweeprolog-definition-at-point)) ":-"))
-          (when args-string (insert args-string))
-          (funcall sweeprolog-new-predicate-location-function
-                   name (length args) neck)
-          (let ((def-beg (1+ (point)))
-                (clause (concat "\n"
-                                head
-                                " "
-                                neck
-                                "\n"
-                                body
-                                ".\n")))
-            (insert clause)
-            (indent-region-line-by-line def-beg (point))
-            (setq def-end (point))
-            (goto-char def-beg))))
-      (when all
-        (let ((def-beg (point)))
-          (save-excursion
-            (goto-char (point-min))
-            (let ((sweeprolog-query-replace-term-include-match-function
-                   (pcase-lambda (`(,beg ,end . ,_))
-                     (not (<= def-beg beg end def-end)))))
-              (deactivate-mark)
-              (sweeprolog-query-replace-term
-               body head "true" '(goal))))))
-      (sweeprolog-analyze-buffer))))
+  (interactive "r\nsNew predicate functor: \nP" sweeprolog-mode)
+  (let* ((module (sweeprolog-buffer-module))
+         (pred-beg nil)
+         (pred-end nil)
+         (clause-beg (save-excursion
+                       (goto-char end)
+                       (sweeprolog-beginning-of-top-term)
+                       (point)))
+         (clause-end (save-excursion
+                       (goto-char beg)
+                       (sweeprolog-end-of-top-term)
+                       (point)))
+         (clause-str (buffer-substring-no-properties clause-beg
+                                                     clause-end)))
+    (pcase
+        (condition-case error
+            (sweeprolog--extract-goal clause-str
+                                      (- beg clause-beg)
+                                      (- end clause-beg)
+                                      new)
+          (prolog-exception
+           (pcase error
+             (`(prolog-exception
+                compound "error"
+                (compound "syntax_error" ,_)
+                ,_)
+              (user-error "Cannot extract goal from invalid term!")))))
+      ('nil (user-error (format "Selection %s is not a valid goal!" (buffer-substring-no-properties beg end))))
+      (`(,call ,head ,neck ,body ,safe ,functor ,arity ,in-use)
+       (cond
+        ((or (and (not safe)
+                  (not (y-or-n-p (concat
+                                  "The selected goal contains a cut whose "
+                                  "scope may change as a result of this "
+                                  "operation.  Continue?"))))
+             (and in-use
+              (not (y-or-n-p (concat
+                              "Predicate %s:%s/%d is already defined.  "
+                              "Continue?")))))
+         (message "Canceled."))
+        (t
+         (goto-char beg)
+         (combine-after-change-calls
+           (delete-region beg end)
+           (insert call)
+           (funcall sweeprolog-new-predicate-location-function
+                    functor arity neck)
+           (setq pred-beg (1+ (point)))
+           (insert "\n" head " " neck "\n" body ".\n")
+           (setq pred-end (point))
+           (indent-region-line-by-line pred-beg pred-end)
+           (goto-char pred-beg))
+         (deactivate-mark)
+         (when all
+           (save-excursion
+             (goto-char (point-min))
+             (let ((sweeprolog-query-replace-term-include-match-function
+                    (pcase-lambda (`(,beg ,end . ,_))
+                      (not (<= pred-beg beg end pred-end)))))
+               (sweeprolog-query-replace-term
+                body head "true" '(goal)))))
+         (sweeprolog-analyze-buffer)))))))
 
 (defun sweeprolog-maybe-extract-region-to-predicate (_point arg)
   (when (and (use-region-p)