mnemosyne_lc.erl

OTP是开放电信平台的简称

%% ``The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
%% compliance with the License. You should have received a copy of the
%% Erlang Public License along with this software. If not, it can be
%% retrieved via the world wide web at http://www.erlang.org/.
%% 
%% Software distributed under the License is distributed on an "AS IS"
%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%% the License for the specific language governing rights and limitations
%% under the License.
%% 
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%% 
%%     $Id$
%%
-module(mnemosyne_lc).

%% Purpose : A List Comprehension transformer of Mnemosyne

-export([parse_transform/2, format_error/1, the_query/1,
	 one_lc_to_handle/1]).

%%-export([abstract_keep_vars/2]).

%%-define(debug, 3).

-include("mnemosyne_debug.hrl").
-include("mnemosyne_internal_form.hrl").


%% This module transforms Mnemosyne things in the erlang source
%% module. Queries are transformed into function calls:
%%
%%           query [ P || B ] end
%%           
%%  --->     mnemosyne_lc:the_query({query,1,P',B',Data})
%%
%%           
%%  Rules are transformed as:
%%
%%           P(PV1) :- PB1;
%%           P(PV2) :- PB2;
%%		 ...
%%           P(PVn) :- PBn.
%%           
%%
%%           S(SV1) :- SB1;
%%           S(SV2) :- SB2;
%%		 ...
%%           S(SVm) :- SBm.
%%           
%%  --->     'MNEMOSYNE RULE'(P) -> [{PV1', PB1'},
%%				     {PV2', PB2'},
%%				       ...
%%				     {PVn', PBn'}];
%%
%%           'MNEMOSYNE RULE'(S) -> [{SV1', SB1'},
%%				     {SV2', SB2'},
%%				       ...
%%				     {SVm', SBm'}].
%%




-record(s, {options = [],
	    recdefs = [],
	    argtypes = [],
	    module = ?NO_MODULE,
	    line = none,
	    erl_vars = ordsets:new(),
	    db_vars = ordsets:new(),
	    allow_erl_vars = false,
	    allow_db_vars = true,
	    allow_fun_calls = false,
	    rules = [],
	    recdeffun = [],
	    var_types= [],
	    mquery = [],
	    mquery_next = 0
	    }).

%% -record(rec_def, {name, fields=[]}).  %% Field <- {name, init}

