- CicTypeChecker.TypeCheckerFailure s ->
- MatitaLog.message
- ("Unable to create projection " ^ name ^ " cause: " ^ s);
- status
- | CicEnvironment.Object_not_found uri ->
- let depend = UriManager.name_of_uri uri in
- MatitaLog.message
- ("Unable to create projection " ^ name ^ " because it requires " ^ depend);
- status
- ) status projections
-
-let eval_command status cmd =
- match cmd with
- | TacticAst.Set (loc, name, value) -> set_option status name value
- | TacticAst.Qed loc ->
- let uri, metasenv, bo, ty =
- match status.proof_status with
- | Proof (Some uri, metasenv, body, ty) ->
- uri, metasenv, body, ty
- | Proof (None, metasenv, body, ty) ->
- command_error
- ("Someone allows to start a thm without giving the "^
- "name/uri. This should be fixed!")
- | _-> command_error "You can't qed an uncomplete theorem"
- in
- let suri = UriManager.string_of_uri uri in
- if metasenv <> [] then
- command_error "Proof not completed! metasenv is not empty!";
- let name = UriManager.name_of_uri uri in
- let obj = Cic.Constant (name,Some bo,ty,[],[]) in
- MatitaSync.add_obj uri obj status
- | TacticAst.Coercion (loc, coercion) ->
- eval_coercion status coercion
- | TacticAst.Alias (loc, spec) ->
- (match spec with
- | TacticAst.Ident_alias (id,uri) ->
- {status with aliases =
- DisambiguateTypes.Environment.add
- (DisambiguateTypes.Id id)
- ("boh?",(fun _ _ _ -> CicUtil.term_of_uri (UriManager.uri_of_string uri)))
- status.aliases }
- | TacticAst.Symbol_alias (symb, instance, desc) ->
- {status with aliases =
- DisambiguateTypes.Environment.add
- (DisambiguateTypes.Symbol (symb,instance))
- (DisambiguateChoices.lookup_symbol_by_dsc symb desc)
- status.aliases }
- | TacticAst.Number_alias (instance,desc) ->
- {status with aliases =
- DisambiguateTypes.Environment.add
- (DisambiguateTypes.Num instance)
- (DisambiguateChoices.lookup_num_by_dsc desc) status.aliases })
- | TacticAst.Obj (loc,obj) ->
- let ext,name =
- match obj with
- Cic.Constant (name,_,_,_,_)
- | Cic.CurrentProof (name,_,_,_,_,_) -> ".con",name
- | Cic.InductiveDefinition (types,_,_,_) ->
- ".ind",
- (match types with (name,_,_,_)::_ -> name | _ -> assert false)
- | _ -> assert false in
- let uri =
- UriManager.uri_of_string (MatitaMisc.qualify status name ^ ext)
- in
- let metasenv = MatitaMisc.get_proof_metasenv status in
- match obj with
- Cic.CurrentProof (_,metasenv',bo,ty,_,_) ->
- assert (metasenv = metasenv');
- let goalno =
- match metasenv' with (goalno,_,_)::_ -> goalno | _ -> assert false in
- let initial_proof = (Some uri, metasenv, bo, ty) in
- { status with proof_status = Incomplete_proof (initial_proof,goalno)}
- | _ ->
- if metasenv <> [] then
- command_error (
- "metasenv not empty while giving a definition with body: " ^
- CicMetaSubst.ppmetasenv metasenv []);
- let status = MatitaSync.add_obj uri obj status in
- match obj with
- Cic.Constant _ -> status
- | Cic.InductiveDefinition (_,_,_,attrs) ->
- let status = generate_elimination_principles uri status in
- let rec get_record_attrs =
- function
- [] -> None
- | (`Class (`Record fields))::_ -> Some fields
- | _::tl -> get_record_attrs tl
- in
- (match get_record_attrs attrs with
- None -> status (* not a record *)
- | Some fields -> generate_projections uri fields status)
- | Cic.CurrentProof _
- | Cic.Variable _ -> assert false
-
-let eval_executable status ex =
- match ex with
- | TacticAst.Tactical (_, tac) -> eval_tactical status tac
- | TacticAst.Command (_, cmd) -> eval_command status cmd
- | TacticAst.Macro (_, mac) ->
- command_error (sprintf "The macro %s can't be in a script"
- (TacticAstPp.pp_macro_cic mac))
-
-let eval_comment status c = status
-
-let eval status st =
- match st with
- | TacticAst.Executable (_,ex) -> eval_executable status ex
- | TacticAst.Comment (_,c) -> eval_comment status c
-
-let disambiguate_term status term =
- let (aliases, metasenv, cic, _) =
- match
- MatitaDisambiguator.disambiguate_term ~dbd:(MatitaDb.instance ())
- ~aliases:(status.aliases) ~context:(MatitaMisc.get_proof_context status)
- ~metasenv:(MatitaMisc.get_proof_metasenv status) term
- with
- | [x] -> x
- | _ -> assert false
- in
- let proof_status =
- match status.proof_status with
- | No_proof -> Intermediate metasenv
- | Incomplete_proof ((uri, _, proof, ty), goal) ->
- Incomplete_proof ((uri, metasenv, proof, ty), goal)
- | Intermediate _ -> Intermediate metasenv
- | Proof _ -> assert false
- in
- let status =
- { status with
- aliases = aliases;
- proof_status = proof_status }
- in
- status, cic
-
-let disambiguate_obj status obj =
- let uri =
- match obj with
- TacticAst.Inductive (_,(name,_,_,_)::_)
- | TacticAst.Record (_,name,_,_) ->
- Some (UriManager.uri_of_string (MatitaMisc.qualify status name ^ ".ind"))
- | TacticAst.Inductive _ -> assert false
- | _ -> None in
- let (aliases, metasenv, cic, _) =
- match
- MatitaDisambiguator.disambiguate_obj ~dbd:(MatitaDb.instance ())
- ~aliases:(status.aliases) ~uri obj
- with
- | [x] -> x
- | _ -> assert false
- in
- let proof_status =
- match status.proof_status with
- | No_proof -> Intermediate metasenv
- | Incomplete_proof _
- | Intermediate _
- | Proof _ -> assert false
- in
- let status =
- { status with
- aliases = aliases;
- proof_status = proof_status }
- in
- status, cic
-
-let disambiguate_tactic status = function
- | TacticAst.Transitivity (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Transitivity (loc, cic)
- | TacticAst.Apply (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Apply (loc, cic)
- | TacticAst.Absurd (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Absurd (loc, cic)
- | TacticAst.Exact (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Exact (loc, cic)
- | TacticAst.Cut (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Cut (loc, cic)
- | TacticAst.Elim (loc, term, Some term') ->
- let status, cic1 = disambiguate_term status term in
- let status, cic2 = disambiguate_term status term' in
- status, TacticAst.Elim (loc, cic1, Some cic2)
- | TacticAst.Elim (loc, term, None) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.Elim (loc, cic, None)
- | TacticAst.ElimType (loc, term) ->
- let status, cic = disambiguate_term status term in
- status, TacticAst.ElimType (loc, cic)
- | TacticAst.Replace (loc, what, with_what) ->
- let status, cic1 = disambiguate_term status what in
- let status, cic2 = disambiguate_term status with_what in
- status, TacticAst.Replace (loc, cic1, cic2)
- | TacticAst.Change (loc, what, with_what, ident) ->
- let status, cic1 = disambiguate_term status what in
- let status, cic2 = disambiguate_term status with_what in
- status, TacticAst.Change (loc, cic1, cic2, ident)
-(*
- (* TODO Zack a lot more of tactics to be implemented here ... *)
- | TacticAst.Change_pattern of 'term pattern * 'term * 'ident option
- | TacticAst.Change of 'term * 'term * 'ident option
- | TacticAst.Decompose of 'ident * 'ident list
- | TacticAst.Discriminate of 'ident
- | TacticAst.Fold of reduction_kind * 'term
- | TacticAst.Injection of 'ident
- | TacticAst.Replace_pattern of 'term pattern * 'term
-*)
- | TacticAst.LetIn (loc,term,name) ->
- let status, term = disambiguate_term status term in
- status, TacticAst.LetIn (loc,term,name)
- | TacticAst.ReduceAt (loc, reduction_kind, ident, path) ->
- let path = Disambiguate.interpretate_path [] status.aliases path in
- status, TacticAst.ReduceAt(loc, reduction_kind, ident, path)
- | TacticAst.Reduce (loc, reduction_kind, opts) ->
- let status, opts =
- match opts with
- | None -> status, None
- | Some (l,pat) ->
- let status, l =
- List.fold_right (fun t (status,acc) ->
- let status',t' = disambiguate_term status t in
- status', t'::acc)
- l (status,[])
- in
- status, Some (l, pat)
- in
- status, TacticAst.Reduce (loc, reduction_kind, opts)
- | TacticAst.Rewrite (loc,dir,t,ident) ->
- let status, term = disambiguate_term status t in
- status, TacticAst.Rewrite (loc,dir,term,ident)
- | TacticAst.Intros (loc, num, names) ->
- status, TacticAst.Intros (loc, num, names)
- | TacticAst.Auto (loc,num) -> status, TacticAst.Auto (loc,num)
- | TacticAst.Reflexivity loc -> status, TacticAst.Reflexivity loc
- | TacticAst.Assumption loc -> status, TacticAst.Assumption loc
- | TacticAst.Contradiction loc -> status, TacticAst.Contradiction loc
- | TacticAst.Exists loc -> status, TacticAst.Exists loc
- | TacticAst.Fourier loc -> status, TacticAst.Fourier loc
- | TacticAst.Left loc -> status, TacticAst.Left loc
- | TacticAst.Right loc -> status, TacticAst.Right loc
- | TacticAst.Ring loc -> status, TacticAst.Ring loc
- | TacticAst.Split loc -> status, TacticAst.Split loc
- | TacticAst.Symmetry loc -> status, TacticAst.Symmetry loc
- | TacticAst.Goal (loc, g) -> status, TacticAst.Goal (loc, g)
- | TacticAst.FwdSimpl (loc, name) -> status, TacticAst.FwdSimpl (loc, name)
- | TacticAst.LApply (loc, term, substs) ->
- let f (status, substs) (name, term) =
- let status, term = disambiguate_term status term in
- status, (name, term) :: substs