/* File:      flrcompileinclude.P -- Workspace wrapper for .fli files
**
** Author(s): kifer
**
** Contact:   flora-users@lists.sourceforge.net
**
** Copyright (C) The Research Foundation of SUNY, 2001, 2002
** 
** FLORA-2 is free software; you can redistribute it and/or modify it under the
** terms of the GNU Library General Public License as published by the Free
** Software Foundation; either version 2 of the License, or (at your option)
** any later version.
** 
** FLORA-2 is distributed in the hope that it will be useful, but WITHOUT ANY
** WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
** FOR A PARTICULAR PURPOSE.  See the GNU Library General Public License for
** more details.
** 
** You should have received a copy of the GNU Library General Public License
** along with FLORA-2; if not, write to the Free Software Foundation,
** Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
**
** $Id: flrwraparound.P,v 1.13 2003/06/18 07:01:34 kifer Exp $
**
*/

:- compiler_options([xpp_on]).

/*
  This simple wrapper understands the directives
  :- WRAP_DUMP string.
  :- WRAP_WITH_WORKSPACE predicate-list.
  :- WRAP_STORAGE predicate-list.
  :- WRAP_DEBUGMODULE predicate. 
  :- WRAP_MODULE predicate.

  Predicates mentioned in these directives are 
  recorded and whenever they occur in other directives or rules
  they are wrapped accordingly.

  :- WRAP_DUMP whatever.

  causes the argument to be dumped into the output as is.

  The predicates listed in the other directives are wrapped with
  FLORA_THIS_WORKSPACE(predicate), 
  or FLORA_THIS_FDB_STORAGE(predicate), respectively, for further processing 
  by the gpp preprocessor.
*/


#include "flag_defs_xsb.h"
#include "flora_terms.flh"
#include "flora_porting.flh"
#include "flora_wrap.flh"

:- dynamic wrap_arguments_directive/1.
:- dynamic flora_wraparound_info/2.

:- op(1100,fy,WRAP_WITH_WORKSPACE).
:- op(1100,fy,WRAP_DUMP).
:- op(1100,fy,WRAP_STORAGE).
:- op(1100,fy,WRAP_MODULE).

:- op(1100,fx,WRAP_INDICES).

%%:- op(1100,fx,FL_ARGUMENTS).
:- op(1100,fx,FL_EQUALITY).

:- bootstrap_flora.

/*************************************************************************
  flWrapAround(+File)
  This is used only in the closure/Makefile
  It takes a trailer template and wraps it with the workspace and 
  flora prefixes. This way the trailer is easier to maintain and understand.

*************************************************************************/
flWrapAround(File) :-
	flora_check_filename(File),
	( (flora_locate_file(File,INFILE_EXT,InFile), !
	  ; flora_locate_file(File,FLIFILE_EXT,InFile)
	  )
	->
	    flora_out_filename(InFile,OutFile),
	    wrapWorkspace(InFile,OutFile)
	;
	  flora_stderr_nl,
	  flora_error_line("File %s[.%s] does not exist!",
			   args(File,INFILE_EXT)),
          fail
        ),
	!.


wrapWorkspace(InFile,OutFile) :-
	telling(PreOutFile),
	tell(OutFile),
	wrapWorkspace(InFile),
	told,
	tell(PreOutFile).

%% this one just writes to stdout
wrapWorkspace(InFile) :- 
	seeing(PreInFile),
	flora_set_xpp_options_for_read,
	xpp_process_file(InFile,XPP_process,IOportFromProc),
	stat_set_flag(CURRENT_INPUT,IOportFromProc),
	process_fli_file,
	%% Wait, not to leave zombies.
	process_control(XPP_process,wait(ExitStatus)),
	(ExitStatus==0, !
	; flora_error_line('Error while preprocessing %s', InFile)
	),
	%% Release the file descriptor used to read from cpp.
	file_close(IOportFromProc),
	flora_clear_xpp_options,
	see(PreInFile).
