2015-02-03 00:03:06 +00:00
/*
Copyright ( c ) 2015 Microsoft Corporation . All rights reserved .
Released under Apache 2.0 license as described in the file LICENSE .
Author : Leonardo de Moura
*/
2015-02-05 00:13:15 +00:00
# include <algorithm>
2015-02-03 17:00:37 +00:00
# include <string>
2015-02-04 17:59:34 +00:00
# include "util/interrupt.h"
# include "util/list_fn.h"
2015-02-05 00:13:15 +00:00
# include "util/sexpr/option_declarations.h"
2015-02-04 17:59:34 +00:00
# include "kernel/instantiate.h"
2015-02-05 04:04:19 +00:00
# include "kernel/abstract.h"
2015-02-04 17:59:34 +00:00
# include "kernel/replace_fn.h"
# include "kernel/for_each_fn.h"
2015-02-04 23:17:58 +00:00
# include "kernel/inductive/inductive.h"
2015-02-05 20:48:55 +00:00
# include "library/normalize.h"
2015-02-03 00:03:06 +00:00
# include "library/kernel_serializer.h"
2015-02-04 17:59:34 +00:00
# include "library/reducible.h"
# include "library/util.h"
# include "library/match.h"
# include "library/projection.h"
2015-02-04 21:51:32 +00:00
# include "library/local_context.h"
# include "library/unifier.h"
2015-02-04 23:17:58 +00:00
# include "library/constants.h"
2015-02-04 17:59:34 +00:00
# include "library/generic_exception.h"
2015-02-03 00:03:06 +00:00
# include "library/tactic/rewrite_tactic.h"
# include "library/tactic/expr_to_tactic.h"
2015-02-04 21:51:32 +00:00
# include "library/tactic/class_instance_synth.h"
2015-02-03 00:03:06 +00:00
2015-02-04 17:59:34 +00:00
// #define TRACE_MATCH_PLUGIN
2015-02-05 00:13:15 +00:00
# ifndef LEAN_DEFAULT_REWRITER_MAX_ITERATIONS
# define LEAN_DEFAULT_REWRITER_MAX_ITERATIONS 200
# endif
2015-02-06 21:27:33 +00:00
# ifndef LEAN_DEFAULT_REWRITER_SYNTACTIC
# define LEAN_DEFAULT_REWRITER_SYNTACTIC false
# endif
2015-02-03 00:03:06 +00:00
namespace lean {
2015-02-05 00:13:15 +00:00
static name * g_rewriter_max_iterations = nullptr ;
2015-02-06 21:27:33 +00:00
static name * g_rewriter_syntactic = nullptr ;
2015-02-05 00:13:15 +00:00
unsigned get_rewriter_max_iterations ( options const & opts ) {
return opts . get_unsigned ( * g_rewriter_max_iterations , LEAN_DEFAULT_REWRITER_MAX_ITERATIONS ) ;
}
2015-02-06 21:27:33 +00:00
bool get_rewriter_syntactic ( options const & opts ) {
return opts . get_bool ( * g_rewriter_syntactic , LEAN_DEFAULT_REWRITER_SYNTACTIC ) ;
}
2015-02-03 03:20:24 +00:00
class unfold_info {
2015-02-06 19:03:36 +00:00
list < name > m_names ;
location m_location ;
2015-02-03 03:20:24 +00:00
public :
unfold_info ( ) { }
2015-02-06 19:03:36 +00:00
unfold_info ( list < name > const & l , location const & loc ) : m_names ( l ) , m_location ( loc ) { }
list < name > const & get_names ( ) const { return m_names ; }
2015-02-03 03:20:24 +00:00
location const & get_location ( ) const { return m_location ; }
2015-02-05 21:16:05 +00:00
friend serializer & operator < < ( serializer & s , unfold_info const & e ) {
2015-02-06 19:03:36 +00:00
write_list < name > ( s , e . m_names ) ;
s < < e . m_location ;
2015-02-05 21:16:05 +00:00
return s ;
}
friend deserializer & operator > > ( deserializer & d , unfold_info & e ) {
2015-02-06 19:03:36 +00:00
e . m_names = read_list < name > ( d ) ;
d > > e . m_location ;
2015-02-05 21:16:05 +00:00
return d ;
}
2015-02-03 03:20:24 +00:00
} ;
2015-02-03 00:03:06 +00:00
2015-02-05 21:16:05 +00:00
class reduce_info {
location m_location ;
public :
reduce_info ( ) { }
reduce_info ( location const & loc ) : m_location ( loc ) { }
location const & get_location ( ) const { return m_location ; }
friend serializer & operator < < ( serializer & s , reduce_info const & e ) {
s < < e . m_location ;
return s ;
}
friend deserializer & operator > > ( deserializer & d , reduce_info & e ) {
d > > e . m_location ;
return d ;
}
} ;
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
class rewrite_info {
2015-02-04 17:59:34 +00:00
public :
2015-02-03 03:20:24 +00:00
enum multiplicity { Once , AtMostN , ExactlyN , ZeroOrMore , OneOrMore } ;
2015-02-04 17:59:34 +00:00
private :
2015-02-03 03:20:24 +00:00
bool m_symm ;
multiplicity m_multiplicity ;
optional < unsigned > m_num ;
location m_location ;
rewrite_info ( bool symm , multiplicity m , optional < unsigned > const & n ,
location const & loc ) :
m_symm ( symm ) , m_multiplicity ( m ) , m_num ( n ) , m_location ( loc ) { }
public :
rewrite_info ( ) : m_symm ( false ) , m_multiplicity ( Once ) { }
static rewrite_info mk_once ( bool symm , location const & loc ) {
return rewrite_info ( symm , Once , optional < unsigned > ( ) , loc ) ;
}
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
static rewrite_info mk_at_most_n ( unsigned n , bool symm , location const & loc ) {
return rewrite_info ( symm , AtMostN , optional < unsigned > ( n ) , loc ) ;
}
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
static rewrite_info mk_exactly_n ( unsigned n , bool symm , location const & loc ) {
return rewrite_info ( symm , ExactlyN , optional < unsigned > ( n ) , loc ) ;
}
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
static rewrite_info mk_zero_or_more ( bool symm , location const & loc ) {
return rewrite_info ( symm , ZeroOrMore , optional < unsigned > ( ) , loc ) ;
}
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
static rewrite_info mk_one_or_more ( bool symm , location const & loc ) {
2015-02-04 17:59:34 +00:00
return rewrite_info ( symm , OneOrMore , optional < unsigned > ( ) , loc ) ;
2015-02-03 03:20:24 +00:00
}
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
bool symm ( ) const {
return m_symm ;
}
multiplicity get_multiplicity ( ) const {
return m_multiplicity ;
}
bool has_num ( ) const {
2015-02-06 21:02:50 +00:00
return get_multiplicity ( ) = = AtMostN | | get_multiplicity ( ) = = ExactlyN ;
2015-02-03 03:20:24 +00:00
}
unsigned num ( ) const {
lean_assert ( has_num ( ) ) ;
return * m_num ;
}
2015-02-04 17:59:34 +00:00
location const & get_location ( ) const { return m_location ; }
2015-02-03 03:20:24 +00:00
2015-02-05 21:16:05 +00:00
friend serializer & operator < < ( serializer & s , rewrite_info const & e ) {
s < < e . m_symm < < static_cast < char > ( e . m_multiplicity ) < < e . m_location ;
if ( e . has_num ( ) )
s < < e . num ( ) ;
return s ;
}
2015-02-03 00:03:06 +00:00
2015-02-05 21:16:05 +00:00
friend deserializer & operator > > ( deserializer & d , rewrite_info & e ) {
char multp ;
d > > e . m_symm > > multp > > e . m_location ;
e . m_multiplicity = static_cast < rewrite_info : : multiplicity > ( multp ) ;
if ( e . has_num ( ) )
e . m_num = d . read_unsigned ( ) ;
return d ;
}
} ;
2015-02-03 00:03:06 +00:00
2015-02-03 03:20:24 +00:00
static expr * g_rewrite_tac = nullptr ;
static name * g_rewrite_elem_name = nullptr ;
static std : : string * g_rewrite_elem_opcode = nullptr ;
static name * g_rewrite_unfold_name = nullptr ;
static std : : string * g_rewrite_unfold_opcode = nullptr ;
2015-02-05 21:16:05 +00:00
static name * g_rewrite_reduce_name = nullptr ;
static std : : string * g_rewrite_reduce_opcode = nullptr ;
2015-02-03 00:03:06 +00:00
2015-02-05 21:16:05 +00:00
[[ noreturn ]] static void throw_re_ex ( ) { throw exception ( " unexpected occurrence of 'rewrite' expression " ) ; }
class rewrite_core_macro_cell : public macro_definition_cell {
public :
virtual pair < expr , constraint_seq > get_type ( expr const & , extension_context & ) const { throw_re_ex ( ) ; }
virtual optional < expr > expand ( expr const & , extension_context & ) const { throw_re_ex ( ) ; }
} ;
class rewrite_reduce_macro_cell : public rewrite_core_macro_cell {
reduce_info m_info ;
public :
rewrite_reduce_macro_cell ( reduce_info const & info ) : m_info ( info ) { }
virtual name get_name ( ) const { return * g_rewrite_reduce_name ; }
virtual void write ( serializer & s ) const {
s < < * g_rewrite_reduce_opcode < < m_info ;
}
reduce_info const & get_info ( ) const { return m_info ; }
} ;
expr mk_rewrite_reduce ( location const & loc ) {
macro_definition def ( new rewrite_reduce_macro_cell ( reduce_info ( loc ) ) ) ;
return mk_macro ( def ) ;
}
expr mk_rewrite_reduce_to ( expr const & e , location const & loc ) {
macro_definition def ( new rewrite_reduce_macro_cell ( reduce_info ( loc ) ) ) ;
return mk_macro ( def , 1 , & e ) ;
}
bool is_rewrite_reduce_step ( expr const & e ) {
return is_macro ( e ) & & macro_def ( e ) . get_name ( ) = = * g_rewrite_reduce_name ;
}
reduce_info const & get_rewrite_reduce_info ( expr const & e ) {
lean_assert ( is_rewrite_reduce_step ( e ) ) ;
return static_cast < rewrite_reduce_macro_cell const * > ( macro_def ( e ) . raw ( ) ) - > get_info ( ) ;
}
class rewrite_unfold_macro_cell : public rewrite_core_macro_cell {
2015-02-03 03:20:24 +00:00
unfold_info m_info ;
public :
rewrite_unfold_macro_cell ( unfold_info const & info ) : m_info ( info ) { }
virtual name get_name ( ) const { return * g_rewrite_unfold_name ; }
virtual void write ( serializer & s ) const {
s < < * g_rewrite_unfold_opcode < < m_info ;
}
unfold_info const & get_info ( ) const { return m_info ; }
} ;
2015-02-03 00:03:06 +00:00
2015-02-06 19:03:36 +00:00
expr mk_rewrite_unfold ( list < name > const & ns , location const & loc ) {
macro_definition def ( new rewrite_unfold_macro_cell ( unfold_info ( ns , loc ) ) ) ;
2015-02-03 03:20:24 +00:00
return mk_macro ( def ) ;
}
bool is_rewrite_unfold_step ( expr const & e ) {
return is_macro ( e ) & & macro_def ( e ) . get_name ( ) = = * g_rewrite_unfold_name ;
}
2015-02-04 17:59:34 +00:00
unfold_info const & get_rewrite_unfold_info ( expr const & e ) {
lean_assert ( is_rewrite_unfold_step ( e ) ) ;
return static_cast < rewrite_unfold_macro_cell const * > ( macro_def ( e ) . raw ( ) ) - > get_info ( ) ;
}
2015-02-05 21:16:05 +00:00
class rewrite_element_macro_cell : public rewrite_core_macro_cell {
2015-02-03 03:20:24 +00:00
rewrite_info m_info ;
2015-02-03 00:03:06 +00:00
public :
2015-02-03 03:20:24 +00:00
rewrite_element_macro_cell ( rewrite_info const & info ) : m_info ( info ) { }
virtual name get_name ( ) const { return * g_rewrite_elem_name ; }
2015-02-03 00:03:06 +00:00
virtual void write ( serializer & s ) const {
2015-02-03 03:20:24 +00:00
s < < * g_rewrite_elem_opcode < < m_info ;
2015-02-03 00:03:06 +00:00
}
2015-02-03 03:20:24 +00:00
rewrite_info const & get_info ( ) const { return m_info ; }
2015-02-03 00:03:06 +00:00
} ;
2015-02-03 03:20:24 +00:00
expr mk_rw_macro ( macro_definition const & def , optional < expr > const & pattern , expr const & H ) {
if ( pattern ) {
expr args [ 2 ] = { H , * pattern } ;
return mk_macro ( def , 2 , args ) ;
} else {
return mk_macro ( def , 1 , & H ) ;
}
2015-02-03 00:03:06 +00:00
}
2015-02-03 03:20:24 +00:00
expr mk_rewrite_once ( optional < expr > const & pattern , expr const & H , bool symm , location const & loc ) {
macro_definition def ( new rewrite_element_macro_cell ( rewrite_info : : mk_once ( symm , loc ) ) ) ;
return mk_rw_macro ( def , pattern , H ) ;
2015-02-03 00:03:06 +00:00
}
2015-02-03 03:20:24 +00:00
expr mk_rewrite_zero_or_more ( optional < expr > const & pattern , expr const & H , bool symm , location const & loc ) {
macro_definition def ( new rewrite_element_macro_cell ( rewrite_info : : mk_zero_or_more ( symm , loc ) ) ) ;
return mk_rw_macro ( def , pattern , H ) ;
2015-02-03 00:03:06 +00:00
}
2015-02-03 03:20:24 +00:00
expr mk_rewrite_one_or_more ( optional < expr > const & pattern , expr const & H , bool symm , location const & loc ) {
macro_definition def ( new rewrite_element_macro_cell ( rewrite_info : : mk_one_or_more ( symm , loc ) ) ) ;
return mk_rw_macro ( def , pattern , H ) ;
}
expr mk_rewrite_at_most_n ( optional < expr > const & pattern , expr const & H , bool symm , unsigned n , location const & loc ) {
macro_definition def ( new rewrite_element_macro_cell ( rewrite_info : : mk_at_most_n ( n , symm , loc ) ) ) ;
return mk_rw_macro ( def , pattern , H ) ;
2015-02-03 00:03:06 +00:00
}
2015-02-03 03:20:24 +00:00
expr mk_rewrite_exactly_n ( optional < expr > const & pattern , expr const & H , bool symm , unsigned n , location const & loc ) {
macro_definition def ( new rewrite_element_macro_cell ( rewrite_info : : mk_exactly_n ( n , symm , loc ) ) ) ;
return mk_rw_macro ( def , pattern , H ) ;
2015-02-03 01:02:14 +00:00
}
2015-02-03 03:20:24 +00:00
bool is_rewrite_step ( expr const & e ) {
return is_macro ( e ) & & macro_def ( e ) . get_name ( ) = = * g_rewrite_elem_name ;
}
bool has_rewrite_pattern ( expr const & e ) {
lean_assert ( is_rewrite_step ( e ) ) ;
return macro_num_args ( e ) = = 2 ;
}
expr const & get_rewrite_rule ( expr const & e ) {
lean_assert ( is_rewrite_step ( e ) ) ;
return macro_arg ( e , 0 ) ;
}
expr const & get_rewrite_pattern ( expr const & e ) {
lean_assert ( has_rewrite_pattern ( e ) ) ;
return macro_arg ( e , 1 ) ;
}
2015-02-04 17:59:34 +00:00
rewrite_info const & get_rewrite_info ( expr const & e ) {
lean_assert ( is_rewrite_step ( e ) ) ;
return static_cast < rewrite_element_macro_cell const * > ( macro_def ( e ) . raw ( ) ) - > get_info ( ) ;
}
2015-02-03 03:20:24 +00:00
expr mk_rewrite_tactic_expr ( buffer < expr > const & elems ) {
lean_assert ( std : : all_of ( elems . begin ( ) , elems . end ( ) , [ ] ( expr const & e ) {
2015-02-06 04:02:49 +00:00
return is_rewrite_step ( e ) | | is_rewrite_unfold_step ( e ) | | is_rewrite_reduce_step ( e ) ;
2015-02-03 03:20:24 +00:00
} ) ) ;
return mk_app ( * g_rewrite_tac , mk_expr_list ( elems . size ( ) , elems . data ( ) ) ) ;
}
2015-02-04 17:59:34 +00:00
class rewrite_match_plugin : public match_plugin {
# ifdef TRACE_MATCH_PLUGIN
io_state m_ios ;
# endif
type_checker & m_tc ;
public :
# ifdef TRACE_MATCH_PLUGIN
rewrite_match_plugin ( io_state const & ios , type_checker & tc ) :
m_ios ( ios ) , m_tc ( tc ) { }
# else
rewrite_match_plugin ( io_state const & , type_checker & tc ) :
m_tc ( tc ) { }
# endif
bool is_projection_app ( expr const & e ) const {
expr const & f = get_app_fn ( e ) ;
return is_constant ( f ) & & is_projection ( m_tc . env ( ) , const_name ( f ) ) ;
}
virtual bool on_failure ( expr const & p , expr const & t , match_context & ctx ) const {
try {
constraint_seq cs ;
2015-02-04 20:14:47 +00:00
// We do not unfold projections.
2015-02-04 17:59:34 +00:00
expr p1 = is_projection_app ( p ) ? p : m_tc . whnf ( p , cs ) ;
expr t1 = is_projection_app ( t ) ? t : m_tc . whnf ( t , cs ) ;
return ! cs & & ( p1 ! = p | | t1 ! = t ) & & ctx . match ( p1 , t1 ) ;
} catch ( exception & ) {
return false ;
}
}
2015-02-04 20:14:47 +00:00
// Return true iff the given declaration contains inst_implicit arguments
bool has_inst_implicit_args ( name const & d ) const {
if ( auto decl = m_tc . env ( ) . find ( d ) ) {
expr const * it = & decl - > get_type ( ) ;
while ( is_pi ( * it ) ) {
if ( binding_info ( * it ) . is_inst_implicit ( ) )
return true ;
it = & binding_body ( * it ) ;
}
return false ;
} else {
return false ;
}
}
2015-02-04 17:59:34 +00:00
virtual lbool pre ( expr const & p , expr const & t , match_context & ctx ) const {
if ( ! is_app ( p ) | | ! is_app ( t ) )
return l_undef ;
expr const & p_fn = get_app_fn ( p ) ;
if ( ! is_constant ( p_fn ) )
2015-02-04 20:14:47 +00:00
return l_undef ;
2015-02-04 17:59:34 +00:00
expr const & t_fn = get_app_fn ( t ) ;
if ( ! is_constant ( t_fn ) )
2015-02-04 20:14:47 +00:00
return l_undef ;
2015-02-04 17:59:34 +00:00
if ( ! ctx . match ( p_fn , t_fn ) )
2015-02-04 20:14:47 +00:00
return l_undef ;
2015-02-04 17:59:34 +00:00
projection_info const * info = get_projection_info ( m_tc . env ( ) , const_name ( p_fn ) ) ;
2015-02-04 20:14:47 +00:00
if ( info & & info - > m_inst_implicit ) {
// Special support for projections
buffer < expr > p_args , t_args ;
get_app_args ( p , p_args ) ;
get_app_args ( t , t_args ) ;
if ( p_args . size ( ) ! = t_args . size ( ) )
return l_false ;
for ( unsigned i = 0 ; i < p_args . size ( ) ; i + + ) {
if ( i = = info - > m_nparams )
continue ; // skip structure
if ( ! ctx . match ( p_args [ i ] , t_args [ i ] ) )
return l_false ;
}
return l_true ;
}
if ( has_inst_implicit_args ( const_name ( p_fn ) ) ) {
// Special support for declarations that contains inst_implicit arguments.
// The idea is to skip them during matching.
buffer < expr > p_args , t_args ;
get_app_args ( p , p_args ) ;
get_app_args ( t , t_args ) ;
if ( p_args . size ( ) ! = t_args . size ( ) )
2015-02-04 17:59:34 +00:00
return l_false ;
2015-02-04 20:14:47 +00:00
expr const * it = & m_tc . env ( ) . get ( const_name ( p_fn ) ) . get_type ( ) ;
for ( unsigned i = 0 ; i < p_args . size ( ) ; i + + ) {
if ( is_pi ( * it ) & & binding_info ( * it ) . is_inst_implicit ( ) ) {
it = & binding_body ( * it ) ;
continue ; // skip argument
}
if ( ! ctx . match ( p_args [ i ] , t_args [ i ] ) )
return to_lbool ( on_failure ( p , t , ctx ) ) ; // try to unfold if possible
if ( is_pi ( * it ) )
it = & binding_body ( * it ) ;
}
return l_true ;
2015-02-04 17:59:34 +00:00
}
2015-02-04 20:14:47 +00:00
return l_undef ;
2015-02-04 17:59:34 +00:00
}
} ;
class rewrite_fn {
2015-02-06 21:27:33 +00:00
typedef std : : shared_ptr < type_checker > type_checker_ptr ;
2015-02-04 17:59:34 +00:00
environment m_env ;
io_state m_ios ;
elaborate_fn m_elab ;
proof_state m_ps ;
name_generator m_ngen ;
type_checker_ptr m_tc ;
2015-02-06 21:27:33 +00:00
type_checker_ptr m_matcher_tc ;
2015-02-04 17:59:34 +00:00
rewrite_match_plugin m_mplugin ;
goal m_g ;
2015-02-04 21:51:32 +00:00
local_context m_ctx ;
2015-02-04 17:59:34 +00:00
substitution m_subst ;
expr m_expr_loc ; // auxiliary expression used for error localization
2015-02-05 00:13:15 +00:00
unsigned m_max_iter ;
2015-02-04 17:59:34 +00:00
buffer < optional < level > > m_lsubst ; // auxiliary buffer for pattern matching
buffer < optional < expr > > m_esubst ; // auxiliary buffer for pattern matching
[[ noreturn ]] void throw_rewrite_exception ( char const * msg ) {
throw_generic_exception ( msg , m_expr_loc ) ;
}
[[ noreturn ]] void throw_rewrite_exception ( sstream const & strm ) {
throw_generic_exception ( strm , m_expr_loc ) ;
}
2015-02-05 00:13:15 +00:00
[[ noreturn ]] void throw_max_iter_exceeded ( ) {
2015-02-05 21:16:05 +00:00
throw_rewrite_exception ( sstream ( ) < < " rewrite tactic failed, maximum number of iterations exceeded "
< < " (current threshold: " < < m_max_iter
< < " , increase the threshold by setting option 'rewrite.max_iter') " ) ;
2015-02-05 00:13:15 +00:00
}
2015-02-04 21:51:32 +00:00
void update_goal ( goal const & g ) {
m_g = g ;
buffer < expr > hyps ;
g . get_hyps ( hyps ) ;
m_ctx = local_context ( to_list ( hyps ) ) ;
}
2015-02-04 17:59:34 +00:00
expr mk_meta ( expr const & type ) {
return m_g . mk_meta ( m_ngen . next ( ) , type ) ;
}
2015-02-06 19:03:36 +00:00
optional < expr > reduce ( expr const & e , list < name > const & to_unfold ) {
2015-02-05 20:48:55 +00:00
bool unfolded = ! to_unfold ;
extra_opaque_pred pred ( [ & ] ( name const & n ) {
// everything is opaque but to_unfold
2015-02-06 19:03:36 +00:00
if ( std : : find ( to_unfold . begin ( ) , to_unfold . end ( ) , n ) ! = to_unfold . end ( ) ) {
2015-02-05 20:48:55 +00:00
unfolded = true ;
return false ;
} else {
return true ;
}
} ) ;
bool relax_main_opaque = false ;
bool memoize = true ;
auto tc = new type_checker ( m_env , m_ngen . mk_child ( ) ,
mk_default_converter ( m_env , relax_main_opaque ,
memoize , pred ) ) ;
constraint_seq cs ;
expr r = normalize ( * tc , e , cs ) ;
if ( ! unfolded | | cs ) // FAIL if didn't unfolded or generated constraints
return none_expr ( ) ;
return some_expr ( r ) ;
}
2015-02-05 21:59:55 +00:00
// Replace goal with definitionally equal one
void replace_goal ( expr const & new_type ) {
expr M = m_g . mk_meta ( m_ngen . next ( ) , new_type ) ;
goal new_g ( M , new_type ) ;
expr val = m_g . abstract ( M ) ;
m_subst . assign ( m_g . get_name ( ) , val ) ;
update_goal ( new_g ) ;
}
2015-02-06 19:03:36 +00:00
bool process_reduce_goal ( list < name > const & to_unfold ) {
2015-02-05 20:48:55 +00:00
if ( auto new_type = reduce ( m_g . get_type ( ) , to_unfold ) ) {
2015-02-05 21:59:55 +00:00
replace_goal ( * new_type ) ;
2015-02-05 20:48:55 +00:00
return true ;
} else {
return false ;
}
}
2015-02-05 21:59:55 +00:00
// Replace hypothesis type with definitionally equal one
void replace_hypothesis ( expr const & hyp , expr const & new_hyp_type ) {
expr new_hyp = update_mlocal ( hyp , new_hyp_type ) ;
buffer < expr > new_hyps ;
m_g . get_hyps ( new_hyps ) ;
for ( expr & h : new_hyps ) {
if ( mlocal_name ( h ) = = mlocal_name ( hyp ) ) {
h = new_hyp ;
break ;
}
}
expr new_type = m_g . get_type ( ) ;
expr new_mvar = mk_metavar ( m_ngen . next ( ) , Pi ( new_hyps , new_type ) ) ;
expr new_meta = mk_app ( new_mvar , new_hyps ) ;
goal new_g ( new_meta , new_type ) ;
expr val = m_g . abstract ( new_meta ) ;
m_subst . assign ( m_g . get_name ( ) , val ) ;
update_goal ( new_g ) ;
}
2015-02-06 19:03:36 +00:00
bool process_reduce_hypothesis ( expr const & hyp , list < name > const & to_unfold ) {
2015-02-05 20:48:55 +00:00
if ( auto new_hyp_type = reduce ( mlocal_type ( hyp ) , to_unfold ) ) {
2015-02-05 21:59:55 +00:00
replace_hypothesis ( hyp , * new_hyp_type ) ;
2015-02-05 20:48:55 +00:00
return true ;
} else {
return false ;
}
}
2015-02-06 19:03:36 +00:00
bool process_reduce_step ( list < name > const & to_unfold , location const & loc ) {
2015-02-05 20:48:55 +00:00
if ( loc . is_goal_only ( ) )
return process_reduce_goal ( to_unfold ) ;
bool progress = false ;
buffer < expr > hyps ;
m_g . get_hyps ( hyps ) ;
for ( expr const & h : hyps ) {
if ( ! loc . includes_hypothesis ( local_pp_name ( h ) ) )
continue ;
if ( process_reduce_hypothesis ( h , to_unfold ) )
progress = true ;
}
if ( loc . includes_goal ( ) ) {
if ( process_reduce_goal ( to_unfold ) )
progress = true ;
}
return progress ;
}
2015-02-04 17:59:34 +00:00
bool process_unfold_step ( expr const & elem ) {
lean_assert ( is_rewrite_unfold_step ( elem ) ) ;
2015-02-05 20:48:55 +00:00
auto info = get_rewrite_unfold_info ( elem ) ;
2015-02-06 19:03:36 +00:00
return process_reduce_step ( info . get_names ( ) , info . get_location ( ) ) ;
2015-02-04 17:59:34 +00:00
}
2015-02-05 21:59:55 +00:00
optional < expr > unify_with ( expr const & t , expr const & e ) {
auto ecs = m_elab ( m_g , m_ngen . mk_child ( ) , e , false ) ;
expr new_e = ecs . first ;
buffer < constraint > cs ;
to_buffer ( ecs . second , cs ) ;
constraint_seq cs_seq ;
if ( ! m_tc - > is_def_eq ( t , new_e , justification ( ) , cs_seq ) )
return none_expr ( ) ;
cs_seq . linearize ( cs ) ;
unifier_config cfg ;
2015-02-06 03:08:47 +00:00
cfg . m_discard = true ;
2015-02-05 21:59:55 +00:00
unify_result_seq rseq = unify ( m_env , cs . size ( ) , cs . data ( ) , m_ngen . mk_child ( ) , m_subst , cfg ) ;
if ( auto p = rseq . pull ( ) ) {
substitution new_subst = p - > first . first ;
new_e = new_subst . instantiate_all ( new_e ) ;
if ( has_expr_metavar_strict ( new_e ) )
return none_expr ( ) ; // new expressions was not completely instantiated
m_subst = new_subst ;
return some_expr ( new_e ) ;
}
return none_expr ( ) ;
}
bool process_reduce_to_goal ( expr const & e ) {
if ( auto new_type = unify_with ( m_g . get_type ( ) , e ) ) {
replace_goal ( * new_type ) ;
return true ;
} else {
return false ;
}
}
bool process_reduce_to_hypothesis ( expr const & hyp , expr const & e ) {
if ( auto new_hyp_type = unify_with ( mlocal_type ( hyp ) , e ) ) {
replace_hypothesis ( hyp , * new_hyp_type ) ;
return true ;
} else {
return false ;
}
}
bool process_reduce_to_step ( expr const & e , location const & loc ) {
if ( loc . is_goal_only ( ) )
return process_reduce_to_goal ( e ) ;
bool progress = false ;
buffer < expr > hyps ;
m_g . get_hyps ( hyps ) ;
for ( expr const & h : hyps ) {
if ( ! loc . includes_hypothesis ( local_pp_name ( h ) ) )
continue ;
if ( process_reduce_to_hypothesis ( h , e ) )
progress = true ;
}
if ( loc . includes_goal ( ) ) {
if ( process_reduce_to_goal ( e ) )
progress = true ;
}
return progress ;
}
2015-02-05 21:42:50 +00:00
bool process_reduce_step ( expr const & elem ) {
lean_assert ( is_rewrite_reduce_step ( elem ) ) ;
if ( macro_num_args ( elem ) = = 0 ) {
auto info = get_rewrite_reduce_info ( elem ) ;
2015-02-06 19:03:36 +00:00
return process_reduce_step ( list < name > ( ) , info . get_location ( ) ) ;
2015-02-05 21:42:50 +00:00
} else {
2015-02-05 21:59:55 +00:00
auto info = get_rewrite_reduce_info ( elem ) ;
return process_reduce_to_step ( macro_arg ( elem , 0 ) , info . get_location ( ) ) ;
2015-02-05 21:42:50 +00:00
}
}
2015-02-04 17:59:34 +00:00
// Replace metavariables with special metavariables for the higher-order matcher. This is method is used when
// converting an expression into a pattern.
expr to_meta_idx ( expr const & e ) {
m_lsubst . clear ( ) ;
m_esubst . clear ( ) ;
name_map < expr > emap ;
name_map < level > lmap ;
auto to_meta_idx = [ & ] ( level const & l ) {
return replace ( l , [ & ] ( level const & l ) {
if ( ! has_meta ( l ) ) {
return some_level ( l ) ;
} else if ( is_meta ( l ) ) {
if ( auto it = lmap . find ( meta_id ( l ) ) ) {
return some_level ( * it ) ;
} else {
unsigned next_idx = m_lsubst . size ( ) ;
level r = mk_idx_meta_univ ( next_idx ) ;
m_lsubst . push_back ( none_level ( ) ) ;
lmap . insert ( meta_id ( l ) , r ) ;
return some_level ( r ) ;
}
} else {
return none_level ( ) ;
}
} ) ;
} ;
return replace ( e , [ & ] ( expr const & e , unsigned ) {
if ( ! has_metavar ( e ) ) {
return some_expr ( e ) ; // done
} else if ( is_binding ( e ) ) {
throw_rewrite_exception ( " invalid rewrite tactic, pattern contains binders " ) ;
} else if ( is_meta ( e ) ) {
expr const & fn = get_app_fn ( e ) ;
lean_assert ( is_metavar ( fn ) ) ;
name const & n = mlocal_name ( fn ) ;
if ( auto it = emap . find ( n ) ) {
return some_expr ( * it ) ;
} else {
unsigned next_idx = m_esubst . size ( ) ;
expr r = mk_idx_meta ( next_idx , m_tc - > infer ( e ) . first ) ;
m_esubst . push_back ( none_expr ( ) ) ;
emap . insert ( n , r ) ;
return some_expr ( r ) ;
}
} else if ( is_constant ( e ) ) {
levels ls = map ( const_levels ( e ) , [ & ] ( level const & l ) { return to_meta_idx ( l ) ; } ) ;
return some_expr ( update_constant ( e , ls ) ) ;
} else {
return none_expr ( ) ;
}
} ) ;
}
// Given the rewrite step \c e, return a pattern to be used to locate the term to be rewritten.
expr get_pattern ( expr const & e ) {
lean_assert ( is_rewrite_step ( e ) ) ;
if ( has_rewrite_pattern ( e ) ) {
return to_meta_idx ( get_rewrite_pattern ( e ) ) ;
} else {
// Remark: we discard constraints generated producing the pattern.
// Patterns are only used to locate positions where the rule should be applied.
expr rule = get_rewrite_rule ( e ) ;
expr rule_type = m_tc - > whnf ( m_tc - > infer ( rule ) . first ) . first ;
while ( is_pi ( rule_type ) ) {
expr meta = mk_meta ( binding_domain ( rule_type ) ) ;
rule_type = m_tc - > whnf ( instantiate ( binding_body ( rule_type ) , meta ) ) . first ;
}
if ( ! is_eq ( rule_type ) )
throw_rewrite_exception ( " invalid rewrite tactic, given lemma is not an equality " ) ;
if ( get_rewrite_info ( e ) . symm ( ) ) {
return to_meta_idx ( app_arg ( rule_type ) ) ;
} else {
return to_meta_idx ( app_arg ( app_fn ( rule_type ) ) ) ;
}
}
}
// Set m_esubst and m_lsubst elements to none
void reset_subst ( ) {
for ( optional < level > & l : m_lsubst )
l = none_level ( ) ;
for ( optional < expr > & e : m_esubst )
e = none_expr ( ) ;
}
2015-02-04 21:51:32 +00:00
pair < expr , constraint > mk_class_instance_elaborator ( expr const & type ) {
unifier_config cfg ;
cfg . m_conservative = true ;
bool use_local_instances = true ;
bool is_strict = false ;
return : : lean : : mk_class_instance_elaborator ( m_env , m_ios , m_ctx , m_ngen . next ( ) , optional < name > ( ) ,
m_ps . relax_main_opaque ( ) , use_local_instances , is_strict ,
some_expr ( type ) , m_expr_loc . get_tag ( ) , cfg , nullptr ) ;
}
// rule, new_t
typedef optional < pair < expr , expr > > unify_result ;
2015-02-05 04:04:19 +00:00
// When successful, the result is the pair (H, new_t) where
// (H : new_t = t) if is_goal == true
// (H : t = new_t) if is_goal == false
2015-02-05 18:04:03 +00:00
unify_result unify_target ( expr const & t , expr const & orig_elem , bool is_goal ) {
2015-02-04 21:51:32 +00:00
try {
2015-02-05 18:04:03 +00:00
expr rule = get_rewrite_rule ( orig_elem ) ;
2015-02-04 21:51:32 +00:00
auto rcs = m_elab ( m_g , m_ngen . mk_child ( ) , rule , false ) ;
rule = rcs . first ;
buffer < constraint > cs ;
to_buffer ( rcs . second , cs ) ;
constraint_seq cs_seq ;
expr rule_type = m_tc - > whnf ( m_tc - > infer ( rule , cs_seq ) , cs_seq ) ;
while ( is_pi ( rule_type ) ) {
expr meta ;
if ( binding_info ( rule_type ) . is_inst_implicit ( ) ) {
auto mc = mk_class_instance_elaborator ( binding_domain ( rule_type ) ) ;
meta = mc . first ;
cs_seq + = mc . second ;
} else {
meta = mk_meta ( binding_domain ( rule_type ) ) ;
}
rule_type = m_tc - > whnf ( instantiate ( binding_body ( rule_type ) , meta ) , cs_seq ) ;
rule = mk_app ( rule , meta ) ;
}
lean_assert ( is_eq ( rule_type ) ) ;
2015-02-05 18:04:03 +00:00
bool symm = get_rewrite_info ( orig_elem ) . symm ( ) ;
2015-02-04 21:51:32 +00:00
expr src ;
if ( symm )
src = app_arg ( rule_type ) ;
else
src = app_arg ( app_fn ( rule_type ) ) ;
if ( ! m_tc - > is_def_eq ( t , src , justification ( ) , cs_seq ) )
return unify_result ( ) ;
cs_seq . linearize ( cs ) ;
unifier_config cfg ;
2015-02-06 03:08:47 +00:00
cfg . m_conservative = false ;
cfg . m_discard = true ;
2015-02-04 21:51:32 +00:00
unify_result_seq rseq = unify ( m_env , cs . size ( ) , cs . data ( ) , m_ngen . mk_child ( ) , m_subst , cfg ) ;
if ( auto p = rseq . pull ( ) ) {
substitution new_subst = p - > first . first ;
rule = new_subst . instantiate_all ( rule ) ;
rule_type = new_subst . instantiate_all ( rule_type ) ;
if ( has_expr_metavar_strict ( rule ) | | has_expr_metavar_strict ( rule_type ) )
2015-02-05 21:59:55 +00:00
return unify_result ( ) ; // rule was not completely instantiated.
2015-02-04 21:51:32 +00:00
m_subst = new_subst ;
expr lhs = app_arg ( app_fn ( rule_type ) ) ;
expr rhs = app_arg ( rule_type ) ;
2015-02-05 04:04:19 +00:00
if ( is_goal ) {
if ( symm ) {
return unify_result ( rule , lhs ) ;
} else {
rule = mk_symm ( * m_tc , rule ) ;
return unify_result ( rule , rhs ) ;
}
2015-02-04 21:51:32 +00:00
} else {
2015-02-05 04:04:19 +00:00
if ( symm ) {
rule = mk_symm ( * m_tc , rule ) ;
return unify_result ( rule , lhs ) ;
} else {
return unify_result ( rule , rhs ) ;
}
2015-02-04 21:51:32 +00:00
}
}
} catch ( exception & ) { }
return unify_result ( ) ;
}
2015-02-05 04:04:19 +00:00
// target, new_target, H : represents the rewrite (H : target = new_target) for hypothesis and (H : new_target = target) for goals
2015-02-04 21:51:32 +00:00
typedef optional < std : : tuple < expr , expr , expr > > find_result ;
// Search for \c pattern in \c e. If \c t is a match, then try to unify the type of the rule
2015-02-05 18:04:03 +00:00
// in the rewrite step \c orig_elem with \c t.
2015-02-04 21:51:32 +00:00
// When successful, this method returns the target \c t, the fully elaborated rule \c r,
// and the new value \c new_t (i.e., the expression that will replace \c t).
2015-02-05 04:04:19 +00:00
//
// \remark is_goal == true if \c e is the type of a goal. Otherwise, it is assumed to be the type
// of a hypothesis. This flag affects the equality proof built by this method.
2015-02-05 18:04:03 +00:00
find_result find_target ( expr const & e , expr const & pattern , expr const & orig_elem , bool is_goal ) {
2015-02-04 21:51:32 +00:00
find_result result ;
2015-02-04 17:59:34 +00:00
for_each ( e , [ & ] ( expr const & t , unsigned ) {
2015-02-04 21:51:32 +00:00
if ( result )
2015-02-04 17:59:34 +00:00
return false ; // stop search
if ( closed ( t ) ) {
lean_assert ( std : : all_of ( m_esubst . begin ( ) , m_esubst . end ( ) , [ & ] ( optional < expr > const & e ) { return ! e ; } ) ) ;
bool assigned = false ;
bool r = match ( pattern , t , m_lsubst , m_esubst , nullptr , nullptr , & m_mplugin , & assigned ) ;
if ( assigned )
reset_subst ( ) ;
if ( r ) {
2015-02-05 18:04:03 +00:00
if ( auto p = unify_target ( t , orig_elem , is_goal ) ) {
2015-02-04 23:17:58 +00:00
result = std : : make_tuple ( t , p - > second , p - > first ) ;
2015-02-04 21:51:32 +00:00
return false ;
}
2015-02-04 17:59:34 +00:00
}
}
return true ;
} ) ;
2015-02-04 21:51:32 +00:00
return result ;
2015-02-04 17:59:34 +00:00
}
2015-02-05 18:04:03 +00:00
bool process_rewrite_hypothesis ( expr const & hyp , expr const & orig_elem , expr const & pattern , occurrence const & occ ) {
2015-02-05 04:04:19 +00:00
expr Pa = mlocal_type ( hyp ) ;
bool is_goal = false ;
2015-02-05 18:04:03 +00:00
if ( auto it = find_target ( Pa , pattern , orig_elem , is_goal ) ) {
2015-02-05 04:04:19 +00:00
expr a , Heq , b ; // Heq is a proof of a = b
std : : tie ( a , b , Heq ) = * it ;
2015-02-04 23:17:58 +00:00
2015-02-05 04:04:19 +00:00
bool has_dep_elim = inductive : : has_dep_elim ( m_env , get_eq_name ( ) ) ;
unsigned vidx = has_dep_elim ? 1 : 0 ;
expr Px = replace_occurrences ( Pa , a , occ , vidx ) ;
expr Pb = instantiate ( Px , vidx , b ) ;
expr A = m_tc - > infer ( a ) . first ;
level l1 = sort_level ( m_tc - > ensure_type ( Pa ) . first ) ;
level l2 = sort_level ( m_tc - > ensure_type ( A ) . first ) ;
expr H ;
if ( has_dep_elim ) {
expr Haeqx = mk_app ( mk_constant ( get_eq_name ( ) , { l1 } ) , A , b , mk_var ( 0 ) ) ;
expr P = mk_lambda ( " x " , A , mk_lambda ( " H " , Haeqx , Px ) ) ;
H = mk_app ( { mk_constant ( get_eq_rec_name ( ) , { l1 , l2 } ) , A , a , P , hyp , b , Heq } ) ;
} else {
H = mk_app ( { mk_constant ( get_eq_rec_name ( ) , { l1 , l2 } ) , A , a , mk_lambda ( " x " , A , Px ) , hyp , b , Heq } ) ;
}
expr new_hyp = update_mlocal ( hyp , Pb ) ;
buffer < expr > new_hyps ;
buffer < expr > args ;
m_g . get_hyps ( new_hyps ) ;
for ( expr & h : new_hyps ) {
if ( mlocal_name ( h ) = = mlocal_name ( hyp ) ) {
h = new_hyp ;
args . push_back ( H ) ;
} else {
args . push_back ( h ) ;
}
}
expr new_type = m_g . get_type ( ) ;
expr new_mvar = mk_metavar ( m_ngen . next ( ) , Pi ( new_hyps , new_type ) ) ;
expr new_meta = mk_app ( new_mvar , new_hyps ) ;
goal new_g ( new_meta , new_type ) ;
expr val = m_g . abstract ( mk_app ( new_mvar , args ) ) ;
m_subst . assign ( m_g . get_name ( ) , val ) ;
update_goal ( new_g ) ;
return true ;
}
2015-02-04 17:59:34 +00:00
return false ;
}
2015-02-05 18:04:03 +00:00
bool process_rewrite_goal ( expr const & orig_elem , expr const & pattern , occurrence const & occ ) {
2015-02-05 04:04:19 +00:00
expr Pa = m_g . get_type ( ) ;
bool is_goal = true ;
2015-02-05 18:04:03 +00:00
if ( auto it = find_target ( Pa , pattern , orig_elem , is_goal ) ) {
2015-02-04 23:17:58 +00:00
expr a , Heq , b ;
std : : tie ( a , b , Heq ) = * it ;
2015-02-05 04:04:19 +00:00
// Given (a, b, P[a], Heq : b = a, occ), return (P[b], M : P[b], H : P[a])
// where M is a metavariable application of a fresh metavariable, and H is a witness (based on M) for P[a].
bool has_dep_elim = inductive : : has_dep_elim ( m_env , get_eq_name ( ) ) ;
unsigned vidx = has_dep_elim ? 1 : 0 ;
expr Px = replace_occurrences ( Pa , a , occ , vidx ) ;
expr Pb = instantiate ( Px , vidx , b ) ;
expr A = m_tc - > infer ( a ) . first ;
level l1 = sort_level ( m_tc - > ensure_type ( Pa ) . first ) ;
level l2 = sort_level ( m_tc - > ensure_type ( A ) . first ) ;
expr M = m_g . mk_meta ( m_ngen . next ( ) , Pb ) ;
expr H ;
if ( has_dep_elim ) {
expr Haeqx = mk_app ( mk_constant ( get_eq_name ( ) , { l1 } ) , A , b , mk_var ( 0 ) ) ;
expr P = mk_lambda ( " x " , A , mk_lambda ( " H " , Haeqx , Px ) ) ;
H = mk_app ( { mk_constant ( get_eq_rec_name ( ) , { l1 , l2 } ) , A , b , P , M , a , Heq } ) ;
} else {
H = mk_app ( { mk_constant ( get_eq_rec_name ( ) , { l1 , l2 } ) , A , b , mk_lambda ( " x " , A , Px ) , M , a , Heq } ) ;
}
2015-02-04 23:17:58 +00:00
goal new_g ( M , Pb ) ;
expr val = m_g . abstract ( H ) ;
m_subst . assign ( m_g . get_name ( ) , val ) ;
update_goal ( new_g ) ;
// regular(m_env, m_ios) << "FOUND\n" << a << "\n==>\n" << b << "\nWITH\n" << Heq << "\n";
// regular(m_env, m_ios) << H << "\n";
return true ;
2015-02-04 17:59:34 +00:00
}
2015-02-04 21:51:32 +00:00
return false ;
2015-02-04 17:59:34 +00:00
}
2015-02-05 18:04:03 +00:00
bool process_rewrite_single_step ( expr const & orig_elem , expr const & pattern ) {
2015-02-04 17:59:34 +00:00
check_system ( " rewrite tactic " ) ;
2015-02-05 18:04:03 +00:00
rewrite_info const & info = get_rewrite_info ( orig_elem ) ;
2015-02-04 17:59:34 +00:00
location const & loc = info . get_location ( ) ;
if ( loc . is_goal_only ( ) )
2015-02-05 18:04:03 +00:00
return process_rewrite_goal ( orig_elem , pattern , * loc . includes_goal ( ) ) ;
2015-02-04 17:59:34 +00:00
bool progress = false ;
buffer < expr > hyps ;
m_g . get_hyps ( hyps ) ;
for ( expr const & h : hyps ) {
2015-02-04 23:17:58 +00:00
auto occ = loc . includes_hypothesis ( local_pp_name ( h ) ) ;
if ( ! occ )
2015-02-04 17:59:34 +00:00
continue ;
2015-02-05 18:04:03 +00:00
if ( process_rewrite_hypothesis ( h , orig_elem , pattern , * occ ) )
2015-02-04 23:17:58 +00:00
progress = true ;
}
if ( auto occ = loc . includes_goal ( ) ) {
2015-02-05 18:04:03 +00:00
if ( process_rewrite_goal ( orig_elem , pattern , * occ ) )
2015-02-04 17:59:34 +00:00
progress = true ;
}
return progress ;
2015-02-03 03:20:24 +00:00
}
2015-02-04 17:59:34 +00:00
2015-02-05 00:13:15 +00:00
void check_max_iter ( unsigned i ) {
if ( i > = m_max_iter )
throw_max_iter_exceeded ( ) ;
}
2015-02-05 18:04:03 +00:00
bool process_rewrite_step ( expr const & elem , expr const & orig_elem ) {
2015-02-04 17:59:34 +00:00
lean_assert ( is_rewrite_step ( elem ) ) ;
expr pattern = get_pattern ( elem ) ;
2015-02-04 23:17:58 +00:00
// regular(m_env, m_ios) << "pattern: " << pattern << "\n";
2015-02-04 17:59:34 +00:00
rewrite_info const & info = get_rewrite_info ( elem ) ;
2015-02-05 00:13:15 +00:00
unsigned i , num ;
2015-02-04 17:59:34 +00:00
switch ( info . get_multiplicity ( ) ) {
case rewrite_info : : Once :
2015-02-05 18:04:03 +00:00
return process_rewrite_single_step ( orig_elem , pattern ) ;
2015-02-04 17:59:34 +00:00
case rewrite_info : : AtMostN :
num = info . num ( ) ;
2015-02-05 00:13:15 +00:00
for ( i = 0 ; i < std : : min ( num , m_max_iter ) ; i + + ) {
2015-02-05 18:04:03 +00:00
if ( ! process_rewrite_single_step ( orig_elem , pattern ) )
2015-02-04 17:59:34 +00:00
return true ;
}
2015-02-05 00:13:15 +00:00
check_max_iter ( i ) ;
2015-02-04 17:59:34 +00:00
return true ;
case rewrite_info : : ExactlyN :
num = info . num ( ) ;
2015-02-05 00:13:15 +00:00
for ( i = 0 ; i < std : : min ( num , m_max_iter ) ; i + + ) {
2015-02-05 18:04:03 +00:00
if ( ! process_rewrite_single_step ( orig_elem , pattern ) )
2015-02-04 17:59:34 +00:00
return false ;
}
2015-02-05 00:13:15 +00:00
check_max_iter ( i ) ;
2015-02-04 17:59:34 +00:00
return true ;
case rewrite_info : : ZeroOrMore :
2015-02-05 00:13:15 +00:00
for ( i = 0 ; i < m_max_iter ; i + + ) {
2015-02-05 18:04:03 +00:00
if ( ! process_rewrite_single_step ( orig_elem , pattern ) )
2015-02-04 17:59:34 +00:00
return true ;
}
2015-02-05 00:13:15 +00:00
throw_max_iter_exceeded ( ) ;
2015-02-04 17:59:34 +00:00
case rewrite_info : : OneOrMore :
2015-02-05 18:04:03 +00:00
if ( ! process_rewrite_single_step ( orig_elem , pattern ) )
2015-02-04 17:59:34 +00:00
return false ;
2015-02-05 00:13:15 +00:00
for ( i = 0 ; i < m_max_iter ; i + + ) {
2015-02-05 18:04:03 +00:00
if ( ! process_rewrite_single_step ( orig_elem , pattern ) )
2015-02-04 17:59:34 +00:00
return true ;
}
2015-02-05 00:13:15 +00:00
throw_max_iter_exceeded ( ) ;
2015-02-04 17:59:34 +00:00
}
lean_unreachable ( ) ;
}
// Process the given rewrite element/step. This method destructively update
// m_g, m_subst, m_ngen. It returns true if it succeeded and false otherwise.
2015-02-05 18:01:18 +00:00
bool process_step ( expr const & elem ) {
2015-02-04 17:59:34 +00:00
if ( is_rewrite_unfold_step ( elem ) ) {
return process_unfold_step ( elem ) ;
2015-02-05 21:42:50 +00:00
} else if ( is_rewrite_reduce_step ( elem ) ) {
return process_reduce_step ( elem ) ;
2015-02-04 17:59:34 +00:00
} else {
2015-02-05 18:01:18 +00:00
expr rule = get_rewrite_rule ( elem ) ;
expr new_elem ;
if ( has_rewrite_pattern ( elem ) ) {
expr pattern = m_elab ( m_g , m_ngen . mk_child ( ) , get_rewrite_pattern ( elem ) , false ) . first ;
expr new_args [ 2 ] = { rule , pattern } ;
new_elem = mk_macro ( macro_def ( elem ) , 2 , new_args ) ;
} else {
rule = m_elab ( m_g , m_ngen . mk_child ( ) , rule , false ) . first ;
new_elem = mk_macro ( macro_def ( elem ) , 1 , & rule ) ;
}
return process_rewrite_step ( new_elem , elem ) ;
2015-02-04 17:59:34 +00:00
}
}
2015-02-04 23:29:52 +00:00
bool check_trivial_goal ( ) {
expr type = m_g . get_type ( ) ;
if ( is_eq ( type ) ) {
constraint_seq cs ;
expr lhs = app_arg ( app_fn ( type ) ) ;
expr rhs = app_arg ( type ) ;
if ( m_tc - > is_def_eq ( lhs , rhs , justification ( ) , cs ) & & ! cs ) {
expr H = mk_refl ( * m_tc , lhs ) ;
m_subst . assign ( m_g . get_name ( ) , m_g . abstract ( H ) ) ;
return true ;
} else {
return false ;
}
} else if ( type = = mk_true ( ) ) {
m_subst . assign ( m_g . get_name ( ) , mk_constant ( get_eq_intro_name ( ) ) ) ;
return true ;
} else {
return false ;
}
}
2015-02-06 21:27:33 +00:00
type_checker_ptr mk_matcher_tc ( ) {
if ( get_rewriter_syntactic ( m_ios . get_options ( ) ) ) {
// use an everything opaque converter
return mk_opaque_type_checker ( m_env , m_ngen . mk_child ( ) ) ;
} else {
return m_tc ;
}
}
2015-02-04 17:59:34 +00:00
public :
rewrite_fn ( environment const & env , io_state const & ios , elaborate_fn const & elab , proof_state const & ps ) :
m_env ( env ) , m_ios ( ios ) , m_elab ( elab ) , m_ps ( ps ) , m_ngen ( ps . get_ngen ( ) ) ,
m_tc ( mk_type_checker ( m_env , m_ngen . mk_child ( ) , ps . relax_main_opaque ( ) ) ) ,
2015-02-06 21:27:33 +00:00
m_matcher_tc ( mk_matcher_tc ( ) ) ,
m_mplugin ( m_ios , * m_matcher_tc ) {
2015-02-04 17:59:34 +00:00
goals const & gs = m_ps . get_goals ( ) ;
lean_assert ( gs ) ;
2015-02-04 21:51:32 +00:00
update_goal ( head ( gs ) ) ;
2015-02-04 17:59:34 +00:00
m_subst = m_ps . get_subst ( ) ;
2015-02-05 00:13:15 +00:00
m_max_iter = get_rewriter_max_iterations ( ios . get_options ( ) ) ;
2015-02-04 17:59:34 +00:00
}
proof_state_seq operator ( ) ( buffer < expr > const & elems ) {
2015-02-05 18:01:18 +00:00
for ( expr const & elem : elems ) {
flet < expr > set1 ( m_expr_loc , elem ) ;
if ( ! process_step ( elem ) ) {
2015-02-04 17:59:34 +00:00
return proof_state_seq ( ) ;
}
}
2015-02-04 23:29:52 +00:00
goals new_gs ;
if ( check_trivial_goal ( ) )
new_gs = tail ( m_ps . get_goals ( ) ) ;
else
new_gs = cons ( m_g , tail ( m_ps . get_goals ( ) ) ) ;
2015-02-04 23:17:58 +00:00
proof_state new_ps ( m_ps , new_gs , m_subst , m_ngen ) ;
return proof_state_seq ( new_ps ) ;
2015-02-04 17:59:34 +00:00
}
} ;
tactic mk_rewrite_tactic ( elaborate_fn const & elab , buffer < expr > const & elems ) {
return tactic ( [ = ] ( environment const & env , io_state const & ios , proof_state const & s ) {
goals const & gs = s . get_goals ( ) ;
if ( empty ( gs ) )
return proof_state_seq ( ) ;
return rewrite_fn ( env , ios , elab , s ) ( elems ) ;
} ) ;
2015-02-03 00:03:06 +00:00
}
void initialize_rewrite_tactic ( ) {
2015-02-05 00:13:15 +00:00
g_rewriter_max_iterations = new name { " rewriter " , " max_iter " } ;
register_unsigned_option ( * g_rewriter_max_iterations , LEAN_DEFAULT_REWRITER_MAX_ITERATIONS , " (rewriter tactic) maximum number of iterations " ) ;
2015-02-06 21:27:33 +00:00
g_rewriter_syntactic = new name { " rewriter " , " syntactic " } ;
register_bool_option ( * g_rewriter_syntactic , LEAN_DEFAULT_REWRITER_SYNTACTIC , " (rewriter tactic) if true tactic will not unfold any constant when performing pattern matching " ) ;
2015-02-03 00:03:06 +00:00
name rewrite_tac_name { " tactic " , " rewrite_tac " } ;
2015-02-03 03:20:24 +00:00
g_rewrite_tac = new expr ( Const ( rewrite_tac_name ) ) ;
2015-02-05 21:16:05 +00:00
g_rewrite_reduce_name = new name ( " rewrite_reduce " ) ;
g_rewrite_reduce_opcode = new std : : string ( " RWR " ) ;
2015-02-03 03:20:24 +00:00
g_rewrite_unfold_name = new name ( " rewrite_unfold " ) ;
g_rewrite_unfold_opcode = new std : : string ( " RWU " ) ;
g_rewrite_elem_name = new name ( " rewrite_element " ) ;
g_rewrite_elem_opcode = new std : : string ( " RWE " ) ;
2015-02-05 21:16:05 +00:00
register_macro_deserializer ( * g_rewrite_reduce_opcode ,
[ ] ( deserializer & d , unsigned num , expr const * args ) {
if ( num > 1 )
throw corrupted_stream_exception ( ) ;
2015-02-05 21:42:50 +00:00
reduce_info info ;
2015-02-05 21:16:05 +00:00
d > > info ;
if ( num = = 0 )
return mk_rewrite_reduce ( info . get_location ( ) ) ;
else
return mk_rewrite_reduce_to ( args [ 0 ] , info . get_location ( ) ) ;
} ) ;
2015-02-03 03:20:24 +00:00
register_macro_deserializer ( * g_rewrite_unfold_opcode ,
2015-02-03 00:03:06 +00:00
[ ] ( deserializer & d , unsigned num , expr const * ) {
if ( num ! = 0 )
throw corrupted_stream_exception ( ) ;
2015-02-03 03:20:24 +00:00
unfold_info info ;
d > > info ;
macro_definition def ( new rewrite_unfold_macro_cell ( info ) ) ;
return mk_macro ( def ) ;
} ) ;
register_macro_deserializer ( * g_rewrite_elem_opcode ,
[ ] ( deserializer & d , unsigned num , expr const * args ) {
if ( num ! = 1 & & num ! = 2 )
throw corrupted_stream_exception ( ) ;
rewrite_info info ;
d > > info ;
macro_definition def ( new rewrite_element_macro_cell ( info ) ) ;
return mk_macro ( def , num , args ) ;
2015-02-03 00:03:06 +00:00
} ) ;
register_tac ( rewrite_tac_name ,
2015-02-04 17:59:34 +00:00
[ ] ( type_checker & , elaborate_fn const & elab , expr const & e , pos_info_provider const * ) {
2015-02-03 03:20:24 +00:00
buffer < expr > args ;
get_tactic_expr_list_elements ( app_arg ( e ) , args , " invalid 'rewrite' tactic, invalid argument " ) ;
for ( expr const & arg : args ) {
2015-02-05 21:42:50 +00:00
if ( ! is_rewrite_step ( arg ) & & ! is_rewrite_unfold_step ( arg ) & & ! is_rewrite_reduce_step ( arg ) )
2015-02-03 03:20:24 +00:00
throw expr_to_tactic_exception ( e , " invalid 'rewrite' tactic, invalid argument " ) ;
}
2015-02-04 17:59:34 +00:00
return mk_rewrite_tactic ( elab , args ) ;
2015-02-03 00:03:06 +00:00
} ) ;
}
void finalize_rewrite_tactic ( ) {
2015-02-05 02:40:11 +00:00
delete g_rewriter_max_iterations ;
2015-02-03 00:03:06 +00:00
delete g_rewrite_tac ;
2015-02-03 03:20:24 +00:00
delete g_rewrite_unfold_name ;
delete g_rewrite_unfold_opcode ;
2015-02-05 21:42:50 +00:00
delete g_rewrite_reduce_name ;
delete g_rewrite_reduce_opcode ;
2015-02-03 03:20:24 +00:00
delete g_rewrite_elem_name ;
delete g_rewrite_elem_opcode ;
2015-02-03 00:03:06 +00:00
}
}