format_error(Msg) ->
    lists:concat(
      case Msg of
	  mnesia_not_running ->
	      ["Mnesia is not running"];

	  {no_erl_var,Name} ->
	      ["no Erlang variable (",Name,") at this place in a database "
	       "list comprehension"];

%	  {unbound_var,Name} ->
%	      ["variable '",Name,"' in list comprehension is unbound"];
	  
	  {illegal_lc_generator,table,too_few_arguments} ->
	      ["Table needs at least one argument."];

	  {illegal_lc_generator,table,too_many_arguments} ->
	      ["Table cannot have more than one argument."];

	  {illegal_lc_generator, table, ArgNo, Arg} ->
	      ["Table can only have atom or variable as ", ArgNo, "argument"] 
		  ++ case lists:flatten(erl_pp:expr(Arg, 
						    fun(_,_,_,_) -> "" end)) of
			 "" ->
			     ["."];
			 Str ->
			     [", not ", Str, "."]
		     end;
	  
	       
	  {illegal_lc_generator, Side, X} ->
	      case lists:flatten(erl_pp:expr(X, fun(_,_,_,_) -> "" end)) of
		  "" ->
		      ["illegal ",Side,
		       " side in database list comprehension generator"];
		  Str ->
		      ["illegal ",Side,
		       " side in database list comprehension generator: ",
		      Str]
	      end;
	  
	  {illegal_lc_body,X} ->
	      case lists:flatten(erl_pp:expr(X, fun(_,_,_,_) -> "" end)) of
		  "" ->
		      ["illegal body in database list comprehension"];
		  Str ->
		      ["illegal body \"",
		       Str, "\" in database list comprehension"]
	      end;
	  
	  {illegal_expr,X} ->
	      case lists:flatten(erl_pp:expr(X, fun(_,_,_,_) -> "" end)) of
		  "" ->
		      ["illegal expression in database list comprehension"];
		  Str ->
		      ["illegal expression \"", Str,
		       "\" in database list comprehension"]
	      end;
	  
	  {illegal_op,Op} ->
	      ["illegal operation (",Op,") in database list comprehension"];
	  
	  {illegal_field,Name} ->
	      ["illegal database record field value for \"",Name, "\""];

	  {undefined_field,RecType,Field} ->
	      ["undefined database record field \"",Field,
	       "\" in record \"", RecType, "\""];
	  
	  {illegal_record_init,Name,Field} ->
	      ["database record \"",Name,
	       "\" has illegal initialization of the field \"", Field, "\""];
	  
	  {illegal_rule_arity,Name,Arity} ->
	      ["the rule \"",Name,"\" has arity =/= 1"];

	  {already_defined,What,Name} ->
	      ["the ", What," \"", Name, "\" is already defined"];

	  {undefined,What,Name} ->
	      ["the ", What," \"", Name, "\" is undefined"];


	  {type_error, VName, Type1, Type2} ->
	      ["The variable ", VName, " cannot be both ", Type1,
	       " and ", Type2, "."];

	  {illegal_rule_clause_header, Args} ->
	      ["Illegal clause header of rule"]
		  ++ case lists:flatten(erl_pp:expr(Args, fun(_,_,_,_) -> "" end)) of
			 "" ->
			     ["."];
			 Str ->
			     [": ", Str, "."]
		     end;

	  {rule_type_error, VName, Type1, Type2} ->
	      ["The rule \"", VName, "\" cannot return both \"", Type1,
	       "\" and \"", Type2, "\"."];

	  {rule_arity_error, Name, A1, A2} ->
	      ["The rule \"", Name, "\" cannot have arity ", 
	       A1, " and ", A2, "."];

	  {variable_types_dont_match, V1, V2} ->
	      ["Variables ", V1, " and ", V2, " have different types"];

	  Other ->
	      [io_lib:write(Other)]
      end).


parse_transform(Forms, Options) ->
    case catch pass2( pass1(Forms,Options) ) of
	{error, E} -> [{error, E}];
	R -> R
    end.



%%%----------------------------------------------------------------
one_lc_to_handle([Expr]) ->
    TabAttrs =
	lists:map(
	  fun(Tab) ->
		  case catch mnesia:table_info(Tab, attributes) of
		      {'EXIT',{aborted,no_exists}} ->
			  throw({error, atom_to_list(Tab)++" does not exist"});
		      Attrs when is_list(Attrs) ->
			  {Tab,Attrs}
		  end
	  end, find_tables(Expr)),

    FakedFunction = {function,0,hale_bopp,0,[{clause,0,[],[],[Expr]}]},
    FakedModule = mk_rec_defs(TabAttrs) ++ [FakedFunction, {eof,0}] ,
    TransformedFakedModule = 
	parse_transform(FakedModule, [report_errors,report_warnings]),
    
    the_query(
      hd(lists:foldl(
	   fun({function,0,hale_bopp,0,
		[{clause,0,[],[],
		  [{call,1,{remote,1,{atom,1,mnemosyne_lc},{atom,1,the_query}},
		    [X]}]}]}, Acc) -> [erl_parse:normalise(X)|Acc];
	      (_, Acc) ->
		   Acc
	   end, [], TransformedFakedModule))).



mk_rec_defs(TabAttrs) ->
    lists:map(fun({Tab,Attrs}) ->
		      {attribute,0,record,
		       {Tab, lists:map(fun(Attr) ->
					       {record_field,0,{atom,0,Attr}}
				       end, Attrs)}}
	      end, TabAttrs).

find_tables(E) -> find_tables(E,[]).


find_tables({generate,_,{var,_,_},{call,_,{atom,_,table},[{atom,_,Table}]}},
	    Acc) ->  [Table | Acc];