wrapWorkspace(_).

process_fli_file :-
	repeat,
	read(X),
	(X==end_of_file -> true
	; process_clause(X)
	).
process_fli_file.

process_clause(X) :-
	(is_directive(X,WRAP_WITH_WORKSPACE,PredList)
	-> intern_predicate_specs(PredList,WRAP_WITH_WORKSPACE)
	; is_directive(X,WRAP_INDICES,IndexSpecList)
	-> dump_indices_directive(IndexSpecList)
	; is_directive(X,WRAP_DUMP,DumpString)
	-> writeln(DumpString)
	; is_directive(X,WRAP_STORAGE,RuleList)
	-> dump_storage_rules(RuleList)
	; is_directive(X,WRAP_MODULE,Pred)
	-> dump_module_rule(Pred)
	; is_directive(X,Directive,PredList)
	-> dump_other_directive(Directive,PredList)
	; %% assume it is a rule -- no queries
	    dump_rule(X)
	),
	!,
	fail.


%% Which macro to use for which type of encoding
wrapper_macro(WRAP_WITH_WORKSPACE,'FLORA_THIS_WORKSPACE').

%% tells how to wrap a predicate spec
wrapper(P/A, WrappedSpec, Changed) :- !,
	(var(A) -> EncodedA = '$var' ; EncodedA = A),
	(flora_wraparound_info(P/EncodedA,EncodingType),
	    wrapper_macro(EncodingType,WrapperMacroName)
	-> 
	    flora_concat_items([WrapperMacroName,'(',P,')'],WrappedP),
	    WrappedSpec = WrappedP/A,
	    Changed = wrapped
	;  WrappedSpec = P/A, Changed = notwrapped
	).
wrapper(Spec, WrappedSpec, Changed) :-
	Spec =.. [P|Args],
	(flora_wraparound_info(Spec,EncodingType),
	    wrapper_macro(EncodingType,WrapperMacroName)
	-> 
	    flora_concat_items([WrapperMacroName,'(',P,')'],WP),
	    WrappedSpec =.. [WP|Args], Changed = wrapped
	;  WrappedSpec = Spec, Changed = notwrapped
	).

spec2skeleton(P/A,Skeleton) :- !, functor(Skeleton,P,A).
spec2skeleton(Skeleton,Skeleton).


is_directive((:- WRAP_WITH_WORKSPACE PredList),WRAP_WITH_WORKSPACE,PredList) :- !.
is_directive((:- WRAP_INDICES IndexSpecList), WRAP_INDICES, IndexSpecList) :- !.
is_directive((:- WRAP_DUMP Atom),WRAP_DUMP,Atom) :- !.
is_directive((:- WRAP_STORAGE RuleList),WRAP_STORAGE,RuleList) :- !.
%% for now, only handle simple directives of the form :- Directive PredList.
is_directive(':-'(DirectiveBody),Directive,PredList) :-
        DirectiveBody =.. [Directive,PredList], !.

intern_predicate_specs(','(P,Ps),EncodingType) :- !,
	intern_predicate_spec(P,EncodingType),
	intern_predicate_specs(Ps,EncodingType).
intern_predicate_specs(P,EncodingType) :-
	intern_predicate_spec(P,EncodingType).

%% Insert both the p/a form and p(_,...,_) form
%% Arity can also be a variable. In this case, it is treated specially and the
%% predicate spec is inserted simply as p/_.
%% If p/_ is in the flora_compile_trie, then insert p/'$var' and don't insert
%% p(_,...,_)
intern_predicate_spec(P,EncodingType) :-
	P = '/'(Name,Arity),
	!,
	(var(Arity)
	-> assert(flora_wraparound_info('/'(Name,'$var'),EncodingType))
	; assert(flora_wraparound_info(P,EncodingType))
	),
	(var(Arity) -> true
	;   functor(NewP,Name,Arity),
	    assert(flora_wraparound_info(NewP,EncodingType))
	).
