% -----------------------------------------------------------------------------
%  (C) Altran Praxis Limited
% -----------------------------------------------------------------------------
% 
%  The SPARK toolset is free software; you can redistribute it and/or modify it
%  under terms of the GNU General Public License as published by the Free
%  Software Foundation; either version 3, or (at your option) any later
%  version. The SPARK toolset 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 General
%  Public License for more details. You should have received a copy of the GNU
%  General Public License distributed with the SPARK toolset; see file
%  COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
%  the license.
% 
% =============================================================================

%###############################################################################
% PURPOSE
%-------------------------------------------------------------------------------
% The main export, checktype(Expression, Type), takes a ground
% (fully-instantiated) Expression and a Type which is either an atom or
% uninstantiated.  In the former case, the call will succeed if it is
% possible to interpret Expression as being of the given Type; in the latter
% case, the call will succeed if it is at all possible to type-check
% Expression validly, and Type will end up instantiated to an appropriate
% atomic type name as a result.
%###############################################################################

%###############################################################################
% MODULE
%###############################################################################

%###############################################################################
% DEPENDENCIES
%###############################################################################

%###############################################################################
% TYPES
%###############################################################################

%###############################################################################
% DATA
%###############################################################################

%###############################################################################
% PREDICATES
%###############################################################################

checktype(E, T) :-
        nonvar(T),
        !,
        find_core_type(T, CT),
        !,
        (
           checkhastype(E, CT)
        ;
           CT = real,
           checkhastype(E, integer)
        ),
        !.

checktype(E, T) :-
        checkhastype(E, TYPE),
        !,
        (
           T = TYPE
        ;
           TYPE = integer,
           !,
           T = real
        ;
           E =.. [mk__record|_],
           !,
           compatible_record_type(TYPE, T),
           checkhastype(E, T)
        ;
           E =.. [mk__array|_],
           !,
           compatible_array_type(TYPE, T),
           checkhastype(E, T)
        ).

%-------------------------------------------------------------------------------

checktypes([E|EL], [T|TL]) :-
        checktype(E, T),
        checktypes(EL, TL).
checktypes([], []).

%-------------------------------------------------------------------------------

% BOOL1
checkhastype(true, boolean) :-
    !.

% BOOL2
checkhastype(false, boolean) :-
    !.

% BOOL3
checkhastype(for_all(V:AT, FORMULA), boolean) :-
                !,
                atom(V),
                find_core_type(AT, T),
                (
                   type(T, _)
                ;
                   T = integer
                ;
                   T = real
                ;
                   T = boolean
                ),
                !,
                (
                   var_const(V, T, v),
                   !,
                   checkhastype(FORMULA, boolean)
                ;
                   asserta(var_const(V, T, v)),
                   checkhastype(FORMULA, boolean),
                   retract(var_const(V, T, v)),
                   !
                ;
                   retract(var_const(V, T, v)),
                   fail
                ), !.

% BOOL4
checkhastype(for_some(V:AT, FORMULA), boolean) :-
                !,
                atom(V),
                find_core_type(AT, T),
                (
                   type(T, _)
                ;
                   T = integer
                ;
                   T = real
                ;
                   T = boolean
                ),
                !,
                (
                   var_const(V, T, v),
                   !,
                   checkhastype(FORMULA, boolean)
                ;
                   asserta(var_const(V, T, v)),
                   checkhastype(FORMULA, boolean),
                   retract(var_const(V, T, v)),
                   !
                ;
                   retract(var_const(V, T, v)),
                   fail
                ), !.