find_tables({generate,_,{var,_,_},_}, Acc) ->
    throw({error, "Illegal generator"});
find_tables(T, Acc) when is_tuple(T) ->  find_tables(tuple_to_list(T), Acc);
find_tables([H|T], Acc) ->  find_tables(T, find_tables(H,Acc));
find_tables(_, Acc) ->   Acc.
    




%%%----------------------------------------------------------------
%%%----------------
pass1(Forms, Options) ->
    lists:foldl(
      fun
	  ({attribute,Line,record,{Name,Defs0}}, {Acc,S}) ->
	      case catch record_defs(Defs0, Name) of
		  {error, E} ->
		      {[{error,E}|Acc], S};
		  {'EXIT', Cause} ->
		      throw({'EXIT', Cause});
		  {ok, Def} ->
		      {[{attribute,Line,record,{Name,Defs0}}|Acc], 
		       S#s{recdefs=[Def|S#s.recdefs],
			   recdeffun=add_rec_clause(S#s.recdeffun, Line, 
						    Def)}}
	      end;
      
	  ({attribute,Line,module,Name}, {Acc,S}) ->
	      {[{attribute,Line,module,Name}|Acc], S#s{module=Name}};
      
	  ({attribute,Line,argtype,{RuleName,RecordName}}, {Acc,S}) ->
	      case lists:keysearch(RuleName,1,S#s.argtypes) of
		  {value, _} ->
		      {[{error, 
			 {Line,?MODULE,
			  {already_defined,"argument type of",RuleName}}} |
			Acc], S};
		  false ->
		      {Acc, S#s{argtypes=[{RuleName,RecordName}|S#s.argtypes]}}
	      end;
      
	  ({rule,Line,Name,Arity,Clauses}, {Acc,S}) when Arity=<2, Arity > 0 ->
	      case lists:keysearch(Name,1,S#s.rules) of
		  {value,_} ->
		      {[{error, {Line,?MODULE,{already_defined,rule,Name}}} |
			Acc], S};
		  false -> 
		      {Acc, S#s{rules=[{Name,Line,Clauses}|S#s.rules]}}
	      end;
      
	  ({rule,Line,Name,Arity,_}, {Acc,S})  ->
	      {[{error, 
		 {Line,?MODULE,{illegal_rule_arity,Name,Arity}}}|Acc], S};
      
	  (F, {Acc,S}) ->
	      {[F|Acc], S}
	       
      end, {[],#s{options=Options}}, Forms).


%% This adds one case to the set of clauses in a case-set.
add_rec_clause (Clauses, Line, {Name, Names}) ->
    Clauses ++ [{clause, Line,
		 [{atom, Line, Name}],           %% pattern
		 [],                             %% no guards
		 [{record, Line, Name, []}]}].   %% action: empty record #Name


pass2({[{eof,EOFline}|Forms],S0}) -> %% Forms are the forms in reverse order
    S1 = S0#s{mquery = mk_initial_mquery ()},
    {RulePart, S3} =
	case mk_rules_def_fkn(S1) of
	    {ok, FnDefL, S2} ->
		{FnDefL, S2};
	    {error, ErrLst} ->
		{ErrLst, S1#s{rules=nope}} %% prevent export decl of 
		                           %% 'MNEMOSYNE RULE' if needed
	end,

    {RecFunDefList, S4} =
	case S3#s.recdeffun of
	    [] ->
		{[], S3};
	    RecList ->
		{make_recdeffun (RecList), S3#s{recdeffun=[]}}
	end,
    

    %%    Following two cases prepare needed export declarations 
    Export1 = [{'MNEMOSYNE RULE',1}, {'MNEMOSYNE QUERY', 2}],
    Export =
	case RecFunDefList of
	    [] ->
		Export1;
	    _ ->
		[{'MNEMOSYNE RECFUNDEF',1}] ++ Export1
	end,
    
    {NewForms,S5} = 
	lists:foldl(    
	  fun
	      ({attribute,Line,'export',L}, {Acc,S}) when S#s.rules == true -> 
		  {[{attribute,Line,'export', Export ++ L}
		    | Acc],
		   S#s{rules=false}}; %% prevent further export decls.
			  
	      ({function,Line,Name,Arity,Clauses}, {Acc,S}) -> 
		  {FunDef, S6} =
		      case catch fn_clauses(Clauses,S) of
			  {error, E} ->
			      {{error,E}, S};
			  {'EXIT',Cause} ->
			      throw({'EXIT',Cause});
			  {TClauses, S5} ->
			      {{function,Line,Name,Arity,TClauses}, S5}
		      end,
		  {[FunDef | Acc], S6};

	      (F, {Acc,S}) ->
		  {[F|Acc], S}
	  end, {[],S4#s{rules=true}}, Forms),

    NewForms ++ RecFunDefList ++ S5#s.mquery ++ RulePart ++ [{eof,EOFline}];

pass2({L, S}) ->
    L.

make_recdeffun (RecFunDefList) ->
    [{function, 0, 'MNEMOSYNE RECFUNDEF', 1,     %% name and arity line=0
      [{clause, 0, 
	[{var, 0, 'X'}],                         %% clause takes var X
	[],                                      %% no guards
	[{'case', 0, {var, 0, 'X'},              %% 'case X of'
	  RecFunDefList}]}]}].                   %% our list of cases


%%  N.B. Field names are full expressions here but only atoms are allowed
%%  by the *parser*!

record_defs(Defs, Name) ->
    R = record_defs(Defs, Name, []),
    ?debugmsg(3, "RecDef = ~w\n", [R]),
    {ok,R}.

record_defs([{record_field,Line,{atom,La,A},Val0}|Defs], Name, Fs) ->
%    case valid_record_def_inits(Val0) of
%	true ->
	    record_defs(Defs, Name, [A|Fs]);
%	false ->
%	    throw({error, {La,?MODULE,{illegal_record_init,Name,A}}})
%    end;

record_defs([{record_field,Line,{atom,La,A}}|Defs], Name, Fs) ->
    record_defs(Defs, Name, [A|Fs]);
record_defs([], Name, Fs) ->
    {Name, lists:reverse(Fs)}.


%%%----------------------------------------------------------------
mk_rules_def_fkn(S) ->
    {Rules0, S1} = lists:foldl(fun one_rule/2, {[], S}, S#s.rules),
    case mnemosyne_compiler:pass2_rules(Rules0, 
					S1#s.module, 
					S1#s.recdefs) of
	{ok, CompiledRules} ->
	    {ok, [{function,0,'MNEMOSYNE RULE',1,
		   mk_fn_clauses(CompiledRules)++mk_data_clauses(S1)}],
	     S1};

	{error, L} ->
	    {error, L}
    end.


one_rule({Name,Line,Clauses}, {Accu0, S0}) ->
    {Arity, Rettype, S1, Clauses1} = rule_check_arity_type (Name, Clauses, S0),
    lists:foldl(
      fun({clause,CLine,[Arg0],[],LCBody0}, {Accu,S}) ->
	      S2 = S#s{db_vars=db_vars(LCBody0), var_types=[]},
	      {Body0, S3} = tr_body(LCBody0, S2),
	      {Arg,Body} =
		  case tr_pattern(Arg0,S3) of
		      {'#var',V} ->
			  {{'#var',V}, Body0};
		      NonVar ->
			  NewArg = mnemosyne_lib:unique_var(rule_arg),
			  {NewArg, [#constraint{exprL = NewArg, 
						op    = '=', 
						exprR = NonVar, 
						line  = CLine} | Body0]}
		  end,
	      OrigVars = mnemosyne_unify:variables_and_annonymous(Arg),
	      Head = #pred_sym{module       = S#s.module,
			       functor      = Name,
			       line	    = CLine,
			       type	    = rule,
			       record_def   = arg_record_def(rule,Name,S3),
			       record_type  = Rettype,