%% Spec of the form of the form name(_,...,_)
intern_predicate_spec(P,EncodingType) :-
	functor(P,Name,Arity), Arity >= 0,
	!,
	assert(flora_wraparound_info(P,EncodingType)),
	assert(flora_wraparound_info(Name/Arity,EncodingType)).
intern_predicate_spec(P,EncodingType) :-
	flora_error_line('[flWrapAround] Invalid predicate specification in a %s directive: %S', arg(EncodingType,P)).


dump_other_directive(Directive, PredSpecs) :-
	write(':- '), writeln(Directive),
	dump_rule_body(PredSpecs,1),
	writeln('.').

dump_indices_directive(IndexSpecList) :-
	writeln(':- index'),
	dump_index_specs(IndexSpecList).
dump_index_specs(','(Spec,IndexSpecList)) :-
	!,
	dump_index_spec(Spec),
	writeln(','),
	dump_index_specs(IndexSpecList).
dump_index_specs(Spec) :- dump_index_spec(Spec), writeln('.').
dump_index_spec(Spec) :-
	(Spec = Pred/Arity-ArgNo, !
	; abort(('Invalid index specification: ', Spec))),
	dump_literal(Pred/Arity,1),
	write('-'), write(ArgNo).


dump_storage_rules(','(Rule,Rest)) :- !,
	dump_storage_rule(Rule),
	dump_storage_rules(Rest).
dump_storage_rules(Rule) :- dump_storage_rule(Rule).

%% A storage rule looks like this: rule(head-predicate/arity,body-predicate)
dump_storage_rule(rule(HeadSpec,TailPred)) :-
	dump_storage_rule(rule(HeadSpec,TailPred,fdb)).

dump_storage_rule(rule(HeadSpec,TailPred,Storage)) :-
    dump_storage_rule(rule(HeadSpec,TailPred,Storage,no_leading)).

dump_storage_rule(rule(HeadSpec,TailPred,Storage,Leading)) :-
	spec2skeleton(HeadSpec,HeadSkeleton),
	dump_simple_goal(HeadSkeleton,0,Leading), writeln(' :-'),
	indent(1),
	( Storage=fld,
	    write('flora_db_find_base(FLORA_THIS_FLD_STORAGE,')
	;
	  Storage=fdb,
	    write('flora_db_find_base(FLORA_THIS_FDB_STORAGE,')
	),
	%% attach tail's functor to Head's variables
	HeadSkeleton =.. [_|HeadVars], BodySkeleton =.. [TailPred|HeadVars],
	dump_simple_goal(BodySkeleton,0), writeln(').').
	
dump_module_rule(rule(HeadSpec,TailPred)) :-
	spec2skeleton(HeadSpec,HeadSkeleton),
	dump_simple_goal(HeadSkeleton,0), writeln(' :-'),
	indent(1),
	HeadSkeleton =.. [_|HeadVars],
	dump_simple_goal(TailPred,0),
	write('(FLORA_THIS_MODULE_NAME'),
	( HeadVars == [] ->
	    true
	;
	    write(','),
	    write_args(HeadVars)
	),
	writeln(').').

dump_rule((Head :- Body)) :- !,
	dump_simple_goal(Head,0),
	writeln(' :-'),
	dump_rule_body(Body,1),
	writeln('.').
%% Headless rule
dump_rule((:- Body)) :- !,
    	writeln(':- '), dump_rule_body(Body,1), writeln('.').

%% Facts
dump_rule(Head) :-
	dump_literal(Head,0),
	writeln('.').

dump_rule_body(','(L,Rest),Indent) :-  !,
	dump_literal(L,Indent), writeln(','),
	dump_rule_body(Rest,Indent).