% I/R1
checkhastype(X+Y, IR) :-
                checkhastype(X, IRX),
                !,
                checkhastype(Y, IRY),
                !,
                (
                   (
                      IRX=real
                   ;
                      IRY=real
                   ),
                   !,
                   IR=real
                ;
                   IRX=integer,
                   IRY=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% I/R2
checkhastype(X-Y, IR) :-
                checkhastype(X, IRX),
                !,
                checkhastype(Y, IRY),
                !,
                (
                   (
                      IRX=real
                   ;
                      IRY=real
                   ),
                   !,
                   IR=real
                ;
                   IRX=integer,
                   IRY=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% I/R3
checkhastype(X*Y, IR) :-
                checkhastype(X, IRX),
                !,
                checkhastype(Y, IRY),
                !,
                (
                   (
                      IRX=real
                   ;
                      IRY=real
                   ),
                   !,
                   IR=real
                ;
                   IRX=integer,
                   IRY=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% I/R4
checkhastype(-X, IR) :-
                checkhastype(X, IRX),
                !,
                (
                   IRX=real,
                   IR=real
                ;
                   IRX=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% INT1
checkhastype(X div Y, integer) :-
                checkhastype(X, integer), !,
                checkhastype(Y, integer), !.
% INT2
checkhastype(X mod Y, integer) :-
                checkhastype(X, integer), !,
                checkhastype(Y, integer), !.

% I/R5
checkhastype(abs(X), IR) :-
                checkhastype(X, IRX), !,
                (
                   IRX=real,
                   IR=real
                ;
                   IRX=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% I/R6
checkhastype(sqr(X), IR) :-
                checkhastype(X, IRX), !,
                (
                   IRX=real,
                   IR=real
                ;
                   IRX=integer,
                   (IR=integer ; IR=real)
                ),
                !.

% I/R7
checkhastype(X ** Y, IR) :-
                checkhastype(Y, integer),
                checkhastype(X, IR),
                (
                    IR = integer
                ;
                    IR = real
                ),
                !.

% I/R8
checkhastype(+X, IR) :-
                checkhastype(X, IR),
                !,
                (
                    IR=real
                ;
                    IR=integer
                ),
                !.

% REA1
checkhastype(X/Y, real) :-
                checkhastype(X, real),
                !,
                checkhastype(Y, real),
                !.

% REL1
checkhastype(X=Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   checkhastype(Y, TX)
                ), !.

% REL2
checkhastype(X<>Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   checkhastype(Y, TX)
                ), !.

% REL3
checkhastype(X>Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   type(TX, enumerated),
                   checkhastype(Y, TX)
                ), !.

% REL4
checkhastype(X<Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   type(TX, enumerated),
                   checkhastype(Y, TX)
                ), !.

% REL5
checkhastype(X>=Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   type(TX, enumerated),
                   checkhastype(Y, TX)
                ), !.

% REL6
checkhastype(X<=Y, boolean) :-
                checkhastype(X, TX),
                (
                   (
                      TX=integer
                   ;
                      TX=real
                   ),
                   !,
                   checkhastype(Y, TY),
                   (
                        TY=integer
                   ;
                        TY=real
                   )
                ;
                   type(TX, enumerated),
                   checkhastype(Y, TX)
                ), !.

% ARR1
checkhastype(update(A, IL, E), T) :-
                checkhastype(A, T),
                (
                   type(T, array(ITL, ET))
                ;
                   find_core_type(T, TN),
                   type(TN, array(ITL, ET))
                ),
                checkhastypelist(IL, ITL),
                checkhastype(E, ET), !.

% ARR2
checkhastype(element(A, IL), ET) :-
                checkhastype(A, T),
                (
                   type(T, array(ITL, ET))
                ;
                   find_core_type(T, TN),
                   type(TN, array(ITL, ET))
                ),
                checkhastypelist(IL, ITL), !.

% BOOL5
checkhastype((not X), boolean) :-
                checkhastype(X, boolean), !.

% BOOL6
checkhastype(X and Y, boolean) :-
                checkhastype(X, boolean), !,
                checkhastype(Y, boolean), !.

% BOOL7
checkhastype(X or Y, boolean) :-
                checkhastype(X, boolean), !,
                checkhastype(Y, boolean), !.

% BOOL8
checkhastype(X -> Y, boolean) :-
                checkhastype(X, boolean), !,
                checkhastype(Y, boolean), !.

% BOOL9
checkhastype(X <-> Y, boolean) :-
                checkhastype(X, boolean), !,
                checkhastype(Y, boolean), !.

% INT3
checkhastype(A, integer) :- integer(A), !.

% TYP1
checkhastype(A, T) :-
                atomic(A),
                var_const(A, T, _), !.

%  ODD
checkhastype(odd(X), boolean) :-
                checkhastype(X, integer), !.

% ORD1
checkhastype(pred(X), T) :-
                checkhastype(X, T), !,
                (type(T,enumerated) ; T=integer), !.

% ORD2
checkhastype(succ(X), T) :-
                checkhastype(X, T), !,
                (type(T,enumerated) ; T=integer), !.

% SEQ1
checkhastype(length(S), integer) :-
                checkhastype(S, ST), !, type(ST, sequence(_)), !.

% SEQ2
checkhastype(first(S), ET) :-
                checkhastype(S, ST), type(ST, sequence(ET)).

% SEQ3
checkhastype(last(S), ET) :-
                checkhastype(S, ST), type(ST, sequence(ET)).

% SEQ4
checkhastype(nonfirst(S), ST) :-
                checkhastype(S, ST), type(ST, sequence(_)).

% SEQ5
checkhastype(nonlast(S), ST) :-
                checkhastype(S, ST), type(ST, sequence(_)).

% SEQ6
checkhastype(X @ Y, ST) :-
                checkhastype(X, ST),
                type(ST, sequence(_)),
                checkhastype(Y, ST).

% SET1
checkhastype(X \/ Y, ST) :-
                checkhastype(X, ST),
                type(ST, set(_)),
                checkhastype(Y, ST).

% SET2
checkhastype(X \ Y, ST) :-
                checkhastype(X, ST),
                type(ST, set(_)),
                checkhastype(Y, ST).

% SET3
checkhastype(X /\ Y, ST) :-
                checkhastype(X, ST),
                type(ST, set(_)),
                checkhastype(Y, ST).

% SET4
checkhastype(X in Y, boolean) :-
                checkhastype(Y, ST),
                type(ST, set(ET)),
                checkhastype(X, ET), !.

% SET5
checkhastype(X not_in Y, boolean) :-
                checkhastype(Y, ST),
                type(ST, set(ET)),
                checkhastype(X, ET), !.

% SET6
checkhastype(X subset_of Y, boolean) :-
                checkhastype(X, ST),
                type(ST, set(_)),
                checkhastype(Y, ST), !.

% SET7
checkhastype(X strict_subset_of Y, boolean) :-
                checkhastype(X, ST),
                type(ST, set(_)),
                checkhastype(Y, ST), !.

% SEQ7
checkhastype([], T) :- type(T, sequence(_)).

% SEQ8
checkhastype([E|EL], T) :-
                checkhastype(E, ET),
                type(T, sequence(ET)),
                checkhastype(EL, T).

% SET8
checkhastype(set [], T) :- type(T, set(_)).

% SET9
checkhastype(set [E|EL], T) :-
                checkhastype(E, ET),
                type(T, set(ET)),
                checkhastype(set EL, T).

% ARR3
checkhastype(mk__array(VALUE), T) :-
                (
                   type(T, array([IT], VT))
                ;
                   find_core_type(T, TN),
                   type(TN, array([IT], VT))
                ),
                VALUE \= (_ := _),
                checktype(VALUE, VT).

% ARR4
checkhastype(AGG, T) :-
                \+ atomic(AGG),
                AGG =.. [F|ARGS],
                get_provenance_framework(spark),
                (
                   F = mk__array,
                   !,
                   collect_indices_and_values(
                        ARGS, [I|INDS], [V|VALS]),
                   !,
                   checktype(I, IT),
                   checkrestoflist(INDS, IT),
                   checktype(V, VT),
                   checkrestoflist(VALS, VT),
                   type(T, array([IT], VT))
                ;
                   F = mk__record,
                   !,
                   collect_fields_and_values(
                        ARGS, FIELDS, VALUES),
                   type(T, record(RECFIELDS)),
                   permutation_of_fields(
                        FIELDS, RECFIELDS, TYPES),
                   checktypelist(VALUES, TYPES)
                ).

% ARR5
checkhastype(E, T) :-
                \+ atomic(E),
                E =.. [F,Arg],
                mk__function_name(F, TN, array),
                Arg \= (_ := _),
                !,
                (
                   type(TN, array([IT], VT)),
                   T = TN
                ;
                   find_core_type(TN, T),
                   type(T, array([IT], VT))
                ),
                checktype(Arg, VT).

% ARR6
checkhastype(AGG, T) :-
                \+ atomic(AGG),
                AGG =.. [F|ARGS],
                get_provenance_framework(spark),
                (
                   mk__function_name(F , TN, array),
                   !,
                   collect_indices_and_values(
                        ARGS, [I|INDS], [V|VALS]),
                   !,
                   checktype(I, IT),
                   checkrestoflist(INDS, IT),
                   checktype(V, VT),
                   checkrestoflist(VALS, VT),
                   (
                      type(TN, array([IT], VT)),
                      T = TN
                   ;
                      find_core_type(TN, T),
                      type(T, array([IT], VT))
                   )
                ;
                   mk__function_name(F, T, record),
                   !,
                   collect_fields_and_values(
                        ARGS, FIELDS, VALUES),
                   type(T, record(RECFIELDS)),
                   permutation_of_fields(
                        FIELDS, RECFIELDS, TYPES),
                   checktypelist(VALUES, TYPES)
                ).

% FUNC
checkhastype(A, T) :-
                \+ atomic(A),
                function_template(A, AL, F),
                checktypelist(AL, ATL),
                (
                   function(F, ATLX, T)
                ;
                   function(F, ATLX, XT),
                   compatible_type_lists([XT], [T])
                ),
                compatible_type_lists(ATL, ATLX),
                !.

% REC1
checkhastype(A, T) :-
                \+ atomic(A),
                record_function(_N, A, access, _FIELD, [REC], _),
                checkhastype(REC, RTYPE),
                A =.. [F|_],
                (
                   function(F, [RTYPE], T)
                ;
                   function(F, [RTYPE], XT),
                   compatible_type_lists([XT], [T])
                ),
                !.

% REC2
checkhastype(A, RTYPE) :-
                \+ atomic(A),
                record_function(_N, A, update, _FIELD, [R,V], _),
                checkhastype(R, RTYPE),
                A =.. [F|_],
                function(F, [RTYPE,VTYPE], RTYPE),
                checkhastype(V, VTYPE),
                !.

% UNIV
checkhastype(A, T) :-
                \+ atomic(A),
                \+ function_template(A, _, _),
                \+ record_function(_, A, _, _, _, _),
                A=..[F|ARGS],
                check_is_an_ok_arity_function(F, ARGS),
                checktypelist(ARGS, ATL),
                (
                   function(F, ATLX, T)
                ;
                   function(F, ATLX, XT),
                   compatible_type_lists([XT], [T])
                ),
                compatible_type_lists(ATL, ATLX),
                !.

% REA2
checkhastype(X, real) :-
    checkhastype(X, integer),
    !.

% CTL1
checktypelist([E], [T]) :-
    !,
    checkhastype(E, T),
    !.

% CTL2
checktypelist([E|EL], [T|TL]) :-
    checkhastype(E, T),
    checktypelist(EL, TL),
    !.

%-------------------------------------------------------------------------------

% CHL1
checkhastypelist([E], [T]) :-
    !,
    checkhastype(E, T),
    !.

% CHL2
checkhastypelist([E|EL], [T|TL]) :-
                checkhastype(E, T),
                 !,
                checkhastypelist(EL, TL),
                !.
% CHL3
checkhastypelist([E], T) :- !, checkhastype(E, T), !.

% CHL4
checkhastypelist([E|EL], T) :-
                checkhastype(E, T),
                !,
                checkhastypelist(EL, T),
                !.

%-------------------------------------------------------------------------------

compatible_type_lists([A], [A]) :-
    !.

compatible_type_lists([integer], [real]) :-
    !.

compatible_type_lists([A|AL], [A|RL]) :-
    compatible_type_lists(AL, RL),
    !.

compatible_type_lists([integer|AL],[real|RL]) :-
    compatible_type_lists(AL,RL),
    !.

compatible_type_lists([T1|AL],[T2|RL]) :-
    compatible_set_or_seq_types(T1, T2),
    !,
    compatible_type_lists(AL, RL),
    !.

compatible_type_lists([], []) :-
    !.

%-------------------------------------------------------------------------------

compatible_set_or_seq_types(T1, T2) :-
        type(T1, set(ET1)),
        type(T2, set(ET2)),
        !,
        compatible_type_lists([ET1],[ET2]),
        !.

compatible_set_or_seq_types(T1, T2) :-
        type(T1, sequence(ET1)),
        type(T2, sequence(ET2)),
        !,
        compatible_type_lists([ET1],[ET2]),
        !.

%-------------------------------------------------------------------------------

check_is_an_ok_arity_function(F, ARGS) :-
        function(F, ARGL, _),
        length(ARGL, LEN),
        length(ARGS, LEN),
        !.

%-------------------------------------------------------------------------------

compatible_record_type(T1, T2) :-
        type(T1, record(F1)),
        type(T2, record(F2)),
        T1 \= T2,
        same_record_field_names(F1, F2).

%-------------------------------------------------------------------------------

same_record_field_names(Fs, Gs) :-
        collect_record_field_names(Fs, Fn),
        collect_record_field_names(Gs, Gn),
        sort(Fn, S),
        sort(Gn, S),
        !.

%-------------------------------------------------------------------------------

collect_record_field_names([[F,_]|FTs], [F|Fs]) :-
        !,
        collect_record_field_names(FTs, Fs).

collect_record_field_names([], []) :-
    !.

%-------------------------------------------------------------------------------

compatible_array_type(T1, T2) :-
        type(T1, array(I1, R1)),
        type(T2, array(I2, R2)),
        T1 \= T2,
        compatible_array_result_types(R1, R2),
        compatible_array_indices(I1, I2).

%-------------------------------------------------------------------------------

compatible_array_result_types(T, T) :-
    !.

compatible_array_result_types(integer, real) :-
    !.

compatible_array_result_types(real, integer) :-
    !.

compatible_array_result_types(T1, T2) :-
        compatible_record_type(T1, T2),
        !.

%-------------------------------------------------------------------------------

compatible_array_indices([I|Is], [I|Js]) :-
        !,
        compatible_array_indices(Is, Js).

compatible_array_indices([], []) :-
    !.

%-------------------------------------------------------------------------------

collect_indices_and_values([A|ARGS], INDS, [V|VALS]) :-
        (
           A = (LHS := V),
           collect_indices(LHS, I),
           collect_indices_and_values(ARGS, RESTINDS, VALS),
           !,
           append(I, RESTINDS, INDS)
        ;
           V = A,
           !,
           collect_indices_and_values(ARGS, INDS, VALS)
        ),
        !.

collect_indices_and_values([], [], []) :-
    !.

%-------------------------------------------------------------------------------

collect_indices(X & Y, I) :-
        collect_indices(X, XL),
        collect_indices(Y, YL),
        !,
        append(XL, YL, I),
        !.

collect_indices([X .. Y], [X,Y]) :-
    !.

collect_indices([X], [X]) :-
    !.

%-------------------------------------------------------------------------------

collect_fields_and_values([(F := V)|ARGS], [F|Fs], [V|Vs]) :-
        !,
        collect_fields_and_values(ARGS, Fs, Vs),
        !.

collect_fields_and_values([], [], []) :-
        !.

%-------------------------------------------------------------------------------

permutation_of_fields([F|FIELDS], FTL, [T|TYPES]) :-
        gen_append(LHS, [[F,T]|RHS], FTL),
        !,
        append(LHS, RHS, NEWFTL),
        !,
        permutation_of_fields(FIELDS, NEWFTL, TYPES),
        !.

permutation_of_fields([], [], []) :-
        !.

%-------------------------------------------------------------------------------

checkrestoflist([X|XL], T) :-
        checktype(X, T),
        checkrestoflist(XL, T).

checkrestoflist([], _).

%###############################################################################
% END-OF-FILE
