tml.g

:- use_module(library(must_sanity)).
:- set_prolog_flag(double_quotes,codes).

% Mini DCG interpretor
%
% example
%

optionally(G) --> G ; !.

some(P) --> P, optionally(some(P)).

any(S,S,[]).

end_of_file --> ([-1] ; [end_of_file] ; \+ [_]),!.
end_of_file(S,E):- S==[],!, E=[].


dcg_peek(Until,S,S) :- phrase(Until,S,_).

is_until(Until) --> dcg_peek(Until) ; end_of_file.

conj_until(Out, P, Until) --> call(P, A),
 ( is_until(Until) -> {A = Out} ; conj_until(B, P, Until), {Out = (A,B)}).

seq_until([], _, Until) --> is_until(Until),!.
seq_until([H|T], P, Until) --> call(P, H), !, seq_until(T, P, Until).


until(Until,Stuff) --> until_0(Until,Stuff),Until.
until_0(Until,[C|Before]) --> "\\",[C],!,until_0(Until,Before).
until_0(DCG,[],[Found|Rest],[Found|Rest]):- phrase(DCG,[Found],[])-> true ; phrase(DCG,[Found|Rest],_).
until_0(DCG,[Skipped|Before],[Skipped|More],[Found|Rest]):- until_0(DCG,Before,More,[Found|Rest]).


% // =========
% //  Dot Gee
% // =========
gee_comment(Cmt) -->
 ("//" ; "#") -> (until(eol,Cmt) ; any(Cmt)) ;
  "/*", any(Cmt), "*/".

white --> ` ` ; eol ; gee_comment(_).

eot --> dcg_peek(`.`) ; white.
eol --> "\n\r" ; "\r" ; "\n" .


gee_token(Txt) --> \+ dcg_peek(`.`),
  {quotes(Q,EQ)}, (Q -> until(EQ, Txt) ; until_0(eot,Txt)).

quotes(`<`,`>`).
quotes(S,S):- quotes1(S).
quotes1(`"`). quotes1(`'`).


padded(DCG) --> optionally(some(white)), DCG, optionally(some(white)).

gee_unit(DCG) --> ` `, !, gee_unit(DCG).
gee_unit(DCG) --> gee_unit_1(DCG), (eot;!). % trim off end

gee_unit_1(DCG,S,E) :-
  var(DCG) -> gee_token(Txt,S,E), name(DCG,Txt) ; % forward
  atomic(DCG) -> name(DCG,Txt), gee_token(Txt,S,E) ; % reverse
  phrase(DCG,S,E). % mixed

gee_dcg( Out ) --> gee_dcg1( A ), (end_of_file -> {Out=A} ;  gee_dcg( B ) , {Out = (A,B)}).


gee_dcg1(DCG) --> ` `, !, gee_dcg1(DCG).
gee_dcg1( comment(Comment) ) --> gee_comment(Codes), {name(Comment,Codes)}.
gee_dcg1( Out) --> gee_unit(L), (  "=>" -> gee_body(R), { Out = (L --> R)} ; gee_body(R), {Out = (:- do_gee(L,R))}), ".".
gee_dcg1( done) --> [], !.


gee_body(Body) --> conj_until( Body, [E] >> padded(gee_unit(E)), ".").
gee_body(A;B) --> gee_body(A), "|",  gee_body(B).

write_clause(X):- writeq(X), nl.


test_g:- phrase_from_file(({trace},conj_until(DCG, gee_dcg, end_of_file)), 'tml.g'),
  maplist(write_clause, DCG).


% call(+SyntaxName, +Content, +SyntaxArgs, +VariableNames, -Result)

qq_string(Data,_Args,_VarsIn,Result):- !,
  phrase_from_quasi_quotation(any(Resuult),Data).

gee(Data,_Args,_VarsIn,Result):- !,
  phrase_from_quasi_quotation(({trace},
   seq_until(Result, gee_dcg, end_of_file)),Data).


:- quasi_quotation_syntax(qq_string).
%:- quasi_quotation_syntax(gee).


gee_string(
{|qq_string||

#{
@string str <tml.g>.

identifier => sym | var.
args => identifier ws args | null.
var => '?' chars.
sym => chars.
relname => sym.
chars => alpha chars1 | '_' chars1.
chars1=> alnum chars1 | '_' chars1 | null.
ws =>   space ws | ws '#' printable_chars eol ws | null.
terminal => quoted_char | string.
quoted_char =>  '\'' printable '\'' | "'\\r'" | "'\\n'"
        | "'\\t'" | "'\\''" | "''".
eol => '\r' | '\n' | ''.
nonterminal => relname.
fname => '<' printable_chars '>' ws.
string => '"' printable_chars '"' ws.
printable_chars => printable printable_chars | null.
cmdline => '$' digits ws.
query => '!' ws term | "!!" ws term.

term => relname args.
pred => term | '~' ws term ws.
args => ws '(' ws args1 ws ')' ws | null.
args1 => identifier ws args1 ws | args | null.

directive =>    ws "@string" space ws strdir ws '.' ws |
        ws "@stdout" space ws term ws '.' ws |
        ws "@trace" space ws relname ws '.' ws |
        ws "@bwd" ws '.' ws.
strdir => relname ws fname | relname ws string | relname ws cmdline | relname ws term.

production => relname ws "=>" ws alt ws alts ws '.' ws.
alt =>  terminal ws alt ws | nonterminal ws alt ws | null.
alts => null | '|' ws alt ws alts ws.

fact => pred '.' ws.
preds => ws pred preds_rest.
preds_rest => ws ',' ws pred ws preds_rest | null.
rule => ws preds ws ":-" ws preds ws '.' ws.

fof => term ws ':' '=' ws form ws '.' ws.
form => term |
    ws prefix ws var ws '(' ws form ws ')' ws |
    ws '(' ws form ws ')' ws "and" ws '(' ws form ws ')' ws |
    ws '(' ws form ws ')' ws "or" ws '(' ws form ws ')' ws |
    ws "not" '(' ws form ws ')' ws |
    ws term ws "and" ws '(' ws form ws ')' ws |
    ws term ws "or" ws '(' ws form ws ')' ws |
    ws "not" '(' ws form ws ')' ws |
    ws term ws "and" ws term ws |
    ws term ws "or" ws term ws |
    ws "not" term ws |
    ws '(' ws form ws ')' ws "and" ws term ws |
    ws '(' ws form ws ')' ws "or" ws term ws.
prefix => "forall" | "exists" | "unique".

prog => directive S | rule S | production S | fof S | query S | null.
S => ws '{' ws prog ws '}' ws S ws | ws prog ws | null.
#}
#{
#   ~S(?x?x):-S(?x?x).
#   ~prog(?x?x):-prog(?x?x).
#   ~alt(?x?x):-alt(?x?x).
#   ~alts(?x?x):-alts(?x?x).
#}

|}).


:- phrase(seq_until(X,gee_unit,`.`), `@string a.` , O), O == `.`, X ==  ['@string', a].

:-               (phrase(seq_until(O,gee_unit,`.`), `@string str <tml.g> .` , O)).