dump_rule_body(';'(Front,Back),Indent) :-  !,
	indent(Indent), writeln('('),
	Indent1 is Indent + 1,
	dump_rule_body(Front,Indent1),
	nl, indent(Indent), writeln(';'),
	dump_rule_body(Back,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body('->'(Front,Back),Indent) :-  !,
	indent(Indent), writeln('('),
	Indent1 is Indent + 1,
	dump_rule_body(Front,Indent1),
	nl, indent(Indent), writeln('->'),
	dump_rule_body(Back,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body('\+'(Body),Indent) :-  !,
	indent(Indent), writeln('\+('),
	Indent1 is Indent+1,
	dump_rule_body(Body,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body(not(Body), Indent) :-  !,
	indent(Indent), writeln('not('),
	Indent1 is Indent+1,
	dump_rule_body(Body,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body(tnot(Body), Indent) :-  !,
	indent(Indent), writeln('tnot('),
	Indent1 is Indent+1,
	dump_rule_body(Body,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body(call(Body), Indent) :-  !,
	indent(Indent), writeln('call('),
	Indent1 is Indent+1,
	dump_rule_body(Body,Indent1),
	nl, indent(Indent), write(')').
dump_rule_body(L,Indent) :- dump_literal(L,Indent).


dump_literal(Spec,Indent) :-
	( Spec = ','(F,B) -> dump_rule_body(Spec,Indent)
	; Spec = ';'(F,B) -> dump_rule_body(Spec,Indent)
	; Spec = '\+'(F) -> dump_rule_body(Spec,Indent)
	; Spec = 'not'(F) -> dump_rule_body(Spec,Indent)
	; Spec = 'tnot'(F) -> dump_rule_body(Spec,Indent)
	; Spec = 'call'(F) -> dump_rule_body(Spec,Indent)
	; Spec = '->'(F,B) -> dump_rule_body(Spec,Indent)
	; dump_simple_goal(Spec, Indent)
	).

%% We don't want things like FLORA_THIS_WORKSPACE
%% to appear in quote marks, as it would be with write_canonical/1
%% Simple write/1 won't work either because strings that are arguments
%% to predicates wil then be written without the quotes
dump_simple_goal(Spec, Indent) :- 
    dump_simple_goal(Spec, Indent, no_leading).

dump_simple_goal(Spec, Indent, Leading) :-
	wrapper(Spec,WSpec,Changed),
	indent(Indent),
	(Changed=notwrapped
	->  (WSpec = '/'(P,A) -> write_canonical(P), write('/'), write(A)
	    ; WSpec =.. [P|Args], Args \== [] ->
		write_canonical(P), write('('),
        ( Leading = leading(L) ->
            write_args(L),
            write(',')
        ;
            true
        ),
		write_args(Args),
		write(')')
	    ; write_canonical(WSpec)
	    )
	; %% Wrapped
	    (WSpec = '/'(P,A) -> write(P), write('/'), write(A)
	    ; WSpec =.. [P|Args], Args \== [] ->
		write(P), write('('),
        ( Leading = leading(L) ->
            write_args(L),
            write(',')
        ;
            true
        ),
		write_args(Args),
		write(')')
	    ; write(WSpec)
	    )
	).


write_args(Args) :-
	Args=[First|Rest], !,
	((atomic(First); var(First))
	-> write_canonical(First)
	; dump_simple_goal(First,0)
	),
	(Rest==[] -> true
	; write(','), write_args(Rest)
	).


indent(0) :- !.
indent(1) :- !, write('        ').
indent(N) :- N>1, write('  '), N1 is N-1, indent(N1).

flora_out_filename(File,OutFile) :-
	parse_filename(File,Dir,Base,Ext),
	in2out_extension(Ext,OutExt),
	flora_concat_atoms([Dir,Base,'.',OutExt],OutFile).

in2out_extension(INFILE_EXT,DATFILE_EXT) :- !.
in2out_extension(FLIFILE_EXT,FLHFILE_EXT) :- !.
in2out_extension(Ext,_) :-
	flora_error_line('[flWrapAround] Unknown extension, %s', Ext).