From b1b75794f6e816ba3626e18953de85c0d90b949b Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Tue, 15 Sep 2020 17:28:02 +0200 Subject: [PATCH 01/17] Add first versions of proof tactics #159 --- base/coq/Free.v | 1 + base/coq/Free/Tactic/ProveForall.v | 117 +++++++++++++++++++++++++++++ base/coq/Free/Tactic/ProveInd.v | 90 +++++++++++++++++++--- 3 files changed, 198 insertions(+), 10 deletions(-) create mode 100644 base/coq/Free/Tactic/ProveForall.v diff --git a/base/coq/Free.v b/base/coq/Free.v index 9acf70e7..e081ec8e 100644 --- a/base/coq/Free.v +++ b/base/coq/Free.v @@ -4,4 +4,5 @@ From Base Require Export Free.Induction. From Base Require Export Free.Malias. From Base Require Export Free.Monad. From Base Require Export Free.Tactic.ProveInd. +From Base Require Export Free.Tactic.ProveForall. From Base Require Export Free.Tactic.Simplify. diff --git a/base/coq/Free/Tactic/ProveForall.v b/base/coq/Free/Tactic/ProveForall.v new file mode 100644 index 00000000..cd09df6a --- /dev/null +++ b/base/coq/Free/Tactic/ProveForall.v @@ -0,0 +1,117 @@ +(* This file contains the tactic [prove_forall] that proofs such a the + [ForallT_a_forall] lemmas for datatypes. + For each type variable [a] of each datatype [T] that has strong induction + schemes, there should be the inductive properties [ForT_a] and [InT_a] as + well as a lemma [ForT_a_forall] that states the connection between these + values. *) + +From Base Require Import Free.ForFree. + +Require Import Coq.Program.Equality. + +Ltac forall_ForType_InType forType inType forType_forall := + match goal with + | [ HF : forType _ ?fx + , HI : inType ?x ?fx + |- _ ] => + rewrite forType_forall in HF; + specialize (HF x HI) + end. + +Ltac forall_ForFree_InFree := + match goal with + | [ HF : ForFree ?Shape ?Pos ?T _ ?fx + , HI : InFree ?Shape ?Pos ?T ?x ?fx + |- _ ] => + rewrite ForFree_forall in HF; + specialize (HF x HI) + end. + +Ltac forall_trivial := + match goal with + | [ H : ?P |- ?P ] => apply H + end. + +Ltac forall_trivial_imp2 := + match goal with + | [ HImp : ?TF -> ?TI -> ?P + , HF : ?TF + , HI : ?TI + |- ?P ] => + apply (HImp HF HI) + end. + +Hint Extern 0 => forall_trivial : prove_forall_db. +Hint Extern 0 => forall_trivial_imp2 : prove_forall_db. +Hint Extern 0 => forall_ForFree_InFree : prove_forall_db. + +Ltac prove_forall Ind := + let P := fresh "P" + in let C := fresh "C" + in let HF := fresh "HF" + in let x := fresh "x" + in let HI := fresh "HI" + in let H := fresh "H" + in intros P C; split; + [ intros HF x HI; + induction C using Ind; + dependent destruction HI; + dependent destruction HF; + auto with prove_forall_db + | intro H; + induction C using Ind; + constructor; + auto with prove_forall_db2 + ]. + +Ltac forall_ForType forType forType_forall := + match goal with + | [ HF : forType _ ?fx + |- forType _ ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply forType_forall; intros x HI; + rewrite forType_forall in HF; + specialize (HF x HI) + | [ H : forall y : ?A, _ |- forType ?P ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply forType_forall; intros x HI; + specialize (H x) + end. + +Ltac forall_ForFree := + match goal with + | [ HF : ForFree ?Shape ?Pos ?T _ ?fx + |- ForFree ?Shape ?Pos ?T _ ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForFree_forall; intros x HI; + rewrite ForFree_forall in HF; + specialize (HF x HI) + | [ H : forall y : ?A, _ |- ForFree ?Shape ?Pos ?T ?P ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForFree_forall; intros x HI; + specialize (H x) + end. + +Ltac forall_finish := + match goal with + | [ H : ?TI -> ?P |- ?P ] => + apply H; constructor; trivial + end. + +Hint Extern 0 => forall_finish : prove_forall_db2. +Hint Extern 0 => forall_trivial : prove_forall_db2. +Hint Extern 0 => forall_ForFree : prove_forall_db2. + +Ltac forall_finish2 Con := + match goal with + | [ H1 : (forall y : ?A, _ -> ?P y) -> ?TF ?P ?C + , H2 : forall z : ?A, _ -> ?P z + |- ?TF ?P ?C ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply H1; intros x HI; apply H2; eauto using Con + end. diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index 3b42edc5..8d3b31cb 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -1,22 +1,34 @@ +(* This file contains tactics that help to prove induction schemes for types. + [prove_ind] is able to do such a proof if all required instances of + [prove_ind_prove_for_type] were added to [prove_ind_db]. *) + From Base Require Import Free.ForFree. From Base Require Import Free.Induction. From Base Require Import Free.Monad. Require Import Coq.Program.Equality. -Local Ltac is_fixpoint H P := +(* The hint database that contains instances of [prove_ind_prove_for_type]. *) +Create HintDb prove_ind_db. + +(* This tactic is needed to prevent [prove_ind_apply_assumption] from applying + the fixpoint hypothesis which would invalidify the proof. *) +Local Ltac prove_ind_is_fixpoint H P := match type of H with | forall x, P x => idtac end. +(* This tactic is applied at the beginning of the proof of an induction scheme + to introduce the induction hypotheses. *) Local Ltac prove_ind_apply_assumption := match goal with - | [ H : _ |- ?P ?x ] => tryif is_fixpoint H P then fail else apply H + | [ H : _ |- ?P ?x ] => tryif prove_ind_is_fixpoint H P then fail else apply H; clear H end. -Local Ltac prove_ind_prove_for_free FP := +(* This tactic eliminates the monadic layer of an induction hypothesis. *) +Local Ltac prove_ind_prove_ForFree := match goal with - | [ fx: Free ?Shape ?Pos ?T |- _ ] => + | [ fx : Free ?Shape ?Pos ?T |- _ ] => match goal with | [ |- ForFree Shape Pos T ?P fx ] => let x1 := fresh "x" @@ -25,17 +37,75 @@ Local Ltac prove_ind_prove_for_free FP := in let s := fresh "s" in let pf := fresh "pf" in let IHpf := fresh "IHpf" - in let p := fresh "p" in apply ForFree_forall; intros x1 H; induction fx as [ x2 | s pf IHpf ] using Free_Ind; - [ inversion H; subst; apply FP - | dependent destruction H; subst; destruct H as [ p ]; - apply (IHpf p); apply H ] + [ inversion H; subst; clear H + | dependent destruction H; + match goal with + | [ IHpf : forall p : Pos s, InFree Shape Pos T x1 (pf p) -> P x1 + , H : exists q : Pos s, InFree Shape Pos T x1 (pf q) + |- _ ] => + let p := fresh "p" + in destruct H as [ p ]; apply (IHpf p); apply H + end ] end end. +(* This tactic tries to finish the proof with an hypothesis with fulfilled + preconditions. *) +Local Ltac prove_ind_apply_hypothesis H := + match type of H with + | ?PC -> _ => + match goal with + | [ H2 : PC |- _ ] => specialize (H H2); prove_ind_apply_hypothesis H + end + | _ => apply H + end. + +(* This tactic eliminates intermediate monadic layers. *) +Local Ltac prove_ind_prove_for_free_in_free := + match goal with + | [ HIF : InFree ?Shape ?Pos ?T _ ?fx + , IH : ForFree ?Shape ?Pos ?T _ ?fx + |- _ ] => + rewrite ForFree_forall in IH; prove_ind_apply_hypothesis IH + | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx + |- ?P ?x ] => + let x1 := fresh "x" + in let s := fresh "s" + in let pf := fresh "pf" + in let IHpf := fresh "IHpf" + in induction fx as [ x1 | s pf IHpf ] using Free_Ind; + [ inversion HIF; subst; clear HIF + | dependent destruction HIF; + match goal with + | [H : exists p : Pos s, InFree Shape Pos T x (pf p) |- _ ] => + let p := fresh "p" + in destruct H as [ p H ]; apply (IHpf p H) + end + ] + end. + +(* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) +Ltac prove_ind_prove_for_type type forType forType_forall type_induction := + match goal with + | [ x : type |- _ ] => + match goal with + | [ |- forType ?P x ] => + let y := fresh "x" + in let H := fresh "H" + in apply forType_forall; + type_induction x; + intros y H; inversion H; subst; clear H; try prove_ind_prove_for_free_in_free + end + end. + +(* This tactic proves an induction scheme. *) Ltac prove_ind := match goal with - | [ FP : forall y, ?P y |- ?P ?x ] => - destruct x; prove_ind_apply_assumption; prove_ind_prove_for_free FP + | [ FP : forall x, ?P x |- _ ] => + match goal with + | [ |- P x] => destruct x; prove_ind_apply_assumption; prove_ind_prove_ForFree; + auto with prove_ind_db + end end. From 9bcabc68b4573a9e3a3643c36a301f67114f950f Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Tue, 15 Sep 2020 17:48:30 +0200 Subject: [PATCH 02/17] Add properties and hints for list and pair to base #159 --- base/coq/Prelude/List.v | 70 ++++++++++++++++++++++++ base/coq/Prelude/Pair.v | 117 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 187 insertions(+) diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index bdab5f69..8e0c0a88 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -174,3 +174,73 @@ Section SecFreeListInd. FreeList_rect Shape Pos A PF P NilFP ConsFP PureListF ImpureP fxs. End SecFreeListInd. + +(* ForList *) +Inductive ForList_A (Shape : Type) (Pos : Shape -> Type) (A : Type) (P : A -> Prop) + : List Shape Pos A -> Prop := + | ForList_A_nil : ForList_A Shape Pos A P (@nil Shape Pos A) + | ForList_A_cons : forall (fx : Free Shape Pos A) + (fxs : Free Shape Pos (List Shape Pos A)), + ForFree Shape Pos A P fx -> + ForFree Shape Pos (List Shape Pos A) (ForList_A Shape Pos A P) fxs -> + ForList_A Shape Pos A P (@cons Shape Pos A fx fxs). + +Inductive InList_A (Shape : Type) (Pos : Shape -> Type) (A : Type) + : A -> List Shape Pos A -> Prop := + | InList_A_cons_fx : forall (x : A) + (fx : Free Shape Pos A) + (fys : Free Shape Pos (List Shape Pos A)), + InFree Shape Pos A x fx -> + InList_A Shape Pos A x (cons fx fys) + | InList_A_cons_fxs : forall (x : A) + (xs : List Shape Pos A) + (fy : Free Shape Pos A) + (fys : Free Shape Pos (List Shape Pos A)), + InList_A Shape Pos A x xs -> + InFree Shape Pos (List Shape Pos A) xs fys -> + InList_A Shape Pos A x (cons fy fys). + +Lemma ForList_A_forall (Shape : Type) (Pos : Shape -> Type) + (A : Type) : forall + (P : A -> Prop) + (fl : List Shape Pos A), + ForList_A Shape Pos A P fl <-> (forall (x : A), InList_A Shape Pos A x fl -> P x). +Proof. + Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_A_cons_fx Shape Pos A) : prove_forall_db2. + Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_A_cons_fxs Shape Pos A) : prove_forall_db2. + prove_forall List_Ind. +Qed. + +(* Add hints for proof generation *) +Local Ltac list_induction x := induction x as [ | fx fxs IHfxs ] using List_Ind. +Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => prove_ind_prove_for_type + (List Shape Pos A) + (ForList_A Shape Pos A) + (ForList_A_forall Shape Pos A) + (list_induction) + : prove_ind_db. +Local Ltac forall_ForList_A_InList_A := + match goal with + | [ HF : ForList_A ?Shape ?Pos ?A _ ?fx + , HI : InList_A ?Shape ?Pos ?A ?x ?fx + |- _ ] => + rewrite ForList_A_forall in HF; + specialize (HF x HI) + end. +Hint Extern 0 => forall_ForList_A_InList_A : prove_forall_db. +Local Ltac forall_ForList_A := + match goal with + | [ HF : ForList_A ?Shape ?Pos ?T _ ?fx + |- ForList_A ?Shape ?Pos ?T _ ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForList_A_forall; intros x HI; + rewrite ForList_A_forall in HF; + specialize (HF x HI) + | [ H : forall y : ?A, _ |- ForList_A ?Shape ?Pos ?T ?P ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForList_A_forall; intros x HI; + specialize (H x) + end. +Hint Extern 0 => forall_ForList_A : prove_forall_db2. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 5a0728f2..7ac8a43e 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -2,6 +2,8 @@ From Base Require Import Free. From Base Require Import Free.Instance.Identity. From Base Require Import Free.Malias. +Require Import Coq.Program.Equality. + Section SecPair. Variable Shape : Type. Variable Pos : Shape -> Type. @@ -62,3 +64,118 @@ Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) (pure (pair_ sx sy)) end }. + +(* ForPair_A *) +Inductive ForPair_A (Shape : Type) (Pos : Shape -> Type) (A B : Type) (P : A -> Prop) + : Pair Shape Pos A B -> Prop := + | ForPair_A_pair : forall (fx : Free Shape Pos A) + (fy : Free Shape Pos B), + ForFree Shape Pos A P fx -> + ForPair_A Shape Pos A B P (@pair_ Shape Pos A B fx fy). + +Inductive InPair_A (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : A -> Pair Shape Pos A B -> Prop := + | InPair_A_pair_fx : forall (x : A) + (fx : Free Shape Pos A) + (fy : Free Shape Pos B), + InFree Shape Pos A x fx -> + InPair_A Shape Pos A B x (@pair_ Shape Pos A B fx fy). + +Lemma ForPair_A_forall (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : forall (P : A -> Prop) + (fp : Pair Shape Pos A B), + ForPair_A Shape Pos A B P fp <-> (forall (x : A), InPair_A Shape Pos A B x fp -> P x). +Proof. + Hint Extern 0 (ForPair_A ?Shape ?Pos ?A ?B _ _) => forall_finish2 (@InPair_A_pair_fx Shape Pos A B) : prove_forall_db2. + prove_forall Pair_ind. +Qed. + +(* ForPair_B *) +Inductive ForPair_B (Shape : Type) (Pos : Shape -> Type) (A B : Type) (P : B -> Prop) + : Pair Shape Pos A B -> Prop := + | ForPair_B_pair : forall (fx : Free Shape Pos A) + (fy : Free Shape Pos B), + ForFree Shape Pos B P fy -> + ForPair_B Shape Pos A B P (@pair_ Shape Pos A B fx fy). + +Inductive InPair_B (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : B -> Pair Shape Pos A B -> Prop := + | InPair_B_pair_fy : forall (y : B) + (fx : Free Shape Pos A) + (fy : Free Shape Pos B), + InFree Shape Pos B y fy -> + InPair_B Shape Pos A B y (@pair_ Shape Pos A B fx fy). + +Lemma ForPair_B_forall (Shape : Type) (Pos : Shape -> Type) (A B : Type) + : forall (P : B -> Prop) + (fp : Pair Shape Pos A B), + ForPair_B Shape Pos A B P fp <-> (forall (x : B), InPair_B Shape Pos A B x fp -> P x). +Proof. + Hint Extern 0 (ForPair_B ?Shape ?Pos ?A ?B _ _) => forall_finish2 (@InPair_B_pair_fy Shape Pos A B) : prove_forall_db2. + prove_forall Pair_ind. +Qed. + +(* Add hints for proof generation *) +Local Ltac pair_induction x := induction x as [ fx fy ] using Pair_ind. +Hint Extern 0 (ForPair_A ?Shape ?Pos ?A ?B _ _) => prove_ind_prove_for_type + (Pair Shape Pos A B) + (ForPair_A Shape Pos A B) + (ForPair_A_forall Shape Pos A B) + (pair_induction) + : prove_ind_db. +Hint Extern 0 (ForPair_B ?Shape ?Pos ?A ?B _ _) => prove_ind_prove_for_type + (Pair Shape Pos A B) + (ForPair_B Shape Pos A B) + (ForPair_B_forall Shape Pos A B) + (pair_induction) + : prove_ind_db. +Local Ltac forall_ForPair_A_InPair_A := + match goal with + | [ HF : ForPair_A ?Shape ?Pos ?A ?B _ ?fx + , HI : InPair_A ?Shape ?Pos ?A ?B ?x ?fx + |- _ ] => + rewrite ForPair_A_forall in HF; + specialize (HF x HI) + end. +Hint Extern 0 => forall_ForPair_A_InPair_A : prove_forall_db. +Local Ltac forall_ForPair_B_InPair_B := + match goal with + | [ HF : ForPair_B ?Shape ?Pos ?A ?B _ ?fx + , HI : InPair_B ?Shape ?Pos ?A ?B ?x ?fx + |- _ ] => + rewrite ForPair_B_forall in HF; + specialize (HF x HI) + end. +Hint Extern 0 => forall_ForPair_B_InPair_B : prove_forall_db. +Local Ltac forall_ForPair_A := + match goal with + | [ HF : ForPair_A ?Shape ?Pos ?T1 ?T2 _ ?fx + |- ForPair_A ?Shape ?Pos ?T1 ?T2 _ ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForPair_A_forall; intros x HI; + rewrite ForPair_A_forall in HF; + specialize (HF x HI) + | [ H : forall y : ?A, _ |- ForPair_A ?Shape ?Pos ?T1 ?T2 ?P ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForPair_A_forall; intros x HI; + specialize (H x) + end. +Hint Extern 0 => forall_ForPair_A : prove_forall_db2. +Local Ltac forall_ForPair_B := + match goal with + | [ HF : ForPair_B ?Shape ?Pos ?T1 ?T2 _ ?fx + |- ForPair_B ?Shape ?Pos ?T1 ?T2 _ ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForPair_B_forall; intros x HI; + rewrite ForPair_B_forall in HF; + specialize (HF x HI) + | [ H : forall y : ?A, _ |- ForPair_B ?Shape ?Pos ?T1 ?T2 ?P ?fx ] => + let x := fresh "x" + in let HI := fresh "HI" + in apply ForPair_B_forall; intros x HI; + specialize (H x) + end. +Hint Extern 0 => forall_ForPair_B : prove_forall_db2. From 7e04367d593be42c5bbfbe7d240255c29632d07b Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Fri, 18 Sep 2020 13:55:27 +0200 Subject: [PATCH 03/17] Add generation of `For-` properties #159 --- src/lib/FreeC/Backend/Coq/Base.hs | 11 ++ .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 120 ++++++++++++++++-- src/lib/FreeC/Backend/Coq/Syntax.hs | 6 + 3 files changed, 128 insertions(+), 9 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 96d98c87..0a388f1f 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -30,6 +30,8 @@ module FreeC.Backend.Coq.Base , shareableArgsBinder , implicitArg , share + -- * Induction Schemes + , noProperty -- * Effect Selection , selectExplicitArgs , selectImplicitArgs @@ -194,6 +196,13 @@ implicitArg = Coq.Underscore share :: Coq.Qualid share = Coq.bare "share" +------------------------------------------------------------------------------- +-- Induction Schemes -- +------------------------------------------------------------------------------- +-- | The Coq Identifier for a trivial property. +noProperty :: Coq.Qualid +noProperty = Coq.bare "NoProperty" + ------------------------------------------------------------------------------- -- Effect selection -- ------------------------------------------------------------------------------- @@ -268,5 +277,7 @@ reservedIdents , strategyArg , shareableArgs , share + -- Induction Schemes + , noProperty ] ++ map fst freeArgs diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index b70de9eb..37e7e6e3 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -18,7 +18,8 @@ import Control.Monad.Extra ( concatMapM ) import Data.List ( partition ) import Data.List.Extra ( concatUnzip ) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes, fromJust ) +import Data.Maybe ( catMaybes, fromJust, fromMaybe ) +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -126,12 +127,13 @@ convertTypeSynDecl (IR.DataDecl _ _ _ _) convertDataDecls :: [IR.TypeDecl] -> Converter ([Coq.Sentence], [Coq.Sentence]) convertDataDecls dataDecls = do (indBodies, extraSentences') <- mapAndUnzipM convertDataDecl dataDecls + inductionSentences <- generateInductionSchemes dataDecls let (extraSentences, qualSmartConDecls) = concatUnzip extraSentences' return ( Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) - : extraSentences + : extraSentences ++ inductionSentences , qualSmartConDecls ) @@ -148,15 +150,11 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do (body, argumentsSentences) <- generateBodyAndArguments (smartConDecls, qualSmartConDecls) <- concatUnzip <$> mapM generateSmartConDecl conDecls - inductionScheme <- generateInductionScheme return ( body , ( Coq.commentedSentences ("Arguments sentences for " ++ showPretty (IR.toUnQual name)) argumentsSentences ++ Coq.commentedSentences - ("Induction scheme for " ++ showPretty (IR.toUnQual name)) - inductionScheme - ++ Coq.commentedSentences ("Smart constructors for " ++ showPretty (IR.toUnQual name)) smartConDecls , Coq.commentedSentences ("Qualified smart constructors for " @@ -299,6 +297,112 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do , Coq.sModIdentLevel (NonEmpty.fromList expArgIdents) (Just 9) ] +-- Type synonyms are not allowed in this function. +convertDataDecl (IR.TypeSynDecl _ _ _ _) + = error "convertDataDecl: Type synonym not allowed." + +generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] +generateInductionSchemes dataDecls = do + forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) dataDecls + forBodies <- catMaybes <$> mapM (generateForProperty forQualidMap) dataDecls + {-} + inBodies <- return [] -- generateInProperties + inductionSentences <- return [] -- generateInductionSchemes' + forallSentences <- return [] -- generateForallSentences-} + return [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] + where + + generateForName :: IR.QName -> Converter (IR.QName, Coq.Qualid) + generateForName typeQName = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + forQualid <- freshCoqQualid $ "For" ++ typeIdent + return (typeQName, forQualid) + + generateForConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid + generateForConName forTypeQualid conQName = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName + let Just forTypeName = Coq.unpackQualid forTypeQualid + Just conName = Coq.unpackQualid conQualid + freshCoqQualid $ forTypeName ++ "_" ++ conName + + generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Maybe Coq.IndBody) + generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" + generateForProperty _ (IR.DataDecl _ _ [] _) = return Nothing -- Types without out type variable do not need a 'For-' property + generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + let forQualid = forQualidMap Map.! typeName + forConQualids <- mapM (generateForConName forQualid . IR.conDeclQName) conDecls + localEnv $ do + (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids + forCons <- mapM (uncurry (generateForConstructor typeVarQualids propertyQualids)) $ zip conDecls forConQualids + let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids + propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes + binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders + returnType = Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + (Coq.Sort Coq.Prop) + return $ Just $ Coq.IndBody forQualid binders returnType forCons + where + generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) + generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args + forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) + let forQualid = forQualidMap Map.! typeName + forResult = Coq.app (Coq.Qualid forQualid) + ( map (Coq.Qualid . fst) Coq.Base.freeArgs + ++ map Coq.Qualid typeVarQualids + ++ map Coq.Qualid propertyQualids + ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) + returnType = Coq.forall binders (foldr Coq.Arrow forResult forHypotheses) + return (forConQualid, [], Just returnType) + where + propertyMap :: Map.Map Coq.Qualid Coq.Qualid + propertyMap = Map.fromList $ zip typeVarQualids propertyQualids + + generateForHypothesis :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis argQualid argType = do + coqType <- convertType' argType + argType' <- expandAllTypeSynonyms argType + mbHyp <- generateForHypothesis_1 argType' + return $ case mbHyp of + Just hyp -> Just $ Coq.app (Coq.Qualid Coq.Base.forFree) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ [coqType, hyp, Coq.Qualid argQualid]) + Nothing -> Nothing + + generateForHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis_1 (IR.FuncType _ _ _) = return Nothing + generateForHypothesis_1 (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 tcon [lastArg] + generateForHypothesis_1 (IR.TypeCon _ _) = return Nothing -- Ignore type vars that do not have any type variable or are partially applied + generateForHypothesis_1 tvar@(IR.TypeVar _ _) = do + Coq.Qualid tvarQualid <- convertType' tvar + return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid + + generateForHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateForHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing + generateForHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 tcon (lastArg : typeArgs) + generateForHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + hypotheses <- mapM generateForHypothesis_1 typeArgs + coqArgs <- mapM convertType' typeArgs + forType <- getForType tconName + if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) + then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + return $ Just $ Coq.app forType (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ coqArgs ++ hypotheses') + else return Nothing + generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing + + getForType :: IR.QName -> Converter Coq.Term + getForType t = case forQualidMap Map.!? t of + Just qualid -> return $ Coq.Qualid qualid + Nothing -> do + -- TODO use environment to store and load other 'For-' properties + Just qualid <- inEnv $ lookupIdent IR.TypeScope t + let name = case qualid of + Coq.Bare n -> Text.unpack n + Coq.Qualified _ n -> Text.unpack n + return $ Coq.Qualid $ Coq.bare $ "For" ++ name +{-} -- | Generates an induction scheme for the data type. generateInductionScheme :: Converter [Coq.Sentence] generateInductionScheme = localEnv $ do @@ -371,6 +475,4 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do indCaseIdent <- freshCoqQualid freshArgPrefix indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) return (indCaseIdent, indCaseBinder) --- Type synonyms are not allowed in this function. -convertDataDecl (IR.TypeSynDecl _ _ _ _) - = error "convertDataDecl: Type synonym not allowed." +-} \ No newline at end of file diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index 4c93b545..ed06dbb7 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -42,6 +42,7 @@ module FreeC.Backend.Coq.Syntax , notEquals , conj , disj + , forall -- * Imports , requireImportFrom , requireExportFrom @@ -257,6 +258,11 @@ conj t1 t2 = app (Qualid (bare "op_/\\__")) [t1, t2] disj :: Term -> Term -> Term disj t1 t2 = app (Qualid (bare "op_\\/__")) [t1, t2] +-- | Smart constructor for a forall term in Coq. +forall :: [Binder] -> Term -> Term +forall [] t = t +forall bs t = Forall (NonEmpty.fromList bs) t + ------------------------------------------------------------------------------- -- Imports -- ------------------------------------------------------------------------------- From 9dae89c78b8804ecb6126cd4e8736ee35477e0af Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Fri, 18 Sep 2020 14:00:39 +0200 Subject: [PATCH 04/17] Add test file for induction scheme generation #159 --- example/Proofs/InductionSchemes.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 example/Proofs/InductionSchemes.hs diff --git a/example/Proofs/InductionSchemes.hs b/example/Proofs/InductionSchemes.hs new file mode 100644 index 00000000..3f6c03d0 --- /dev/null +++ b/example/Proofs/InductionSchemes.hs @@ -0,0 +1,16 @@ +module Proofs.InductionSchemes where + +data MyList a = MyNil | MyCons a (MyList a) + +data MyPair a b = MyPair a b + +data Tree a b = Forest (MyPair a (MyList (Tree a b))) + +data AltList a b = AltNil | AltCons a (AltList b a) + +type MapEntry k v = MyPair k v +type MapList k v = MyList (MapEntry k v) +data Map k v = Map (MapList k v) + +data Foo a = Foo a (Bar a) +data Bar a = Bar a (Foo a) From 7ac0e2e0405f020b5897a1f1946900d019d868de Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Sat, 19 Sep 2020 18:35:11 +0200 Subject: [PATCH 05/17] Add generation of 'In-' properties #159 --- src/lib/FreeC/Backend/Coq/Base.hs | 6 + src/lib/FreeC/Backend/Coq/Converter/Arg.hs | 9 ++ .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 149 ++++++++++++++++-- 3 files changed, 149 insertions(+), 15 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 0a388f1f..6f446a97 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -14,6 +14,7 @@ module FreeC.Backend.Coq.Base , freeBind , freeArgs , forFree + , inFree -- * Partiality , partial , partialArg @@ -112,6 +113,10 @@ freeArgs = [ (shape, Coq.Sort Coq.Type) forFree :: Coq.Qualid forFree = Coq.bare "ForFree" +-- | The Coq identifier for the @InFree@ property. +inFree :: Coq.Qualid +inFree = Coq.bare "InFree" + ------------------------------------------------------------------------------- -- Partiality -- ------------------------------------------------------------------------------- @@ -264,6 +269,7 @@ reservedIdents , freePureCon , freeImpureCon , forFree + , inFree -- Partiality , partial , partialArg diff --git a/src/lib/FreeC/Backend/Coq/Converter/Arg.hs b/src/lib/FreeC/Backend/Coq/Converter/Arg.hs index a9acabcb..8fcc075c 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/Arg.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/Arg.hs @@ -92,3 +92,12 @@ convertAnonymousArg mArgType = do mArgType' <- mapM convertType mArgType binder <- generateArgBinder ident' mArgType' return (ident', binder) + +-- | Like 'convertAnonymousArg' but does not lift the type into the @Free@ +-- monad. +convertAnonymousArg' :: Maybe IR.Type -> Converter (Coq.Qualid, Coq.Binder) +convertAnonymousArg' mArgType = do + ident' <- freshCoqQualid freshArgPrefix + mArgType' <- mapM convertType' mArgType + binder <- generateArgBinder ident' mArgType' + return (ident', binder) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 37e7e6e3..5eff349b 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -303,15 +303,23 @@ convertDataDecl (IR.TypeSynDecl _ _ _ _) generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateInductionSchemes dataDecls = do - forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) dataDecls - forBodies <- catMaybes <$> mapM (generateForProperty forQualidMap) dataDecls - {-} - inBodies <- return [] -- generateInProperties - inductionSentences <- return [] -- generateInductionSchemes' + let complexDataDecls = filter hasTypeVar dataDecls + forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) complexDataDecls + forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls + inQualidMap <- Map.fromList <$> concatMapM generateInNames complexDataDecls + inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls + {-inductionSentences <- return [] -- generateInductionSchemes' forallSentences <- return [] -- generateForallSentences-} - return [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] + return + ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] + ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] + ) where + hasTypeVar :: IR.TypeDecl -> Bool + hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" + hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls + generateForName :: IR.QName -> Converter (IR.QName, Coq.Qualid) generateForName typeQName = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName @@ -326,9 +334,8 @@ generateInductionSchemes dataDecls = do Just conName = Coq.unpackQualid conQualid freshCoqQualid $ forTypeName ++ "_" ++ conName - generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Maybe Coq.IndBody) + generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" - generateForProperty _ (IR.DataDecl _ _ [] _) = return Nothing -- Types without out type variable do not need a 'For-' property generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName let forQualid = forQualidMap Map.! typeName @@ -342,10 +349,10 @@ generateInductionSchemes dataDecls = do binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders returnType = Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) (Coq.Sort Coq.Prop) - return $ Just $ Coq.IndBody forQualid binders returnType forCons + return $ Coq.IndBody forQualid binders returnType forCons where generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) - generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = do + generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = localEnv $ do Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) @@ -384,24 +391,136 @@ generateInductionSchemes dataDecls = do generateForHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName hypotheses <- mapM generateForHypothesis_1 typeArgs - coqArgs <- mapM convertType' typeArgs - forType <- getForType tconName if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + coqArgs <- mapM convertType' typeArgs + forType <- Coq.Qualid <$> getForType tconName return $ Just $ Coq.app forType (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ coqArgs ++ hypotheses') else return Nothing generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing - getForType :: IR.QName -> Converter Coq.Term + getForType :: IR.QName -> Converter Coq.Qualid getForType t = case forQualidMap Map.!? t of - Just qualid -> return $ Coq.Qualid qualid + Just qualid -> return qualid Nothing -> do -- TODO use environment to store and load other 'For-' properties Just qualid <- inEnv $ lookupIdent IR.TypeScope t let name = case qualid of Coq.Bare n -> Text.unpack n Coq.Qualified _ n -> Text.unpack n - return $ Coq.Qualid $ Coq.bare $ "For" ++ name + return $ Coq.bare $ "For" ++ name + + generateInNames :: IR.TypeDecl -> Converter [((IR.QName, Int), Coq.Qualid)] + generateInNames (IR.TypeSynDecl _ _ _ _) = error "generateInNames: Type synonym not allowed" + generateInNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = + let nTVars = length typeVarDecls + mbIndices = if nTVars == 1 then [Nothing] else map Just [1 .. nTVars] + in mapM (generateInName typeName) mbIndices + + generateInName :: IR.QName -> Maybe Int -> Converter ((IR.QName, Int), Coq.Qualid) + generateInName typeQName mbInt = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + forQualid <- freshCoqQualid $ "In" ++ typeIdent ++ maybe "" ((++) "_" . show) mbInt + return ((typeQName, fromMaybe 1 mbInt), forQualid) + + generateInConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid + generateInConName inTypeQualid conQName = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName + let Just inTypeName = Coq.unpackQualid inTypeQualid + Just conName = Coq.unpackQualid conQualid + freshCoqQualid $ inTypeName ++ "_" ++ conName + + generateInProperties :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter [Coq.IndBody] + generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" + generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = + mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [1 .. length typeVarDecls] + + generateInProperty :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody + generateInProperty inQualidMap typeName typeVarDecls conDecls index = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + let inQualid = inQualidMap Map.! (typeName, index) + (cons, mkBody) <- localEnv $ do + (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + let binders = genericArgDecls Coq.Explicit ++ typeVarBinders + returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! (index - 1)) + (Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + (Coq.Sort Coq.Prop)) + mkBody cons' = Coq.IndBody inQualid binders returnType cons' + cons <- concatMapM (generateInConstructors typeVarQualids) conDecls + return (cons, mkBody) + cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateInConName inQualid conName) cons + return $ mkBody cons' + where + generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] + generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) = localEnv $ do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args + elemQualid <- freshCoqQualid "x" + occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args + let inQualid = inQualidMap Map.! (typeName, index) + inResult = Coq.app (Coq.Qualid inQualid) + ( map (Coq.Qualid . fst) Coq.Base.freeArgs + ++ map Coq.Qualid typeVarQualids + ++ [Coq.Qualid elemQualid] + ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) + elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid (Coq.Qualid elemType) + mkConType (occBinders, inHypotheses) = Coq.forall + (elemBinder : occBinders ++ argBinders) + (foldr Coq.Arrow inResult (reverse inHypotheses)) + conTypes = map mkConType occurrences + return $ map ((,) conName . Just) conTypes + where + elemType :: Coq.Qualid + elemType = typeVarQualids !! (index - 1) + + inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term + inHypothesis inQualid typeArgs containerQualid elemQualid = + Coq.app (Coq.Qualid inQualid) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + + findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences elemQualid argQualid argType = do + coqType <- convertType' argType + argType' <- expandAllTypeSynonyms argType + findOccurrences_1 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' + + findOccurrences_1 :: Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_1 _ _ (IR.FuncType _ _ _) = return [] + findOccurrences_1 _ _ (IR.TypeCon _ _) = return [] -- Ignore type vars that do not have any type variable or are partially applied + findOccurrences_1 elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do + tvarType <- convertType' tvar + return [([], [mkInHyp elemQualid]) | tvarType == Coq.Qualid elemType] + findOccurrences_1 elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = + findOccurrences_2 fullType [] + where + findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_2 (IR.FuncType _ _ _) _ = return [] + findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = findOccurrences_2 tcon (lastArg : typeArgs) + findOccurrences_2 (IR.TypeVar _ _) _ = return [] + findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + if tconArity == length typeArgs + then do + coqArgs <- mapM convertType' typeArgs + inTypes <- mapM (getInType tconName) [1 .. length typeArgs] + (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) + occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs + let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) + return $ map mkNewOcc occurrences + else return [] + + getInType :: IR.QName -> Int -> Converter Coq.Qualid + getInType t argIndex = case inQualidMap Map.!? (t, argIndex) of + Just qualid -> return qualid + Nothing -> do + -- TODO use environment to store and load other 'In-' properties + Just qualid <- inEnv $ lookupIdent IR.TypeScope t + Just arity <- inEnv $ lookupArity IR.TypeScope t + let name = case qualid of + Coq.Bare n -> Text.unpack n + Coq.Qualified _ n -> Text.unpack n + return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) + {-} -- | Generates an induction scheme for the data type. generateInductionScheme :: Converter [Coq.Sentence] From edf2fdd73aa1031c61dd9e6b2059acf59959f842 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Mon, 21 Sep 2020 13:49:52 +0200 Subject: [PATCH 06/17] Generate induction schemes #159 --- base/coq/Free/Tactic/ProveInd.v | 3 + example/Proofs/InductionSchemes.hs | 2 +- free-compiler.cabal | 1 + .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 302 +-------------- .../Coq/Converter/TypeDecl/InductionScheme.hs | 362 ++++++++++++++++++ src/lib/FreeC/Backend/Coq/Syntax.hs | 4 +- 6 files changed, 372 insertions(+), 302 deletions(-) create mode 100644 src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index 8d3b31cb..cc353276 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -11,6 +11,9 @@ Require Import Coq.Program.Equality. (* The hint database that contains instances of [prove_ind_prove_for_type]. *) Create HintDb prove_ind_db. +(* Trivial property *) +Definition NoProperty {A : Type} : A -> Prop := fun _ => True. + (* This tactic is needed to prevent [prove_ind_apply_assumption] from applying the fixpoint hypothesis which would invalidify the proof. *) Local Ltac prove_ind_is_fixpoint H P := diff --git a/example/Proofs/InductionSchemes.hs b/example/Proofs/InductionSchemes.hs index 3f6c03d0..e6e00e10 100644 --- a/example/Proofs/InductionSchemes.hs +++ b/example/Proofs/InductionSchemes.hs @@ -13,4 +13,4 @@ type MapList k v = MyList (MapEntry k v) data Map k v = Map (MapList k v) data Foo a = Foo a (Bar a) -data Bar a = Bar a (Foo a) +data Bar a = Bar a (Foo a) \ No newline at end of file diff --git a/free-compiler.cabal b/free-compiler.cabal index 533050c0..96bf4e4a 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -114,6 +114,7 @@ library freec-internal , FreeC.Backend.Coq.Converter.Module , FreeC.Backend.Coq.Converter.Type , FreeC.Backend.Coq.Converter.TypeDecl + , FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme , FreeC.Backend.Coq.Keywords , FreeC.Backend.Coq.Pretty , FreeC.Backend.Coq.Syntax diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 5eff349b..3e6c10ef 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -18,19 +18,18 @@ import Control.Monad.Extra ( concatMapM ) import Data.List ( partition ) import Data.List.Extra ( concatUnzip ) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes, fromJust, fromMaybe ) -import qualified Data.Map as Map +import Data.Maybe ( catMaybes, fromJust ) import qualified Data.Set as Set -import qualified Data.Text as Text import qualified FreeC.Backend.Coq.Base as Coq.Base import FreeC.Backend.Coq.Converter.Arg import FreeC.Backend.Coq.Converter.Free import FreeC.Backend.Coq.Converter.Type +import FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqIdent, freshCoqQualid ) + ( freshArgPrefix, freshCoqIdent ) import FreeC.Environment.Renamer ( renameAndDefineTypeVar ) import FreeC.IR.DependencyGraph import qualified FreeC.IR.Syntax as IR @@ -300,298 +299,3 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do -- Type synonyms are not allowed in this function. convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." - -generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] -generateInductionSchemes dataDecls = do - let complexDataDecls = filter hasTypeVar dataDecls - forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) complexDataDecls - forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls - inQualidMap <- Map.fromList <$> concatMapM generateInNames complexDataDecls - inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls - {-inductionSentences <- return [] -- generateInductionSchemes' - forallSentences <- return [] -- generateForallSentences-} - return - ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] - ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] - ) - where - - hasTypeVar :: IR.TypeDecl -> Bool - hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" - hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls - - generateForName :: IR.QName -> Converter (IR.QName, Coq.Qualid) - generateForName typeQName = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - forQualid <- freshCoqQualid $ "For" ++ typeIdent - return (typeQName, forQualid) - - generateForConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid - generateForConName forTypeQualid conQName = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName - let Just forTypeName = Coq.unpackQualid forTypeQualid - Just conName = Coq.unpackQualid conQualid - freshCoqQualid $ forTypeName ++ "_" ++ conName - - generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody - generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" - generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let forQualid = forQualidMap Map.! typeName - forConQualids <- mapM (generateForConName forQualid . IR.conDeclQName) conDecls - localEnv $ do - (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids - forCons <- mapM (uncurry (generateForConstructor typeVarQualids propertyQualids)) $ zip conDecls forConQualids - let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids - propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes - binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders - returnType = Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) - (Coq.Sort Coq.Prop) - return $ Coq.IndBody forQualid binders returnType forCons - where - generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) - generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = localEnv $ do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName - (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args - forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) - let forQualid = forQualidMap Map.! typeName - forResult = Coq.app (Coq.Qualid forQualid) - ( map (Coq.Qualid . fst) Coq.Base.freeArgs - ++ map Coq.Qualid typeVarQualids - ++ map Coq.Qualid propertyQualids - ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) - returnType = Coq.forall binders (foldr Coq.Arrow forResult forHypotheses) - return (forConQualid, [], Just returnType) - where - propertyMap :: Map.Map Coq.Qualid Coq.Qualid - propertyMap = Map.fromList $ zip typeVarQualids propertyQualids - - generateForHypothesis :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) - generateForHypothesis argQualid argType = do - coqType <- convertType' argType - argType' <- expandAllTypeSynonyms argType - mbHyp <- generateForHypothesis_1 argType' - return $ case mbHyp of - Just hyp -> Just $ Coq.app (Coq.Qualid Coq.Base.forFree) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ [coqType, hyp, Coq.Qualid argQualid]) - Nothing -> Nothing - - generateForHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) - generateForHypothesis_1 (IR.FuncType _ _ _) = return Nothing - generateForHypothesis_1 (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 tcon [lastArg] - generateForHypothesis_1 (IR.TypeCon _ _) = return Nothing -- Ignore type vars that do not have any type variable or are partially applied - generateForHypothesis_1 tvar@(IR.TypeVar _ _) = do - Coq.Qualid tvarQualid <- convertType' tvar - return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid - - generateForHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateForHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing - generateForHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 tcon (lastArg : typeArgs) - generateForHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do - Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - hypotheses <- mapM generateForHypothesis_1 typeArgs - if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) - then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses - coqArgs <- mapM convertType' typeArgs - forType <- Coq.Qualid <$> getForType tconName - return $ Just $ Coq.app forType (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ coqArgs ++ hypotheses') - else return Nothing - generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing - - getForType :: IR.QName -> Converter Coq.Qualid - getForType t = case forQualidMap Map.!? t of - Just qualid -> return qualid - Nothing -> do - -- TODO use environment to store and load other 'For-' properties - Just qualid <- inEnv $ lookupIdent IR.TypeScope t - let name = case qualid of - Coq.Bare n -> Text.unpack n - Coq.Qualified _ n -> Text.unpack n - return $ Coq.bare $ "For" ++ name - - generateInNames :: IR.TypeDecl -> Converter [((IR.QName, Int), Coq.Qualid)] - generateInNames (IR.TypeSynDecl _ _ _ _) = error "generateInNames: Type synonym not allowed" - generateInNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = - let nTVars = length typeVarDecls - mbIndices = if nTVars == 1 then [Nothing] else map Just [1 .. nTVars] - in mapM (generateInName typeName) mbIndices - - generateInName :: IR.QName -> Maybe Int -> Converter ((IR.QName, Int), Coq.Qualid) - generateInName typeQName mbInt = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - forQualid <- freshCoqQualid $ "In" ++ typeIdent ++ maybe "" ((++) "_" . show) mbInt - return ((typeQName, fromMaybe 1 mbInt), forQualid) - - generateInConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid - generateInConName inTypeQualid conQName = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName - let Just inTypeName = Coq.unpackQualid inTypeQualid - Just conName = Coq.unpackQualid conQualid - freshCoqQualid $ inTypeName ++ "_" ++ conName - - generateInProperties :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter [Coq.IndBody] - generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" - generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = - mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [1 .. length typeVarDecls] - - generateInProperty :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody - generateInProperty inQualidMap typeName typeVarDecls conDecls index = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let inQualid = inQualidMap Map.! (typeName, index) - (cons, mkBody) <- localEnv $ do - (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - let binders = genericArgDecls Coq.Explicit ++ typeVarBinders - returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! (index - 1)) - (Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) - (Coq.Sort Coq.Prop)) - mkBody cons' = Coq.IndBody inQualid binders returnType cons' - cons <- concatMapM (generateInConstructors typeVarQualids) conDecls - return (cons, mkBody) - cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateInConName inQualid conName) cons - return $ mkBody cons' - where - generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] - generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) = localEnv $ do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName - (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args - elemQualid <- freshCoqQualid "x" - occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args - let inQualid = inQualidMap Map.! (typeName, index) - inResult = Coq.app (Coq.Qualid inQualid) - ( map (Coq.Qualid . fst) Coq.Base.freeArgs - ++ map Coq.Qualid typeVarQualids - ++ [Coq.Qualid elemQualid] - ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) - elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid (Coq.Qualid elemType) - mkConType (occBinders, inHypotheses) = Coq.forall - (elemBinder : occBinders ++ argBinders) - (foldr Coq.Arrow inResult (reverse inHypotheses)) - conTypes = map mkConType occurrences - return $ map ((,) conName . Just) conTypes - where - elemType :: Coq.Qualid - elemType = typeVarQualids !! (index - 1) - - inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term - inHypothesis inQualid typeArgs containerQualid elemQualid = - Coq.app (Coq.Qualid inQualid) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) - - findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences elemQualid argQualid argType = do - coqType <- convertType' argType - argType' <- expandAllTypeSynonyms argType - findOccurrences_1 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' - - findOccurrences_1 :: Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_1 _ _ (IR.FuncType _ _ _) = return [] - findOccurrences_1 _ _ (IR.TypeCon _ _) = return [] -- Ignore type vars that do not have any type variable or are partially applied - findOccurrences_1 elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do - tvarType <- convertType' tvar - return [([], [mkInHyp elemQualid]) | tvarType == Coq.Qualid elemType] - findOccurrences_1 elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = - findOccurrences_2 fullType [] - where - findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_2 (IR.FuncType _ _ _) _ = return [] - findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = findOccurrences_2 tcon (lastArg : typeArgs) - findOccurrences_2 (IR.TypeVar _ _) _ = return [] - findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do - Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - if tconArity == length typeArgs - then do - coqArgs <- mapM convertType' typeArgs - inTypes <- mapM (getInType tconName) [1 .. length typeArgs] - (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) - occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs - let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) - return $ map mkNewOcc occurrences - else return [] - - getInType :: IR.QName -> Int -> Converter Coq.Qualid - getInType t argIndex = case inQualidMap Map.!? (t, argIndex) of - Just qualid -> return qualid - Nothing -> do - -- TODO use environment to store and load other 'In-' properties - Just qualid <- inEnv $ lookupIdent IR.TypeScope t - Just arity <- inEnv $ lookupArity IR.TypeScope t - let name = case qualid of - Coq.Bare n -> Text.unpack n - Coq.Qualified _ n -> Text.unpack n - return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) - -{-} - -- | Generates an induction scheme for the data type. - generateInductionScheme :: Converter [Coq.Sentence] - generateInductionScheme = localEnv $ do - Just tIdent <- inEnv $ lookupIdent IR.TypeScope name - -- Create variables and binders. - let generateArg :: Coq.Term -> Converter (Coq.Qualid, Coq.Binder) - generateArg argType = do - ident <- freshCoqQualid freshArgPrefix - return - $ ( ident - , Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [ident] argType - ) - (tvarIdents, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - (propIdent, propBinder) <- generateArg - (Coq.Arrow (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) - (Coq.Sort Coq.Prop)) - (_hIdents, hBinders) <- mapAndUnzipM (generateInductionCase propIdent) - conDecls - (valIdent, valBinder) <- generateArg - (genericApply tIdent [] [] (map Coq.Qualid tvarIdents)) - -- Stick everything together. - schemeName <- freshCoqQualid $ fromJust (Coq.unpackQualid tIdent) ++ "_Ind" - hypothesisVar <- freshCoqIdent "H" - let binders = genericArgDecls Coq.Explicit - ++ tvarBinders - ++ [propBinder] - ++ hBinders - term = Coq.Forall (NonEmpty.fromList [valBinder]) - (Coq.app (Coq.Qualid propIdent) [Coq.Qualid valIdent]) - scheme = Coq.Assertion Coq.Definition schemeName binders term - proof = Coq.ProofDefined - (Text.pack - $ " fix " - ++ hypothesisVar - ++ " 1; intro; " - ++ fromJust (Coq.unpackQualid Coq.Base.proveInd) - ++ ".") - return [Coq.AssertionSentence scheme proof] - - -- | Generates an induction case for a given property and constructor. - generateInductionCase - :: Coq.Qualid -> IR.ConDecl -> Converter (Coq.Qualid, Coq.Binder) - generateInductionCase pIdent (IR.ConDecl _ declIdent argTypes) = do - let conName = IR.declIdentName declIdent - Just conIdent <- inEnv $ lookupIdent IR.ValueScope conName - Just conType' <- inEnv $ lookupReturnType IR.ValueScope conName - conType <- convertType' conType' - fConType <- convertType conType' - fArgTypes <- mapM convertType argTypes - (argIdents, argBinders) <- mapAndUnzipM convertAnonymousArg - (map Just argTypes) - let - -- We need an induction hypothesis for every argument that has the same - -- type as the constructor but lifted into the free monad. - addHypotheses' :: [(Coq.Term, Coq.Qualid)] -> Coq.Term -> Coq.Term - addHypotheses' [] = id - addHypotheses' ((argType, argIdent) : args) - | argType == fConType = Coq.Arrow - (genericForFree conType pIdent argIdent) - . addHypotheses' args - addHypotheses' (_ : args) = addHypotheses' args - addHypotheses = addHypotheses' (zip fArgTypes argIdents) - -- Create induction case. - term = addHypotheses - (Coq.app (Coq.Qualid pIdent) - [Coq.app (Coq.Qualid conIdent) (map Coq.Qualid argIdents)]) - indCase = if null argBinders - then term - else Coq.Forall (NonEmpty.fromList argBinders) term - indCaseIdent <- freshCoqQualid freshArgPrefix - indCaseBinder <- generateArgBinder indCaseIdent (Just indCase) - return (indCaseIdent, indCaseBinder) --} \ No newline at end of file diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs new file mode 100644 index 00000000..3fb3ac8b --- /dev/null +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -0,0 +1,362 @@ +module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme where + +import Control.Monad ( mapAndUnzipM ) +import Control.Monad.Extra ( concatMapM ) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe ( catMaybes, fromMaybe, fromJust ) +import qualified Data.Map as Map +import qualified Data.Text as Text + +import qualified FreeC.Backend.Coq.Base as Coq.Base +import FreeC.Backend.Coq.Converter.Arg +import FreeC.Backend.Coq.Converter.Free +import FreeC.Backend.Coq.Converter.Type +import qualified FreeC.Backend.Coq.Syntax as Coq +import FreeC.Environment +import FreeC.Environment.Fresh + ( freshArgPrefix, freshCoqQualid ) +import qualified FreeC.IR.Syntax as IR +import FreeC.IR.TypeSynExpansion +import FreeC.Monad.Converter + +--import FreeC.Pretty +--import Text.PrettyPrint.Leijen.Text ( (<+>) ) +--import Debug.Trace + +generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] +generateInductionSchemes dataDecls = do + let complexDataDecls = filter hasTypeVar dataDecls + forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) complexDataDecls + forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls + inQualidMap <- Map.fromList <$> concatMapM generateInNames complexDataDecls + inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls + schemeQualidMap <- Map.fromList <$> mapM (generateSchemeName . IR.typeDeclQName) dataDecls + schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls + {- forallSentences <- return [] -- generateForallSentences-} + return + ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] + ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] + ++(map (\(name, binders, term, proof) -> + Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) schemeBodies) + ) + where + + hasTypeVar :: IR.TypeDecl -> Bool + hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" + hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls + + ----------------------------------------------------------------------------- + -- @ForType@ Properties -- + ----------------------------------------------------------------------------- + generateForName :: IR.QName -> Converter (IR.QName, Coq.Qualid) + generateForName typeQName = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + forQualid <- freshCoqQualid $ "For" ++ typeIdent + return (typeQName, forQualid) + + generateForConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid + generateForConName forTypeQualid conQName = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName + let Just forTypeName = Coq.unpackQualid forTypeQualid + Just conName = Coq.unpackQualid conQualid + freshCoqQualid $ forTypeName ++ "_" ++ conName + + generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody + generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" + generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + let forQualid = forQualidMap Map.! typeName + forConQualids <- mapM (generateForConName forQualid . IR.conDeclQName) conDecls + localEnv $ do + (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids + forCons <- mapM (uncurry (generateForConstructor typeVarQualids propertyQualids)) $ zip conDecls forConQualids + let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids + propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes + binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders + returnType = Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + (Coq.Sort Coq.Prop) + return $ Coq.IndBody forQualid binders returnType forCons + where + generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) + generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = localEnv $ do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args + forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) + let forQualid = forQualidMap Map.! typeName + forResult = Coq.app (Coq.Qualid forQualid) + ( map (Coq.Qualid . fst) Coq.Base.freeArgs + ++ map Coq.Qualid typeVarQualids + ++ map Coq.Qualid propertyQualids + ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) + returnType = Coq.forall binders (foldr Coq.Arrow forResult forHypotheses) + return (forConQualid, [], Just returnType) + where + propertyMap :: Map.Map Coq.Qualid Coq.Qualid + propertyMap = Map.fromList $ zip typeVarQualids propertyQualids + + generateForHypothesis :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis argQualid argType = do + coqType <- convertType' argType + argType' <- expandAllTypeSynonyms argType + mbHyp <- generateForHypothesis_1 argType' + return $ case mbHyp of + Just hyp -> Just $ Coq.app (Coq.Qualid Coq.Base.forFree) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ [coqType, hyp, Coq.Qualid argQualid]) + Nothing -> Nothing + + generateForHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis_1 (IR.FuncType _ _ _) = return Nothing + generateForHypothesis_1 (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 tcon [lastArg] + generateForHypothesis_1 (IR.TypeCon _ _) = return Nothing -- Ignore type constructors that do not have any type variable or are partially applied + generateForHypothesis_1 tvar@(IR.TypeVar _ _) = do + Coq.Qualid tvarQualid <- convertType' tvar + return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid + + generateForHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateForHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing + generateForHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 tcon (lastArg : typeArgs) + generateForHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + hypotheses <- mapM generateForHypothesis_1 typeArgs + if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) + then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + coqArgs <- mapM convertType' typeArgs + forType <- Coq.Qualid <$> getForType forQualidMap tconName + return $ Just $ Coq.app forType (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ coqArgs ++ hypotheses') + else return Nothing + generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing + + ----------------------------------------------------------------------------- + -- @InType@ Properties -- + ----------------------------------------------------------------------------- + + generateInNames :: IR.TypeDecl -> Converter [((IR.QName, Int), Coq.Qualid)] + generateInNames (IR.TypeSynDecl _ _ _ _) = error "generateInNames: Type synonym not allowed" + generateInNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = + let nTVars = length typeVarDecls + mbIndices = if nTVars == 1 then [Nothing] else map Just [1 .. nTVars] + in mapM (generateInName typeName) mbIndices + + generateInName :: IR.QName -> Maybe Int -> Converter ((IR.QName, Int), Coq.Qualid) + generateInName typeQName mbInt = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + forQualid <- freshCoqQualid $ "In" ++ typeIdent ++ maybe "" ((++) "_" . show) mbInt + return ((typeQName, fromMaybe 1 mbInt), forQualid) + + generateInConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid + generateInConName inTypeQualid conQName = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName + let Just inTypeName = Coq.unpackQualid inTypeQualid + Just conName = Coq.unpackQualid conQualid + freshCoqQualid $ inTypeName ++ "_" ++ conName + + generateInProperties :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter [Coq.IndBody] + generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" + generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = + mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [1 .. length typeVarDecls] + + generateInProperty :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody + generateInProperty inQualidMap typeName typeVarDecls conDecls index = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + let inQualid = inQualidMap Map.! (typeName, index) + (cons, mkBody) <- localEnv $ do + (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + let binders = genericArgDecls Coq.Explicit ++ typeVarBinders + returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! (index - 1)) + (Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + (Coq.Sort Coq.Prop)) + mkBody cons' = Coq.IndBody inQualid binders returnType cons' + cons <- concatMapM (generateInConstructors typeVarQualids) conDecls + return (cons, mkBody) + cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateInConName inQualid conName) cons + return $ mkBody cons' + where + generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] + generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) = localEnv $ do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args + elemQualid <- freshCoqQualid "x" + occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args + let inQualid = inQualidMap Map.! (typeName, index) + inResult = Coq.app (Coq.Qualid inQualid) + ( map (Coq.Qualid . fst) Coq.Base.freeArgs + ++ map Coq.Qualid typeVarQualids + ++ [Coq.Qualid elemQualid] + ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) + elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid (Coq.Qualid elemType) + mkConType (occBinders, inHypotheses) = Coq.forall + (elemBinder : occBinders ++ argBinders) + (foldr Coq.Arrow inResult (reverse inHypotheses)) + conTypes = map mkConType occurrences + return $ map ((,) conName . Just) conTypes + where + elemType :: Coq.Qualid + elemType = typeVarQualids !! (index - 1) + + inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term + inHypothesis inQualid typeArgs containerQualid elemQualid = + Coq.app (Coq.Qualid inQualid) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + + findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences elemQualid argQualid argType = do + coqType <- convertType' argType + argType' <- expandAllTypeSynonyms argType + findOccurrences_1 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' + + findOccurrences_1 :: Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_1 _ _ (IR.FuncType _ _ _) = return [] + findOccurrences_1 _ _ (IR.TypeCon _ _) = return [] -- Ignore type constructors that do not have any type variable or are partially applied + findOccurrences_1 elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do + tvarType <- convertType' tvar + return [([], [mkInHyp elemQualid]) | tvarType == Coq.Qualid elemType] + findOccurrences_1 elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = + findOccurrences_2 fullType [] + where + findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_2 (IR.FuncType _ _ _) _ = return [] + findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = findOccurrences_2 tcon (lastArg : typeArgs) + findOccurrences_2 (IR.TypeVar _ _) _ = return [] + findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + if tconArity == length typeArgs + then do + coqArgs <- mapM convertType' typeArgs + inTypes <- mapM (getInType inQualidMap tconName) [1 .. length typeArgs] + (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) + occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs + let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) + return $ map mkNewOcc occurrences + else return [] + + ----------------------------------------------------------------------------- + -- Induction Schemes -- + ----------------------------------------------------------------------------- + + generateSchemeName :: IR.QName -> Converter (IR.QName, Coq.Qualid) + generateSchemeName typeQName = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + schemeQualid <- freshCoqQualid $ typeIdent ++ "_Ind" + return (typeQName, schemeQualid) + + -- | Generates an induction scheme for the data type. + generateSchemeLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" + generateSchemeLemma schemeQualidMap forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = localEnv $ do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + let generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) + generateArg argName argType = do + ident <- freshCoqQualid argName + return + $ ( ident + , Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [ident] argType + ) + (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (propQualid, propBinder) <- generateArg "P" + (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + (Coq.Sort Coq.Prop)) + indCases <- mapM (generateInductionCase propQualid) conDecls + (valIdent, valBinder) <- generateArg freshArgPrefix + (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + (indCaseQualids, fixpointQualid, varQualid) <- localEnv $ + do indCaseQualids <- mapM (const $ freshCoqQualid "InductionCase") indCases + fixpointQualid <- freshCoqQualid "FP" + varQualid <- freshCoqQualid "x" + return (indCaseQualids, fixpointQualid, varQualid) + let schemeName = schemeQualidMap Map.! typeName + binders = genericArgDecls Coq.Explicit + ++ tvarBinders + ++ [propBinder] + goal = Coq.forall [valBinder] + (Coq.app (Coq.Qualid propQualid) [Coq.Qualid valIdent]) + term = Coq.forall binders (foldr Coq.Arrow goal indCases) + vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ [propQualid] ++ indCaseQualids) + fixpoint = fromJust $ Coq.unpackQualid fixpointQualid + var = fromJust $ Coq.unpackQualid varQualid + proof = Coq.ProofQed + (Text.pack + $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" + ++ " fix " ++ fixpoint ++ " 1; intro " ++ var ++ "; " + ++ fromJust (Coq.unpackQualid Coq.Base.proveInd) + ++ ".") + return (schemeName, [], term, proof) + where + -- | Generates an induction case for a given property and constructor. + generateInductionCase + :: Coq.Qualid -> IR.ConDecl -> Converter Coq.Term + generateInductionCase propQualid (IR.ConDecl _ (IR.DeclIdent _ conName) argTypes) = localEnv $ do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + argTypes' <- mapM expandAllTypeSynonyms argTypes + Just conType <- inEnv $ lookupReturnType IR.ValueScope conName + conType' <- convertType' conType + (argQualids, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) + hypotheses <- catMaybes <$> mapM (uncurry $ generateInductionHypothesis propQualid conType') (zip argQualids argTypes') + -- Create induction case. + let term = foldr Coq.Arrow (Coq.app (Coq.Qualid propQualid) [Coq.app (Coq.Qualid conQualid) (map Coq.Qualid argQualids)]) hypotheses + indCase = Coq.forall argBinders term + return indCase + + generateInductionHypothesis :: Coq.Qualid -> Coq.Term -> Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) + generateInductionHypothesis propQualid conType argQualid argType = do + mbHypothesis <- generateInductionHypothesis_1 argType + argType' <- convertType' argType + case mbHypothesis of + Just hypothesis -> return $ Just $ genericApply Coq.Base.forFree [] [] [argType', hypothesis, Coq.Qualid argQualid] + Nothing -> return Nothing + where + generateInductionHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) + generateInductionHypothesis_1 (IR.FuncType _ _ _) = return Nothing + generateInductionHypothesis_1 t@(IR.TypeApp _ tcon lastArg) = do + t' <- convertType' t + if conType == t' + then return $ Just $ Coq.Qualid propQualid + else generateInductionHypothesis_2 tcon [lastArg] + generateInductionHypothesis_1 t@(IR.TypeCon _ _) = do + t' <- convertType' t + if conType == t' + then return $ Just $ Coq.Qualid propQualid + else return Nothing -- Ignore type constructors that do not have any type variable or are partially applied + generateInductionHypothesis_1 (IR.TypeVar _ _) = return Nothing + + generateInductionHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateInductionHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing + generateInductionHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateInductionHypothesis_2 tcon (lastArg : typeArgs) + generateInductionHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + hypotheses <- mapM generateInductionHypothesis_1 typeArgs + if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) + then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + coqArgs <- mapM convertType' typeArgs + forType <- getForType forQualidMap tconName + return $ Just $ genericApply forType [] [] (coqArgs ++ hypotheses') + else return Nothing + generateInductionHypothesis_2 (IR.TypeVar _ _) _ = return Nothing + + ----------------------------------------------------------------------------- + -- Helper Functions -- + ----------------------------------------------------------------------------- + + getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter Coq.Qualid + getForType forQualidMap t = case forQualidMap Map.!? t of + Just qualid -> return qualid + Nothing -> do + -- TODO use environment to store and load other 'For-' properties + Just qualid <- inEnv $ lookupIdent IR.TypeScope t + let name = case qualid of + Coq.Bare n -> Text.unpack n + Coq.Qualified _ n -> Text.unpack n + return $ Coq.bare $ "For" ++ name + + getInType :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> Int -> Converter Coq.Qualid + getInType inQualidMap t argIndex = case inQualidMap Map.!? (t, argIndex) of + Just qualid -> return qualid + Nothing -> do + -- TODO use environment to store and load other 'In-' properties + Just qualid <- inEnv $ lookupIdent IR.TypeScope t + Just arity <- inEnv $ lookupArity IR.TypeScope t + let name = case qualid of + Coq.Bare n -> Text.unpack n + Coq.Qualified _ n -> Text.unpack n + return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) \ No newline at end of file diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index ed06dbb7..e824c152 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -26,7 +26,7 @@ module FreeC.Backend.Coq.Syntax , variable -- * Definition Sentences , definitionSentence - -- * Notation sentences + -- * Notation Sentences , notationSentence , nSymbol , nIdent @@ -187,7 +187,7 @@ definitionSentence qualid binders returnType term = DefinitionSentence (DefinitionDef Global qualid binders returnType term) ------------------------------------------------------------------------------- --- Definition sentences -- +-- Notation sentences -- ------------------------------------------------------------------------------- -- | Smart constructor for a Coq notation sentence. notationSentence From a85ed8d8ea1c5efa3c0e71594d8bbab8415d9045 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Mon, 21 Sep 2020 16:05:30 +0200 Subject: [PATCH 07/17] Generate forall lemmas #159 --- .../Coq/Converter/TypeDecl/InductionScheme.hs | 59 +++++++++++++++---- src/lib/FreeC/Backend/Coq/Syntax.hs | 5 ++ 2 files changed, 53 insertions(+), 11 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index 3fb3ac8b..c15323c4 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -32,12 +32,13 @@ generateInductionSchemes dataDecls = do inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls schemeQualidMap <- Map.fromList <$> mapM (generateSchemeName . IR.typeDeclQName) dataDecls schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls - {- forallSentences <- return [] -- generateForallSentences-} + forallQualidMap <- Map.fromList <$> mapM (generateForallName . IR.typeDeclQName) complexDataDecls + forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) dataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] ++(map (\(name, binders, term, proof) -> - Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) schemeBodies) + Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) (schemeBodies ++ forallBodies)) ) where @@ -246,13 +247,6 @@ generateInductionSchemes dataDecls = do generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" generateSchemeLemma schemeQualidMap forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = localEnv $ do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) - generateArg argName argType = do - ident <- freshCoqQualid argName - return - $ ( ident - , Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [ident] argType - ) (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls (propQualid, propBinder) <- generateArg "P" (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) @@ -333,7 +327,44 @@ generateInductionSchemes dataDecls = do return $ Just $ genericApply forType [] [] (coqArgs ++ hypotheses') else return Nothing generateInductionHypothesis_2 (IR.TypeVar _ _) _ = return Nothing - + + ----------------------------------------------------------------------------- + -- Forall Lemmas -- + ----------------------------------------------------------------------------- + + generateForallName :: IR.QName -> Converter (IR.QName, Coq.Qualid) + generateForallName typeQName = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + forallQualid <- freshCoqQualid $ "For" ++ typeIdent ++ "_forall" + return (typeQName, forallQualid) + + generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateForallLemma _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" + generateForallLemma forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (propQualids, propBinders) <- mapAndUnzipM (\tv -> generateArg "P" (Coq.Arrow (Coq.Qualid tv) (Coq.Sort Coq.Prop))) tvarQualids + (valQualid, valBinder) <- generateArg freshArgPrefix + (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + inTerms <- mapM (uncurry $ generateInTerm valQualid tvarQualids) $ zip [1 ..] propQualids + let forallQualid = forallQualidMap Map.! typeName + forQualid = forQualidMap Map.! typeName + binders = genericArgDecls Coq.Explicit ++ tvarBinders ++ propBinders ++ [valBinder] + lhs = genericApply forQualid [] [] (map Coq.Qualid $ tvarQualids ++ propQualids ++ [valQualid]) + rhs = let (inQualids', [lastIn]) = splitAt (length inTerms - 1) $ inTerms + in foldr Coq.conj lastIn inQualids' + term = Coq.forall binders (Coq.equiv lhs rhs) + proof = Coq.ProofQed $ Text.pack "" + return (forallQualid, [], term, proof) + where + generateInTerm :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term + generateInTerm valQualid tvarQualids index propQualid = localEnv $ do + let inQualid = inQualidMap Map.! (typeName, index) + (val2Qualid, val2Binder) <- generateArg "y" (Coq.Qualid $ tvarQualids !! (index - 1)) + let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) + return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) + ----------------------------------------------------------------------------- -- Helper Functions -- ----------------------------------------------------------------------------- @@ -359,4 +390,10 @@ generateInductionSchemes dataDecls = do let name = case qualid of Coq.Bare n -> Text.unpack n Coq.Qualified _ n -> Text.unpack n - return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) \ No newline at end of file + return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) + + generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) + generateArg argName argType = do + qualid <- freshCoqQualid argName + let binder = Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [qualid] argType + return (qualid, binder) diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index e824c152..ae9b8a99 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -42,6 +42,7 @@ module FreeC.Backend.Coq.Syntax , notEquals , conj , disj + , equiv , forall -- * Imports , requireImportFrom @@ -258,6 +259,10 @@ conj t1 t2 = app (Qualid (bare "op_/\\__")) [t1, t2] disj :: Term -> Term -> Term disj t1 t2 = app (Qualid (bare "op_\\/__")) [t1, t2] +-- | Smart constructor for a equivalence in Coq. +equiv :: Term -> Term -> Term +equiv t1 t2 = app (Qualid (bare "op_<->__")) [t1, t2] + -- | Smart constructor for a forall term in Coq. forall :: [Binder] -> Term -> Term forall [] t = t From 4e43846a6aaa4df34e144fb1f9a33fafc9b45829 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Mon, 21 Sep 2020 16:40:59 +0200 Subject: [PATCH 08/17] Refactor code #159 --- .../Coq/Converter/TypeDecl/InductionScheme.hs | 145 ++++++++---------- 1 file changed, 60 insertions(+), 85 deletions(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index c15323c4..47b44039 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -26,13 +26,13 @@ import FreeC.Monad.Converter generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateInductionSchemes dataDecls = do let complexDataDecls = filter hasTypeVar dataDecls - forQualidMap <- Map.fromList <$> mapM (generateForName . IR.typeDeclQName) complexDataDecls + forQualidMap <- Map.fromList <$> mapM (generateName "For" "" . IR.typeDeclQName) complexDataDecls forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls - inQualidMap <- Map.fromList <$> concatMapM generateInNames complexDataDecls + inQualidMap <- Map.fromList <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls - schemeQualidMap <- Map.fromList <$> mapM (generateSchemeName . IR.typeDeclQName) dataDecls + schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_Ind" . IR.typeDeclQName) dataDecls schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls - forallQualidMap <- Map.fromList <$> mapM (generateForallName . IR.typeDeclQName) complexDataDecls + forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) dataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] @@ -42,33 +42,16 @@ generateInductionSchemes dataDecls = do ) where - hasTypeVar :: IR.TypeDecl -> Bool - hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" - hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls - ----------------------------------------------------------------------------- -- @ForType@ Properties -- ----------------------------------------------------------------------------- - generateForName :: IR.QName -> Converter (IR.QName, Coq.Qualid) - generateForName typeQName = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - forQualid <- freshCoqQualid $ "For" ++ typeIdent - return (typeQName, forQualid) - - generateForConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid - generateForConName forTypeQualid conQName = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName - let Just forTypeName = Coq.unpackQualid forTypeQualid - Just conName = Coq.unpackQualid conQualid - freshCoqQualid $ forTypeName ++ "_" ++ conName generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName let forQualid = forQualidMap Map.! typeName - forConQualids <- mapM (generateForConName forQualid . IR.conDeclQName) conDecls + forConQualids <- mapM (generateConName forQualid . IR.conDeclQName) conDecls localEnv $ do (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids @@ -76,7 +59,7 @@ generateInductionSchemes dataDecls = do let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders - returnType = Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + returnType = Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) (Coq.Sort Coq.Prop) return $ Coq.IndBody forQualid binders returnType forCons where @@ -86,9 +69,8 @@ generateInductionSchemes dataDecls = do (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) let forQualid = forQualidMap Map.! typeName - forResult = Coq.app (Coq.Qualid forQualid) - ( map (Coq.Qualid . fst) Coq.Base.freeArgs - ++ map Coq.Qualid typeVarQualids + forResult = genericApply forQualid [] [] + ( map Coq.Qualid typeVarQualids ++ map Coq.Qualid propertyQualids ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) returnType = Coq.forall binders (foldr Coq.Arrow forResult forHypotheses) @@ -103,7 +85,7 @@ generateInductionSchemes dataDecls = do argType' <- expandAllTypeSynonyms argType mbHyp <- generateForHypothesis_1 argType' return $ case mbHyp of - Just hyp -> Just $ Coq.app (Coq.Qualid Coq.Base.forFree) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ [coqType, hyp, Coq.Qualid argQualid]) + Just hyp -> Just $ genericApply Coq.Base.forFree [] [] [coqType, hyp, Coq.Qualid argQualid] Nothing -> Nothing generateForHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) @@ -123,8 +105,8 @@ generateInductionSchemes dataDecls = do if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses coqArgs <- mapM convertType' typeArgs - forType <- Coq.Qualid <$> getForType forQualidMap tconName - return $ Just $ Coq.app forType (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ coqArgs ++ hypotheses') + forType <- getForType forQualidMap tconName + return $ Just $ genericApply forType [] [] (coqArgs ++ hypotheses') else return Nothing generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing @@ -132,46 +114,33 @@ generateInductionSchemes dataDecls = do -- @InType@ Properties -- ----------------------------------------------------------------------------- - generateInNames :: IR.TypeDecl -> Converter [((IR.QName, Int), Coq.Qualid)] - generateInNames (IR.TypeSynDecl _ _ _ _) = error "generateInNames: Type synonym not allowed" - generateInNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = - let nTVars = length typeVarDecls - mbIndices = if nTVars == 1 then [Nothing] else map Just [1 .. nTVars] - in mapM (generateInName typeName) mbIndices - - generateInName :: IR.QName -> Maybe Int -> Converter ((IR.QName, Int), Coq.Qualid) - generateInName typeQName mbInt = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - forQualid <- freshCoqQualid $ "In" ++ typeIdent ++ maybe "" ((++) "_" . show) mbInt - return ((typeQName, fromMaybe 1 mbInt), forQualid) - - generateInConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid - generateInConName inTypeQualid conQName = do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName - let Just inTypeName = Coq.unpackQualid inTypeQualid - Just conName = Coq.unpackQualid conQualid - freshCoqQualid $ inTypeName ++ "_" ++ conName + generateInNames :: IR.QName -> Converter (IR.QName, [Coq.Qualid]) + generateInNames typeName = do + Just arity <- inEnv $ lookupArity IR.TypeScope typeName + inQualids <- map snd <$> if arity == 1 + then mapM (generateName "In" "") [typeName] + else mapM (\index -> generateName "In" ("_" ++ show index) typeName) [1 .. arity] + return (typeName, inQualids) - generateInProperties :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter [Coq.IndBody] + generateInProperties :: Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.IndBody] generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = - mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [1 .. length typeVarDecls] + mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [0 .. length typeVarDecls - 1] - generateInProperty :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody + generateInProperty :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody generateInProperty inQualidMap typeName typeVarDecls conDecls index = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let inQualid = inQualidMap Map.! (typeName, index) + let inQualid = (inQualidMap Map.! typeName) !! index (cons, mkBody) <- localEnv $ do (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls let binders = genericArgDecls Coq.Explicit ++ typeVarBinders - returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! (index - 1)) - (Coq.Arrow (Coq.app (Coq.Qualid typeQualid) (map Coq.Qualid (map fst Coq.Base.freeArgs ++ typeVarQualids))) + returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! index) + (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) (Coq.Sort Coq.Prop)) mkBody cons' = Coq.IndBody inQualid binders returnType cons' cons <- concatMapM (generateInConstructors typeVarQualids) conDecls return (cons, mkBody) - cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateInConName inQualid conName) cons + cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateConName inQualid conName) cons return $ mkBody cons' where generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] @@ -180,10 +149,9 @@ generateInductionSchemes dataDecls = do (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args elemQualid <- freshCoqQualid "x" occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args - let inQualid = inQualidMap Map.! (typeName, index) - inResult = Coq.app (Coq.Qualid inQualid) - ( map (Coq.Qualid . fst) Coq.Base.freeArgs - ++ map Coq.Qualid typeVarQualids + let inQualid = (inQualidMap Map.! typeName) !! index + inResult = genericApply inQualid [] [] + ( map Coq.Qualid typeVarQualids ++ [Coq.Qualid elemQualid] ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid (Coq.Qualid elemType) @@ -194,11 +162,11 @@ generateInductionSchemes dataDecls = do return $ map ((,) conName . Just) conTypes where elemType :: Coq.Qualid - elemType = typeVarQualids !! (index - 1) + elemType = typeVarQualids !! index inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term inHypothesis inQualid typeArgs containerQualid elemQualid = - Coq.app (Coq.Qualid inQualid) (map (Coq.Qualid . fst) Coq.Base.freeArgs ++ typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + genericApply inQualid [] [] (typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] findOccurrences elemQualid argQualid argType = do @@ -224,7 +192,7 @@ generateInductionSchemes dataDecls = do if tconArity == length typeArgs then do coqArgs <- mapM convertType' typeArgs - inTypes <- mapM (getInType inQualidMap tconName) [1 .. length typeArgs] + inTypes <- getInTypes inQualidMap tconName (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) @@ -235,13 +203,6 @@ generateInductionSchemes dataDecls = do -- Induction Schemes -- ----------------------------------------------------------------------------- - generateSchemeName :: IR.QName -> Converter (IR.QName, Coq.Qualid) - generateSchemeName typeQName = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - schemeQualid <- freshCoqQualid $ typeIdent ++ "_Ind" - return (typeQName, schemeQualid) - -- | Generates an induction scheme for the data type. generateSchemeLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" @@ -332,14 +293,7 @@ generateInductionSchemes dataDecls = do -- Forall Lemmas -- ----------------------------------------------------------------------------- - generateForallName :: IR.QName -> Converter (IR.QName, Coq.Qualid) - generateForallName typeQName = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName - let Just typeIdent = Coq.unpackQualid typeQualid - forallQualid <- freshCoqQualid $ "For" ++ typeIdent ++ "_forall" - return (typeQName, forallQualid) - - generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map (IR.QName, Int) Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) generateForallLemma _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" generateForallLemma forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName @@ -347,7 +301,7 @@ generateInductionSchemes dataDecls = do (propQualids, propBinders) <- mapAndUnzipM (\tv -> generateArg "P" (Coq.Arrow (Coq.Qualid tv) (Coq.Sort Coq.Prop))) tvarQualids (valQualid, valBinder) <- generateArg freshArgPrefix (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) - inTerms <- mapM (uncurry $ generateInTerm valQualid tvarQualids) $ zip [1 ..] propQualids + inTerms <- mapM (uncurry $ generateInTerm valQualid tvarQualids) $ zip [0 ..] propQualids let forallQualid = forallQualidMap Map.! typeName forQualid = forQualidMap Map.! typeName binders = genericArgDecls Coq.Explicit ++ tvarBinders ++ propBinders ++ [valBinder] @@ -360,8 +314,8 @@ generateInductionSchemes dataDecls = do where generateInTerm :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term generateInTerm valQualid tvarQualids index propQualid = localEnv $ do - let inQualid = inQualidMap Map.! (typeName, index) - (val2Qualid, val2Binder) <- generateArg "y" (Coq.Qualid $ tvarQualids !! (index - 1)) + let inQualid = (inQualidMap Map.! typeName) !! index + (val2Qualid, val2Binder) <- generateArg "y" (Coq.Qualid $ tvarQualids !! index) let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) @@ -369,6 +323,24 @@ generateInductionSchemes dataDecls = do -- Helper Functions -- ----------------------------------------------------------------------------- + hasTypeVar :: IR.TypeDecl -> Bool + hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" + hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls + + generateName :: String -> String -> IR.QName -> Converter (IR.QName, Coq.Qualid) + generateName prefix suffix typeQName = do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName + let Just typeIdent = Coq.unpackQualid typeQualid + newQualid <- freshCoqQualid $ prefix ++ typeIdent ++ suffix + return (typeQName, newQualid) + + generateConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid + generateConName baseQualid conQName = do + Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName + let Just baseName = Coq.unpackQualid baseQualid + Just conName = Coq.unpackQualid conQualid + freshCoqQualid $ baseName ++ "_" ++ conName + getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter Coq.Qualid getForType forQualidMap t = case forQualidMap Map.!? t of Just qualid -> return qualid @@ -380,9 +352,9 @@ generateInductionSchemes dataDecls = do Coq.Qualified _ n -> Text.unpack n return $ Coq.bare $ "For" ++ name - getInType :: Map.Map (IR.QName, Int) Coq.Qualid -> IR.QName -> Int -> Converter Coq.Qualid - getInType inQualidMap t argIndex = case inQualidMap Map.!? (t, argIndex) of - Just qualid -> return qualid + getInTypes :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter [Coq.Qualid] + getInTypes inQualidMap t = case inQualidMap Map.!? t of + Just qualids -> return qualids Nothing -> do -- TODO use environment to store and load other 'In-' properties Just qualid <- inEnv $ lookupIdent IR.TypeScope t @@ -390,7 +362,10 @@ generateInductionSchemes dataDecls = do let name = case qualid of Coq.Bare n -> Text.unpack n Coq.Qualified _ n -> Text.unpack n - return $ Coq.bare $ "In" ++ name ++ (if arity == 1 then "" else "_" ++ show argIndex) + suffixes = if arity == 1 + then [""] + else map (\index -> "_" ++ show index) [1 .. arity] + return $ map (\suffix -> Coq.bare $ "In" ++ name ++ suffix) suffixes generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) generateArg argName argType = do From ae244fead4d5702d9426b798719fd7822e17b494 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Tue, 22 Sep 2020 19:49:40 +0200 Subject: [PATCH 09/17] Adjust Prelude #159 --- base/coq/Free/Tactic/ProveForall.v | 15 ++- base/coq/Free/Tactic/ProveInd.v | 128 ++++++++++++------------- base/coq/Prelude/List.v | 106 +++++++++++---------- base/coq/Prelude/Pair.v | 147 ++++++++--------------------- 4 files changed, 173 insertions(+), 223 deletions(-) diff --git a/base/coq/Free/Tactic/ProveForall.v b/base/coq/Free/Tactic/ProveForall.v index cd09df6a..9298dcb7 100644 --- a/base/coq/Free/Tactic/ProveForall.v +++ b/base/coq/Free/Tactic/ProveForall.v @@ -46,19 +46,26 @@ Hint Extern 0 => forall_trivial_imp2 : prove_forall_db. Hint Extern 0 => forall_ForFree_InFree : prove_forall_db. Ltac prove_forall Ind := - let P := fresh "P" - in let C := fresh "C" + repeat (match goal with + | [ |- forall (_ : _ -> Prop), _ ] => intro + end); + let C := fresh "C" in let HF := fresh "HF" in let x := fresh "x" in let HI := fresh "HI" in let H := fresh "H" - in intros P C; split; - [ intros HF x HI; + in intro C; split; + [ intro HF; + repeat split; + intros x HI; induction C using Ind; dependent destruction HI; dependent destruction HF; auto with prove_forall_db | intro H; + repeat (match goal with + | [H1 : _ /\ _ |- _] => destruct H1 + end); induction C using Ind; constructor; auto with prove_forall_db2 diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index cc353276..fa752410 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -13,23 +13,21 @@ Create HintDb prove_ind_db. (* Trivial property *) Definition NoProperty {A : Type} : A -> Prop := fun _ => True. - -(* This tactic is needed to prevent [prove_ind_apply_assumption] from applying - the fixpoint hypothesis which would invalidify the proof. *) -Local Ltac prove_ind_is_fixpoint H P := - match type of H with - | forall x, P x => idtac - end. +Hint Extern 0 (NoProperty _) => unfold NoProperty; constructor : prove_ind_db. (* This tactic is applied at the beginning of the proof of an induction scheme - to introduce the induction hypotheses. *) -Local Ltac prove_ind_apply_assumption := + to select the correct hypothesis for the current induction case. *) +Ltac prove_ind_select_case FP := match goal with - | [ H : _ |- ?P ?x ] => tryif prove_ind_is_fixpoint H P then fail else apply H; clear H + | [ H : ?T |- _ ] => + lazymatch type of FP with + | T => fail + | _ => apply H; clear H + end end. (* This tactic eliminates the monadic layer of an induction hypothesis. *) -Local Ltac prove_ind_prove_ForFree := +Ltac prove_ind_prove_ForFree := match goal with | [ fx : Free ?Shape ?Pos ?T |- _ ] => match goal with @@ -40,75 +38,79 @@ Local Ltac prove_ind_prove_ForFree := in let s := fresh "s" in let pf := fresh "pf" in let IHpf := fresh "IHpf" - in apply ForFree_forall; intros x1 H; + in apply ForFree_forall; + intros x1 H; induction fx as [ x2 | s pf IHpf ] using Free_Ind; [ inversion H; subst; clear H | dependent destruction H; match goal with - | [ IHpf : forall p : Pos s, InFree Shape Pos T x1 (pf p) -> P x1 - , H : exists q : Pos s, InFree Shape Pos T x1 (pf q) + | [ IHpf : forall p : Pos s, InFree Shape Pos T ?x1 (pf p) -> P ?x1 + , H : exists q : Pos s, InFree Shape Pos T ?x1 (pf q) |- _ ] => let p := fresh "p" - in destruct H as [ p ]; apply (IHpf p); apply H + in destruct H as [ p H ]; + apply (IHpf p H) end ] end end. (* This tactic tries to finish the proof with an hypothesis with fulfilled - preconditions. *) -Local Ltac prove_ind_apply_hypothesis H := - match type of H with - | ?PC -> _ => - match goal with - | [ H2 : PC |- _ ] => specialize (H H2); prove_ind_apply_hypothesis H - end - | _ => apply H - end. + preconditions. *) +Ltac prove_ind_apply_hypothesis H := + match type of H with + | ?PC -> _ => + match goal with + | [ H2 : PC |- _ ] => specialize (H H2); prove_ind_apply_hypothesis H + end + | _ => apply H + end. (* This tactic eliminates intermediate monadic layers. *) -Local Ltac prove_ind_prove_for_free_in_free := - match goal with - | [ HIF : InFree ?Shape ?Pos ?T _ ?fx - , IH : ForFree ?Shape ?Pos ?T _ ?fx - |- _ ] => - rewrite ForFree_forall in IH; prove_ind_apply_hypothesis IH - | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx - |- ?P ?x ] => - let x1 := fresh "x" - in let s := fresh "s" - in let pf := fresh "pf" - in let IHpf := fresh "IHpf" - in induction fx as [ x1 | s pf IHpf ] using Free_Ind; - [ inversion HIF; subst; clear HIF - | dependent destruction HIF; - match goal with - | [H : exists p : Pos s, InFree Shape Pos T x (pf p) |- _ ] => - let p := fresh "p" - in destruct H as [ p H ]; apply (IHpf p H) - end - ] - end. +Ltac prove_ind_prove_ForFree_InFree := + match goal with + | [ HIF : InFree ?Shape ?Pos ?T _ ?fx + , IH : ForFree ?Shape ?Pos ?T _ ?fx + |- _ ] => + rewrite ForFree_forall in IH; prove_ind_apply_hypothesis IH + | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx + |- ?P ?x ] => + let x1 := fresh "x" + in let s := fresh "s" + in let pf := fresh "pf" + in let IHpf := fresh "IHpf" + in induction fx as [ x1 | s pf IHpf ] using Free_Ind; + [ inversion HIF; subst; clear HIF + | dependent destruction HIF; + match goal with + | [H : exists p : Pos s, InFree Shape Pos T x (pf p) |- _ ] => + let p := fresh "p" + in destruct H as [ p H ]; apply (IHpf p H) + end + ] + end. (* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) -Ltac prove_ind_prove_for_type type forType forType_forall type_induction := - match goal with - | [ x : type |- _ ] => - match goal with - | [ |- forType ?P x ] => - let y := fresh "x" - in let H := fresh "H" - in apply forType_forall; - type_induction x; - intros y H; inversion H; subst; clear H; try prove_ind_prove_for_free_in_free - end - end. +Ltac prove_ind_prove_ForType x forType_forall type_induction := + let y := fresh "y" + in let H := fresh "H" + in apply forType_forall; + repeat split; + type_induction x; + intros y H; inversion H; subst; clear H; + prove_ind_prove_ForFree_InFree. + +(* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) +(*Ltac prove_ind_prove_ForType x type_induction := + induction x using type_induction; + constructor; + prove_ind_prove_ForFree.*) (* This tactic proves an induction scheme. *) Ltac prove_ind := match goal with - | [ FP : forall x, ?P x |- _ ] => - match goal with - | [ |- P x] => destruct x; prove_ind_apply_assumption; prove_ind_prove_ForFree; - auto with prove_ind_db - end + | [ FP : forall y, ?P y |- ?P ?x ] => + destruct x; + prove_ind_select_case FP; + prove_ind_prove_ForFree; + intuition auto with prove_ind_db end. diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index 8e0c0a88..3676e8b3 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -176,71 +176,79 @@ Section SecFreeListInd. End SecFreeListInd. (* ForList *) -Inductive ForList_A (Shape : Type) (Pos : Shape -> Type) (A : Type) (P : A -> Prop) - : List Shape Pos A -> Prop := - | ForList_A_nil : ForList_A Shape Pos A P (@nil Shape Pos A) - | ForList_A_cons : forall (fx : Free Shape Pos A) - (fxs : Free Shape Pos (List Shape Pos A)), - ForFree Shape Pos A P fx -> - ForFree Shape Pos (List Shape Pos A) (ForList_A Shape Pos A P) fxs -> - ForList_A Shape Pos A P (@cons Shape Pos A fx fxs). - -Inductive InList_A (Shape : Type) (Pos : Shape -> Type) (A : Type) - : A -> List Shape Pos A -> Prop := - | InList_A_cons_fx : forall (x : A) - (fx : Free Shape Pos A) - (fys : Free Shape Pos (List Shape Pos A)), - InFree Shape Pos A x fx -> - InList_A Shape Pos A x (cons fx fys) - | InList_A_cons_fxs : forall (x : A) - (xs : List Shape Pos A) - (fy : Free Shape Pos A) - (fys : Free Shape Pos (List Shape Pos A)), - InList_A Shape Pos A x xs -> - InFree Shape Pos (List Shape Pos A) xs fys -> - InList_A Shape Pos A x (cons fy fys). - -Lemma ForList_A_forall (Shape : Type) (Pos : Shape -> Type) - (A : Type) : forall - (P : A -> Prop) - (fl : List Shape Pos A), - ForList_A Shape Pos A P fl <-> (forall (x : A), InList_A Shape Pos A x fl -> P x). +Inductive ForList (Shape : Type) (Pos : Shape -> Type) (a : Type) (P0 + : a -> Prop) + : List Shape Pos a -> Prop + := ForList_nil : ForList Shape Pos a P0 (@nil Shape Pos a) + | ForList_cons + : forall (x : Free Shape Pos a) (x0 : Free Shape Pos (List Shape Pos a)), + ForFree Shape Pos a P0 x -> + ForFree Shape Pos (List Shape Pos a) (ForList Shape Pos a P0) x0 -> + ForList Shape Pos a P0 (@cons Shape Pos a x x0). + +Inductive InList (Shape : Type) (Pos : Shape -> Type) (a : Type) + : a -> List Shape Pos a -> Prop + := InList_cons + : forall (x1 : a) + (x : Free Shape Pos a) + (x0 : Free Shape Pos (List Shape Pos a)), + InFree Shape Pos a x1 x -> InList Shape Pos a x1 (@cons Shape Pos a x x0) + | InList_cons0 + : forall (x1 : a) + (x2 : List Shape Pos a) + (x : Free Shape Pos a) + (x0 : Free Shape Pos (List Shape Pos a)), + InList Shape Pos a x1 x2 -> + InFree Shape Pos (List Shape Pos a) x2 x0 -> + InList Shape Pos a x1 (@cons Shape Pos a x x0). + +Lemma ForList_forall : forall (Shape : Type) + (Pos : Shape -> Type) + (a : Type) + (P0 : a -> Prop) + (x : List Shape Pos a), + ForList Shape Pos a P0 x <-> + (forall (y : a), InList Shape Pos a y x -> P0 y). Proof. - Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_A_cons_fx Shape Pos A) : prove_forall_db2. - Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_A_cons_fxs Shape Pos A) : prove_forall_db2. + intros Shape Pos a. + Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons Shape Pos A) : prove_forall_db2. + Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons0 Shape Pos A) : prove_forall_db2. prove_forall List_Ind. Qed. (* Add hints for proof generation *) -Local Ltac list_induction x := induction x as [ | fx fxs IHfxs ] using List_Ind. -Hint Extern 0 (ForList_A ?Shape ?Pos ?A _ _) => prove_ind_prove_for_type - (List Shape Pos A) - (ForList_A Shape Pos A) - (ForList_A_forall Shape Pos A) +Local Ltac list_induction x := + let fx := fresh "fx" + in let fxs := fresh "fxs" + in let IHfxs := fresh "IHfxs" + in induction x as [ | fx fxs IHfxs ] using List_Ind. +Hint Extern 0 (ForList ?Shape ?Pos ?A ?P ?x) => prove_ind_prove_ForType + x + (ForList_forall Shape Pos A) (list_induction) : prove_ind_db. -Local Ltac forall_ForList_A_InList_A := +Local Ltac forall_ForList_InList := match goal with - | [ HF : ForList_A ?Shape ?Pos ?A _ ?fx - , HI : InList_A ?Shape ?Pos ?A ?x ?fx + | [ HF : ForList ?Shape ?Pos ?A _ ?fx + , HI : InList ?Shape ?Pos ?A ?x ?fx |- _ ] => - rewrite ForList_A_forall in HF; + rewrite ForList_forall in HF; specialize (HF x HI) end. -Hint Extern 0 => forall_ForList_A_InList_A : prove_forall_db. -Local Ltac forall_ForList_A := +Hint Extern 0 => forall_ForList_InList : prove_forall_db. +Local Ltac forall_ForList := match goal with - | [ HF : ForList_A ?Shape ?Pos ?T _ ?fx - |- ForList_A ?Shape ?Pos ?T _ ?fx ] => + | [ HF : ForList ?Shape ?Pos ?T _ ?fx + |- ForList ?Shape ?Pos ?T _ ?fx ] => let x := fresh "x" in let HI := fresh "HI" - in apply ForList_A_forall; intros x HI; - rewrite ForList_A_forall in HF; + in apply ForList_forall; intros x HI; + rewrite ForList_forall in HF; specialize (HF x HI) - | [ H : forall y : ?A, _ |- ForList_A ?Shape ?Pos ?T ?P ?fx ] => + | [ H : forall y : ?A, _ |- ForList ?Shape ?Pos ?T ?P ?fx ] => let x := fresh "x" in let HI := fresh "HI" - in apply ForList_A_forall; intros x HI; + in apply ForList_forall; intros x HI; specialize (H x) end. -Hint Extern 0 => forall_ForList_A : prove_forall_db2. +Hint Extern 0 => forall_ForList : prove_forall_db2. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 7ac8a43e..4bcf12ee 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -65,117 +65,50 @@ Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) end }. -(* ForPair_A *) -Inductive ForPair_A (Shape : Type) (Pos : Shape -> Type) (A B : Type) (P : A -> Prop) - : Pair Shape Pos A B -> Prop := - | ForPair_A_pair : forall (fx : Free Shape Pos A) - (fy : Free Shape Pos B), - ForFree Shape Pos A P fx -> - ForPair_A Shape Pos A B P (@pair_ Shape Pos A B fx fy). - -Inductive InPair_A (Shape : Type) (Pos : Shape -> Type) (A B : Type) - : A -> Pair Shape Pos A B -> Prop := - | InPair_A_pair_fx : forall (x : A) - (fx : Free Shape Pos A) - (fy : Free Shape Pos B), - InFree Shape Pos A x fx -> - InPair_A Shape Pos A B x (@pair_ Shape Pos A B fx fy). - -Lemma ForPair_A_forall (Shape : Type) (Pos : Shape -> Type) (A B : Type) - : forall (P : A -> Prop) - (fp : Pair Shape Pos A B), - ForPair_A Shape Pos A B P fp <-> (forall (x : A), InPair_A Shape Pos A B x fp -> P x). +(* ForPair *) +Inductive ForPair (Shape : Type) (Pos : Shape -> Type) (a b : Type) (P0 + : a -> Prop) (P1 : b -> Prop) + : Pair Shape Pos a b -> Prop + := ForPair_pair_ + : forall (x : Free Shape Pos a) (x0 : Free Shape Pos b), + ForFree Shape Pos a P0 x -> + ForFree Shape Pos b P1 x0 -> + ForPair Shape Pos a b P0 P1 (@pair_ Shape Pos a b x x0). + +Inductive InPair_1 (Shape : Type) (Pos : Shape -> Type) (a b : Type) + : a -> Pair Shape Pos a b -> Prop + := InPair_1_pair_ + : forall (x1 : a) (x : Free Shape Pos a) (x0 : Free Shape Pos b), + InFree Shape Pos a x1 x -> + InPair_1 Shape Pos a b x1 (@pair_ Shape Pos a b x x0) +with InPair_2 (Shape : Type) (Pos : Shape -> Type) (a b : Type) + : b -> Pair Shape Pos a b -> Prop + := InPair_2_pair_ + : forall (x1 : b) (x : Free Shape Pos a) (x0 : Free Shape Pos b), + InFree Shape Pos b x1 x0 -> + InPair_2 Shape Pos a b x1 (@pair_ Shape Pos a b x x0). + +Lemma ForPair_forall : forall (Shape : Type) + (Pos : Shape -> Type) + (a b : Type) + (P0 : a -> Prop) + (P1 : b -> Prop) + (x : Pair Shape Pos a b), + ForPair Shape Pos a b P0 P1 x <-> + ((forall (y : a), InPair_1 Shape Pos a b y x -> P0 y) /\ + (forall (y : b), InPair_2 Shape Pos a b y x -> P1 y)). Proof. - Hint Extern 0 (ForPair_A ?Shape ?Pos ?A ?B _ _) => forall_finish2 (@InPair_A_pair_fx Shape Pos A B) : prove_forall_db2. - prove_forall Pair_ind. -Qed. - -(* ForPair_B *) -Inductive ForPair_B (Shape : Type) (Pos : Shape -> Type) (A B : Type) (P : B -> Prop) - : Pair Shape Pos A B -> Prop := - | ForPair_B_pair : forall (fx : Free Shape Pos A) - (fy : Free Shape Pos B), - ForFree Shape Pos B P fy -> - ForPair_B Shape Pos A B P (@pair_ Shape Pos A B fx fy). - -Inductive InPair_B (Shape : Type) (Pos : Shape -> Type) (A B : Type) - : B -> Pair Shape Pos A B -> Prop := - | InPair_B_pair_fy : forall (y : B) - (fx : Free Shape Pos A) - (fy : Free Shape Pos B), - InFree Shape Pos B y fy -> - InPair_B Shape Pos A B y (@pair_ Shape Pos A B fx fy). - -Lemma ForPair_B_forall (Shape : Type) (Pos : Shape -> Type) (A B : Type) - : forall (P : B -> Prop) - (fp : Pair Shape Pos A B), - ForPair_B Shape Pos A B P fp <-> (forall (x : B), InPair_B Shape Pos A B x fp -> P x). -Proof. - Hint Extern 0 (ForPair_B ?Shape ?Pos ?A ?B _ _) => forall_finish2 (@InPair_B_pair_fy Shape Pos A B) : prove_forall_db2. + intros Shape Pos a b. prove_forall Pair_ind. Qed. (* Add hints for proof generation *) -Local Ltac pair_induction x := induction x as [ fx fy ] using Pair_ind. -Hint Extern 0 (ForPair_A ?Shape ?Pos ?A ?B _ _) => prove_ind_prove_for_type - (Pair Shape Pos A B) - (ForPair_A Shape Pos A B) - (ForPair_A_forall Shape Pos A B) - (pair_induction) - : prove_ind_db. -Hint Extern 0 (ForPair_B ?Shape ?Pos ?A ?B _ _) => prove_ind_prove_for_type - (Pair Shape Pos A B) - (ForPair_B Shape Pos A B) - (ForPair_B_forall Shape Pos A B) +Local Ltac pair_induction x := + let fx := fresh "fx" + in let fy := fresh "fy" + in induction x as [ fx fy ] using Pair_ind. +Hint Extern 0 (ForPair ?Shape ?Pos ?A ?B ?PA ?PB ?x) => prove_ind_prove_ForType + x + (ForPair_forall Shape Pos A B) (pair_induction) : prove_ind_db. -Local Ltac forall_ForPair_A_InPair_A := - match goal with - | [ HF : ForPair_A ?Shape ?Pos ?A ?B _ ?fx - , HI : InPair_A ?Shape ?Pos ?A ?B ?x ?fx - |- _ ] => - rewrite ForPair_A_forall in HF; - specialize (HF x HI) - end. -Hint Extern 0 => forall_ForPair_A_InPair_A : prove_forall_db. -Local Ltac forall_ForPair_B_InPair_B := - match goal with - | [ HF : ForPair_B ?Shape ?Pos ?A ?B _ ?fx - , HI : InPair_B ?Shape ?Pos ?A ?B ?x ?fx - |- _ ] => - rewrite ForPair_B_forall in HF; - specialize (HF x HI) - end. -Hint Extern 0 => forall_ForPair_B_InPair_B : prove_forall_db. -Local Ltac forall_ForPair_A := - match goal with - | [ HF : ForPair_A ?Shape ?Pos ?T1 ?T2 _ ?fx - |- ForPair_A ?Shape ?Pos ?T1 ?T2 _ ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForPair_A_forall; intros x HI; - rewrite ForPair_A_forall in HF; - specialize (HF x HI) - | [ H : forall y : ?A, _ |- ForPair_A ?Shape ?Pos ?T1 ?T2 ?P ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForPair_A_forall; intros x HI; - specialize (H x) - end. -Hint Extern 0 => forall_ForPair_A : prove_forall_db2. -Local Ltac forall_ForPair_B := - match goal with - | [ HF : ForPair_B ?Shape ?Pos ?T1 ?T2 _ ?fx - |- ForPair_B ?Shape ?Pos ?T1 ?T2 _ ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForPair_B_forall; intros x HI; - rewrite ForPair_B_forall in HF; - specialize (HF x HI) - | [ H : forall y : ?A, _ |- ForPair_B ?Shape ?Pos ?T1 ?T2 ?P ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForPair_B_forall; intros x HI; - specialize (H x) - end. -Hint Extern 0 => forall_ForPair_B : prove_forall_db2. From acaea383288573981a464e2acf77f2b974b97eb2 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Thu, 24 Sep 2020 09:34:00 +0200 Subject: [PATCH 10/17] Generate forall properties only for complex datatypes #159 --- src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index 47b44039..c0c61bd0 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -33,7 +33,7 @@ generateInductionSchemes dataDecls = do schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_Ind" . IR.typeDeclQName) dataDecls schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls - forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) dataDecls + forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) complexDataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] From e1d3b8168f83e2a8e756d16be52efbec8a4de179 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Fri, 25 Sep 2020 18:37:12 +0200 Subject: [PATCH 11/17] Name induction schemes `_ind` instead of `_Ind` #163 Also generate first hints #159 --- base/coq/Free/Tactic/ProveInd.v | 50 ++++---- base/coq/Prelude/List.v | 22 ++-- base/coq/Prelude/Pair.v | 11 +- src/lib/FreeC/Backend/Coq/Base.hs | 19 ++- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 4 +- .../Coq/Converter/TypeDecl/InductionScheme.hs | 111 ++++++++++++------ src/lib/FreeC/Backend/Coq/Syntax.hs | 30 +++++ 7 files changed, 163 insertions(+), 84 deletions(-) diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index fa752410..e45a3bb2 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -32,25 +32,25 @@ Ltac prove_ind_prove_ForFree := | [ fx : Free ?Shape ?Pos ?T |- _ ] => match goal with | [ |- ForFree Shape Pos T ?P fx ] => - let x1 := fresh "x" - in let H := fresh "H" - in let x2 := fresh "x" + apply ForFree_forall; + let x1 := fresh "x" + in let H := fresh "H" + in intros x1 H; + let x2 := fresh "x" in let s := fresh "s" in let pf := fresh "pf" in let IHpf := fresh "IHpf" - in apply ForFree_forall; - intros x1 H; - induction fx as [ x2 | s pf IHpf ] using Free_Ind; - [ inversion H; subst; clear H - | dependent destruction H; - match goal with - | [ IHpf : forall p : Pos s, InFree Shape Pos T ?x1 (pf p) -> P ?x1 - , H : exists q : Pos s, InFree Shape Pos T ?x1 (pf q) - |- _ ] => - let p := fresh "p" - in destruct H as [ p H ]; - apply (IHpf p H) - end ] + in induction fx as [ x2 | s pf IHpf ] using Free_Ind; + [ inversion H; subst; clear H + | dependent destruction H; + match goal with + | [ IHpf : forall p : Pos s, InFree Shape Pos T ?x1 (pf p) -> P ?x1 + , H : exists q : Pos s, InFree Shape Pos T ?x1 (pf q) + |- _ ] => + let p := fresh "p" + in destruct H as [ p H ]; + apply (IHpf p H) + end ] end end. @@ -74,7 +74,7 @@ Ltac prove_ind_prove_ForFree_InFree := rewrite ForFree_forall in IH; prove_ind_apply_hypothesis IH | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx |- ?P ?x ] => - let x1 := fresh "x" + let x1 := fresh "x" in let s := fresh "s" in let pf := fresh "pf" in let IHpf := fresh "IHpf" @@ -90,14 +90,14 @@ Ltac prove_ind_prove_ForFree_InFree := end. (* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) -Ltac prove_ind_prove_ForType x forType_forall type_induction := - let y := fresh "y" - in let H := fresh "H" - in apply forType_forall; - repeat split; - type_induction x; - intros y H; inversion H; subst; clear H; - prove_ind_prove_ForFree_InFree. +Ltac prove_ind_prove_ForType x forType_forall type_ind := + apply forType_forall; + repeat split; + induction x using type_ind; + let y := fresh "y" + in let H := fresh "H" + in intros y H; inversion H; subst; clear H; + prove_ind_prove_ForFree_InFree. (* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) (*Ltac prove_ind_prove_ForType x type_induction := diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index 3676e8b3..e9af1449 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -9,11 +9,13 @@ Section SecList. Variable Pos : Shape -> Type. Notation "'Free''" := (Free Shape Pos). + Unset Elimination Schemes. Inductive List (A : Type) : Type := | nil : List A | cons : Free' A -> Free' (List A) -> List A. + Set Elimination Schemes. -End SecList. + End SecList. (* smart constructors *) @@ -105,14 +107,14 @@ Section SecListInd. (fxs : Free Shape Pos (List Shape Pos A)), ForFree Shape Pos (List Shape Pos A) P fxs -> P (cons fx fxs). - Fixpoint List_Ind (l : List Shape Pos A) : P l. + Fixpoint List_ind (l : List Shape Pos A) : P l. Proof. destruct l. - apply nilP. - apply consP. apply (ForFree_forall Shape Pos). intros xs HIn. induction f0 using Free_Ind. - + inversion HIn; subst. apply List_Ind. + + inversion HIn; subst. apply List_ind. + dependent destruction HIn; subst. destruct H0 as [ p ]. apply H with (p := p). apply H0. Defined. @@ -213,20 +215,12 @@ Proof. intros Shape Pos a. Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons Shape Pos A) : prove_forall_db2. Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons0 Shape Pos A) : prove_forall_db2. - prove_forall List_Ind. + prove_forall List_ind. Qed. (* Add hints for proof generation *) -Local Ltac list_induction x := - let fx := fresh "fx" - in let fxs := fresh "fxs" - in let IHfxs := fresh "IHfxs" - in induction x as [ | fx fxs IHfxs ] using List_Ind. -Hint Extern 0 (ForList ?Shape ?Pos ?A ?P ?x) => prove_ind_prove_ForType - x - (ForList_forall Shape Pos A) - (list_induction) - : prove_ind_db. +Hint Extern 0 (ForList _ _ _ _ ?x) => + prove_ind_prove_ForType x ForList_forall list_induction : prove_ind_db. Local Ltac forall_ForList_InList := match goal with | [ HF : ForList ?Shape ?Pos ?A _ ?fx diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 4bcf12ee..3601228a 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -103,12 +103,5 @@ Proof. Qed. (* Add hints for proof generation *) -Local Ltac pair_induction x := - let fx := fresh "fx" - in let fy := fresh "fy" - in induction x as [ fx fy ] using Pair_ind. -Hint Extern 0 (ForPair ?Shape ?Pos ?A ?B ?PA ?PB ?x) => prove_ind_prove_ForType - x - (ForPair_forall Shape Pos A B) - (pair_induction) - : prove_ind_db. +Hint Extern 0 (ForPair _ _ _ _ _ _ ?x) => + prove_ind_prove_ForType x ForPair_forall pair_induction : prove_ind_db. diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 6f446a97..3ccdee03 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -44,6 +44,9 @@ module FreeC.Backend.Coq.Base , stringScope -- * Tactics , proveInd + , proveInd_proveForType + -- * Hint Databases + , proveInd_db -- * Reserved Identifiers , reservedIdents ) where @@ -253,8 +256,20 @@ stringScope = Coq.ident "string" -- Tactics -- ------------------------------------------------------------------------------- -- | The tactic that is needed to prove induction schemes. -proveInd :: Coq.Qualid -proveInd = Coq.bare "prove_ind" +proveInd :: Coq.Ident +proveInd = Coq.ident "prove_ind" + +-- | The tactic that has to be instantiated for data types and added to +-- 'proveInd_db'. +proveInd_proveForType :: Coq.Ident +proveInd_proveForType = Coq.ident "prove_ind_prove_ForType" + +------------------------------------------------------------------------------- +-- Hint Databases -- +------------------------------------------------------------------------------- +-- | The hint database that is used ba 'proveInd'. +proveInd_db :: Coq.Ident +proveInd_db = Coq.ident "prove_ind_db" ------------------------------------------------------------------------------- -- Reserved Identifiers -- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 3e6c10ef..cf840757 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -129,9 +129,11 @@ convertDataDecls dataDecls = do inductionSentences <- generateInductionSchemes dataDecls let (extraSentences, qualSmartConDecls) = concatUnzip extraSentences' return - ( Coq.comment ("Data type declarations for " + ( Coq.unsetOption (Just Coq.Local) "EliminationSchemes" + : Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) + : Coq.setOption (Just Coq.Local) "EliminationSchemes" Nothing : extraSentences ++ inductionSentences , qualSmartConDecls ) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index c0c61bd0..670c48a6 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -14,7 +14,7 @@ import FreeC.Backend.Coq.Converter.Type import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqQualid ) + ( freshArgPrefix, freshCoqQualid, freshCoqIdent ) import qualified FreeC.IR.Syntax as IR import FreeC.IR.TypeSynExpansion import FreeC.Monad.Converter @@ -30,15 +30,17 @@ generateInductionSchemes dataDecls = do forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls inQualidMap <- Map.fromList <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls - schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_Ind" . IR.typeDeclQName) dataDecls + schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_ind" . IR.typeDeclQName) dataDecls schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) complexDataDecls + hintSentences <- concatMapM (generateHints schemeQualidMap forQualidMap inQualidMap) complexDataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] ++(map (\(name, binders, term, proof) -> Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) (schemeBodies ++ forallBodies)) + ++ hintSentences ) where @@ -105,8 +107,8 @@ generateInductionSchemes dataDecls = do if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses coqArgs <- mapM convertType' typeArgs - forType <- getForType forQualidMap tconName - return $ Just $ genericApply forType [] [] (coqArgs ++ hypotheses') + mbForType <- getForType Map.empty tconName -- Do not search in mutually recursive types + return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing @@ -191,18 +193,30 @@ generateInductionSchemes dataDecls = do Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName if tconArity == length typeArgs then do - coqArgs <- mapM convertType' typeArgs - inTypes <- getInTypes inQualidMap tconName - (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) - occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs - let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) - return $ map mkNewOcc occurrences + mbInTypes <- getInTypes Map.empty tconName -- Do not search in mutually recursive types + case mbInTypes of + Just inTypes -> do + coqArgs <- mapM convertType' typeArgs + (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) + occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs + let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) + return $ map mkNewOcc occurrences + Nothing -> return [] else return [] ----------------------------------------------------------------------------- -- Induction Schemes -- ----------------------------------------------------------------------------- + -- | The maximal depth to search for recursive occurrences when construction + -- induction hypotheses. + -- @0@ -> Create only induction hypotheses for direct recursion. + -- @n@ -> Create only induction hypotheses for constructor arguments where + -- the recursive occurrence is encapsulated in at most @n@ data + -- types. + maxDepth :: Int + maxDepth = 1 + -- | Generates an induction scheme for the data type. generateSchemeLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" @@ -234,7 +248,7 @@ generateInductionSchemes dataDecls = do (Text.pack $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" ++ " fix " ++ fixpoint ++ " 1; intro " ++ var ++ "; " - ++ fromJust (Coq.unpackQualid Coq.Base.proveInd) + ++ Text.unpack Coq.Base.proveInd ++ ".") return (schemeName, [], term, proof) where @@ -255,39 +269,39 @@ generateInductionSchemes dataDecls = do generateInductionHypothesis :: Coq.Qualid -> Coq.Term -> Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) generateInductionHypothesis propQualid conType argQualid argType = do - mbHypothesis <- generateInductionHypothesis_1 argType + mbHypothesis <- generateInductionHypothesis_1 maxDepth argType argType' <- convertType' argType case mbHypothesis of Just hypothesis -> return $ Just $ genericApply Coq.Base.forFree [] [] [argType', hypothesis, Coq.Qualid argQualid] Nothing -> return Nothing where - generateInductionHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) - generateInductionHypothesis_1 (IR.FuncType _ _ _) = return Nothing - generateInductionHypothesis_1 t@(IR.TypeApp _ tcon lastArg) = do + generateInductionHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) + generateInductionHypothesis_1 _ (IR.FuncType _ _ _) = return Nothing + generateInductionHypothesis_1 md t@(IR.TypeApp _ tcon lastArg) = do t' <- convertType' t if conType == t' then return $ Just $ Coq.Qualid propQualid - else generateInductionHypothesis_2 tcon [lastArg] - generateInductionHypothesis_1 t@(IR.TypeCon _ _) = do + else if md > 0 then generateInductionHypothesis_2 (md-1) tcon [lastArg] else return Nothing + generateInductionHypothesis_1 _ t@(IR.TypeCon _ _) = do t' <- convertType' t if conType == t' then return $ Just $ Coq.Qualid propQualid else return Nothing -- Ignore type constructors that do not have any type variable or are partially applied - generateInductionHypothesis_1 (IR.TypeVar _ _) = return Nothing + generateInductionHypothesis_1 _ (IR.TypeVar _ _) = return Nothing - generateInductionHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateInductionHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing - generateInductionHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateInductionHypothesis_2 tcon (lastArg : typeArgs) - generateInductionHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do + generateInductionHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateInductionHypothesis_2 _ (IR.FuncType _ _ _) _ = return Nothing + generateInductionHypothesis_2 md (IR.TypeApp _ tcon lastArg) typeArgs = generateInductionHypothesis_2 md tcon (lastArg : typeArgs) + generateInductionHypothesis_2 md (IR.TypeCon _ tconName) typeArgs = do Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - hypotheses <- mapM generateInductionHypothesis_1 typeArgs + hypotheses <- mapM (generateInductionHypothesis_1 md) typeArgs if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses coqArgs <- mapM convertType' typeArgs - forType <- getForType forQualidMap tconName - return $ Just $ genericApply forType [] [] (coqArgs ++ hypotheses') + mbForType <- getForType forQualidMap tconName + return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateInductionHypothesis_2 (IR.TypeVar _ _) _ = return Nothing + generateInductionHypothesis_2 _ (IR.TypeVar _ _) _ = return Nothing ----------------------------------------------------------------------------- -- Forall Lemmas -- @@ -309,7 +323,12 @@ generateInductionSchemes dataDecls = do rhs = let (inQualids', [lastIn]) = splitAt (length inTerms - 1) $ inTerms in foldr Coq.conj lastIn inQualids' term = Coq.forall binders (Coq.equiv lhs rhs) - proof = Coq.ProofQed $ Text.pack "" + vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ propQualids ++ [valQualid]) + proof = Coq.ProofQed + (Text.pack + $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" + ++ Text.unpack Coq.Base.proveInd + ++ ".") return (forallQualid, [], term, proof) where generateInTerm :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term @@ -319,6 +338,32 @@ generateInductionSchemes dataDecls = do let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) + ----------------------------------------------------------------------------- + -- Hints -- + ----------------------------------------------------------------------------- + -- | Generates hints that are used in the proofs of induction schemes and + -- 'forall' sentences. + generateHints :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] + generateHints _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateHint: Type synonym not allowed" + generateHints schemeQualidMap forallQualidMap _inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = do + let forType = forallQualidMap Map.! typeName + scheme = schemeQualidMap Map.! typeName + proveIndHint <- generateProveIndHint forType scheme (length typeVarDecls) + return [proveIndHint] + + generateProveIndHint :: Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) + generateProveIndHint forType scheme nTvars = localEnv $ do + valStr <- localEnv $ freshCoqIdent freshArgPrefix + let tacticConStr = Text.unpack Coq.Base.proveInd_proveForType + Just forTypeStr = Coq.unpackQualid forType + Just schemeStr = Coq.unpackQualid scheme + tactic = tacticConStr ++ ' ' : valStr ++ ' ' : forTypeStr ++ ' ' : schemeStr + underscores = replicate (2 * nTvars + 2) Coq.UnderscorePat + valPattern = Coq.QualidPat $ Coq.bare $ '?':valStr + forTypePattern = Coq.ArgsPat forType $ underscores ++ [valPattern] + return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveInd_db] + + ----------------------------------------------------------------------------- -- Helper Functions -- ----------------------------------------------------------------------------- @@ -341,20 +386,20 @@ generateInductionSchemes dataDecls = do Just conName = Coq.unpackQualid conQualid freshCoqQualid $ baseName ++ "_" ++ conName - getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter Coq.Qualid + getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) getForType forQualidMap t = case forQualidMap Map.!? t of - Just qualid -> return qualid + Just qualid -> return $ Just qualid Nothing -> do -- TODO use environment to store and load other 'For-' properties Just qualid <- inEnv $ lookupIdent IR.TypeScope t let name = case qualid of Coq.Bare n -> Text.unpack n Coq.Qualified _ n -> Text.unpack n - return $ Coq.bare $ "For" ++ name + return $ Just $ Coq.bare $ "For" ++ name - getInTypes :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter [Coq.Qualid] + getInTypes :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter (Maybe [Coq.Qualid]) getInTypes inQualidMap t = case inQualidMap Map.!? t of - Just qualids -> return qualids + Just qualids -> return $ Just qualids Nothing -> do -- TODO use environment to store and load other 'In-' properties Just qualid <- inEnv $ lookupIdent IR.TypeScope t @@ -365,7 +410,7 @@ generateInductionSchemes dataDecls = do suffixes = if arity == 1 then [""] else map (\index -> "_" ++ show index) [1 .. arity] - return $ map (\suffix -> Coq.bare $ "In" ++ name ++ suffix) suffixes + return $ Just $ map (\suffix -> Coq.bare $ "In" ++ name ++ suffix) suffixes generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) generateArg argName argType = do diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index ae9b8a99..d07bcf8c 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -44,6 +44,11 @@ module FreeC.Backend.Coq.Syntax , disj , equiv , forall + -- * Options + , setOption + , unsetOption + -- * Hints + , externHint -- * Imports , requireImportFrom , requireExportFrom @@ -268,6 +273,31 @@ forall :: [Binder] -> Term -> Term forall [] t = t forall bs t = Forall (NonEmpty.fromList bs) t +------------------------------------------------------------------------------- +-- Options -- +------------------------------------------------------------------------------- +-- | Smart constructor for a sentence which sets an option or flag. +setOption :: Maybe Locality -> String -> Maybe (Either Num String) -> Sentence +setOption mbLoc opt mbArg = + OptionSentence $ SetOption mbLoc (Text.pack opt) mbArg' + where + mbArg' = case mbArg of + Nothing -> Nothing + (Just (Left num)) -> Just (OVNum num) + (Just (Right str)) -> Just (OVText (Text.pack str)) + +-- | Smart constructor for a sentence which unsets an option or flag. +unsetOption :: Maybe Locality -> String -> Sentence +unsetOption mbLoc opt = OptionSentence $ UnsetOption mbLoc (Text.pack opt) + +------------------------------------------------------------------------------- +-- Hints -- +------------------------------------------------------------------------------- +-- | Smart constructor for an extern hint. +externHint :: Maybe Locality -> Num -> Maybe Pattern -> String -> [Ident] -> Sentence +externHint mbLoc num mbPat tactic dbs = + HintSentence $ Hint mbLoc (HintExtern num mbPat $ Text.pack tactic) dbs + ------------------------------------------------------------------------------- -- Imports -- ------------------------------------------------------------------------------- From 1f82d14baaff206be030d1a5df189d555a0af960 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Fri, 25 Sep 2020 20:52:31 +0200 Subject: [PATCH 12/17] Add environment entries for `For-` and `In-` properties #159 --- src/lib/FreeC/Environment/Entry.hs | 4 ++++ .../Environment/ModuleInterface/Decoder.hs | 16 +++++++++----- .../Environment/ModuleInterface/Encoder.hs | 22 ++++++++++++++----- src/lib/FreeC/Pass/DefineDeclPass.hs | 14 +++++++----- 4 files changed, 38 insertions(+), 18 deletions(-) diff --git a/src/lib/FreeC/Environment/Entry.hs b/src/lib/FreeC/Environment/Entry.hs index 00038307..753d156f 100644 --- a/src/lib/FreeC/Environment/Entry.hs +++ b/src/lib/FreeC/Environment/Entry.hs @@ -29,6 +29,10 @@ data EnvEntry -- ^ The name of the data type in the module it has been defined in. , entryConsNames :: [IR.ConName] -- ^ The names of the constructors of the data type. + , entryForPropertyIdent :: Maybe Coq.Qualid + -- ^ The name of the 'For-' property in Coq. + , entryInPropertyIdents :: Maybe [Coq.Qualid] + -- ^ The names of the 'In-' properties in Coq. } -- | Entry for a type synonym declaration. | TypeSynEntry diff --git a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs index f824fda7..9bb534d3 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs @@ -215,12 +215,16 @@ instance Aeson.FromJSON ModuleInterface where coqName <- obj .: "coq-name" agdaName <- obj .: "agda-name" consNames <- obj .: "cons-names" - return DataEntry { entrySrcSpan = NoSrcSpan - , entryArity = arity - , entryIdent = coqName - , entryAgdaIdent = agdaName - , entryName = haskellName - , entryConsNames = consNames + coqForPropertyName <- obj .:? "coq-for-property-name" + coqInPropertyNames <- obj .:? "coq-in-property-names" + return DataEntry { entrySrcSpan = NoSrcSpan + , entryArity = arity + , entryIdent = coqName + , entryAgdaIdent = agdaName + , entryName = haskellName + , entryConsNames = consNames + , entryForPropertyIdent = coqForPropertyName + , entryInPropertyIdents = coqInPropertyNames } parseConfigTypeSyn :: Aeson.Value -> Aeson.Parser EnvEntry diff --git a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs index f61ee409..d35f641e 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs @@ -90,12 +90,17 @@ instance Aeson.ToJSON ModuleInterface where encodeEntry :: EnvEntry -> Maybe Aeson.Value encodeEntry entry | isDataEntry entry = return - $ Aeson.object [ "haskell-name" .= haskellName - , "coq-name" .= coqName - , "agda-name" .= agdaName - , "cons-names" .= consNames - , "arity" .= arity - ] + $ Aeson.object $ + [ "haskell-name" .= haskellName + , "coq-name" .= coqName + , "agda-name" .= agdaName + , "cons-names" .= consNames + , "arity" .= arity + ] + ++ mapMaybe id + [ ("coq-for-property-name" .=) <$> coqForPropertyName + , ("coq-in-property-names" .=) <$> coqInPropertyNames + ] | isTypeSynEntry entry = return $ Aeson.object [ "haskell-name" .= haskellName @@ -135,6 +140,11 @@ encodeEntry entry coqSmartName = Aeson.toJSON (entrySmartIdent entry) + coqForPropertyName, coqInPropertyNames :: Maybe Aeson.Value + coqForPropertyName = Aeson.toJSON <$> (entryForPropertyIdent entry) + + coqInPropertyNames = Aeson.toJSON <$> (entryInPropertyIdents entry) + -- @entryAgdaIdent entry@ is undefined because the agda renamer isn't -- implemented at the moment. To allow encoding a dummy value is needed. -- I decided to insert the placeholder at this point to avoid placing diff --git a/src/lib/FreeC/Pass/DefineDeclPass.hs b/src/lib/FreeC/Pass/DefineDeclPass.hs index 65bc455f..e6c20ac7 100644 --- a/src/lib/FreeC/Pass/DefineDeclPass.hs +++ b/src/lib/FreeC/Pass/DefineDeclPass.hs @@ -71,12 +71,14 @@ defineTypeDecl (IR.TypeSynDecl srcSpan declIdent typeArgs typeExpr) = do return () defineTypeDecl (IR.DataDecl srcSpan declIdent typeArgs conDecls) = do _ <- renameAndAddEntry DataEntry - { entrySrcSpan = srcSpan - , entryArity = length typeArgs - , entryName = IR.declIdentName declIdent - , entryConsNames = map IR.conDeclQName conDecls - , entryIdent = undefined -- filled by renamer - , entryAgdaIdent = undefined -- filled by renamer + { entrySrcSpan = srcSpan + , entryArity = length typeArgs + , entryName = IR.declIdentName declIdent + , entryConsNames = map IR.conDeclQName conDecls + , entryIdent = undefined -- filled by renamer + , entryAgdaIdent = undefined -- filled by renamer + , entryForPropertyIdent = Nothing -- may be filled by induction scheme generation + , entryInPropertyIdent = Nothing -- may be filled by induction scheme generation } mapM_ defineConDecl conDecls where From 2aa58185c49b59e33346ded6cf7866a2e1a07940 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Sat, 26 Sep 2020 13:36:22 +0200 Subject: [PATCH 13/17] Use new environment entries #159 --- base/Prelude.toml | 27 ++++++++----- src/lib/FreeC/Backend/Coq/Base.hs | 22 +++++++++- .../Coq/Converter/TypeDecl/InductionScheme.hs | 33 ++++++--------- src/lib/FreeC/Environment.hs | 40 +++++++++++++++++++ src/lib/FreeC/Pass/DefineDeclPass.hs | 4 +- 5 files changed, 92 insertions(+), 34 deletions(-) diff --git a/base/Prelude.toml b/base/Prelude.toml index 9e5e5f08..40ef6967 100644 --- a/base/Prelude.toml +++ b/base/Prelude.toml @@ -208,14 +208,16 @@ exported-values = [ ############################################################################## [[types]] - haskell-name = 'Prelude.([])' - coq-name = 'List' - agda-name = 'List' - arity = 1 - cons-names = [ + haskell-name = 'Prelude.([])' + coq-name = 'List' + agda-name = 'List' + arity = 1 + cons-names = [ 'Prelude.([])', 'Prelude.(:)', ] + coq-for-property-name = 'ForList' + coq-in-property-names = ['InList'] [[constructors]] haskell-type = 'Prelude.([]) a' @@ -240,11 +242,16 @@ exported-values = [ ############################################################################## [[types]] - haskell-name = 'Prelude.(,)' - coq-name = 'Pair' - agda-name = 'Pair' - arity = 2 - cons-names = ['Prelude.(,)'] + haskell-name = 'Prelude.(,)' + coq-name = 'Pair' + agda-name = 'Pair' + arity = 2 + cons-names = ['Prelude.(,)'] + coq-for-property-name = 'ForPair' + coq-in-property-names = [ + 'InPair_1', + 'InPair_2' + ] [[constructors]] haskell-type = 'a -> b -> Prelude.(,) a b' diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 3ccdee03..29eb7fcd 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -45,8 +45,11 @@ module FreeC.Backend.Coq.Base -- * Tactics , proveInd , proveInd_proveForType + , proveForall -- * Hint Databases , proveInd_db + , proveForall_ltr_db + , proveForall_rtl_db -- * Reserved Identifiers , reservedIdents ) where @@ -264,13 +267,30 @@ proveInd = Coq.ident "prove_ind" proveInd_proveForType :: Coq.Ident proveInd_proveForType = Coq.ident "prove_ind_prove_ForType" + +-- | The tactic that is needed to prove 'forall' lemmas. +proveForall :: Coq.Ident +proveForall = Coq.ident "prove_forall" + ------------------------------------------------------------------------------- -- Hint Databases -- ------------------------------------------------------------------------------- --- | The hint database that is used ba 'proveInd'. +-- | The hint database that is used by 'proveInd'. proveInd_db :: Coq.Ident proveInd_db = Coq.ident "prove_ind_db" + +-- | The hint database that is used by 'proveForall' to prove the '->' +-- direction of the equivalence. +proveForall_ltr_db :: Coq.Ident +proveForall_ltr_db = Coq.ident "prove_ind_ltr_db" + + +-- | The hint database that is used by 'proveForall' to prove the '<-' +-- direction of the equivalence. +proveForall_rtl_db :: Coq.Ident +proveForall_rtl_db = Coq.ident "prove_ind_rtl_db" + ------------------------------------------------------------------------------- -- Reserved Identifiers -- ------------------------------------------------------------------------------- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index 670c48a6..c4f44fbe 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -35,6 +35,7 @@ generateInductionSchemes dataDecls = do forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) complexDataDecls hintSentences <- concatMapM (generateHints schemeQualidMap forQualidMap inQualidMap) complexDataDecls + mapM_ (insertPropertiesInEnv forQualidMap inQualidMap . IR.typeDeclQName) complexDataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] @@ -327,7 +328,7 @@ generateInductionSchemes dataDecls = do proof = Coq.ProofQed (Text.pack $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" - ++ Text.unpack Coq.Base.proveInd + ++ Text.unpack Coq.Base.proveForall ++ ".") return (forallQualid, [], term, proof) where @@ -387,30 +388,20 @@ generateInductionSchemes dataDecls = do freshCoqQualid $ baseName ++ "_" ++ conName getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) - getForType forQualidMap t = case forQualidMap Map.!? t of + getForType forQualidMap name = case forQualidMap Map.!? name of Just qualid -> return $ Just qualid - Nothing -> do - -- TODO use environment to store and load other 'For-' properties - Just qualid <- inEnv $ lookupIdent IR.TypeScope t - let name = case qualid of - Coq.Bare n -> Text.unpack n - Coq.Qualified _ n -> Text.unpack n - return $ Just $ Coq.bare $ "For" ++ name + Nothing -> inEnv $ lookupForProperty name getInTypes :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter (Maybe [Coq.Qualid]) - getInTypes inQualidMap t = case inQualidMap Map.!? t of + getInTypes inQualidMap name = case inQualidMap Map.!? name of Just qualids -> return $ Just qualids - Nothing -> do - -- TODO use environment to store and load other 'In-' properties - Just qualid <- inEnv $ lookupIdent IR.TypeScope t - Just arity <- inEnv $ lookupArity IR.TypeScope t - let name = case qualid of - Coq.Bare n -> Text.unpack n - Coq.Qualified _ n -> Text.unpack n - suffixes = if arity == 1 - then [""] - else map (\index -> "_" ++ show index) [1 .. arity] - return $ Just $ map (\suffix -> Coq.bare $ "In" ++ name ++ suffix) suffixes + Nothing -> inEnv $ lookupInProperties name + + insertPropertiesInEnv :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter () + insertPropertiesInEnv forQualidMap inQualidMap name = do + let forName = forQualidMap Map.!? name + inNames = inQualidMap Map.!? name + modifyEnv $ addPropertyNamesToEntry name forName inNames generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) generateArg argName argType = do diff --git a/src/lib/FreeC/Environment.hs b/src/lib/FreeC/Environment.hs index ea3c242c..541f2d2c 100644 --- a/src/lib/FreeC/Environment.hs +++ b/src/lib/FreeC/Environment.hs @@ -16,6 +16,7 @@ module FreeC.Environment -- * Modifying Entries in the Environment , modifyEntryIdent , addEffectsToEntry + , addPropertyNamesToEntry -- * Looking up Entries from the Environment , lookupEntry , isFunction @@ -34,6 +35,8 @@ module FreeC.Environment , lookupReturnType , lookupTypeScheme , lookupArity + , lookupForProperty + , lookupInProperties , lookupTypeSynonym , needsFreeArgs , hasEffect @@ -155,6 +158,17 @@ addEffectsToEntry name effects env = case lookupEntry IR.ValueScope name env of then addEntry (entry { entryEffects = entryEffects entry ++ effects }) env else env +-- | Adds the given Coq identifiers for the 'For-' property and 'In-' +-- properties for the data entry with the given name. +-- +-- If such a data entry does not exist, the environment is not changed. +addPropertyNamesToEntry :: IR.QName -> Maybe Coq.Qualid -> Maybe [Coq.Qualid] -> Environment -> Environment +addPropertyNamesToEntry name forIdent inIdents env = case lookupEntry IR.TypeScope name env of + Nothing -> env + Just entry -> if isDataEntry entry + then addEntry (entry { entryForPropertyIdent = forIdent, entryInPropertyIdents = inIdents }) env + else env + ------------------------------------------------------------------------------- -- Looking up Entries from the Environment -- ------------------------------------------------------------------------------- @@ -295,6 +309,32 @@ lookupArity :: IR.Scope -> IR.QName -> Environment -> Maybe Int lookupArity = fmap entryArity . find (not . (isVarEntry .||. isTypeVarEntry)) .:. lookupEntry +-- | Looks up the Coq identifier for the 'For-' property of data entry with the +-- given name. +-- +-- Returns @Nothing@ if there is no such data entry or if the data entry has +-- no 'For-' property. +lookupForProperty :: IR.QName -> Environment -> Maybe Coq.Qualid +lookupForProperty = concatMaybe . fmap entryForPropertyIdent . find isDataEntry + .: lookupEntry IR.TypeScope + where + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing + +-- | Looks up the Coq identifiers for the 'In-' properties of data entry with +-- the given name. +-- +-- Returns @Nothing@ if there is no such data entry or if the data entry has +-- no 'In-' properties. +lookupInProperties :: IR.QName -> Environment -> Maybe [Coq.Qualid] +lookupInProperties = concatMaybe . fmap entryInPropertyIdents . find isDataEntry + .: lookupEntry IR.TypeScope + where + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing + -- | Looks up the type the type synonym with the given name is associated with. -- -- Returns @Nothing@ if there is no such type synonym. diff --git a/src/lib/FreeC/Pass/DefineDeclPass.hs b/src/lib/FreeC/Pass/DefineDeclPass.hs index e6c20ac7..9207f450 100644 --- a/src/lib/FreeC/Pass/DefineDeclPass.hs +++ b/src/lib/FreeC/Pass/DefineDeclPass.hs @@ -77,8 +77,8 @@ defineTypeDecl (IR.DataDecl srcSpan declIdent typeArgs conDecls) = do , entryConsNames = map IR.conDeclQName conDecls , entryIdent = undefined -- filled by renamer , entryAgdaIdent = undefined -- filled by renamer - , entryForPropertyIdent = Nothing -- may be filled by induction scheme generation - , entryInPropertyIdent = Nothing -- may be filled by induction scheme generation + , entryForPropertyIdent = Nothing -- may be filled by induction scheme generator + , entryInPropertyIdents = Nothing -- may be filled by induction scheme generator } mapM_ defineConDecl conDecls where From 8b85c088f1906fd80344b6affeb7689d8b0d989d Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Sun, 27 Sep 2020 01:20:28 +0200 Subject: [PATCH 14/17] Update proofs #159 --- base/coq/Free/Tactic/ProveForall.v | 154 +++++++---------- base/coq/Free/Tactic/ProveInd.v | 9 +- base/coq/Prelude/List.v | 40 ++--- base/coq/Prelude/Pair.v | 24 ++- src/lib/FreeC/Backend/Coq/Base.hs | 34 ++-- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 4 +- .../Coq/Converter/TypeDecl/InductionScheme.hs | 163 ++++++++++++------ 7 files changed, 231 insertions(+), 197 deletions(-) diff --git a/base/coq/Free/Tactic/ProveForall.v b/base/coq/Free/Tactic/ProveForall.v index 9298dcb7..b3b80ecd 100644 --- a/base/coq/Free/Tactic/ProveForall.v +++ b/base/coq/Free/Tactic/ProveForall.v @@ -9,30 +9,42 @@ From Base Require Import Free.ForFree. Require Import Coq.Program.Equality. -Ltac forall_ForType_InType forType inType forType_forall := +Create HintDb prove_ind_db. + +Ltac prove_forall_split_hypotheses := + repeat (match goal with + | [H : _ /\ _ |- _] => destruct H + end). + +Ltac prove_forall_ForType_InType HF HI x forType_forall := + rewrite forType_forall in HF; + prove_forall_split_hypotheses; match goal with - | [ HF : forType _ ?fx - , HI : inType ?x ?fx - |- _ ] => - rewrite forType_forall in HF; - specialize (HF x HI) + | [ HF1 : forall y, _ -> _ |- _ ] => + specialize (HF1 x HI); + auto with prove_forall_db end. -Ltac forall_ForFree_InFree := +Hint Extern 0 => match goal with - | [ HF : ForFree ?Shape ?Pos ?T _ ?fx - , HI : InFree ?Shape ?Pos ?T ?x ?fx + | [ HF : ForFree _ _ _ _ ?fx + , HI : InFree _ _ _ ?x ?fx |- _ ] => - rewrite ForFree_forall in HF; - specialize (HF x HI) - end. + prove_forall_ForType_InType HF HI x ForFree_forall + end : prove_forall_db. -Ltac forall_trivial := - match goal with - | [ H : ?P |- ?P ] => apply H - end. +Ltac prove_forall_prove_ForType forType_forall := + rewrite forType_forall; + repeat split; + let x := fresh "x" + in let HI := fresh "HI" + in intros x HI; + auto with prove_forall_db. -Ltac forall_trivial_imp2 := +Hint Extern 0 (ForFree _ _ _ _ _) => + prove_forall_prove_ForType ForFree_forall : prove_forall_db. + +Ltac prove_forall_trivial_imp := match goal with | [ HImp : ?TF -> ?TI -> ?P , HF : ?TF @@ -41,84 +53,42 @@ Ltac forall_trivial_imp2 := apply (HImp HF HI) end. -Hint Extern 0 => forall_trivial : prove_forall_db. -Hint Extern 0 => forall_trivial_imp2 : prove_forall_db. -Hint Extern 0 => forall_ForFree_InFree : prove_forall_db. - -Ltac prove_forall Ind := - repeat (match goal with - | [ |- forall (_ : _ -> Prop), _ ] => intro - end); - let C := fresh "C" - in let HF := fresh "HF" - in let x := fresh "x" - in let HI := fresh "HI" - in let H := fresh "H" - in intro C; split; - [ intro HF; - repeat split; - intros x HI; - induction C using Ind; - dependent destruction HI; - dependent destruction HF; - auto with prove_forall_db - | intro H; - repeat (match goal with - | [H1 : _ /\ _ |- _] => destruct H1 - end); - induction C using Ind; - constructor; - auto with prove_forall_db2 - ]. +Hint Extern 1 => prove_forall_trivial_imp : prove_forall_db. -Ltac forall_ForType forType forType_forall := +Ltac prove_forall_finish_rtl Con := match goal with - | [ HF : forType _ ?fx - |- forType _ ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply forType_forall; intros x HI; - rewrite forType_forall in HF; - specialize (HF x HI) - | [ H : forall y : ?A, _ |- forType ?P ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply forType_forall; intros x HI; - specialize (H x) - end. - -Ltac forall_ForFree := - match goal with - | [ HF : ForFree ?Shape ?Pos ?T _ ?fx - |- ForFree ?Shape ?Pos ?T _ ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForFree_forall; intros x HI; - rewrite ForFree_forall in HF; - specialize (HF x HI) - | [ H : forall y : ?A, _ |- ForFree ?Shape ?Pos ?T ?P ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForFree_forall; intros x HI; - specialize (H x) - end. - -Ltac forall_finish := - match goal with - | [ H : ?TI -> ?P |- ?P ] => - apply H; constructor; trivial + | [ H : (forall y, _ -> ?P y) -> _ + |- _ ] => + apply H; + let x := fresh "x" + in let HI := fresh "HI" + in intros x HI; + auto with prove_forall_db + | [ H : forall y, ?TI -> ?P y |- ?P ?x ] => + apply H; + eapply Con; + eauto end. -Hint Extern 0 => forall_finish : prove_forall_db2. -Hint Extern 0 => forall_trivial : prove_forall_db2. -Hint Extern 0 => forall_ForFree : prove_forall_db2. +Hint Extern 1 => prove_forall_finish_rtl : prove_forall_db. -Ltac forall_finish2 Con := - match goal with - | [ H1 : (forall y : ?A, _ -> ?P y) -> ?TF ?P ?C - , H2 : forall z : ?A, _ -> ?P z - |- ?TF ?P ?C ] => - let x := fresh "x" +Ltac prove_forall type_ind := + let C := fresh "C" + in intro C; split; + [ let HF := fresh "HF" + in intro HF; + repeat split; + let x := fresh "x" in let HI := fresh "HI" - in apply H1; intros x HI; apply H2; eauto using Con - end. + in intros x HI; + induction C using type_ind; + dependent destruction HI; + dependent destruction HF; + auto with prove_forall_db + | let H := fresh "H" + in intro H; + prove_forall_split_hypotheses; + induction C using type_ind; + constructor; + auto with prove_forall_db + ]. diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index e45a3bb2..7ef25e5f 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -29,9 +29,9 @@ Ltac prove_ind_select_case FP := (* This tactic eliminates the monadic layer of an induction hypothesis. *) Ltac prove_ind_prove_ForFree := match goal with - | [ fx : Free ?Shape ?Pos ?T |- _ ] => + | [ fx : Free ?Shape ?Pos ?T1 |- _ ] => match goal with - | [ |- ForFree Shape Pos T ?P fx ] => + | [ |- ForFree Shape Pos ?T ?P fx ] => apply ForFree_forall; let x1 := fresh "x" in let H := fresh "H" @@ -97,7 +97,8 @@ Ltac prove_ind_prove_ForType x forType_forall type_ind := let y := fresh "y" in let H := fresh "H" in intros y H; inversion H; subst; clear H; - prove_ind_prove_ForFree_InFree. + prove_ind_prove_ForFree_InFree; + auto with prove_ind_db. (* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) (*Ltac prove_ind_prove_ForType x type_induction := @@ -112,5 +113,5 @@ Ltac prove_ind := destruct x; prove_ind_select_case FP; prove_ind_prove_ForFree; - intuition auto with prove_ind_db + auto with prove_ind_db end. diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index e9af1449..d967946c 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -212,37 +212,21 @@ Lemma ForList_forall : forall (Shape : Type) ForList Shape Pos a P0 x <-> (forall (y : a), InList Shape Pos a y x -> P0 y). Proof. - intros Shape Pos a. - Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons Shape Pos A) : prove_forall_db2. - Hint Extern 0 (ForList ?Shape ?Pos ?A _ _) => forall_finish2 (@InList_cons0 Shape Pos A) : prove_forall_db2. + intros Shape Pos a P0. + Local Hint Extern 1 => prove_forall_finish_rtl InList_cons : prove_forall_db. + Local Hint Extern 1 => prove_forall_finish_rtl InList_cons0 : prove_forall_db. prove_forall List_ind. -Qed. +Defined. (* Add hints for proof generation *) Hint Extern 0 (ForList _ _ _ _ ?x) => - prove_ind_prove_ForType x ForList_forall list_induction : prove_ind_db. -Local Ltac forall_ForList_InList := - match goal with - | [ HF : ForList ?Shape ?Pos ?A _ ?fx - , HI : InList ?Shape ?Pos ?A ?x ?fx - |- _ ] => - rewrite ForList_forall in HF; - specialize (HF x HI) - end. -Hint Extern 0 => forall_ForList_InList : prove_forall_db. -Local Ltac forall_ForList := + prove_ind_prove_ForType x ForList_forall List_ind : prove_ind_db. +Hint Extern 0 => match goal with | [ HF : ForList ?Shape ?Pos ?T _ ?fx - |- ForList ?Shape ?Pos ?T _ ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForList_forall; intros x HI; - rewrite ForList_forall in HF; - specialize (HF x HI) - | [ H : forall y : ?A, _ |- ForList ?Shape ?Pos ?T ?P ?fx ] => - let x := fresh "x" - in let HI := fresh "HI" - in apply ForList_forall; intros x HI; - specialize (H x) - end. -Hint Extern 0 => forall_ForList : prove_forall_db2. + , HI : InList ?Shape ?Pos ?T ?x ?fx + |- _ ] => + prove_forall_ForType_InType HF HI x ForList_forall + end : prove_forall_db. +Hint Extern 0 (ForList _ _ _ _ _) => + prove_forall_prove_ForType ForList_forall : prove_forall_db. diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 3601228a..017e5fb9 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -98,10 +98,28 @@ Lemma ForPair_forall : forall (Shape : Type) ((forall (y : a), InPair_1 Shape Pos a b y x -> P0 y) /\ (forall (y : b), InPair_2 Shape Pos a b y x -> P1 y)). Proof. - intros Shape Pos a b. + intros Shape Pos a b P0 P1. + Local Hint Extern 1 => prove_forall_finish_rtl InPair_1_pair_ : prove_forall_db. + Local Hint Extern 1 => prove_forall_finish_rtl InPair_2_pair_ : prove_forall_db. prove_forall Pair_ind. -Qed. +Defined. (* Add hints for proof generation *) Hint Extern 0 (ForPair _ _ _ _ _ _ ?x) => - prove_ind_prove_ForType x ForPair_forall pair_induction : prove_ind_db. + prove_ind_prove_ForType x ForPair_forall Pair_ind : prove_ind_db. +Hint Extern 0 => + match goal with + | [ HF : ForPair ?Shape ?Pos ?T1 ?T2 _ _ ?fx + , HI : InPair_1 ?Shape ?Pos ?T1 ?T2 ?x ?fx + |- _ ] => + prove_forall_ForType_InType HF HI x ForPair_forall + end : prove_forall_db. +Hint Extern 0 => + match goal with + | [ HF : ForPair ?Shape ?Pos ?T1 ?T2 _ _ ?fx + , HI : InPair_2 ?Shape ?Pos ?T1 ?T2 ?x ?fx + |- _ ] => + prove_forall_ForType_InType HF HI x ForPair_forall + end : prove_forall_db. +Hint Extern 0 (ForPair _ _ _ _ _ _ _) => + prove_forall_prove_ForType ForPair_forall : prove_forall_db. diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 29eb7fcd..13ae8c7d 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -46,10 +46,12 @@ module FreeC.Backend.Coq.Base , proveInd , proveInd_proveForType , proveForall + , proveForall_ForType_InType + , proveForall_proveForType + , proveForall_finish -- * Hint Databases , proveInd_db - , proveForall_ltr_db - , proveForall_rtl_db + , proveForall_db -- * Reserved Identifiers , reservedIdents ) where @@ -272,6 +274,21 @@ proveInd_proveForType = Coq.ident "prove_ind_prove_ForType" proveForall :: Coq.Ident proveForall = Coq.ident "prove_forall" +-- | One of the tactics that have to be instantiated for data types and added +-- to 'proveInd_db'. +proveForall_ForType_InType :: Coq.Ident +proveForall_ForType_InType = Coq.ident "prove_forall_ForType_InType" + +-- | One of the tactics that have to be instantiated for data types and added +-- to 'proveInd_db'. +proveForall_proveForType :: Coq.Ident +proveForall_proveForType = Coq.ident "prove_forall_prove_ForType" + +-- | This tactic has to be instantiated for data types and added locally to +-- 'proveInd_db' in the proof of the corresponding 'forall' lemma. +proveForall_finish :: Coq.Ident +proveForall_finish = Coq.ident "prove_forall_finish_rtl" + ------------------------------------------------------------------------------- -- Hint Databases -- ------------------------------------------------------------------------------- @@ -280,16 +297,9 @@ proveInd_db :: Coq.Ident proveInd_db = Coq.ident "prove_ind_db" --- | The hint database that is used by 'proveForall' to prove the '->' --- direction of the equivalence. -proveForall_ltr_db :: Coq.Ident -proveForall_ltr_db = Coq.ident "prove_ind_ltr_db" - - --- | The hint database that is used by 'proveForall' to prove the '<-' --- direction of the equivalence. -proveForall_rtl_db :: Coq.Ident -proveForall_rtl_db = Coq.ident "prove_ind_rtl_db" +-- | The hint database that is used by 'proveForall'. +proveForall_db :: Coq.Ident +proveForall_db = Coq.ident "prove_forall_db" ------------------------------------------------------------------------------- -- Reserved Identifiers -- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index cf840757..9d5948af 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -129,11 +129,11 @@ convertDataDecls dataDecls = do inductionSentences <- generateInductionSchemes dataDecls let (extraSentences, qualSmartConDecls) = concatUnzip extraSentences' return - ( Coq.unsetOption (Just Coq.Local) "EliminationSchemes" + ( Coq.unsetOption (Just Coq.Local) "Elimination Schemes" : Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) - : Coq.setOption (Just Coq.Local) "EliminationSchemes" Nothing + : Coq.setOption (Just Coq.Local) "Elimination Schemes" Nothing : extraSentences ++ inductionSentences , qualSmartConDecls ) diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index c4f44fbe..ba0c40c7 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -29,16 +29,17 @@ generateInductionSchemes dataDecls = do forQualidMap <- Map.fromList <$> mapM (generateName "For" "" . IR.typeDeclQName) complexDataDecls forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls inQualidMap <- Map.fromList <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls - inBodies <- concatMapM (generateInProperties inQualidMap) complexDataDecls + (inBodies, inConNames) <- mapAndUnzipM (generateInProperties inQualidMap) complexDataDecls + let inBodies' = concat inBodies schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_ind" . IR.typeDeclQName) dataDecls schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls - forallBodies <- mapM (generateForallLemma forallQualidMap forQualidMap inQualidMap) complexDataDecls - hintSentences <- concatMapM (generateHints schemeQualidMap forQualidMap inQualidMap) complexDataDecls + forallBodies <- mapM (uncurry $ generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap) $ zip inConNames complexDataDecls + hintSentences <- concatMapM (generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap) complexDataDecls mapM_ (insertPropertiesInEnv forQualidMap inQualidMap . IR.typeDeclQName) complexDataDecls return ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] - ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] + ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies') []) | not (null inBodies')] ++(map (\(name, binders, term, proof) -> Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) (schemeBodies ++ forallBodies)) ++ hintSentences @@ -86,32 +87,34 @@ generateInductionSchemes dataDecls = do generateForHypothesis argQualid argType = do coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType - mbHyp <- generateForHypothesis_1 argType' + mbHyp <- generateForHypothesis_1 0 argType' return $ case mbHyp of Just hyp -> Just $ genericApply Coq.Base.forFree [] [] [coqType, hyp, Coq.Qualid argQualid] Nothing -> Nothing - generateForHypothesis_1 :: IR.Type -> Converter (Maybe Coq.Term) - generateForHypothesis_1 (IR.FuncType _ _ _) = return Nothing - generateForHypothesis_1 (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 tcon [lastArg] - generateForHypothesis_1 (IR.TypeCon _ _) = return Nothing -- Ignore type constructors that do not have any type variable or are partially applied - generateForHypothesis_1 tvar@(IR.TypeVar _ _) = do + generateForHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis_1 _ (IR.FuncType _ _ _) = return Nothing + generateForHypothesis_1 d (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 d tcon [lastArg] + generateForHypothesis_1 _ (IR.TypeCon _ _) = return Nothing -- Ignore type constructors that do not have any type variable or are partially applied + generateForHypothesis_1 _ tvar@(IR.TypeVar _ _) = do Coq.Qualid tvarQualid <- convertType' tvar return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid - generateForHypothesis_2 :: IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateForHypothesis_2 (IR.FuncType _ _ _) _ = return Nothing - generateForHypothesis_2 (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 tcon (lastArg : typeArgs) - generateForHypothesis_2 (IR.TypeCon _ tconName) typeArgs = do + generateForHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateForHypothesis_2 _ (IR.FuncType _ _ _) _ = return Nothing + generateForHypothesis_2 d (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 d tcon (lastArg : typeArgs) + generateForHypothesis_2 d (IR.TypeCon _ tconName) typeArgs = do Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - hypotheses <- mapM generateForHypothesis_1 typeArgs + hypotheses <- mapM (generateForHypothesis_1 (d+1)) typeArgs if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses coqArgs <- mapM convertType' typeArgs - mbForType <- getForType Map.empty tconName -- Do not search in mutually recursive types + mbForType <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth + then return $ forQualidMap Map.!? tconName + else getForType Map.empty tconName -- Do not search in mutually recursive types return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateForHypothesis_2 (IR.TypeVar _ _) _ = return Nothing + generateForHypothesis_2 _ (IR.TypeVar _ _) _ = return Nothing ----------------------------------------------------------------------------- -- @InType@ Properties -- @@ -125,12 +128,13 @@ generateInductionSchemes dataDecls = do else mapM (\index -> generateName "In" ("_" ++ show index) typeName) [1 .. arity] return (typeName, inQualids) - generateInProperties :: Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.IndBody] + generateInProperties :: Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter ([Coq.IndBody], [Coq.Qualid]) generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" - generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = - mapM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [0 .. length typeVarDecls - 1] + generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do + (bodies, inConNames) <- mapAndUnzipM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [0 .. length typeVarDecls - 1] + return (bodies, concat inConNames) - generateInProperty :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter Coq.IndBody + generateInProperty :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter (Coq.IndBody, [Coq.Qualid]) generateInProperty inQualidMap typeName typeVarDecls conDecls index = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName let inQualid = (inQualidMap Map.! typeName) !! index @@ -144,7 +148,7 @@ generateInductionSchemes dataDecls = do cons <- concatMapM (generateInConstructors typeVarQualids) conDecls return (cons, mkBody) cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateConName inQualid conName) cons - return $ mkBody cons' + return (mkBody cons', map (\(q,_,_) -> q) cons') where generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) = localEnv $ do @@ -175,15 +179,15 @@ generateInductionSchemes dataDecls = do findOccurrences elemQualid argQualid argType = do coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType - findOccurrences_1 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' + findOccurrences_1 0 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' - findOccurrences_1 :: Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_1 _ _ (IR.FuncType _ _ _) = return [] - findOccurrences_1 _ _ (IR.TypeCon _ _) = return [] -- Ignore type constructors that do not have any type variable or are partially applied - findOccurrences_1 elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do + findOccurrences_1 :: Int -> Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_1 _ _ _ (IR.FuncType _ _ _) = return [] + findOccurrences_1 _ _ _ (IR.TypeCon _ _) = return [] -- Ignore type constructors that do not have any type variable or are partially applied + findOccurrences_1 _ elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do tvarType <- convertType' tvar return [([], [mkInHyp elemQualid]) | tvarType == Coq.Qualid elemType] - findOccurrences_1 elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = + findOccurrences_1 d elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = findOccurrences_2 fullType [] where findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] @@ -194,12 +198,14 @@ generateInductionSchemes dataDecls = do Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName if tconArity == length typeArgs then do - mbInTypes <- getInTypes Map.empty tconName -- Do not search in mutually recursive types + coqArgs <- mapM convertType' typeArgs + mbInTypes <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth + then return $ inQualidMap Map.!? tconName + else getInTypes Map.empty tconName -- Do not search in mutually recursive types case mbInTypes of Just inTypes -> do - coqArgs <- mapM convertType' typeArgs (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) - occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs + occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 (d+1) elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) return $ map mkNewOcc occurrences Nothing -> return [] @@ -245,11 +251,11 @@ generateInductionSchemes dataDecls = do vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ [propQualid] ++ indCaseQualids) fixpoint = fromJust $ Coq.unpackQualid fixpointQualid var = fromJust $ Coq.unpackQualid varQualid - proof = Coq.ProofQed + proof = Coq.ProofDefined (Text.pack $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" - ++ " fix " ++ fixpoint ++ " 1; intro " ++ var ++ "; " - ++ Text.unpack Coq.Base.proveInd + ++ " fix " ++ fixpoint ++ " 1; intro " ++ var ++ ";\n" + ++ " " ++ Text.unpack Coq.Base.proveInd ++ ".") return (schemeName, [], term, proof) where @@ -308,9 +314,11 @@ generateInductionSchemes dataDecls = do -- Forall Lemmas -- ----------------------------------------------------------------------------- - generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) - generateForallLemma _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" - generateForallLemma forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do + generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> + Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> + [Coq.Qualid] -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateForallLemma _ _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" + generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap inConNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls (propQualids, propBinders) <- mapAndUnzipM (\tv -> generateArg "P" (Coq.Arrow (Coq.Qualid tv) (Coq.Sort Coq.Prop))) tvarQualids @@ -324,11 +332,13 @@ generateInductionSchemes dataDecls = do rhs = let (inQualids', [lastIn]) = splitAt (length inTerms - 1) $ inTerms in foldr Coq.conj lastIn inQualids' term = Coq.forall binders (Coq.equiv lhs rhs) - vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ propQualids ++ [valQualid]) - proof = Coq.ProofQed + vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ propQualids) + Just schemeName = Coq.unpackQualid $ schemeQualidMap Map.! typeName + proof = Coq.ProofDefined (Text.pack - $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" - ++ Text.unpack Coq.Base.proveForall + $ concatMap generateForallHint inConNames + ++ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" + ++ " " ++ Text.unpack Coq.Base.proveForall ++ ' ': schemeName ++ ".") return (forallQualid, [], term, proof) where @@ -339,31 +349,72 @@ generateInductionSchemes dataDecls = do let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) + generateForallHint :: Coq.Qualid -> String + generateForallHint inCon = + let Just inStr = Coq.unpackQualid inCon + in " Local Hint Extern 1 => " ++ Text.unpack Coq.Base.proveForall_finish ++ + ' ':inStr ++ " : " ++ Text.unpack Coq.Base.proveForall_db ++ ".\n" + ----------------------------------------------------------------------------- -- Hints -- ----------------------------------------------------------------------------- -- | Generates hints that are used in the proofs of induction schemes and -- 'forall' sentences. - generateHints :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] - generateHints _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateHint: Type synonym not allowed" - generateHints schemeQualidMap forallQualidMap _inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = do - let forType = forallQualidMap Map.! typeName + generateHints :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] + generateHints _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateHint: Type synonym not allowed" + generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = do + let forall = forallQualidMap Map.! typeName + forType = forQualidMap Map.! typeName + inTypes = inQualidMap Map.! typeName scheme = schemeQualidMap Map.! typeName - proveIndHint <- generateProveIndHint forType scheme (length typeVarDecls) - return [proveIndHint] + proveIndHint <- generateProveIndHint forType forall scheme (length typeVarDecls) + proveForallHint1 <- generateProveForallHint1 forType forall (length typeVarDecls) + proveForallHints2 <- mapM (generateProveForallHint2 forType forall (length typeVarDecls)) inTypes + return $ [proveIndHint, proveForallHint1] ++ proveForallHints2 - generateProveIndHint :: Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) - generateProveIndHint forType scheme nTvars = localEnv $ do + generateProveIndHint :: Coq.Qualid -> Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) + generateProveIndHint forType forall scheme nTvars = do valStr <- localEnv $ freshCoqIdent freshArgPrefix - let tacticConStr = Text.unpack Coq.Base.proveInd_proveForType - Just forTypeStr = Coq.unpackQualid forType - Just schemeStr = Coq.unpackQualid scheme - tactic = tacticConStr ++ ' ' : valStr ++ ' ' : forTypeStr ++ ' ' : schemeStr - underscores = replicate (2 * nTvars + 2) Coq.UnderscorePat - valPattern = Coq.QualidPat $ Coq.bare $ '?':valStr - forTypePattern = Coq.ArgsPat forType $ underscores ++ [valPattern] + let tacticConStr = Text.unpack Coq.Base.proveInd_proveForType + Just forallStr = Coq.unpackQualid forall + Just schemeStr = Coq.unpackQualid scheme + tactic = tacticConStr ++ ' ' : valStr ++ ' ' : forallStr ++ ' ' : schemeStr + underscores = replicate (2 + 2 * nTvars) Coq.UnderscorePat + valPattern = Coq.QualidPat $ Coq.bare $ '?':valStr + forTypePattern = Coq.ArgsPat forType $ underscores ++ [valPattern] return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveInd_db] + generateProveForallHint1 :: Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) + generateProveForallHint1 forType forall nTvars = do + let tacticConStr = Text.unpack Coq.Base.proveForall_proveForType + Just forallStr = Coq.unpackQualid forall + tactic = tacticConStr ++ ' ' : forallStr + underscores = replicate (3 + 2 * nTvars) Coq.UnderscorePat + forTypePattern = Coq.ArgsPat forType $ underscores + return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveForall_db] + + generateProveForallHint2 :: Coq.Qualid -> Coq.Qualid -> Int -> Coq.Qualid -> Converter (Coq.Sentence) + generateProveForallHint2 forType forall nTvars inType = localEnv $ do + hForStr <- freshCoqIdent "HF" + hInStr <- freshCoqIdent "HI" + valStr1 <- freshCoqIdent freshArgPrefix + valStr2 <- freshCoqIdent freshArgPrefix + let tacticConStr = Text.unpack Coq.Base.proveForall_ForType_InType + Just forStr = Coq.unpackQualid forType + Just inStr = Coq.unpackQualid inType + Just forallStr = Coq.unpackQualid forall + forPatStrs = forStr : (replicate (2 + 2 * nTvars) "_") ++ ['?':valStr2] + inPatStrs = inStr : (replicate (2 + nTvars) "_") ++ ['?':valStr1, '?':valStr2] + tactic = unlines + [ "" + , " match goal with" + , " | [ " ++ hForStr ++ " : " ++ unwords forPatStrs + , " , " ++ hInStr ++ " : " ++ unwords inPatStrs + , " |- _ ] =>" + , " " ++ unwords [tacticConStr, hForStr, hInStr, valStr1, forallStr] + , " end" + ] + return $ Coq.externHint (Just Coq.Global) 0 Nothing tactic [Coq.Base.proveForall_db] ----------------------------------------------------------------------------- -- Helper Functions -- From 91d5007bde5516d70a10467510f8d8457fa9dee4 Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Mon, 28 Sep 2020 11:15:43 +0200 Subject: [PATCH 15/17] Update comments in Coq files #159 --- base/coq/Free/Tactic/ProveForall.v | 43 ++++++++++++++++++++++++------ base/coq/Free/Tactic/ProveInd.v | 19 +++++++------ base/coq/Prelude/List.v | 9 ++++--- base/coq/Prelude/Pair.v | 8 +++--- 4 files changed, 53 insertions(+), 26 deletions(-) diff --git a/base/coq/Free/Tactic/ProveForall.v b/base/coq/Free/Tactic/ProveForall.v index b3b80ecd..898ed0b9 100644 --- a/base/coq/Free/Tactic/ProveForall.v +++ b/base/coq/Free/Tactic/ProveForall.v @@ -1,21 +1,29 @@ (* This file contains the tactic [prove_forall] that proofs such a the - [ForallT_a_forall] lemmas for datatypes. - For each type variable [a] of each datatype [T] that has strong induction - schemes, there should be the inductive properties [ForT_a] and [InT_a] as - well as a lemma [ForT_a_forall] that states the connection between these - values. *) + [ForallT_forall] lemmas for datatypes. + For each datatype [T] that has type variables, there should be the inductive + property [ForT] and for every tpe variable of that type a Property [InT_a]. + The lemma [ForT_forall] that states the connection between those properties. +*) From Base Require Import Free.ForFree. Require Import Coq.Program.Equality. -Create HintDb prove_ind_db. +(* This is the hint database which is used by [prove_forall]. *) +Create HintDb prove_forall_db. +(* This tactic splits all hypotheses, which are conjunctions, into smaller + hypotheses. *) Ltac prove_forall_split_hypotheses := repeat (match goal with | [H : _ /\ _ |- _] => destruct H end). +(* This tactic rewrites a 'ForT' hypothesis [HF] using a forall lemma + [forType_forall] and specializes it using a value [x] for which an 'InT' + hypothesis [IF] exists. + This tactic should be instantiated for types with type variables and added to + [prove_forall_db]. *) Ltac prove_forall_ForType_InType HF HI x forType_forall := rewrite forType_forall in HF; prove_forall_split_hypotheses; @@ -25,6 +33,9 @@ Ltac prove_forall_ForType_InType HF HI x forType_forall := auto with prove_forall_db end. +(* [prove_forall_ForType_InType] instance of [Free]. + You can use this as reference for instances of + [prove_forall_ForType_InType]. *) Hint Extern 0 => match goal with | [ HF : ForFree _ _ _ _ ?fx @@ -33,7 +44,10 @@ Hint Extern 0 => prove_forall_ForType_InType HF HI x ForFree_forall end : prove_forall_db. -Ltac prove_forall_prove_ForType forType_forall := +(* Rewrites the goal using the given 'forall' lemma. + This tactic should be instantiated for types with type variables and added to + [prove_forall_db]. *) + Ltac prove_forall_prove_ForType forType_forall := rewrite forType_forall; repeat split; let x := fresh "x" @@ -41,9 +55,12 @@ Ltac prove_forall_prove_ForType forType_forall := in intros x HI; auto with prove_forall_db. +(* [prove_forall_prove_ForType] instance of [Free]. *) Hint Extern 0 (ForFree _ _ _ _ _) => prove_forall_prove_ForType ForFree_forall : prove_forall_db. +(* Applies a hypothesis which is an implication with two fulfilled + preconditions to prove the goal. *) Ltac prove_forall_trivial_imp := match goal with | [ HImp : ?TF -> ?TI -> ?P @@ -55,7 +72,11 @@ Ltac prove_forall_trivial_imp := Hint Extern 1 => prove_forall_trivial_imp : prove_forall_db. -Ltac prove_forall_finish_rtl Con := +(* Tries to prove an 'InT' property by using an constructor for that type. + This tactic should be instantiated locally with all 'InT' constructors of a + type with type variables and added to [prove_forall_db] when proving the + corresponding 'forall' lemma. *) + Ltac prove_forall_finish_rtl Con := match goal with | [ H : (forall y, _ -> ?P y) -> _ |- _ ] => @@ -72,6 +93,12 @@ Ltac prove_forall_finish_rtl Con := Hint Extern 1 => prove_forall_finish_rtl : prove_forall_db. +(* This tactic proves a 'forall' lemma using a given induction scheme for the + corresponding type using the database [prove_forall_db]. + The database should contain an instance of [prove_forall_finish_rtl] for + every 'InT' constructor of that type and instances of + [prove_forall_ForType_InType] and [prove_forall_prove_ForType] for every + dependent type. *) Ltac prove_forall type_ind := let C := fresh "C" in intro C; split; diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index 7ef25e5f..15a0189f 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -11,7 +11,7 @@ Require Import Coq.Program.Equality. (* The hint database that contains instances of [prove_ind_prove_for_type]. *) Create HintDb prove_ind_db. -(* Trivial property *) +(* Trivial property. *) Definition NoProperty {A : Type} : A -> Prop := fun _ => True. Hint Extern 0 (NoProperty _) => unfold NoProperty; constructor : prove_ind_db. @@ -54,7 +54,7 @@ Ltac prove_ind_prove_ForFree := end end. -(* This tactic tries to finish the proof with an hypothesis with fulfilled +(* This tactic tries to finish the proof with a given hypothesis with fulfilled preconditions. *) Ltac prove_ind_apply_hypothesis H := match type of H with @@ -89,7 +89,10 @@ Ltac prove_ind_prove_ForFree_InFree := ] end. -(* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) +(* Tries to prove a 'ForT' property for [x] by using the given 'forall' lemma + and induction scheme. + This tactic should be instantiated for types with type variables and added + to [prove_ind_db]. *) Ltac prove_ind_prove_ForType x forType_forall type_ind := apply forType_forall; repeat split; @@ -100,13 +103,9 @@ Ltac prove_ind_prove_ForType x forType_forall type_ind := prove_ind_prove_ForFree_InFree; auto with prove_ind_db. -(* This tactic is instantiated for specific types and should be added to [prove_ind_db]. *) -(*Ltac prove_ind_prove_ForType x type_induction := - induction x using type_induction; - constructor; - prove_ind_prove_ForFree.*) - -(* This tactic proves an induction scheme. *) +(* This tactic proves the induction scheme for a type. + It requires the database [prove_ind_db] to contain instances of + [prove_ind_prove_ForType] for all dependent types. *) Ltac prove_ind := match goal with | [ FP : forall y, ?P y |- ?P ?x ] => diff --git a/base/coq/Prelude/List.v b/base/coq/Prelude/List.v index d967946c..fd555bc5 100644 --- a/base/coq/Prelude/List.v +++ b/base/coq/Prelude/List.v @@ -177,9 +177,8 @@ Section SecFreeListInd. End SecFreeListInd. -(* ForList *) -Inductive ForList (Shape : Type) (Pos : Shape -> Type) (a : Type) (P0 - : a -> Prop) +(* [ForList] property to generate induction hypotheses over lists. *) +Inductive ForList (Shape : Type) (Pos : Shape -> Type) (a : Type) (P0 : a -> Prop) : List Shape Pos a -> Prop := ForList_nil : ForList Shape Pos a P0 (@nil Shape Pos a) | ForList_cons @@ -204,6 +203,8 @@ Inductive InList (Shape : Type) (Pos : Shape -> Type) (a : Type) InFree Shape Pos (List Shape Pos a) x2 x0 -> InList Shape Pos a x1 (@cons Shape Pos a x x0). + +(* 'Forall' lemma to rewrite [ForList] properties. *) Lemma ForList_forall : forall (Shape : Type) (Pos : Shape -> Type) (a : Type) @@ -218,7 +219,7 @@ Proof. prove_forall List_ind. Defined. -(* Add hints for proof generation *) +(* Add hints for proof generation. *) Hint Extern 0 (ForList _ _ _ _ ?x) => prove_ind_prove_ForType x ForList_forall List_ind : prove_ind_db. Hint Extern 0 => diff --git a/base/coq/Prelude/Pair.v b/base/coq/Prelude/Pair.v index 017e5fb9..50ad2a8c 100644 --- a/base/coq/Prelude/Pair.v +++ b/base/coq/Prelude/Pair.v @@ -65,9 +65,8 @@ Instance ShareableArgsPair {Shape : Type} {Pos : Shape -> Type} (A B : Type) end }. -(* ForPair *) -Inductive ForPair (Shape : Type) (Pos : Shape -> Type) (a b : Type) (P0 - : a -> Prop) (P1 : b -> Prop) +(* [ForPair] property to generate induction hypotheses over pairs. *) +Inductive ForPair (Shape : Type) (Pos : Shape -> Type) (a b : Type) (P0 : a -> Prop) (P1 : b -> Prop) : Pair Shape Pos a b -> Prop := ForPair_pair_ : forall (x : Free Shape Pos a) (x0 : Free Shape Pos b), @@ -88,6 +87,7 @@ with InPair_2 (Shape : Type) (Pos : Shape -> Type) (a b : Type) InFree Shape Pos b x1 x0 -> InPair_2 Shape Pos a b x1 (@pair_ Shape Pos a b x x0). +(* 'Forall' lemma to rewrite [ForPair] properties. *) Lemma ForPair_forall : forall (Shape : Type) (Pos : Shape -> Type) (a b : Type) @@ -104,7 +104,7 @@ Proof. prove_forall Pair_ind. Defined. -(* Add hints for proof generation *) +(* Add hints for proof generation. *) Hint Extern 0 (ForPair _ _ _ _ _ _ ?x) => prove_ind_prove_ForType x ForPair_forall Pair_ind : prove_ind_db. Hint Extern 0 => From f9ff5f9d18edf0d650f6ab086d574db48f2111ec Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Tue, 29 Sep 2020 15:49:07 +0200 Subject: [PATCH 16/17] Rework and comment code #159 --- base/Prelude.toml | 2 + base/coq/Free/Tactic/ProveInd.v | 84 ++-- cabal.project | 2 +- example/Proofs/InductionSchemes.hs | 13 +- free-compiler.cabal | 2 +- src/lib/FreeC/Backend/Coq/Base.hs | 3 + .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 4 +- .../Coq/Converter/TypeDecl/InductionScheme.hs | 455 +++++++++++++----- src/lib/FreeC/Environment.hs | 28 +- src/lib/FreeC/Environment/Entry.hs | 3 + .../Environment/ModuleInterface/Decoder.hs | 2 + .../Environment/ModuleInterface/Encoder.hs | 5 +- src/lib/FreeC/Pass/DefineDeclPass.hs | 1 + 13 files changed, 438 insertions(+), 166 deletions(-) diff --git a/base/Prelude.toml b/base/Prelude.toml index 40ef6967..468d9a3d 100644 --- a/base/Prelude.toml +++ b/base/Prelude.toml @@ -218,6 +218,7 @@ exported-values = [ ] coq-for-property-name = 'ForList' coq-in-property-names = ['InList'] + coq-forall-lemma-name = 'ForList_forall' [[constructors]] haskell-type = 'Prelude.([]) a' @@ -252,6 +253,7 @@ exported-values = [ 'InPair_1', 'InPair_2' ] + coq-forall-lemma-name = 'ForPair_forall' [[constructors]] haskell-type = 'a -> b -> Prelude.(,) a b' diff --git a/base/coq/Free/Tactic/ProveInd.v b/base/coq/Free/Tactic/ProveInd.v index 15a0189f..e0938839 100644 --- a/base/coq/Free/Tactic/ProveInd.v +++ b/base/coq/Free/Tactic/ProveInd.v @@ -29,7 +29,7 @@ Ltac prove_ind_select_case FP := (* This tactic eliminates the monadic layer of an induction hypothesis. *) Ltac prove_ind_prove_ForFree := match goal with - | [ fx : Free ?Shape ?Pos ?T1 |- _ ] => + | [ fx : Free ?Shape ?Pos _ |- _ ] => match goal with | [ |- ForFree Shape Pos ?T ?P fx ] => apply ForFree_forall; @@ -57,37 +57,60 @@ Ltac prove_ind_prove_ForFree := (* This tactic tries to finish the proof with a given hypothesis with fulfilled preconditions. *) Ltac prove_ind_apply_hypothesis H := - match type of H with - | ?PC -> _ => - match goal with - | [ H2 : PC |- _ ] => specialize (H H2); prove_ind_apply_hypothesis H - end - | _ => apply H - end. + match type of H with + | ?PC -> _ => + match goal with + | [ H2 : PC |- _ ] => specialize (H H2); prove_ind_apply_hypothesis H + end + | _ => apply H + end. + +Hint Extern 0 => prove_ind_apply_hypothesis : prove_ind_db. + +(* This tactic splits all hypotheses, which are conjunctions, into smaller + hypotheses. *) +Ltac prove_ind_split_hypotheses := + repeat (match goal with + | [H : _ /\ _ |- _] => destruct H + end). + +(* This tactic rewrites a 'ForT' hypothesis [HF] using a forall lemma + [forType_forall] and specializes it using a value [x] for which an 'InT' + hypothesis [IF] exists. *) +Ltac prove_ind_ForType_InType HF HI x forType_forall := + rewrite forType_forall in HF; + prove_ind_split_hypotheses; + match goal with + | [ HF1 : forall y, _ -> _ |- _ ] => + specialize (HF1 x HI); + try (prove_ind_apply_hypothesis HF1) + end. (* This tactic eliminates intermediate monadic layers. *) Ltac prove_ind_prove_ForFree_InFree := - match goal with - | [ HIF : InFree ?Shape ?Pos ?T _ ?fx - , IH : ForFree ?Shape ?Pos ?T _ ?fx - |- _ ] => - rewrite ForFree_forall in IH; prove_ind_apply_hypothesis IH - | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx - |- ?P ?x ] => - let x1 := fresh "x" - in let s := fresh "s" - in let pf := fresh "pf" - in let IHpf := fresh "IHpf" - in induction fx as [ x1 | s pf IHpf ] using Free_Ind; - [ inversion HIF; subst; clear HIF - | dependent destruction HIF; - match goal with - | [H : exists p : Pos s, InFree Shape Pos T x (pf p) |- _ ] => - let p := fresh "p" - in destruct H as [ p H ]; apply (IHpf p H) - end - ] - end. + match goal with + | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx + , IH : ForFree ?Shape ?Pos ?T _ ?fx + |- _ ] => + rewrite ForFree_forall in IH; + specialize (IH x HIF); clear HIF; + try (prove_ind_apply_hypothesis IH) + | [ HIF : InFree ?Shape ?Pos ?T ?x ?fx + |- ?P ?x ] => + let x1 := fresh "x" + in let s := fresh "s" + in let pf := fresh "pf" + in let IHpf := fresh "IHpf" + in induction fx as [ x1 | s pf IHpf ] using Free_Ind; + [ inversion HIF; subst; clear HIF + | dependent destruction HIF; + match goal with + | [H : exists p : Pos s, InFree Shape Pos T x (pf p) |- _ ] => + let p := fresh "p" + in destruct H as [ p H ]; apply (IHpf p H); easy + end + ] + end. (* Tries to prove a 'ForT' property for [x] by using the given 'forall' lemma and induction scheme. @@ -100,8 +123,7 @@ Ltac prove_ind_prove_ForType x forType_forall type_ind := let y := fresh "y" in let H := fresh "H" in intros y H; inversion H; subst; clear H; - prove_ind_prove_ForFree_InFree; - auto with prove_ind_db. + prove_ind_prove_ForFree_InFree. (* This tactic proves the induction scheme for a type. It requires the database [prove_ind_db] to contain instances of diff --git a/cabal.project b/cabal.project index 9b693742..11438d5c 100644 --- a/cabal.project +++ b/cabal.project @@ -3,7 +3,7 @@ source-repository-package type: git location: git://github.com/FreeProving/language-coq.git - tag: v0.2.0.0 + tag: v0.3.0.0 -- The `haskell-src-transformations` package is still in an early development -- state and thus not available on Hackage. The dependency is downloaded diff --git a/example/Proofs/InductionSchemes.hs b/example/Proofs/InductionSchemes.hs index e6e00e10..5c78d6cc 100644 --- a/example/Proofs/InductionSchemes.hs +++ b/example/Proofs/InductionSchemes.hs @@ -2,15 +2,6 @@ module Proofs.InductionSchemes where data MyList a = MyNil | MyCons a (MyList a) -data MyPair a b = MyPair a b +data Tree a = Forest a (MyList (Tree a)) -data Tree a b = Forest (MyPair a (MyList (Tree a b))) - -data AltList a b = AltNil | AltCons a (AltList b a) - -type MapEntry k v = MyPair k v -type MapList k v = MyList (MapEntry k v) -data Map k v = Map (MapList k v) - -data Foo a = Foo a (Bar a) -data Bar a = Bar a (Foo a) \ No newline at end of file +data MyType a = MyCon (Tree (MyType a)) diff --git a/free-compiler.cabal b/free-compiler.cabal index 96bf4e4a..4833057d 100644 --- a/free-compiler.cabal +++ b/free-compiler.cabal @@ -48,7 +48,7 @@ common deps -- ASTs: , Agda ==2.6.* , haskell-src-exts ==1.23.* - , language-coq ==0.2.* + , language-coq ==0.3.* -- Configuration: , aeson ==1.4.* , aeson-pretty ==0.8.* diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index 13ae8c7d..d6beed8b 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -45,6 +45,7 @@ module FreeC.Backend.Coq.Base -- * Tactics , proveInd , proveInd_proveForType + , proveInd_ForType_InType , proveForall , proveForall_ForType_InType , proveForall_proveForType @@ -269,6 +270,8 @@ proveInd = Coq.ident "prove_ind" proveInd_proveForType :: Coq.Ident proveInd_proveForType = Coq.ident "prove_ind_prove_ForType" +proveInd_ForType_InType :: Coq.Ident +proveInd_ForType_InType = Coq.ident "prove_ind_ForType_InType" -- | The tactic that is needed to prove 'forall' lemmas. proveForall :: Coq.Ident diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index 9d5948af..dd4721bf 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -129,9 +129,9 @@ convertDataDecls dataDecls = do inductionSentences <- generateInductionSchemes dataDecls let (extraSentences, qualSmartConDecls) = concatUnzip extraSentences' return - ( Coq.unsetOption (Just Coq.Local) "Elimination Schemes" - : Coq.comment ("Data type declarations for " + ( Coq.comment ("Data type declarations for " ++ showPretty (map IR.typeDeclName dataDecls)) + : Coq.unsetOption (Just Coq.Local) "Elimination Schemes" : Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList indBodies) []) : Coq.setOption (Just Coq.Local) "Elimination Schemes" Nothing : extraSentences ++ inductionSentences diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index ba0c40c7..03ec1cb5 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -1,7 +1,10 @@ +-- This module defines and proofs induction schemes for data declarations. +-- It also creates helper types and lemmas for those induction schemes. module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme where import Control.Monad ( mapAndUnzipM ) import Control.Monad.Extra ( concatMapM ) +import Data.List ( nub, intercalate ) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe ( catMaybes, fromMaybe, fromJust ) import qualified Data.Map as Map @@ -15,51 +18,75 @@ import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Fresh ( freshArgPrefix, freshCoqQualid, freshCoqIdent ) +import FreeC.Environment.LookupOrFail (lookupIdentOrFail) import qualified FreeC.IR.Syntax as IR import FreeC.IR.TypeSynExpansion import FreeC.Monad.Converter +import FreeC.Pretty ---import FreeC.Pretty ---import Text.PrettyPrint.Leijen.Text ( (<+>) ) ---import Debug.Trace +type LookupMap a = Map.Map IR.QName a +-- | Creates induction schemes and helpers for a list of data declarations. generateInductionSchemes :: [IR.TypeDecl] -> Converter [Coq.Sentence] generateInductionSchemes dataDecls = do + -- Filter the data declarations that need helpers. let complexDataDecls = filter hasTypeVar dataDecls + -- Generate names. forQualidMap <- Map.fromList <$> mapM (generateName "For" "" . IR.typeDeclQName) complexDataDecls - forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls inQualidMap <- Map.fromList <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls - (inBodies, inConNames) <- mapAndUnzipM (generateInProperties inQualidMap) complexDataDecls - let inBodies' = concat inBodies schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_ind" . IR.typeDeclQName) dataDecls - schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls + -- Generate properties. + forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls + (inBodies', inConNames) <- mapAndUnzipM (generateInProperties inQualidMap) complexDataDecls + let inBodies = concat inBodies' + -- Generate induction schemes. + schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls + -- Generate lemmas and hints. forallBodies <- mapM (uncurry $ generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap) $ zip inConNames complexDataDecls hintSentences <- concatMapM (generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap) complexDataDecls - mapM_ (insertPropertiesInEnv forQualidMap inQualidMap . IR.typeDeclQName) complexDataDecls + -- Insert names into environment. + mapM_ (insertPropertiesInEnv forQualidMap inQualidMap forallQualidMap . IR.typeDeclQName) complexDataDecls + -- Return result return - ( [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] - ++[Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies') []) | not (null inBodies')] - ++(map (\(name, binders, term, proof) -> - Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) (schemeBodies ++ forallBodies)) - ++ hintSentences + ( Coq.commentedSentences ("ForType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) + [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] + ++ Coq.commentedSentences ("InType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) + [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] + ++ Coq.commentedSentences ("Induction schemes for " ++ showPretty (map IR.typeDeclName dataDecls)) + (map (\(name, binders, term, proof) -> + Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) schemeBodies) + ++ Coq.commentedSentences ("Forall lemmas for " ++ showPretty (map IR.typeDeclName dataDecls)) + (map (\(name, binders, term, proof) -> + Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) forallBodies) + ++ Coq.commentedSentences "Give hints" + hintSentences ) where - ----------------------------------------------------------------------------- -- @ForType@ Properties -- ----------------------------------------------------------------------------- - generateForProperty :: Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody + -- | Generates the 'For-' property for a given data declaration. + -- If the data declaration has @n@ type variables @a1 ... an@ then the property + -- will be of the form: + -- > ForType Shape Pos a_1 ... a_n P_1 ... P_n x + -- This property states that for every @1 <= i <= n@ and every element @y@ of + -- type @a_i@ which is contained in @x@, the property @P_i y@ holds. + generateForProperty :: LookupMap Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" - generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let forQualid = forQualidMap Map.! typeName + generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) = do + -- Generate constructor names. forConQualids <- mapM (generateConName forQualid . IR.conDeclQName) conDecls + -- Enter local environment. localEnv $ do + -- Collect and generate relevant Coq names. + typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids + -- Generate constructors for the 'For-' property. forCons <- mapM (uncurry (generateForConstructor typeVarQualids propertyQualids)) $ zip conDecls forConQualids + -- Stick everything together. let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders @@ -67,13 +94,21 @@ generateInductionSchemes dataDecls = do (Coq.Sort Coq.Prop) return $ Coq.IndBody forQualid binders returnType forCons where + -- | The name of the 'For-' property which we are generating. + forQualid :: Coq.Qualid + forQualid = forQualidMap Map.! typeName + + -- | Generates a constructor for the 'For-' property. generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) - generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) forConQualid = localEnv $ do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) args) forConQualid = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args + -- Generate a hypothesis for every argument of the constructor. + -- But ignore trivial hypotheses. forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) - let forQualid = forQualidMap Map.! typeName - forResult = genericApply forQualid [] [] + -- Generate constructor. + let forResult = genericApply forQualid [] [] ( map Coq.Qualid typeVarQualids ++ map Coq.Qualid propertyQualids ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) @@ -83,43 +118,77 @@ generateInductionSchemes dataDecls = do propertyMap :: Map.Map Coq.Qualid Coq.Qualid propertyMap = Map.fromList $ zip typeVarQualids propertyQualids + -- | Generates an hypothesis for an argument of a 'For-' constructor. generateForHypothesis :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) generateForHypothesis argQualid argType = do + -- Expand type synonyms in the argument type and search for occurrences of the type variables. coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType mbHyp <- generateForHypothesis_1 0 argType' + -- Wrap generated hypothesis in a @ForFree@ property and apply it to the argument. return $ case mbHyp of Just hyp -> Just $ genericApply Coq.Base.forFree [] [] [coqType, hyp, Coq.Qualid argQualid] Nothing -> Nothing - + + -- | Generates an hypothesis for a by searching in the given IR type. + -- Memorizes the depth of the current search path. generateForHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) - generateForHypothesis_1 _ (IR.FuncType _ _ _) = return Nothing - generateForHypothesis_1 d (IR.TypeApp _ tcon lastArg) = generateForHypothesis_2 d tcon [lastArg] - generateForHypothesis_1 _ (IR.TypeCon _ _) = return Nothing -- Ignore type constructors that do not have any type variable or are partially applied + generateForHypothesis_1 _ (IR.FuncType _ _ _) = + -- Ignore functions. + return Nothing + generateForHypothesis_1 d (IR.TypeApp _ tcon lastArg) = + -- Unfold the type application. + generateForHypothesis_2 d tcon [lastArg] + generateForHypothesis_1 _ (IR.TypeCon _ _) = + -- Ignore type constructors that do not have any type variable or are partially applied. + return Nothing generateForHypothesis_1 _ tvar@(IR.TypeVar _ _) = do + -- Lookup hypothesis that has to hold for the given type variable. Coq.Qualid tvarQualid <- convertType' tvar return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid + -- | Unfolds a type application + -- Memorizes the depth of the current search path. generateForHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateForHypothesis_2 _ (IR.FuncType _ _ _) _ = return Nothing - generateForHypothesis_2 d (IR.TypeApp _ tcon lastArg) typeArgs = generateForHypothesis_2 d tcon (lastArg : typeArgs) + generateForHypothesis_2 _ (IR.FuncType _ _ _) _ = + -- Ignore functions. + return Nothing + generateForHypothesis_2 d (IR.TypeApp _ tcon lastArg) typeArgs = + -- Continue unfolding. + generateForHypothesis_2 d tcon (lastArg : typeArgs) generateForHypothesis_2 d (IR.TypeCon _ tconName) typeArgs = do - Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + -- Recursively generate hypotheses for type arguments. hypotheses <- mapM (generateForHypothesis_1 (d+1)) typeArgs + -- Only consider fully applied type constructors and only generate a + -- complex hypothesis, if any of the hypotheses for the arguments is + -- non trivial. + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) - then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses - coqArgs <- mapM convertType' typeArgs - mbForType <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth - then return $ forQualidMap Map.!? tconName - else getForType Map.empty tconName -- Do not search in mutually recursive types - return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) + then do + let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + coqArgs <- mapM convertType' typeArgs + -- Prevent mutual recursion in the hypotheses and prevent + -- direct recursion which is deeper than @maxDepth@. + mbForType <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth + then + -- Legal recursion. + return $ Just forQualid + else + -- Use already defined 'For-' property + inEnv $ lookupForProperty tconName + -- Wrap generated hypotheses in a 'For-' property. + return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateForHypothesis_2 _ (IR.TypeVar _ _) _ = return Nothing + generateForHypothesis_2 _ (IR.TypeVar _ _) _ = + -- Ignore type variables that are used as type constructors. + return Nothing ----------------------------------------------------------------------------- -- @InType@ Properties -- ----------------------------------------------------------------------------- + -- | Generate a name for a 'In-' property for each type variable of the given + -- type constructor. generateInNames :: IR.QName -> Converter (IR.QName, [Coq.Qualid]) generateInNames typeName = do Just arity <- inEnv $ lookupArity IR.TypeScope typeName @@ -128,82 +197,135 @@ generateInductionSchemes dataDecls = do else mapM (\index -> generateName "In" ("_" ++ show index) typeName) [1 .. arity] return (typeName, inQualids) - generateInProperties :: Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter ([Coq.IndBody], [Coq.Qualid]) + -- | Generates the 'In-' properties for a given data declaration. + generateInProperties :: LookupMap [Coq.Qualid] -> IR.TypeDecl -> Converter ([Coq.IndBody], [Coq.Qualid]) generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do (bodies, inConNames) <- mapAndUnzipM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [0 .. length typeVarDecls - 1] return (bodies, concat inConNames) - generateInProperty :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter (Coq.IndBody, [Coq.Qualid]) + -- | Generates an 'In-' property for a given data declaration and the type + -- variable number @index@ of that type and returns the names of its + -- constructors. + -- If the data declaration has @n@ type variables @a1 ... an@ then the + -- property will be of the form: + -- > InType Shape Pos a_1 ... a_n y x + -- This property states that the element @y@ of type @a_index@ is contained + -- in @x@. + generateInProperty :: LookupMap [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter (Coq.IndBody, [Coq.Qualid]) generateInProperty inQualidMap typeName typeVarDecls conDecls index = do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - let inQualid = (inQualidMap Map.! typeName) !! index + -- In contrast to the generation of the 'For-' properties the number of + -- constructors for a 'In-' property is not known yet. + -- Therefore we retrieve components from the local environment and connect + -- them outside of the local environment where we can add the required + -- environment entries. (cons, mkBody) <- localEnv $ do + -- Collect and generate relevant Coq names. + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + -- Generate constructors for the 'In-' property. + cons <- concatMapM (generateInConstructors typeVarQualids) conDecls + -- Start sticking everything together. let binders = genericArgDecls Coq.Explicit ++ typeVarBinders returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! index) (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) (Coq.Sort Coq.Prop)) - mkBody cons' = Coq.IndBody inQualid binders returnType cons' - cons <- concatMapM (generateInConstructors typeVarQualids) conDecls + mkBody = Coq.IndBody inQualid binders returnType return (cons, mkBody) - cons' <- mapM (\(conName, mbConType) -> (\conQualid -> (conQualid, [], mbConType)) <$> generateConName inQualid conName) cons - return (mkBody cons', map (\(q,_,_) -> q) cons') + -- Generate constructor names and add empty binding list. + inConNames <- mapM (generateConName inQualid . fst) cons + let cons' = map (\(inConName, mbConType) -> (inConName, [], mbConType)) $ + zip inConNames $ map snd cons + return (mkBody cons', inConNames) where + -- | The name of the 'In-' property which we are generating. + inQualid :: Coq.Qualid + inQualid = (inQualidMap Map.! typeName) !! index + + -- | Generates constructors for the 'In-' property. generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] - generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent _ conName) args) = localEnv $ do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent srcSpan conName) args) = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan IR.ValueScope conName (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args elemQualid <- freshCoqQualid "x" + -- Find occurrences of the relevant type variable in the arguments. occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args - let inQualid = (inQualidMap Map.! typeName) !! index - inResult = genericApply inQualid [] [] + -- Generate a constructor for each occurrence. + let inResult = genericApply inQualid [] [] ( map Coq.Qualid typeVarQualids ++ [Coq.Qualid elemQualid] ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) - elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid (Coq.Qualid elemType) + elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid elemType mkConType (occBinders, inHypotheses) = Coq.forall (elemBinder : occBinders ++ argBinders) (foldr Coq.Arrow inResult (reverse inHypotheses)) conTypes = map mkConType occurrences return $ map ((,) conName . Just) conTypes where - elemType :: Coq.Qualid - elemType = typeVarQualids !! index + -- | The type variable we are looking for. + elemType :: Coq.Term + elemType = Coq.Qualid (typeVarQualids !! index) + -- | Smart constructor for an 'In-' property. inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term - inHypothesis inQualid typeArgs containerQualid elemQualid = - genericApply inQualid [] [] (typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + inHypothesis inQualid' typeArgs containerQualid elemQualid = + genericApply inQualid' [] [] (typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + -- | Find occurrences of the relevant type variable in the given type. findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] findOccurrences elemQualid argQualid argType = do + -- Expand type synonyms in the argument type and search for occurrences of the type variable. coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType findOccurrences_1 0 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' - + + -- | Find occurrences of the relevant type variable in the given type. + -- Memorizes the depth of the current search path. findOccurrences_1 :: Int -> Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_1 _ _ _ (IR.FuncType _ _ _) = return [] - findOccurrences_1 _ _ _ (IR.TypeCon _ _) = return [] -- Ignore type constructors that do not have any type variable or are partially applied + findOccurrences_1 _ _ _ (IR.FuncType _ _ _) = + -- Ignore functions. + return [] + findOccurrences_1 _ _ _ (IR.TypeCon _ _) = + -- Ignore type constructors that do not have any type variable or are partially applied + return [] findOccurrences_1 _ elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do + -- If this is the desired type variable, return an occurrence. tvarType <- convertType' tvar - return [([], [mkInHyp elemQualid]) | tvarType == Coq.Qualid elemType] + return [([], [mkInHyp elemQualid]) | tvarType == elemType] findOccurrences_1 d elemQualid mkInHyp fullType@(IR.TypeApp _ _ _) = + -- Unfold type application. findOccurrences_2 fullType [] where + -- | Unfolds a type application. findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_2 (IR.FuncType _ _ _) _ = return [] - findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = findOccurrences_2 tcon (lastArg : typeArgs) - findOccurrences_2 (IR.TypeVar _ _) _ = return [] + findOccurrences_2 (IR.FuncType _ _ _) _ = + -- Ignore functions. + return [] + findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = + -- Continue unfolding. + findOccurrences_2 tcon (lastArg : typeArgs) + findOccurrences_2 (IR.TypeVar _ _) _ = + -- Ignore type variables that are used as type constructors. + return [] findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do + -- Only consider fully applied type constructors. Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName if tconArity == length typeArgs then do coqArgs <- mapM convertType' typeArgs + -- Prevent mutual recursion in the hypotheses and prevent + -- direct recursion which is deeper than @maxDepth@. mbInTypes <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth - then return $ inQualidMap Map.!? tconName - else getInTypes Map.empty tconName -- Do not search in mutually recursive types + then + -- Legal recursion. + return $ inQualidMap Map.!? tconName + else + -- Use already defined 'In-' properties + inEnv $ lookupInProperties tconName case mbInTypes of Just inTypes -> do + -- Generate intermediate container and recursively search in type arguments. (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 (d+1) elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) @@ -215,25 +337,19 @@ generateInductionSchemes dataDecls = do -- Induction Schemes -- ----------------------------------------------------------------------------- - -- | The maximal depth to search for recursive occurrences when construction - -- induction hypotheses. - -- @0@ -> Create only induction hypotheses for direct recursion. - -- @n@ -> Create only induction hypotheses for constructor arguments where - -- the recursive occurrence is encapsulated in at most @n@ data - -- types. - maxDepth :: Int - maxDepth = 1 - - -- | Generates an induction scheme for the data type. - generateSchemeLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + -- | Generates an induction scheme for the give data type declaration. + generateSchemeLemma :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" - generateSchemeLemma schemeQualidMap forQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = localEnv $ do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + generateSchemeLemma schemeQualidMap forQualidMap (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) = localEnv $ do + -- Collect and generate relevant Coq names. + typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls (propQualid, propBinder) <- generateArg "P" (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) (Coq.Sort Coq.Prop)) + -- Generate induction cases for constructors. indCases <- mapM (generateInductionCase propQualid) conDecls + -- Generate lemma. (valIdent, valBinder) <- generateArg freshArgPrefix (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) (indCaseQualids, fixpointQualid, varQualid) <- localEnv $ @@ -248,6 +364,7 @@ generateInductionSchemes dataDecls = do goal = Coq.forall [valBinder] (Coq.app (Coq.Qualid propQualid) [Coq.Qualid valIdent]) term = Coq.forall binders (foldr Coq.Arrow goal indCases) + -- Generate proof. vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ [propQualid] ++ indCaseQualids) fixpoint = fromJust $ Coq.unpackQualid fixpointQualid var = fromJust $ Coq.unpackQualid varQualid @@ -262,60 +379,94 @@ generateInductionSchemes dataDecls = do -- | Generates an induction case for a given property and constructor. generateInductionCase :: Coq.Qualid -> IR.ConDecl -> Converter Coq.Term - generateInductionCase propQualid (IR.ConDecl _ (IR.DeclIdent _ conName) argTypes) = localEnv $ do - Just conQualid <- inEnv $ lookupIdent IR.ValueScope conName + generateInductionCase propQualid (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) argTypes) = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName + (argQualids, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) + -- Expand type synonyms in the argument types and create induction hypotheses. argTypes' <- mapM expandAllTypeSynonyms argTypes Just conType <- inEnv $ lookupReturnType IR.ValueScope conName conType' <- convertType' conType - (argQualids, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) hypotheses <- catMaybes <$> mapM (uncurry $ generateInductionHypothesis propQualid conType') (zip argQualids argTypes') - -- Create induction case. + -- Generate induction case. let term = foldr Coq.Arrow (Coq.app (Coq.Qualid propQualid) [Coq.app (Coq.Qualid conQualid) (map Coq.Qualid argQualids)]) hypotheses indCase = Coq.forall argBinders term return indCase + -- | Generates an induction hypothesis for a given property and constructor argument. generateInductionHypothesis :: Coq.Qualid -> Coq.Term -> Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) generateInductionHypothesis propQualid conType argQualid argType = do + -- Generate induction hypotheses with a maximal depth of @maxDepth@. mbHypothesis <- generateInductionHypothesis_1 maxDepth argType + -- Wrap generated hypothesis in a @ForFree@ property and apply it to the argument. argType' <- convertType' argType case mbHypothesis of Just hypothesis -> return $ Just $ genericApply Coq.Base.forFree [] [] [argType', hypothesis, Coq.Qualid argQualid] Nothing -> return Nothing where + -- | Generates an induction hypothesis by searching in the given type for recursive occurrences. + -- Has an argument limiting the search depth. generateInductionHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) - generateInductionHypothesis_1 _ (IR.FuncType _ _ _) = return Nothing + generateInductionHypothesis_1 _ (IR.FuncType _ _ _) = + -- Ignore functions. + return Nothing generateInductionHypothesis_1 md t@(IR.TypeApp _ tcon lastArg) = do + -- Check whether we found a recursive occurrence. t' <- convertType' t if conType == t' - then return $ Just $ Coq.Qualid propQualid - else if md > 0 then generateInductionHypothesis_2 (md-1) tcon [lastArg] else return Nothing + then + return $ Just $ Coq.Qualid propQualid + else + -- If we do not have an recursive occurrence and did not reach the + -- search limit yet, unfold type application. + if md > 0 then generateInductionHypothesis_2 (md-1) tcon [lastArg] else return Nothing generateInductionHypothesis_1 _ t@(IR.TypeCon _ _) = do + -- Check whether we found a recursive occurrence. t' <- convertType' t if conType == t' then return $ Just $ Coq.Qualid propQualid - else return Nothing -- Ignore type constructors that do not have any type variable or are partially applied - generateInductionHypothesis_1 _ (IR.TypeVar _ _) = return Nothing - + else + -- Ignore type constructors that do not have any type variable or are partially applied. + return Nothing + generateInductionHypothesis_1 _ (IR.TypeVar _ _) = + -- There is no induction hypothesis for type variables. + return Nothing + + -- Unfolds a type application. generateInductionHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateInductionHypothesis_2 _ (IR.FuncType _ _ _) _ = return Nothing - generateInductionHypothesis_2 md (IR.TypeApp _ tcon lastArg) typeArgs = generateInductionHypothesis_2 md tcon (lastArg : typeArgs) + generateInductionHypothesis_2 _ (IR.FuncType _ _ _) _ = + -- Ignore functions. + return Nothing + generateInductionHypothesis_2 md (IR.TypeApp _ tcon lastArg) typeArgs = + -- Continue unfolding. + generateInductionHypothesis_2 md tcon (lastArg : typeArgs) generateInductionHypothesis_2 md (IR.TypeCon _ tconName) typeArgs = do - Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName + -- Recursively generate hypotheses for type arguments. hypotheses <- mapM (generateInductionHypothesis_1 md) typeArgs + -- Only consider fully applied type constructors and only generate a + -- complex hypothesis, if any of the hypotheses for the arguments is + -- non trivial. + Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) - then do let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses - coqArgs <- mapM convertType' typeArgs - mbForType <- getForType forQualidMap tconName - return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) + then do + let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + coqArgs <- mapM convertType' typeArgs + mbForType <- getForType forQualidMap tconName + -- Wrap generated hypotheses in a 'For-' property. + return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateInductionHypothesis_2 _ (IR.TypeVar _ _) _ = return Nothing + generateInductionHypothesis_2 _ (IR.TypeVar _ _) _ = + -- Ignore type variables that are used as type constructors. + return Nothing ----------------------------------------------------------------------------- -- Forall Lemmas -- ----------------------------------------------------------------------------- - generateForallLemma :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> - Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> + -- | Generates a lemma which states the relation between the 'For-' property + -- and the 'In-' properties for a data declaration with type variables. + generateForallLemma :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> + LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> [Coq.Qualid] -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) generateForallLemma _ _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap inConNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do @@ -342,6 +493,8 @@ generateInductionSchemes dataDecls = do ++ ".") return (forallQualid, [], term, proof) where + -- | Generates a term stating that for all elements @y@ of type @a_index@ + -- that are contained in @valQualid@, the property @propQualid y@ holds. generateInTerm :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term generateInTerm valQualid tvarQualids index propQualid = localEnv $ do let inQualid = (inQualidMap Map.! typeName) !! index @@ -349,6 +502,7 @@ generateInductionSchemes dataDecls = do let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) + -- | Generate a local hint which is used in the proof of this 'forall' lemma. generateForallHint :: Coq.Qualid -> String generateForallHint inCon = let Just inStr = Coq.unpackQualid inCon @@ -360,29 +514,101 @@ generateInductionSchemes dataDecls = do ----------------------------------------------------------------------------- -- | Generates hints that are used in the proofs of induction schemes and -- 'forall' sentences. - generateHints :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] + generateHints :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] generateHints _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateHint: Type synonym not allowed" - generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = do + generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls tconDecls) = do let forall = forallQualidMap Map.! typeName forType = forQualidMap Map.! typeName inTypes = inQualidMap Map.! typeName scheme = schemeQualidMap Map.! typeName - proveIndHint <- generateProveIndHint forType forall scheme (length typeVarDecls) + proveIndHint <- generateProveIndHint typeName forType forall scheme (length typeVarDecls) tconDecls proveForallHint1 <- generateProveForallHint1 forType forall (length typeVarDecls) proveForallHints2 <- mapM (generateProveForallHint2 forType forall (length typeVarDecls)) inTypes return $ [proveIndHint, proveForallHint1] ++ proveForallHints2 - generateProveIndHint :: Coq.Qualid -> Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) - generateProveIndHint forType forall scheme nTvars = do + -- | Generates a hint for induction scheme generation, using the template + -- @Coq.Base.proveInd_proveForType@. + generateProveIndHint :: IR.QName -> Coq.Qualid -> Coq.Qualid -> Coq.Qualid -> Int -> [IR.ConDecl] -> Converter (Coq.Sentence) + generateProveIndHint typeName forType forall scheme nTvars conDecls = do valStr <- localEnv $ freshCoqIdent freshArgPrefix + dTypes <- concatMapM getDTypes conDecls + unfoldSubProps <- nub <$> concatMapM unfoldSubProp dTypes let tacticConStr = Text.unpack Coq.Base.proveInd_proveForType Just forallStr = Coq.unpackQualid forall Just schemeStr = Coq.unpackQualid scheme - tactic = tacticConStr ++ ' ' : valStr ++ ' ' : forallStr ++ ' ' : schemeStr underscores = replicate (2 + 2 * nTvars) Coq.UnderscorePat valPattern = Coq.QualidPat $ Coq.bare $ '?':valStr forTypePattern = Coq.ArgsPat forType $ underscores ++ [valPattern] + tactic = unwords [tacticConStr, valStr, forallStr, schemeStr] + ++ (if null unfoldSubProps then "" else (";\nrepeat (\n" + ++ tacticUnlines unfoldSubProps + ++ ")")) return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveInd_db] + where + -- | Tries to simplify a pair of 'For-' and 'In-' hypotheses. + unfoldSubProp :: IR.QName -> Converter [String] + unfoldSubProp dname = do + -- Filter complex data types. + mbInTs <- inEnv $ lookupInProperties dname + case mbInTs of + Nothing -> return [] + Just inTs -> mapM (unfoldSubProp' dname) inTs + + -- | Tries to simplify a pair of 'For-' and 'In-' hypotheses. + unfoldSubProp' :: IR.QName -> Coq.Qualid -> Converter String + unfoldSubProp' dName inT = localEnv $ do + hForStr <- freshCoqIdent "HF" + hInStr <- freshCoqIdent "HI" + valStr1 <- freshCoqIdent freshArgPrefix + valStr2 <- freshCoqIdent freshArgPrefix + Just forT <- inEnv $ lookupForProperty dName + Just forallT <- inEnv $ lookupForallLemma dName + Just dArity <- inEnv $ lookupArity IR.TypeScope dName + let forStr = unpackQualid' forT + inStr = unpackQualid' inT + forallStr = unpackQualid' forallT + forPatStrs = forStr : (replicate (2 + 2 * dArity) "_") ++ ['?':valStr2] + inPatStrs = inStr : (replicate (2 + dArity) "_") ++ ['?':valStr1, '?':valStr2] + tactic = unlines' + [ " try match goal with" + , " | [ " ++ hForStr ++ " : " ++ unwords forPatStrs + , " , " ++ hInStr ++ " : " ++ unwords inPatStrs + , " |- _ ] =>" + , " " ++ unwords [Text.unpack Coq.Base.proveInd_ForType_InType, hForStr, hInStr, valStr1, forallStr] + , " end" + ] + return tactic + + -- | Like @unpackQualid@ but does also return a string for qualified names. + unpackQualid' :: Coq.Qualid -> String + unpackQualid' (Coq.Bare n) = Text.unpack n + unpackQualid' (Coq.Qualified p n) = Text.unpack p ++ "." ++ Text.unpack n + + -- | Like @unlines@, but does not put a line break after the last string. + unlines' :: [String] -> String + unlines' = intercalate "\n" + + -- | Like @unlines'@, but inserts also semicolons to connect Coq tactics. + tacticUnlines :: [String] -> String + tacticUnlines = intercalate ";\n" + + -- | Collects all types that occur in an argument of the given constructor. + getDTypes :: IR.ConDecl -> Converter [IR.QName] + getDTypes (IR.ConDecl _ _ argTypes) = do + argTypes' <- mapM expandAllTypeSynonyms argTypes + concatMapM getDTypes' argTypes' + + -- | Collects all types that occur in the given type. + getDTypes' :: IR.Type -> Converter [IR.QName] + getDTypes' (IR.TypeApp _ t1 t2) = do + ts1 <- getDTypes' t1 + ts2 <- getDTypes' t2 + return (ts1 ++ ts2) + getDTypes' (IR.TypeCon _ tconName) + | showPretty tconName == showPretty typeName = return [] + | otherwise = return [tconName] + getDTypes' (IR.TypeVar _ _) = return [] + getDTypes' (IR.FuncType _ _ _) = return [] generateProveForallHint1 :: Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) generateProveForallHint1 forType forall nTvars = do @@ -420,6 +646,15 @@ generateInductionSchemes dataDecls = do -- Helper Functions -- ----------------------------------------------------------------------------- + -- | The maximal depth to search for recursive occurrences when construction + -- induction hypotheses. + -- @0@ -> Create only induction hypotheses for direct recursion. + -- @n@ -> Create only induction hypotheses for constructor arguments where + -- the recursive occurrence is encapsulated in at most @n@ data + -- types. + maxDepth :: Int + maxDepth = 1 + hasTypeVar :: IR.TypeDecl -> Bool hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls @@ -438,21 +673,17 @@ generateInductionSchemes dataDecls = do Just conName = Coq.unpackQualid conQualid freshCoqQualid $ baseName ++ "_" ++ conName - getForType :: Map.Map IR.QName Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) + getForType :: LookupMap Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) getForType forQualidMap name = case forQualidMap Map.!? name of Just qualid -> return $ Just qualid Nothing -> inEnv $ lookupForProperty name - getInTypes :: Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter (Maybe [Coq.Qualid]) - getInTypes inQualidMap name = case inQualidMap Map.!? name of - Just qualids -> return $ Just qualids - Nothing -> inEnv $ lookupInProperties name - - insertPropertiesInEnv :: Map.Map IR.QName Coq.Qualid -> Map.Map IR.QName [Coq.Qualid] -> IR.QName -> Converter () - insertPropertiesInEnv forQualidMap inQualidMap name = do - let forName = forQualidMap Map.!? name - inNames = inQualidMap Map.!? name - modifyEnv $ addPropertyNamesToEntry name forName inNames + insertPropertiesInEnv :: LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> LookupMap Coq.Qualid -> IR.QName -> Converter () + insertPropertiesInEnv forQualidMap inQualidMap forallQualidMap name = do + let forName = forQualidMap Map.!? name + inNames = inQualidMap Map.!? name + forallName = forallQualidMap Map.!? name + modifyEnv $ addPropertyNamesToEntry name forName inNames forallName generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) generateArg argName argType = do diff --git a/src/lib/FreeC/Environment.hs b/src/lib/FreeC/Environment.hs index 541f2d2c..38497e33 100644 --- a/src/lib/FreeC/Environment.hs +++ b/src/lib/FreeC/Environment.hs @@ -37,6 +37,7 @@ module FreeC.Environment , lookupArity , lookupForProperty , lookupInProperties + , lookupForallLemma , lookupTypeSynonym , needsFreeArgs , hasEffect @@ -162,11 +163,11 @@ addEffectsToEntry name effects env = case lookupEntry IR.ValueScope name env of -- properties for the data entry with the given name. -- -- If such a data entry does not exist, the environment is not changed. -addPropertyNamesToEntry :: IR.QName -> Maybe Coq.Qualid -> Maybe [Coq.Qualid] -> Environment -> Environment -addPropertyNamesToEntry name forIdent inIdents env = case lookupEntry IR.TypeScope name env of +addPropertyNamesToEntry :: IR.QName -> Maybe Coq.Qualid -> Maybe [Coq.Qualid] -> Maybe Coq.Qualid -> Environment -> Environment +addPropertyNamesToEntry name forIdent inIdents forallIdent env = case lookupEntry IR.TypeScope name env of Nothing -> env Just entry -> if isDataEntry entry - then addEntry (entry { entryForPropertyIdent = forIdent, entryInPropertyIdents = inIdents }) env + then addEntry (entry { entryForPropertyIdent = forIdent, entryInPropertyIdents = inIdents, entryForallIdent = forallIdent }) env else env ------------------------------------------------------------------------------- @@ -309,8 +310,8 @@ lookupArity :: IR.Scope -> IR.QName -> Environment -> Maybe Int lookupArity = fmap entryArity . find (not . (isVarEntry .||. isTypeVarEntry)) .:. lookupEntry --- | Looks up the Coq identifier for the 'For-' property of data entry with the --- given name. +-- | Looks up the Coq identifier for the 'For-' property of the data entry with +-- the given name. -- -- Returns @Nothing@ if there is no such data entry or if the data entry has -- no 'For-' property. @@ -322,8 +323,8 @@ lookupForProperty = concatMaybe . fmap entryForPropertyIdent . find isDataEntry concatMaybe (Just mb) = mb concatMaybe Nothing = Nothing --- | Looks up the Coq identifiers for the 'In-' properties of data entry with --- the given name. +-- | Looks up the Coq identifiers for the 'In-' properties of the data entry +-- with the given name. -- -- Returns @Nothing@ if there is no such data entry or if the data entry has -- no 'In-' properties. @@ -335,6 +336,19 @@ lookupInProperties = concatMaybe . fmap entryInPropertyIdents . find isDataEntry concatMaybe (Just mb) = mb concatMaybe Nothing = Nothing +-- | Looks up the Coq identifier for the 'forall' lemma of the data entry with +-- the given name. +-- +-- Returns @Nothing@ if there is no such data entry or if the data entry has +-- no 'forall' lemma. +lookupForallLemma :: IR.QName -> Environment -> Maybe Coq.Qualid +lookupForallLemma = concatMaybe . fmap entryForallIdent . find isDataEntry + .: lookupEntry IR.TypeScope + where + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing + -- | Looks up the type the type synonym with the given name is associated with. -- -- Returns @Nothing@ if there is no such type synonym. diff --git a/src/lib/FreeC/Environment/Entry.hs b/src/lib/FreeC/Environment/Entry.hs index 753d156f..3bb38be4 100644 --- a/src/lib/FreeC/Environment/Entry.hs +++ b/src/lib/FreeC/Environment/Entry.hs @@ -33,6 +33,9 @@ data EnvEntry -- ^ The name of the 'For-' property in Coq. , entryInPropertyIdents :: Maybe [Coq.Qualid] -- ^ The names of the 'In-' properties in Coq. + , entryForallIdent :: Maybe Coq.Qualid + -- ^ The names of the 'forall' lemma in Coq. + } -- | Entry for a type synonym declaration. | TypeSynEntry diff --git a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs index 9bb534d3..2fe50835 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs @@ -217,6 +217,7 @@ instance Aeson.FromJSON ModuleInterface where consNames <- obj .: "cons-names" coqForPropertyName <- obj .:? "coq-for-property-name" coqInPropertyNames <- obj .:? "coq-in-property-names" + coqForallName <- obj .:? "coq-forall-lemma-name" return DataEntry { entrySrcSpan = NoSrcSpan , entryArity = arity , entryIdent = coqName @@ -225,6 +226,7 @@ instance Aeson.FromJSON ModuleInterface where , entryConsNames = consNames , entryForPropertyIdent = coqForPropertyName , entryInPropertyIdents = coqInPropertyNames + , entryForallIdent = coqForallName } parseConfigTypeSyn :: Aeson.Value -> Aeson.Parser EnvEntry diff --git a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs index d35f641e..01f4a131 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs @@ -100,6 +100,7 @@ encodeEntry entry ++ mapMaybe id [ ("coq-for-property-name" .=) <$> coqForPropertyName , ("coq-in-property-names" .=) <$> coqInPropertyNames + , ("coq-forall-lemma-name" .=) <$> coqForallName ] | isTypeSynEntry entry = return $ Aeson.object @@ -140,11 +141,13 @@ encodeEntry entry coqSmartName = Aeson.toJSON (entrySmartIdent entry) - coqForPropertyName, coqInPropertyNames :: Maybe Aeson.Value + coqForPropertyName, coqInPropertyNames, coqForallName :: Maybe Aeson.Value coqForPropertyName = Aeson.toJSON <$> (entryForPropertyIdent entry) coqInPropertyNames = Aeson.toJSON <$> (entryInPropertyIdents entry) + coqForallName = Aeson.toJSON <$> (entryForallIdent entry) + -- @entryAgdaIdent entry@ is undefined because the agda renamer isn't -- implemented at the moment. To allow encoding a dummy value is needed. -- I decided to insert the placeholder at this point to avoid placing diff --git a/src/lib/FreeC/Pass/DefineDeclPass.hs b/src/lib/FreeC/Pass/DefineDeclPass.hs index 9207f450..f9f67987 100644 --- a/src/lib/FreeC/Pass/DefineDeclPass.hs +++ b/src/lib/FreeC/Pass/DefineDeclPass.hs @@ -79,6 +79,7 @@ defineTypeDecl (IR.DataDecl srcSpan declIdent typeArgs conDecls) = do , entryAgdaIdent = undefined -- filled by renamer , entryForPropertyIdent = Nothing -- may be filled by induction scheme generator , entryInPropertyIdents = Nothing -- may be filled by induction scheme generator + , entryForallIdent = Nothing -- may be filled by induction scheme generator } mapM_ defineConDecl conDecls where From eaee41eb776717e152dfcb642c93f80fd3835a2e Mon Sep 17 00:00:00 2001 From: Marvin Lira Date: Tue, 29 Sep 2020 16:15:42 +0200 Subject: [PATCH 17/17] Format code --- example/Proofs/InductionSchemes.hs | 2 +- src/lib/FreeC/Backend/Coq/Base.hs | 51 +- .../FreeC/Backend/Coq/Converter/TypeDecl.hs | 29 +- .../Coq/Converter/TypeDecl/InductionScheme.hs | 848 +++++++++++------- src/lib/FreeC/Backend/Coq/Syntax.hs | 19 +- src/lib/FreeC/Environment.hs | 43 +- src/lib/FreeC/Environment/Entry.hs | 17 +- .../Environment/ModuleInterface/Decoder.hs | 21 +- .../Environment/ModuleInterface/Encoder.hs | 31 +- 9 files changed, 643 insertions(+), 418 deletions(-) diff --git a/example/Proofs/InductionSchemes.hs b/example/Proofs/InductionSchemes.hs index 5c78d6cc..bb7f6481 100644 --- a/example/Proofs/InductionSchemes.hs +++ b/example/Proofs/InductionSchemes.hs @@ -2,6 +2,6 @@ module Proofs.InductionSchemes where data MyList a = MyNil | MyCons a (MyList a) -data Tree a = Forest a (MyList (Tree a)) +data Tree a = Forest a (MyList (Tree a)) data MyType a = MyCon (Tree (MyType a)) diff --git a/src/lib/FreeC/Backend/Coq/Base.hs b/src/lib/FreeC/Backend/Coq/Base.hs index d6beed8b..793923a3 100644 --- a/src/lib/FreeC/Backend/Coq/Base.hs +++ b/src/lib/FreeC/Backend/Coq/Base.hs @@ -44,15 +44,15 @@ module FreeC.Backend.Coq.Base , stringScope -- * Tactics , proveInd - , proveInd_proveForType - , proveInd_ForType_InType + , proveIndProveForType + , proveIndForTypeInType , proveForall - , proveForall_ForType_InType - , proveForall_proveForType - , proveForall_finish + , proveForallForTypeInType + , proveForallProveForType + , proveForallFinish -- * Hint Databases - , proveInd_db - , proveForall_db + , proveIndDb + , proveForallDb -- * Reserved Identifiers , reservedIdents ) where @@ -266,43 +266,42 @@ proveInd :: Coq.Ident proveInd = Coq.ident "prove_ind" -- | The tactic that has to be instantiated for data types and added to --- 'proveInd_db'. -proveInd_proveForType :: Coq.Ident -proveInd_proveForType = Coq.ident "prove_ind_prove_ForType" +-- 'proveIndDb'. +proveIndProveForType :: Coq.Ident +proveIndProveForType = Coq.ident "prove_ind_prove_ForType" -proveInd_ForType_InType :: Coq.Ident -proveInd_ForType_InType = Coq.ident "prove_ind_ForType_InType" +proveIndForTypeInType :: Coq.Ident +proveIndForTypeInType = Coq.ident "prove_ind_ForType_InType" -- | The tactic that is needed to prove 'forall' lemmas. proveForall :: Coq.Ident proveForall = Coq.ident "prove_forall" -- | One of the tactics that have to be instantiated for data types and added --- to 'proveInd_db'. -proveForall_ForType_InType :: Coq.Ident -proveForall_ForType_InType = Coq.ident "prove_forall_ForType_InType" +-- to 'proveIndDb'. +proveForallForTypeInType :: Coq.Ident +proveForallForTypeInType = Coq.ident "prove_forall_ForType_InType" -- | One of the tactics that have to be instantiated for data types and added --- to 'proveInd_db'. -proveForall_proveForType :: Coq.Ident -proveForall_proveForType = Coq.ident "prove_forall_prove_ForType" +-- to 'proveIndDb'. +proveForallProveForType :: Coq.Ident +proveForallProveForType = Coq.ident "prove_forall_prove_ForType" -- | This tactic has to be instantiated for data types and added locally to --- 'proveInd_db' in the proof of the corresponding 'forall' lemma. -proveForall_finish :: Coq.Ident -proveForall_finish = Coq.ident "prove_forall_finish_rtl" +-- 'proveIndDb' in the proof of the corresponding 'forall' lemma. +proveForallFinish :: Coq.Ident +proveForallFinish = Coq.ident "prove_forall_finish_rtl" ------------------------------------------------------------------------------- -- Hint Databases -- ------------------------------------------------------------------------------- -- | The hint database that is used by 'proveInd'. -proveInd_db :: Coq.Ident -proveInd_db = Coq.ident "prove_ind_db" - +proveIndDb :: Coq.Ident +proveIndDb = Coq.ident "prove_ind_db" -- | The hint database that is used by 'proveForall'. -proveForall_db :: Coq.Ident -proveForall_db = Coq.ident "prove_forall_db" +proveForallDb :: Coq.Ident +proveForallDb = Coq.ident "prove_forall_db" ------------------------------------------------------------------------------- -- Reserved Identifiers -- diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs index dd4721bf..74f1be10 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl.hs @@ -13,26 +13,32 @@ module FreeC.Backend.Coq.Converter.TypeDecl , convertDataDecl ) where -import Control.Monad ( mapAndUnzipM ) -import Control.Monad.Extra ( concatMapM ) -import Data.List ( partition ) -import Data.List.Extra ( concatUnzip ) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes, fromJust ) -import qualified Data.Set as Set +import Control.Monad + ( mapAndUnzipM ) +import Control.Monad.Extra + ( concatMapM ) +import Data.List + ( partition ) +import Data.List.Extra + ( concatUnzip ) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe + ( catMaybes, fromJust ) +import qualified Data.Set as Set -import qualified FreeC.Backend.Coq.Base as Coq.Base +import qualified FreeC.Backend.Coq.Base as Coq.Base import FreeC.Backend.Coq.Converter.Arg import FreeC.Backend.Coq.Converter.Free import FreeC.Backend.Coq.Converter.Type import FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme -import qualified FreeC.Backend.Coq.Syntax as Coq +import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Fresh ( freshArgPrefix, freshCoqIdent ) -import FreeC.Environment.Renamer ( renameAndDefineTypeVar ) +import FreeC.Environment.Renamer + ( renameAndDefineTypeVar ) import FreeC.IR.DependencyGraph -import qualified FreeC.IR.Syntax as IR +import qualified FreeC.IR.Syntax as IR import FreeC.IR.TypeSynExpansion import FreeC.Monad.Converter import FreeC.Monad.Reporter @@ -297,7 +303,6 @@ convertDataDecl (IR.DataDecl _ (IR.DeclIdent _ name) typeVarDecls conDecls) = do , Coq.sModLevel 10 , Coq.sModIdentLevel (NonEmpty.fromList expArgIdents) (Just 9) ] - -- Type synonyms are not allowed in this function. convertDataDecl (IR.TypeSynDecl _ _ _ _) = error "convertDataDecl: Type synonym not allowed." diff --git a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs index 03ec1cb5..912cc2c1 100644 --- a/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs +++ b/src/lib/FreeC/Backend/Coq/Converter/TypeDecl/InductionScheme.hs @@ -2,12 +2,13 @@ -- It also creates helper types and lemmas for those induction schemes. module FreeC.Backend.Coq.Converter.TypeDecl.InductionScheme where -import Control.Monad ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM, zipWithM ) import Control.Monad.Extra ( concatMapM ) -import Data.List ( nub, intercalate ) +import Data.List ( intercalate, nub ) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe ( catMaybes, fromMaybe, fromJust ) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map +import Data.Maybe + ( catMaybes, fromJust, fromMaybe ) import qualified Data.Text as Text import qualified FreeC.Backend.Coq.Base as Coq.Base @@ -17,8 +18,8 @@ import FreeC.Backend.Coq.Converter.Type import qualified FreeC.Backend.Coq.Syntax as Coq import FreeC.Environment import FreeC.Environment.Fresh - ( freshArgPrefix, freshCoqQualid, freshCoqIdent ) -import FreeC.Environment.LookupOrFail (lookupIdentOrFail) + ( freshArgPrefix, freshCoqIdent, freshCoqQualid ) +import FreeC.Environment.LookupOrFail ( lookupIdentOrFail ) import qualified FreeC.IR.Syntax as IR import FreeC.IR.TypeSynExpansion import FreeC.Monad.Converter @@ -32,177 +33,235 @@ generateInductionSchemes dataDecls = do -- Filter the data declarations that need helpers. let complexDataDecls = filter hasTypeVar dataDecls -- Generate names. - forQualidMap <- Map.fromList <$> mapM (generateName "For" "" . IR.typeDeclQName) complexDataDecls - inQualidMap <- Map.fromList <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls - schemeQualidMap <- Map.fromList <$> mapM (generateName "" "_ind" . IR.typeDeclQName) dataDecls - forallQualidMap <- Map.fromList <$> mapM (generateName "For" "_forall". IR.typeDeclQName) complexDataDecls + forQualidMap <- Map.fromList + <$> mapM (generateName "For" "" . IR.typeDeclQName) complexDataDecls + inQualidMap <- Map.fromList + <$> mapM (generateInNames . IR.typeDeclQName) complexDataDecls + schemeQualidMap <- Map.fromList + <$> mapM (generateName "" "_ind" . IR.typeDeclQName) dataDecls + forallQualidMap <- Map.fromList + <$> mapM (generateName "For" "_forall" . IR.typeDeclQName) complexDataDecls -- Generate properties. forBodies <- mapM (generateForProperty forQualidMap) complexDataDecls - (inBodies', inConNames) <- mapAndUnzipM (generateInProperties inQualidMap) complexDataDecls + (inBodies', inConNames) <- mapAndUnzipM (generateInProperties inQualidMap) + complexDataDecls let inBodies = concat inBodies' -- Generate induction schemes. - schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) dataDecls + schemeBodies <- mapM (generateSchemeLemma schemeQualidMap forQualidMap) + dataDecls -- Generate lemmas and hints. - forallBodies <- mapM (uncurry $ generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap) $ zip inConNames complexDataDecls - hintSentences <- concatMapM (generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap) complexDataDecls + forallBodies <- zipWithM (generateForallLemma schemeQualidMap forallQualidMap + forQualidMap inQualidMap) inConNames + complexDataDecls + hintSentences <- concatMapM + (generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap) + complexDataDecls -- Insert names into environment. - mapM_ (insertPropertiesInEnv forQualidMap inQualidMap forallQualidMap . IR.typeDeclQName) complexDataDecls + mapM_ (insertPropertiesInEnv forQualidMap inQualidMap forallQualidMap + . IR.typeDeclQName) complexDataDecls -- Return result return - ( Coq.commentedSentences ("ForType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) - [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) | not (null forBodies)] - ++ Coq.commentedSentences ("InType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) - [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) | not (null inBodies)] - ++ Coq.commentedSentences ("Induction schemes for " ++ showPretty (map IR.typeDeclName dataDecls)) - (map (\(name, binders, term, proof) -> - Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) schemeBodies) - ++ Coq.commentedSentences ("Forall lemmas for " ++ showPretty (map IR.typeDeclName dataDecls)) - (map (\(name, binders, term, proof) -> - Coq.AssertionSentence (Coq.Assertion Coq.Lemma name binders term) proof) forallBodies) - ++ Coq.commentedSentences "Give hints" - hintSentences - ) + (Coq.commentedSentences + ("ForType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) + [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList forBodies) []) + | not (null forBodies) + ] + ++ Coq.commentedSentences + ("InType properties for " ++ showPretty (map IR.typeDeclName dataDecls)) + [Coq.InductiveSentence (Coq.Inductive (NonEmpty.fromList inBodies) []) + | not (null inBodies) + ] + ++ Coq.commentedSentences + ("Induction schemes for " ++ showPretty (map IR.typeDeclName dataDecls)) + (map (\(name, binders, term, proof) -> Coq.AssertionSentence + (Coq.Assertion Coq.Lemma name binders term) proof) schemeBodies) + ++ Coq.commentedSentences + ("Forall lemmas for " ++ showPretty (map IR.typeDeclName dataDecls)) + (map (\(name, binders, term, proof) -> Coq.AssertionSentence + (Coq.Assertion Coq.Lemma name binders term) proof) forallBodies) + ++ Coq.commentedSentences "Give hints" hintSentences) where ----------------------------------------------------------------------------- -- @ForType@ Properties -- ----------------------------------------------------------------------------- - -- | Generates the 'For-' property for a given data declaration. -- If the data declaration has @n@ type variables @a1 ... an@ then the property -- will be of the form: -- > ForType Shape Pos a_1 ... a_n P_1 ... P_n x -- This property states that for every @1 <= i <= n@ and every element @y@ of -- type @a_i@ which is contained in @x@, the property @P_i y@ holds. - generateForProperty :: LookupMap Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody - generateForProperty _ (IR.TypeSynDecl _ _ _ _) = error "generateForProperty: Type synonym not allowed" - generateForProperty forQualidMap (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) = do - -- Generate constructor names. - forConQualids <- mapM (generateConName forQualid . IR.conDeclQName) conDecls - -- Enter local environment. - localEnv $ do - -- Collect and generate relevant Coq names. - typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName - (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids - -- Generate constructors for the 'For-' property. - forCons <- mapM (uncurry (generateForConstructor typeVarQualids propertyQualids)) $ zip conDecls forConQualids - -- Stick everything together. - let propertyTypes = map (\a -> (Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop))) typeVarQualids - propertyBinders = map (\(a,t) -> Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit a t) $ zip propertyQualids propertyTypes - binders = genericArgDecls Coq.Explicit ++ typeVarBinders ++ propertyBinders - returnType = Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) - (Coq.Sort Coq.Prop) - return $ Coq.IndBody forQualid binders returnType forCons + generateForProperty + :: LookupMap Coq.Qualid -> IR.TypeDecl -> Converter Coq.IndBody + generateForProperty _ (IR.TypeSynDecl _ _ _ _) + = error "generateForProperty: Type synonym not allowed" + generateForProperty forQualidMap + (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) = do + -- Generate constructor names. + forConQualids <- mapM (generateConName forQualid . IR.conDeclQName) + conDecls + -- Enter local environment. + localEnv $ do + -- Collect and generate relevant Coq names. + typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName + (typeVarQualids, typeVarBinders) + <- convertTypeVarDecls' Coq.Explicit typeVarDecls + propertyQualids <- mapM (const $ freshCoqQualid "P") typeVarQualids + -- Generate constructors for the 'For-' property. + forCons <- zipWithM + (generateForConstructor typeVarQualids propertyQualids) conDecls + forConQualids + -- Stick everything together. + let propertyTypes = map + (\a -> Coq.Arrow (Coq.Qualid a) (Coq.Sort Coq.Prop)) + typeVarQualids + propertyBinders = zipWith + (Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit) + propertyQualids propertyTypes + binders = genericArgDecls Coq.Explicit + ++ typeVarBinders + ++ propertyBinders + returnType = Coq.Arrow + (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) + (Coq.Sort Coq.Prop) + return $ Coq.IndBody forQualid binders returnType forCons where -- | The name of the 'For-' property which we are generating. forQualid :: Coq.Qualid forQualid = forQualidMap Map.! typeName -- | Generates a constructor for the 'For-' property. - generateForConstructor :: [Coq.Qualid] -> [Coq.Qualid] -> IR.ConDecl -> Coq.Qualid -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) - generateForConstructor typeVarQualids propertyQualids (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) args) forConQualid = localEnv $ do - -- Collect and generate relevant Coq names. - conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName - (argQualids, binders) <- unzip <$> mapM (convertAnonymousArg . Just) args - -- Generate a hypothesis for every argument of the constructor. - -- But ignore trivial hypotheses. - forHypotheses <- catMaybes <$> (mapM (uncurry generateForHypothesis) $ zip argQualids args) - -- Generate constructor. - let forResult = genericApply forQualid [] [] - ( map Coq.Qualid typeVarQualids - ++ map Coq.Qualid propertyQualids - ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) - returnType = Coq.forall binders (foldr Coq.Arrow forResult forHypotheses) - return (forConQualid, [], Just returnType) + generateForConstructor + :: [Coq.Qualid] + -> [Coq.Qualid] + -> IR.ConDecl + -> Coq.Qualid + -> Converter (Coq.Qualid, [Coq.Binder], Maybe Coq.Term) + generateForConstructor typeVarQualids propertyQualids + (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) args) forConQualid + = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName + (argQualids, binders) <- unzip + <$> mapM (convertAnonymousArg . Just) args + -- Generate a hypothesis for every argument of the constructor. + -- But ignore trivial hypotheses. + forHypotheses + <- catMaybes <$> zipWithM generateForHypothesis argQualids args + -- Generate constructor. + let forResult = genericApply forQualid [] [] + (map Coq.Qualid typeVarQualids + ++ map Coq.Qualid propertyQualids + ++ [ genericApply conQualid [] (map Coq.Qualid typeVarQualids) + (map Coq.Qualid argQualids) + ]) + returnType = Coq.forall binders + (foldr Coq.Arrow forResult forHypotheses) + return (forConQualid, [], Just returnType) where propertyMap :: Map.Map Coq.Qualid Coq.Qualid propertyMap = Map.fromList $ zip typeVarQualids propertyQualids -- | Generates an hypothesis for an argument of a 'For-' constructor. - generateForHypothesis :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) + generateForHypothesis + :: Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) generateForHypothesis argQualid argType = do -- Expand type synonyms in the argument type and search for occurrences of the type variables. - coqType <- convertType' argType + coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType mbHyp <- generateForHypothesis_1 0 argType' -- Wrap generated hypothesis in a @ForFree@ property and apply it to the argument. return $ case mbHyp of - Just hyp -> Just $ genericApply Coq.Base.forFree [] [] [coqType, hyp, Coq.Qualid argQualid] + Just hyp -> Just + $ genericApply Coq.Base.forFree [] [] + [coqType, hyp, Coq.Qualid argQualid] Nothing -> Nothing -- | Generates an hypothesis for a by searching in the given IR type. -- Memorizes the depth of the current search path. generateForHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) - generateForHypothesis_1 _ (IR.FuncType _ _ _) = + generateForHypothesis_1 _ (IR.FuncType _ _ _) = -- Ignore functions. return Nothing generateForHypothesis_1 d (IR.TypeApp _ tcon lastArg) = -- Unfold the type application. generateForHypothesis_2 d tcon [lastArg] - generateForHypothesis_1 _ (IR.TypeCon _ _) = + generateForHypothesis_1 _ (IR.TypeCon _ _) = -- Ignore type constructors that do not have any type variable or are partially applied. return Nothing - generateForHypothesis_1 _ tvar@(IR.TypeVar _ _) = do + generateForHypothesis_1 _ tvar@(IR.TypeVar _ _) = do -- Lookup hypothesis that has to hold for the given type variable. Coq.Qualid tvarQualid <- convertType' tvar return $ Coq.Qualid <$> propertyMap Map.!? tvarQualid -- | Unfolds a type application -- Memorizes the depth of the current search path. - generateForHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateForHypothesis_2 _ (IR.FuncType _ _ _) _ = + generateForHypothesis_2 + :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateForHypothesis_2 _ (IR.FuncType _ _ _) _ = -- Ignore functions. return Nothing generateForHypothesis_2 d (IR.TypeApp _ tcon lastArg) typeArgs = -- Continue unfolding. generateForHypothesis_2 d tcon (lastArg : typeArgs) - generateForHypothesis_2 d (IR.TypeCon _ tconName) typeArgs = do + generateForHypothesis_2 d (IR.TypeCon _ tconName) typeArgs = do -- Recursively generate hypotheses for type arguments. - hypotheses <- mapM (generateForHypothesis_1 (d+1)) typeArgs + hypotheses <- mapM (generateForHypothesis_1 (d + 1)) typeArgs -- Only consider fully applied type constructors and only generate a -- complex hypothesis, if any of the hypotheses for the arguments is -- non trivial. Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) + if (tconArity == length typeArgs) && not (null $ catMaybes hypotheses) then do - let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) + hypotheses coqArgs <- mapM convertType' typeArgs -- Prevent mutual recursion in the hypotheses and prevent -- direct recursion which is deeper than @maxDepth@. - mbForType <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth - then + mbForType <- if tconName == typeName + && all (\(tvar, targ) -> Coq.Qualid tvar == targ) + (zip typeVarQualids coqArgs) + && d <= maxDepth + then -- Legal recursion. return $ Just forQualid - else + else -- Use already defined 'For-' property inEnv $ lookupForProperty tconName -- Wrap generated hypotheses in a 'For-' property. - return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) + return ((\forType -> genericApply forType [] [] + (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateForHypothesis_2 _ (IR.TypeVar _ _) _ = + generateForHypothesis_2 _ (IR.TypeVar _ _) _ = -- Ignore type variables that are used as type constructors. return Nothing ----------------------------------------------------------------------------- -- @InType@ Properties -- ----------------------------------------------------------------------------- - -- | Generate a name for a 'In-' property for each type variable of the given -- type constructor. generateInNames :: IR.QName -> Converter (IR.QName, [Coq.Qualid]) generateInNames typeName = do Just arity <- inEnv $ lookupArity IR.TypeScope typeName - inQualids <- map snd <$> if arity == 1 - then mapM (generateName "In" "") [typeName] - else mapM (\index -> generateName "In" ("_" ++ show index) typeName) [1 .. arity] + inQualids <- map snd + <$> if arity == 1 + then mapM (generateName "In" "") [typeName] + else mapM (\index -> generateName "In" ("_" ++ show index) typeName) + [1 .. arity] return (typeName, inQualids) -- | Generates the 'In-' properties for a given data declaration. - generateInProperties :: LookupMap [Coq.Qualid] -> IR.TypeDecl -> Converter ([Coq.IndBody], [Coq.Qualid]) - generateInProperties _ (IR.TypeSynDecl _ _ _ _) = error "generateInProperty: Type synonym not allowed" - generateInProperties inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do - (bodies, inConNames) <- mapAndUnzipM (generateInProperty inQualidMap typeName typeVarDecls conDecls) [0 .. length typeVarDecls - 1] - return (bodies, concat inConNames) + generateInProperties :: LookupMap [Coq.Qualid] + -> IR.TypeDecl + -> Converter ([Coq.IndBody], [Coq.Qualid]) + generateInProperties _ (IR.TypeSynDecl _ _ _ _) + = error "generateInProperty: Type synonym not allowed" + generateInProperties inQualidMap + (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls conDecls) = do + (bodies, inConNames) <- mapAndUnzipM + (generateInProperty inQualidMap typeName typeVarDecls conDecls) + [0 .. length typeVarDecls - 1] + return (bodies, concat inConNames) -- | Generates an 'In-' property for a given data declaration and the type -- variable number @index@ of that type and returns the names of its @@ -212,7 +271,12 @@ generateInductionSchemes dataDecls = do -- > InType Shape Pos a_1 ... a_n y x -- This property states that the element @y@ of type @a_index@ is contained -- in @x@. - generateInProperty :: LookupMap [Coq.Qualid] -> IR.QName -> [IR.TypeVarDecl] -> [IR.ConDecl] -> Int -> Converter (Coq.IndBody, [Coq.Qualid]) + generateInProperty :: LookupMap [Coq.Qualid] + -> IR.QName + -> [IR.TypeVarDecl] + -> [IR.ConDecl] + -> Int + -> Converter (Coq.IndBody, [Coq.Qualid]) generateInProperty inQualidMap typeName typeVarDecls conDecls index = do -- In contrast to the generation of the 'For-' properties the number of -- constructors for a 'In-' property is not known yet. @@ -222,71 +286,90 @@ generateInductionSchemes dataDecls = do (cons, mkBody) <- localEnv $ do -- Collect and generate relevant Coq names. Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - (typeVarQualids, typeVarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (typeVarQualids, typeVarBinders) + <- convertTypeVarDecls' Coq.Explicit typeVarDecls -- Generate constructors for the 'In-' property. cons <- concatMapM (generateInConstructors typeVarQualids) conDecls -- Start sticking everything together. - let binders = genericArgDecls Coq.Explicit ++ typeVarBinders + let binders = genericArgDecls Coq.Explicit ++ typeVarBinders returnType = Coq.Arrow (Coq.Qualid $ typeVarQualids !! index) - (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid typeVarQualids)) - (Coq.Sort Coq.Prop)) - mkBody = Coq.IndBody inQualid binders returnType + (Coq.Arrow (genericApply typeQualid [] [] + (map Coq.Qualid typeVarQualids)) (Coq.Sort Coq.Prop)) + mkBody = Coq.IndBody inQualid binders returnType return (cons, mkBody) -- Generate constructor names and add empty binding list. inConNames <- mapM (generateConName inQualid . fst) cons - let cons' = map (\(inConName, mbConType) -> (inConName, [], mbConType)) $ - zip inConNames $ map snd cons + let cons' = zipWith (\inConName mbConType -> (inConName, [], mbConType)) + inConNames + $ map snd cons return (mkBody cons', inConNames) where -- | The name of the 'In-' property which we are generating. inQualid :: Coq.Qualid inQualid = (inQualidMap Map.! typeName) !! index - + -- | Generates constructors for the 'In-' property. - generateInConstructors :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] - generateInConstructors typeVarQualids (IR.ConDecl _ (IR.DeclIdent srcSpan conName) args) = localEnv $ do - -- Collect and generate relevant Coq names. - conQualid <- lookupIdentOrFail srcSpan IR.ValueScope conName - (argQualids, argBinders) <- unzip <$> mapM (convertAnonymousArg . Just) args - elemQualid <- freshCoqQualid "x" - -- Find occurrences of the relevant type variable in the arguments. - occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) $ zip argQualids args - -- Generate a constructor for each occurrence. - let inResult = genericApply inQualid [] [] - ( map Coq.Qualid typeVarQualids - ++ [Coq.Qualid elemQualid] - ++ [genericApply conQualid [] (map Coq.Qualid typeVarQualids) (map Coq.Qualid argQualids)]) - elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit elemQualid elemType - mkConType (occBinders, inHypotheses) = Coq.forall - (elemBinder : occBinders ++ argBinders) - (foldr Coq.Arrow inResult (reverse inHypotheses)) - conTypes = map mkConType occurrences - return $ map ((,) conName . Just) conTypes + generateInConstructors + :: [Coq.Qualid] -> IR.ConDecl -> Converter [(IR.QName, Maybe Coq.Term)] + generateInConstructors typeVarQualids + (IR.ConDecl _ (IR.DeclIdent srcSpan conName) args) = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan IR.ValueScope conName + (argQualids, argBinders) <- unzip + <$> mapM (convertAnonymousArg . Just) args + elemQualid <- freshCoqQualid "x" + -- Find occurrences of the relevant type variable in the arguments. + occurrences <- concatMapM (uncurry $ findOccurrences elemQualid) + $ zip argQualids args + -- Generate a constructor for each occurrence. + let inResult = genericApply inQualid [] [] + (map Coq.Qualid typeVarQualids + ++ [Coq.Qualid elemQualid] + ++ [ genericApply conQualid [] (map Coq.Qualid typeVarQualids) + (map Coq.Qualid argQualids) + ]) + elemBinder = Coq.typedBinder' Coq.Ungeneralizable Coq.Explicit + elemQualid elemType + mkConType (occBinders, inHypotheses) = Coq.forall + (elemBinder : occBinders ++ argBinders) + (foldr Coq.Arrow inResult (reverse inHypotheses)) + conTypes = map mkConType occurrences + return $ map ((,) conName . Just) conTypes where -- | The type variable we are looking for. elemType :: Coq.Term elemType = Coq.Qualid (typeVarQualids !! index) -- | Smart constructor for an 'In-' property. - inHypothesis :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term - inHypothesis inQualid' typeArgs containerQualid elemQualid = - genericApply inQualid' [] [] (typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) + inHypothesis + :: Coq.Qualid -> [Coq.Term] -> Coq.Qualid -> Coq.Qualid -> Coq.Term + inHypothesis inQualid' typeArgs containerQualid elemQualid + = genericApply inQualid' [] [] + (typeArgs ++ [Coq.Qualid elemQualid, Coq.Qualid containerQualid]) -- | Find occurrences of the relevant type variable in the given type. - findOccurrences :: Coq.Qualid -> Coq.Qualid -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences :: Coq.Qualid + -> Coq.Qualid + -> IR.Type + -> Converter [([Coq.Binder], [Coq.Term])] findOccurrences elemQualid argQualid argType = do -- Expand type synonyms in the argument type and search for occurrences of the type variable. - coqType <- convertType' argType + coqType <- convertType' argType argType' <- expandAllTypeSynonyms argType - findOccurrences_1 0 elemQualid (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' - + findOccurrences_1 0 elemQualid + (inHypothesis Coq.Base.inFree [coqType] argQualid) argType' + -- | Find occurrences of the relevant type variable in the given type. -- Memorizes the depth of the current search path. - findOccurrences_1 :: Int -> Coq.Qualid -> (Coq.Qualid -> Coq.Term) -> IR.Type -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_1 :: Int + -> Coq.Qualid + -> (Coq.Qualid -> Coq.Term) + -> IR.Type + -> Converter [([Coq.Binder], [Coq.Term])] findOccurrences_1 _ _ _ (IR.FuncType _ _ _) = -- Ignore functions. return [] - findOccurrences_1 _ _ _ (IR.TypeCon _ _) = + findOccurrences_1 _ _ _ (IR.TypeCon _ _) = -- Ignore type constructors that do not have any type variable or are partially applied return [] findOccurrences_1 _ elemQualid mkInHyp tvar@(IR.TypeVar _ _) = do @@ -298,290 +381,389 @@ generateInductionSchemes dataDecls = do findOccurrences_2 fullType [] where -- | Unfolds a type application. - findOccurrences_2 :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] - findOccurrences_2 (IR.FuncType _ _ _) _ = + findOccurrences_2 + :: IR.Type -> [IR.Type] -> Converter [([Coq.Binder], [Coq.Term])] + findOccurrences_2 (IR.FuncType _ _ _) _ = -- Ignore functions. return [] findOccurrences_2 (IR.TypeApp _ tcon lastArg) typeArgs = -- Continue unfolding. findOccurrences_2 tcon (lastArg : typeArgs) - findOccurrences_2 (IR.TypeVar _ _) _ = + findOccurrences_2 (IR.TypeVar _ _) _ = -- Ignore type variables that are used as type constructors. return [] - findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do + findOccurrences_2 (IR.TypeCon _ tconName) typeArgs = localEnv $ do -- Only consider fully applied type constructors. Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - if tconArity == length typeArgs - then do - coqArgs <- mapM convertType' typeArgs - -- Prevent mutual recursion in the hypotheses and prevent - -- direct recursion which is deeper than @maxDepth@. - mbInTypes <- if tconName == typeName && all (\(tvar, targ) -> Coq.Qualid tvar == targ) (zip typeVarQualids coqArgs) && d <= maxDepth - then - -- Legal recursion. - return $ inQualidMap Map.!? tconName - else - -- Use already defined 'In-' properties - inEnv $ lookupInProperties tconName - case mbInTypes of - Just inTypes -> do - -- Generate intermediate container and recursively search in type arguments. - (containerQualid, containerBinder) <- convertAnonymousArg' (Just fullType) - occurrences <- concatMapM (\(it,arg) -> findOccurrences_1 (d+1) elemQualid (inHypothesis it coqArgs containerQualid) arg) $ zip inTypes typeArgs - let mkNewOcc (occBinders, inHypotheses) = (containerBinder : (reverse occBinders), mkInHyp containerQualid : inHypotheses) - return $ map mkNewOcc occurrences - Nothing -> return [] - else return [] + if tconArity == length typeArgs then do + coqArgs <- mapM convertType' typeArgs + -- Prevent mutual recursion in the hypotheses and prevent + -- direct recursion which is deeper than @maxDepth@. + mbInTypes <- if tconName == typeName + && all (\(tvar, targ) -> Coq.Qualid tvar == targ) + (zip typeVarQualids coqArgs) + && d <= maxDepth + then + -- Legal recursion. + return $ inQualidMap Map.!? tconName + else + -- Use already defined 'In-' properties + inEnv $ lookupInProperties tconName + case mbInTypes of + Just inTypes -> do + -- Generate intermediate container and recursively search in type arguments. + (containerQualid, containerBinder) <- convertAnonymousArg' + (Just fullType) + occurrences <- concatMapM + (\(it, arg) -> findOccurrences_1 (d + 1) elemQualid + (inHypothesis it coqArgs containerQualid) arg) + $ zip inTypes typeArgs + let mkNewOcc (occBinders, inHypotheses) + = ( containerBinder : reverse occBinders + , mkInHyp containerQualid : inHypotheses + ) + return $ map mkNewOcc occurrences + Nothing -> return [] else return [] ----------------------------------------------------------------------------- -- Induction Schemes -- ----------------------------------------------------------------------------- - -- | Generates an induction scheme for the give data type declaration. - generateSchemeLemma :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) - generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) = error "generateInductionLemma: Type synonym not allowed" - generateSchemeLemma schemeQualidMap forQualidMap (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) = localEnv $ do - -- Collect and generate relevant Coq names. - typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName - (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - (propQualid, propBinder) <- generateArg "P" - (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) - (Coq.Sort Coq.Prop)) - -- Generate induction cases for constructors. - indCases <- mapM (generateInductionCase propQualid) conDecls - -- Generate lemma. - (valIdent, valBinder) <- generateArg freshArgPrefix - (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) - (indCaseQualids, fixpointQualid, varQualid) <- localEnv $ - do indCaseQualids <- mapM (const $ freshCoqQualid "InductionCase") indCases - fixpointQualid <- freshCoqQualid "FP" - varQualid <- freshCoqQualid "x" - return (indCaseQualids, fixpointQualid, varQualid) - let schemeName = schemeQualidMap Map.! typeName - binders = genericArgDecls Coq.Explicit - ++ tvarBinders - ++ [propBinder] - goal = Coq.forall [valBinder] - (Coq.app (Coq.Qualid propQualid) [Coq.Qualid valIdent]) - term = Coq.forall binders (foldr Coq.Arrow goal indCases) - -- Generate proof. - vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ [propQualid] ++ indCaseQualids) - fixpoint = fromJust $ Coq.unpackQualid fixpointQualid - var = fromJust $ Coq.unpackQualid varQualid - proof = Coq.ProofDefined - (Text.pack - $ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" - ++ " fix " ++ fixpoint ++ " 1; intro " ++ var ++ ";\n" - ++ " " ++ Text.unpack Coq.Base.proveInd - ++ ".") - return (schemeName, [], term, proof) + generateSchemeLemma + :: LookupMap Coq.Qualid + -> LookupMap Coq.Qualid + -> IR.TypeDecl + -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateSchemeLemma _ _ (IR.TypeSynDecl _ _ _ _) + = error "generateInductionLemma: Type synonym not allowed" + generateSchemeLemma schemeQualidMap forQualidMap + (IR.DataDecl _ (IR.DeclIdent srcSpan typeName) typeVarDecls conDecls) + = localEnv $ do + -- Collect and generate relevant Coq names. + typeQualid <- lookupIdentOrFail srcSpan IR.TypeScope typeName + (tvarQualids, tvarBinders) + <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (propQualid, propBinder) <- generateArg "P" + (Coq.Arrow (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + (Coq.Sort Coq.Prop)) + -- Generate induction cases for constructors. + indCases <- mapM (generateInductionCase propQualid) conDecls + -- Generate lemma. + (valIdent, valBinder) <- generateArg freshArgPrefix + (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + (indCaseQualids, fixpointQualid, varQualid) <- localEnv $ do + indCaseQualids <- mapM (const $ freshCoqQualid "InductionCase") indCases + fixpointQualid <- freshCoqQualid "FP" + varQualid <- freshCoqQualid "x" + return (indCaseQualids, fixpointQualid, varQualid) + let schemeName = schemeQualidMap Map.! typeName + binders + = genericArgDecls Coq.Explicit ++ tvarBinders ++ [propBinder] + goal = Coq.forall [valBinder] + (Coq.app (Coq.Qualid propQualid) [Coq.Qualid valIdent]) + term = Coq.forall binders (foldr Coq.Arrow goal indCases) + -- Generate proof. + vars = map (fromJust . Coq.unpackQualid) + (Coq.Base.shape + : Coq.Base.pos + : tvarQualids ++ [propQualid] ++ indCaseQualids) + fixpoint = fromJust $ Coq.unpackQualid fixpointQualid + var = fromJust $ Coq.unpackQualid varQualid + proof = Coq.ProofDefined + (Text.pack + $ " intros " + ++ unwords vars + ++ ";\n" + ++ " fix " + ++ fixpoint + ++ " 1; intro " + ++ var + ++ ";\n" + ++ " " + ++ Text.unpack Coq.Base.proveInd + ++ ".") + return (schemeName, [], term, proof) where -- | Generates an induction case for a given property and constructor. - generateInductionCase - :: Coq.Qualid -> IR.ConDecl -> Converter Coq.Term - generateInductionCase propQualid (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) argTypes) = localEnv $ do - -- Collect and generate relevant Coq names. - conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName - (argQualids, argBinders) <- mapAndUnzipM convertAnonymousArg (map Just argTypes) - -- Expand type synonyms in the argument types and create induction hypotheses. - argTypes' <- mapM expandAllTypeSynonyms argTypes - Just conType <- inEnv $ lookupReturnType IR.ValueScope conName - conType' <- convertType' conType - hypotheses <- catMaybes <$> mapM (uncurry $ generateInductionHypothesis propQualid conType') (zip argQualids argTypes') - -- Generate induction case. - let term = foldr Coq.Arrow (Coq.app (Coq.Qualid propQualid) [Coq.app (Coq.Qualid conQualid) (map Coq.Qualid argQualids)]) hypotheses - indCase = Coq.forall argBinders term - return indCase + generateInductionCase :: Coq.Qualid -> IR.ConDecl -> Converter Coq.Term + generateInductionCase propQualid + (IR.ConDecl _ (IR.DeclIdent srcSpan' conName) argTypes) = localEnv $ do + -- Collect and generate relevant Coq names. + conQualid <- lookupIdentOrFail srcSpan' IR.ValueScope conName + (argQualids, argBinders) <- mapAndUnzipM convertAnonymousArg + (map Just argTypes) + -- Expand type synonyms in the argument types and create induction hypotheses. + argTypes' <- mapM expandAllTypeSynonyms argTypes + Just conType <- inEnv $ lookupReturnType IR.ValueScope conName + conType' <- convertType' conType + hypotheses <- catMaybes + <$> zipWithM (generateInductionHypothesis propQualid conType') + argQualids argTypes' + -- Generate induction case. + let term = foldr Coq.Arrow + (Coq.app (Coq.Qualid propQualid) + [Coq.app (Coq.Qualid conQualid) (map Coq.Qualid argQualids)]) + hypotheses + indCase = Coq.forall argBinders term + return indCase -- | Generates an induction hypothesis for a given property and constructor argument. - generateInductionHypothesis :: Coq.Qualid -> Coq.Term -> Coq.Qualid -> IR.Type -> Converter (Maybe Coq.Term) + generateInductionHypothesis + :: Coq.Qualid + -> Coq.Term + -> Coq.Qualid + -> IR.Type + -> Converter (Maybe Coq.Term) generateInductionHypothesis propQualid conType argQualid argType = do -- Generate induction hypotheses with a maximal depth of @maxDepth@. mbHypothesis <- generateInductionHypothesis_1 maxDepth argType -- Wrap generated hypothesis in a @ForFree@ property and apply it to the argument. argType' <- convertType' argType case mbHypothesis of - Just hypothesis -> return $ Just $ genericApply Coq.Base.forFree [] [] [argType', hypothesis, Coq.Qualid argQualid] - Nothing -> return Nothing + Just hypothesis -> return + $ Just + $ genericApply Coq.Base.forFree [] [] + [argType', hypothesis, Coq.Qualid argQualid] + Nothing -> return Nothing where -- | Generates an induction hypothesis by searching in the given type for recursive occurrences. -- Has an argument limiting the search depth. - generateInductionHypothesis_1 :: Int -> IR.Type -> Converter (Maybe Coq.Term) - generateInductionHypothesis_1 _ (IR.FuncType _ _ _) = + generateInductionHypothesis_1 + :: Int -> IR.Type -> Converter (Maybe Coq.Term) + generateInductionHypothesis_1 _ (IR.FuncType _ _ _) = -- Ignore functions. return Nothing generateInductionHypothesis_1 md t@(IR.TypeApp _ tcon lastArg) = do -- Check whether we found a recursive occurrence. t' <- convertType' t if conType == t' - then - return $ Just $ Coq.Qualid propQualid - else + then return $ Just $ Coq.Qualid propQualid + else -- If we do not have an recursive occurrence and did not reach the -- search limit yet, unfold type application. - if md > 0 then generateInductionHypothesis_2 (md-1) tcon [lastArg] else return Nothing - generateInductionHypothesis_1 _ t@(IR.TypeCon _ _) = do + if md > 0 + then generateInductionHypothesis_2 (md - 1) tcon [lastArg] + else return Nothing + generateInductionHypothesis_1 _ t@(IR.TypeCon _ _) = do -- Check whether we found a recursive occurrence. t' <- convertType' t if conType == t' then return $ Just $ Coq.Qualid propQualid - else + else -- Ignore type constructors that do not have any type variable or are partially applied. return Nothing - generateInductionHypothesis_1 _ (IR.TypeVar _ _) = + generateInductionHypothesis_1 _ (IR.TypeVar _ _) = -- There is no induction hypothesis for type variables. return Nothing -- Unfolds a type application. - generateInductionHypothesis_2 :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) - generateInductionHypothesis_2 _ (IR.FuncType _ _ _) _ = + generateInductionHypothesis_2 + :: Int -> IR.Type -> [IR.Type] -> Converter (Maybe Coq.Term) + generateInductionHypothesis_2 _ (IR.FuncType _ _ _) _ = -- Ignore functions. return Nothing generateInductionHypothesis_2 md (IR.TypeApp _ tcon lastArg) typeArgs = -- Continue unfolding. generateInductionHypothesis_2 md tcon (lastArg : typeArgs) - generateInductionHypothesis_2 md (IR.TypeCon _ tconName) typeArgs = do + generateInductionHypothesis_2 md (IR.TypeCon _ tconName) typeArgs = do -- Recursively generate hypotheses for type arguments. hypotheses <- mapM (generateInductionHypothesis_1 md) typeArgs -- Only consider fully applied type constructors and only generate a -- complex hypothesis, if any of the hypotheses for the arguments is -- non trivial. Just tconArity <- inEnv $ lookupArity IR.TypeScope tconName - if (tconArity == length typeArgs) && (not $ null $ catMaybes hypotheses) + if (tconArity == length typeArgs) && not (null $ catMaybes hypotheses) then do - let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) hypotheses + let hypotheses' = map (fromMaybe (Coq.Qualid Coq.Base.noProperty)) + hypotheses coqArgs <- mapM convertType' typeArgs mbForType <- getForType forQualidMap tconName -- Wrap generated hypotheses in a 'For-' property. - return ((\forType -> genericApply forType [] [] (coqArgs ++ hypotheses')) <$> mbForType) + return ((\forType -> genericApply forType [] [] + (coqArgs ++ hypotheses')) <$> mbForType) else return Nothing - generateInductionHypothesis_2 _ (IR.TypeVar _ _) _ = + generateInductionHypothesis_2 _ (IR.TypeVar _ _) _ = -- Ignore type variables that are used as type constructors. return Nothing ----------------------------------------------------------------------------- -- Forall Lemmas -- ----------------------------------------------------------------------------- - -- | Generates a lemma which states the relation between the 'For-' property -- and the 'In-' properties for a data declaration with type variables. - generateForallLemma :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> - LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> - [Coq.Qualid] -> IR.TypeDecl -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) - generateForallLemma _ _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateForallLemma: Type synonym not allowed" - generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap inConNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) = localEnv $ do - Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName - (tvarQualids, tvarBinders) <- convertTypeVarDecls' Coq.Explicit typeVarDecls - (propQualids, propBinders) <- mapAndUnzipM (\tv -> generateArg "P" (Coq.Arrow (Coq.Qualid tv) (Coq.Sort Coq.Prop))) tvarQualids - (valQualid, valBinder) <- generateArg freshArgPrefix - (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) - inTerms <- mapM (uncurry $ generateInTerm valQualid tvarQualids) $ zip [0 ..] propQualids - let forallQualid = forallQualidMap Map.! typeName - forQualid = forQualidMap Map.! typeName - binders = genericArgDecls Coq.Explicit ++ tvarBinders ++ propBinders ++ [valBinder] - lhs = genericApply forQualid [] [] (map Coq.Qualid $ tvarQualids ++ propQualids ++ [valQualid]) - rhs = let (inQualids', [lastIn]) = splitAt (length inTerms - 1) $ inTerms - in foldr Coq.conj lastIn inQualids' - term = Coq.forall binders (Coq.equiv lhs rhs) - vars = map (fromJust . Coq.unpackQualid) (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ propQualids) - Just schemeName = Coq.unpackQualid $ schemeQualidMap Map.! typeName - proof = Coq.ProofDefined - (Text.pack - $ concatMap generateForallHint inConNames - ++ " intros" ++ concatMap (\v -> ' ' : v) vars ++ ";\n" - ++ " " ++ Text.unpack Coq.Base.proveForall ++ ' ': schemeName - ++ ".") - return (forallQualid, [], term, proof) + generateForallLemma + :: LookupMap Coq.Qualid + -> LookupMap Coq.Qualid + -> LookupMap Coq.Qualid + -> LookupMap [Coq.Qualid] + -> [Coq.Qualid] + -> IR.TypeDecl + -> Converter (Coq.Qualid, [Coq.Binder], Coq.Term, Coq.Proof) + generateForallLemma _ _ _ _ _ (IR.TypeSynDecl _ _ _ _) + = error "generateForallLemma: Type synonym not allowed" + generateForallLemma schemeQualidMap forallQualidMap forQualidMap inQualidMap + inConNames (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls _) + = localEnv $ do + Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeName + (tvarQualids, tvarBinders) + <- convertTypeVarDecls' Coq.Explicit typeVarDecls + (propQualids, propBinders) <- mapAndUnzipM + (\tv -> generateArg "P" (Coq.Arrow (Coq.Qualid tv) (Coq.Sort Coq.Prop))) + tvarQualids + (valQualid, valBinder) <- generateArg freshArgPrefix + (genericApply typeQualid [] [] (map Coq.Qualid tvarQualids)) + inTerms <- zipWithM (generateInTerm valQualid tvarQualids) [0 ..] + propQualids + let forallQualid = forallQualidMap Map.! typeName + forQualid = forQualidMap Map.! typeName + binders = genericArgDecls Coq.Explicit + ++ tvarBinders + ++ propBinders + ++ [valBinder] + lhs = genericApply forQualid [] [] + (map Coq.Qualid $ tvarQualids ++ propQualids ++ [valQualid]) + rhs = let (inQualids', [lastIn]) + = splitAt (length inTerms - 1) $ inTerms + in foldr Coq.conj lastIn inQualids' + term = Coq.forall binders (Coq.equiv lhs rhs) + vars = map (fromJust . Coq.unpackQualid) + (Coq.Base.shape : Coq.Base.pos : tvarQualids ++ propQualids) + Just schemeName = Coq.unpackQualid $ schemeQualidMap Map.! typeName + proof = Coq.ProofDefined + (Text.pack + $ concatMap generateForallHint inConNames + ++ " intros " + ++ unwords vars + ++ ";\n" + ++ " " + ++ Text.unpack Coq.Base.proveForall + ++ ' ' : schemeName ++ ".") + return (forallQualid, [], term, proof) where -- | Generates a term stating that for all elements @y@ of type @a_index@ -- that are contained in @valQualid@, the property @propQualid y@ holds. - generateInTerm :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term + generateInTerm + :: Coq.Qualid -> [Coq.Qualid] -> Int -> Coq.Qualid -> Converter Coq.Term generateInTerm valQualid tvarQualids index propQualid = localEnv $ do let inQualid = (inQualidMap Map.! typeName) !! index - (val2Qualid, val2Binder) <- generateArg "y" (Coq.Qualid $ tvarQualids !! index) - let isIn = genericApply inQualid [] [] (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) - return $ Coq.forall [val2Binder] $ Coq.Arrow isIn (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) + (val2Qualid, val2Binder) <- generateArg "y" + (Coq.Qualid $ tvarQualids !! index) + let isIn = genericApply inQualid [] [] + (map Coq.Qualid $ tvarQualids ++ [val2Qualid, valQualid]) + return + $ Coq.forall [val2Binder] + $ Coq.Arrow isIn + (Coq.app (Coq.Qualid propQualid) [Coq.Qualid val2Qualid]) -- | Generate a local hint which is used in the proof of this 'forall' lemma. generateForallHint :: Coq.Qualid -> String - generateForallHint inCon = - let Just inStr = Coq.unpackQualid inCon - in " Local Hint Extern 1 => " ++ Text.unpack Coq.Base.proveForall_finish ++ - ' ':inStr ++ " : " ++ Text.unpack Coq.Base.proveForall_db ++ ".\n" + generateForallHint inCon + = let Just inStr = Coq.unpackQualid inCon + in " Local Hint Extern 1 => " + ++ Text.unpack Coq.Base.proveForallFinish + ++ ' ' + : inStr ++ " : " ++ Text.unpack Coq.Base.proveForallDb ++ ".\n" ----------------------------------------------------------------------------- -- Hints -- ----------------------------------------------------------------------------- -- | Generates hints that are used in the proofs of induction schemes and -- 'forall' sentences. - generateHints :: LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> IR.TypeDecl -> Converter [Coq.Sentence] - generateHints _ _ _ _ (IR.TypeSynDecl _ _ _ _) = error "generateHint: Type synonym not allowed" - generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls tconDecls) = do - let forall = forallQualidMap Map.! typeName - forType = forQualidMap Map.! typeName - inTypes = inQualidMap Map.! typeName - scheme = schemeQualidMap Map.! typeName - proveIndHint <- generateProveIndHint typeName forType forall scheme (length typeVarDecls) tconDecls - proveForallHint1 <- generateProveForallHint1 forType forall (length typeVarDecls) - proveForallHints2 <- mapM (generateProveForallHint2 forType forall (length typeVarDecls)) inTypes - return $ [proveIndHint, proveForallHint1] ++ proveForallHints2 - + generateHints :: LookupMap Coq.Qualid + -> LookupMap Coq.Qualid + -> LookupMap Coq.Qualid + -> LookupMap [Coq.Qualid] + -> IR.TypeDecl + -> Converter [Coq.Sentence] + generateHints _ _ _ _ (IR.TypeSynDecl _ _ _ _) + = error "generateHint: Type synonym not allowed" + generateHints schemeQualidMap forallQualidMap forQualidMap inQualidMap + (IR.DataDecl _ (IR.DeclIdent _ typeName) typeVarDecls tconDecls) = do + let forall = forallQualidMap Map.! typeName + forType = forQualidMap Map.! typeName + inTypes = inQualidMap Map.! typeName + scheme = schemeQualidMap Map.! typeName + proveIndHint <- generateProveIndHint typeName forType forall scheme + (length typeVarDecls) tconDecls + proveForallHint1 <- generateProveForallHint1 forType forall + (length typeVarDecls) + proveForallHints2 <- mapM + (generateProveForallHint2 forType forall (length typeVarDecls)) inTypes + return $ [proveIndHint, proveForallHint1] ++ proveForallHints2 + -- | Generates a hint for induction scheme generation, using the template - -- @Coq.Base.proveInd_proveForType@. - generateProveIndHint :: IR.QName -> Coq.Qualid -> Coq.Qualid -> Coq.Qualid -> Int -> [IR.ConDecl] -> Converter (Coq.Sentence) + -- @Coq.Base.proveIndProveForType@. + generateProveIndHint + :: IR.QName + -> Coq.Qualid + -> Coq.Qualid + -> Coq.Qualid + -> Int + -> [IR.ConDecl] + -> Converter Coq.Sentence generateProveIndHint typeName forType forall scheme nTvars conDecls = do valStr <- localEnv $ freshCoqIdent freshArgPrefix - dTypes <- concatMapM getDTypes conDecls + dTypes <- concatMapM getDTypes conDecls unfoldSubProps <- nub <$> concatMapM unfoldSubProp dTypes - let tacticConStr = Text.unpack Coq.Base.proveInd_proveForType + let tacticConStr = Text.unpack Coq.Base.proveIndProveForType Just forallStr = Coq.unpackQualid forall Just schemeStr = Coq.unpackQualid scheme underscores = replicate (2 + 2 * nTvars) Coq.UnderscorePat - valPattern = Coq.QualidPat $ Coq.bare $ '?':valStr + valPattern = Coq.QualidPat $ Coq.bare $ '?' : valStr forTypePattern = Coq.ArgsPat forType $ underscores ++ [valPattern] tactic = unwords [tacticConStr, valStr, forallStr, schemeStr] - ++ (if null unfoldSubProps then "" else (";\nrepeat (\n" - ++ tacticUnlines unfoldSubProps - ++ ")")) - return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveInd_db] + ++ (if null unfoldSubProps + then "" + else ";\nrepeat (\n" ++ tacticUnlines unfoldSubProps ++ ")") + return + $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic + [Coq.Base.proveIndDb] where -- | Tries to simplify a pair of 'For-' and 'In-' hypotheses. unfoldSubProp :: IR.QName -> Converter [String] unfoldSubProp dname = do -- Filter complex data types. - mbInTs <- inEnv $ lookupInProperties dname + mbInTs <- inEnv $ lookupInProperties dname case mbInTs of - Nothing -> return [] + Nothing -> return [] Just inTs -> mapM (unfoldSubProp' dname) inTs -- | Tries to simplify a pair of 'For-' and 'In-' hypotheses. unfoldSubProp' :: IR.QName -> Coq.Qualid -> Converter String unfoldSubProp' dName inT = localEnv $ do - hForStr <- freshCoqIdent "HF" - hInStr <- freshCoqIdent "HI" - valStr1 <- freshCoqIdent freshArgPrefix - valStr2 <- freshCoqIdent freshArgPrefix - Just forT <- inEnv $ lookupForProperty dName + hForStr <- freshCoqIdent "HF" + hInStr <- freshCoqIdent "HI" + valStr1 <- freshCoqIdent freshArgPrefix + valStr2 <- freshCoqIdent freshArgPrefix + Just forT <- inEnv $ lookupForProperty dName Just forallT <- inEnv $ lookupForallLemma dName - Just dArity <- inEnv $ lookupArity IR.TypeScope dName + Just dArity <- inEnv $ lookupArity IR.TypeScope dName let forStr = unpackQualid' forT inStr = unpackQualid' inT forallStr = unpackQualid' forallT - forPatStrs = forStr : (replicate (2 + 2 * dArity) "_") ++ ['?':valStr2] - inPatStrs = inStr : (replicate (2 + dArity) "_") ++ ['?':valStr1, '?':valStr2] - tactic = unlines' + forPatStrs = forStr + : replicate (2 + 2 * dArity) "_" ++ ['?' : valStr2] + inPatStrs = inStr + : replicate (2 + dArity) "_" ++ ['?' : valStr1, '?' : valStr2] + tactic = unlines' [ " try match goal with" , " | [ " ++ hForStr ++ " : " ++ unwords forPatStrs , " , " ++ hInStr ++ " : " ++ unwords inPatStrs , " |- _ ] =>" - , " " ++ unwords [Text.unpack Coq.Base.proveInd_ForType_InType, hForStr, hInStr, valStr1, forallStr] + , " " + ++ unwords [ Text.unpack Coq.Base.proveIndForTypeInType + , hForStr + , hInStr + , valStr1 + , forallStr + ] , " end" ] return tactic -- | Like @unpackQualid@ but does also return a string for qualified names. unpackQualid' :: Coq.Qualid -> String - unpackQualid' (Coq.Bare n) = Text.unpack n + unpackQualid' (Coq.Bare n) = Text.unpack n unpackQualid' (Coq.Qualified p n) = Text.unpack p ++ "." ++ Text.unpack n -- | Like @unlines@, but does not put a line break after the last string. @@ -600,52 +782,64 @@ generateInductionSchemes dataDecls = do -- | Collects all types that occur in the given type. getDTypes' :: IR.Type -> Converter [IR.QName] - getDTypes' (IR.TypeApp _ t1 t2) = do + getDTypes' (IR.TypeApp _ t1 t2) = do ts1 <- getDTypes' t1 ts2 <- getDTypes' t2 return (ts1 ++ ts2) getDTypes' (IR.TypeCon _ tconName) | showPretty tconName == showPretty typeName = return [] | otherwise = return [tconName] - getDTypes' (IR.TypeVar _ _) = return [] - getDTypes' (IR.FuncType _ _ _) = return [] + getDTypes' (IR.TypeVar _ _) = return [] + getDTypes' (IR.FuncType _ _ _) = return [] - generateProveForallHint1 :: Coq.Qualid -> Coq.Qualid -> Int -> Converter (Coq.Sentence) + -- | Generates a hint for forall lemma generation, using the template + -- @Coq.Base.proveForallProveForType@. + generateProveForallHint1 + :: Coq.Qualid -> Coq.Qualid -> Int -> Converter Coq.Sentence generateProveForallHint1 forType forall nTvars = do - let tacticConStr = Text.unpack Coq.Base.proveForall_proveForType + let tacticConStr = Text.unpack Coq.Base.proveForallProveForType Just forallStr = Coq.unpackQualid forall tactic = tacticConStr ++ ' ' : forallStr underscores = replicate (3 + 2 * nTvars) Coq.UnderscorePat forTypePattern = Coq.ArgsPat forType $ underscores - return $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic [Coq.Base.proveForall_db] - - generateProveForallHint2 :: Coq.Qualid -> Coq.Qualid -> Int -> Coq.Qualid -> Converter (Coq.Sentence) + return + $ Coq.externHint (Just Coq.Global) 0 (Just forTypePattern) tactic + [Coq.Base.proveForallDb] + + -- | Generates a hint for forall lemma generation, using the template + -- @Coq.Base.proveForallForTypeInType@. + generateProveForallHint2 + :: Coq.Qualid -> Coq.Qualid -> Int -> Coq.Qualid -> Converter Coq.Sentence generateProveForallHint2 forType forall nTvars inType = localEnv $ do hForStr <- freshCoqIdent "HF" - hInStr <- freshCoqIdent "HI" + hInStr <- freshCoqIdent "HI" valStr1 <- freshCoqIdent freshArgPrefix valStr2 <- freshCoqIdent freshArgPrefix - let tacticConStr = Text.unpack Coq.Base.proveForall_ForType_InType - Just forStr = Coq.unpackQualid forType - Just inStr = Coq.unpackQualid inType - Just forallStr = Coq.unpackQualid forall - forPatStrs = forStr : (replicate (2 + 2 * nTvars) "_") ++ ['?':valStr2] - inPatStrs = inStr : (replicate (2 + nTvars) "_") ++ ['?':valStr1, '?':valStr2] - tactic = unlines + let tacticConStr = Text.unpack Coq.Base.proveForallForTypeInType + Just forStr = Coq.unpackQualid forType + Just inStr = Coq.unpackQualid inType + Just forallStr = Coq.unpackQualid forall + forPatStrs = forStr + : replicate (2 + 2 * nTvars) "_" ++ ['?' : valStr2] + inPatStrs = inStr + : replicate (2 + nTvars) "_" ++ ['?' : valStr1, '?' : valStr2] + tactic = unlines [ "" , " match goal with" , " | [ " ++ hForStr ++ " : " ++ unwords forPatStrs , " , " ++ hInStr ++ " : " ++ unwords inPatStrs , " |- _ ] =>" - , " " ++ unwords [tacticConStr, hForStr, hInStr, valStr1, forallStr] + , " " + ++ unwords [tacticConStr, hForStr, hInStr, valStr1, forallStr] , " end" ] - return $ Coq.externHint (Just Coq.Global) 0 Nothing tactic [Coq.Base.proveForall_db] + return + $ Coq.externHint (Just Coq.Global) 0 Nothing tactic + [Coq.Base.proveForallDb] ----------------------------------------------------------------------------- -- Helper Functions -- ----------------------------------------------------------------------------- - -- | The maximal depth to search for recursive occurrences when construction -- induction hypotheses. -- @0@ -> Create only induction hypotheses for direct recursion. @@ -655,38 +849,54 @@ generateInductionSchemes dataDecls = do maxDepth :: Int maxDepth = 1 + -- | Checks whether the type eclaration includes at least one type variable. hasTypeVar :: IR.TypeDecl -> Bool - hasTypeVar (IR.TypeSynDecl _ _ _ _) = error "hasTypeVar: Type synonym not allowed" + hasTypeVar (IR.TypeSynDecl _ _ _ _) + = error "hasTypeVar: Type synonym not allowed" hasTypeVar (IR.DataDecl _ _ typeVarDecls _) = not $ null typeVarDecls - generateName :: String -> String -> IR.QName -> Converter (IR.QName, Coq.Qualid) + -- | Generate a name from a name by adding a prefix and a suffix. + generateName + :: String -> String -> IR.QName -> Converter (IR.QName, Coq.Qualid) generateName prefix suffix typeQName = do Just typeQualid <- inEnv $ lookupIdent IR.TypeScope typeQName let Just typeIdent = Coq.unpackQualid typeQualid newQualid <- freshCoqQualid $ prefix ++ typeIdent ++ suffix return (typeQName, newQualid) + -- | Generate a name from a name by adding the constructor name to it. generateConName :: Coq.Qualid -> IR.QName -> Converter Coq.Qualid generateConName baseQualid conQName = do Just conQualid <- inEnv $ lookupIdent IR.ValueScope conQName let Just baseName = Coq.unpackQualid baseQualid - Just conName = Coq.unpackQualid conQualid + Just conName = Coq.unpackQualid conQualid freshCoqQualid $ baseName ++ "_" ++ conName - getForType :: LookupMap Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) + -- | Returns the name corresponding 'For-' property by using the given Map + -- first and the environment on failure. + getForType + :: LookupMap Coq.Qualid -> IR.QName -> Converter (Maybe Coq.Qualid) getForType forQualidMap name = case forQualidMap Map.!? name of Just qualid -> return $ Just qualid Nothing -> inEnv $ lookupForProperty name - insertPropertiesInEnv :: LookupMap Coq.Qualid -> LookupMap [Coq.Qualid] -> LookupMap Coq.Qualid -> IR.QName -> Converter () + -- | Insert the property names and the forall lemma for a type in the + -- environment. + insertPropertiesInEnv :: LookupMap Coq.Qualid + -> LookupMap [Coq.Qualid] + -> LookupMap Coq.Qualid + -> IR.QName + -> Converter () insertPropertiesInEnv forQualidMap inQualidMap forallQualidMap name = do let forName = forQualidMap Map.!? name inNames = inQualidMap Map.!? name forallName = forallQualidMap Map.!? name modifyEnv $ addPropertyNamesToEntry name forName inNames forallName + -- | Generates an argument with the given name and type. generateArg :: String -> Coq.Term -> Converter (Coq.Qualid, Coq.Binder) generateArg argName argType = do qualid <- freshCoqQualid argName - let binder = Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [qualid] argType + let binder + = Coq.typedBinder Coq.Ungeneralizable Coq.Explicit [qualid] argType return (qualid, binder) diff --git a/src/lib/FreeC/Backend/Coq/Syntax.hs b/src/lib/FreeC/Backend/Coq/Syntax.hs index d07bcf8c..dc774d91 100644 --- a/src/lib/FreeC/Backend/Coq/Syntax.hs +++ b/src/lib/FreeC/Backend/Coq/Syntax.hs @@ -278,13 +278,13 @@ forall bs t = Forall (NonEmpty.fromList bs) t ------------------------------------------------------------------------------- -- | Smart constructor for a sentence which sets an option or flag. setOption :: Maybe Locality -> String -> Maybe (Either Num String) -> Sentence -setOption mbLoc opt mbArg = - OptionSentence $ SetOption mbLoc (Text.pack opt) mbArg' +setOption mbLoc opt mbArg = OptionSentence + $ SetOption mbLoc (Text.pack opt) mbArg' where - mbArg' = case mbArg of - Nothing -> Nothing - (Just (Left num)) -> Just (OVNum num) - (Just (Right str)) -> Just (OVText (Text.pack str)) + mbArg' = case mbArg of + Nothing -> Nothing + (Just (Left num)) -> Just (OVNum num) + (Just (Right str)) -> Just (OVText (Text.pack str)) -- | Smart constructor for a sentence which unsets an option or flag. unsetOption :: Maybe Locality -> String -> Sentence @@ -294,9 +294,10 @@ unsetOption mbLoc opt = OptionSentence $ UnsetOption mbLoc (Text.pack opt) -- Hints -- ------------------------------------------------------------------------------- -- | Smart constructor for an extern hint. -externHint :: Maybe Locality -> Num -> Maybe Pattern -> String -> [Ident] -> Sentence -externHint mbLoc num mbPat tactic dbs = - HintSentence $ Hint mbLoc (HintExtern num mbPat $ Text.pack tactic) dbs +externHint + :: Maybe Locality -> Num -> Maybe Pattern -> String -> [Ident] -> Sentence +externHint mbLoc num mbPat tactic dbs = HintSentence + $ Hint mbLoc (HintExtern num mbPat $ Text.pack tactic) dbs ------------------------------------------------------------------------------- -- Imports -- diff --git a/src/lib/FreeC/Environment.hs b/src/lib/FreeC/Environment.hs index 38497e33..ff13b9f8 100644 --- a/src/lib/FreeC/Environment.hs +++ b/src/lib/FreeC/Environment.hs @@ -163,12 +163,22 @@ addEffectsToEntry name effects env = case lookupEntry IR.ValueScope name env of -- properties for the data entry with the given name. -- -- If such a data entry does not exist, the environment is not changed. -addPropertyNamesToEntry :: IR.QName -> Maybe Coq.Qualid -> Maybe [Coq.Qualid] -> Maybe Coq.Qualid -> Environment -> Environment -addPropertyNamesToEntry name forIdent inIdents forallIdent env = case lookupEntry IR.TypeScope name env of - Nothing -> env - Just entry -> if isDataEntry entry - then addEntry (entry { entryForPropertyIdent = forIdent, entryInPropertyIdents = inIdents, entryForallIdent = forallIdent }) env - else env +addPropertyNamesToEntry + :: IR.QName + -> Maybe Coq.Qualid + -> Maybe [Coq.Qualid] + -> Maybe Coq.Qualid + -> Environment + -> Environment +addPropertyNamesToEntry name forIdent inIdents forallIdent env + = case lookupEntry IR.TypeScope name env of + Nothing -> env + Just entry -> if isDataEntry entry + then addEntry (entry { entryForPropertyIdent = forIdent + , entryInPropertyIdents = inIdents + , entryForallIdent = forallIdent + }) env + else env ------------------------------------------------------------------------------- -- Looking up Entries from the Environment -- @@ -319,9 +329,9 @@ lookupForProperty :: IR.QName -> Environment -> Maybe Coq.Qualid lookupForProperty = concatMaybe . fmap entryForPropertyIdent . find isDataEntry .: lookupEntry IR.TypeScope where - concatMaybe :: Maybe (Maybe a) -> Maybe a - concatMaybe (Just mb) = mb - concatMaybe Nothing = Nothing + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing -- | Looks up the Coq identifiers for the 'In-' properties of the data entry -- with the given name. @@ -329,12 +339,13 @@ lookupForProperty = concatMaybe . fmap entryForPropertyIdent . find isDataEntry -- Returns @Nothing@ if there is no such data entry or if the data entry has -- no 'In-' properties. lookupInProperties :: IR.QName -> Environment -> Maybe [Coq.Qualid] -lookupInProperties = concatMaybe . fmap entryInPropertyIdents . find isDataEntry +lookupInProperties + = concatMaybe . fmap entryInPropertyIdents . find isDataEntry .: lookupEntry IR.TypeScope where - concatMaybe :: Maybe (Maybe a) -> Maybe a - concatMaybe (Just mb) = mb - concatMaybe Nothing = Nothing + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing -- | Looks up the Coq identifier for the 'forall' lemma of the data entry with -- the given name. @@ -345,9 +356,9 @@ lookupForallLemma :: IR.QName -> Environment -> Maybe Coq.Qualid lookupForallLemma = concatMaybe . fmap entryForallIdent . find isDataEntry .: lookupEntry IR.TypeScope where - concatMaybe :: Maybe (Maybe a) -> Maybe a - concatMaybe (Just mb) = mb - concatMaybe Nothing = Nothing + concatMaybe :: Maybe (Maybe a) -> Maybe a + concatMaybe (Just mb) = mb + concatMaybe Nothing = Nothing -- | Looks up the type the type synonym with the given name is associated with. -- diff --git a/src/lib/FreeC/Environment/Entry.hs b/src/lib/FreeC/Environment/Entry.hs index 3bb38be4..c6c9c2d3 100644 --- a/src/lib/FreeC/Environment/Entry.hs +++ b/src/lib/FreeC/Environment/Entry.hs @@ -17,25 +17,24 @@ import FreeC.Util.Predicate data EnvEntry = -- | Entry for a data type declaration. DataEntry - { entrySrcSpan :: SrcSpan + { entrySrcSpan :: SrcSpan -- ^ The source code location where the data type was declared. - , entryArity :: Int + , entryArity :: Int -- ^ The number of type arguments expected by the type constructor. - , entryIdent :: Coq.Qualid + , entryIdent :: Coq.Qualid -- ^ The name of the data type in Coq. - , entryAgdaIdent :: Agda.QName + , entryAgdaIdent :: Agda.QName -- ^ The name of the data type in Agda. - , entryName :: IR.QName + , entryName :: IR.QName -- ^ The name of the data type in the module it has been defined in. - , entryConsNames :: [IR.ConName] + , entryConsNames :: [IR.ConName] -- ^ The names of the constructors of the data type. - , entryForPropertyIdent :: Maybe Coq.Qualid + , entryForPropertyIdent :: Maybe Coq.Qualid -- ^ The name of the 'For-' property in Coq. , entryInPropertyIdents :: Maybe [Coq.Qualid] -- ^ The names of the 'In-' properties in Coq. - , entryForallIdent :: Maybe Coq.Qualid + , entryForallIdent :: Maybe Coq.Qualid -- ^ The names of the 'forall' lemma in Coq. - } -- | Entry for a type synonym declaration. | TypeSynEntry diff --git a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs index 2fe50835..1441b0c9 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Decoder.hs @@ -218,16 +218,17 @@ instance Aeson.FromJSON ModuleInterface where coqForPropertyName <- obj .:? "coq-for-property-name" coqInPropertyNames <- obj .:? "coq-in-property-names" coqForallName <- obj .:? "coq-forall-lemma-name" - return DataEntry { entrySrcSpan = NoSrcSpan - , entryArity = arity - , entryIdent = coqName - , entryAgdaIdent = agdaName - , entryName = haskellName - , entryConsNames = consNames - , entryForPropertyIdent = coqForPropertyName - , entryInPropertyIdents = coqInPropertyNames - , entryForallIdent = coqForallName - } + return DataEntry + { entrySrcSpan = NoSrcSpan + , entryArity = arity + , entryIdent = coqName + , entryAgdaIdent = agdaName + , entryName = haskellName + , entryConsNames = consNames + , entryForPropertyIdent = coqForPropertyName + , entryInPropertyIdents = coqInPropertyNames + , entryForallIdent = coqForallName + } parseConfigTypeSyn :: Aeson.Value -> Aeson.Parser EnvEntry parseConfigTypeSyn = Aeson.withObject "Type synonym" $ \obj -> do diff --git a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs index 01f4a131..a46be8d3 100644 --- a/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs +++ b/src/lib/FreeC/Environment/ModuleInterface/Encoder.hs @@ -17,7 +17,7 @@ module FreeC.Environment.ModuleInterface.Encoder ( writeModuleInterface ) where import Control.Monad.IO.Class ( MonadIO ) import Data.Aeson ( (.=) ) import qualified Data.Aeson as Aeson -import Data.Maybe ( mapMaybe ) +import Data.Maybe ( catMaybes, mapMaybe ) import qualified Data.Set as Set import FreeC.Backend.Agda.Pretty @@ -90,18 +90,17 @@ instance Aeson.ToJSON ModuleInterface where encodeEntry :: EnvEntry -> Maybe Aeson.Value encodeEntry entry | isDataEntry entry = return - $ Aeson.object $ - [ "haskell-name" .= haskellName - , "coq-name" .= coqName - , "agda-name" .= agdaName - , "cons-names" .= consNames - , "arity" .= arity - ] - ++ mapMaybe id - [ ("coq-for-property-name" .=) <$> coqForPropertyName - , ("coq-in-property-names" .=) <$> coqInPropertyNames - , ("coq-forall-lemma-name" .=) <$> coqForallName - ] + $ Aeson.object + $ [ "haskell-name" .= haskellName + , "coq-name" .= coqName + , "agda-name" .= agdaName + , "cons-names" .= consNames + , "arity" .= arity + ] + ++ catMaybes [ ("coq-for-property-name" .=) <$> coqForPropertyName + , ("coq-in-property-names" .=) <$> coqInPropertyNames + , ("coq-forall-lemma-name" .=) <$> coqForallName + ] | isTypeSynEntry entry = return $ Aeson.object [ "haskell-name" .= haskellName @@ -142,11 +141,11 @@ encodeEntry entry coqSmartName = Aeson.toJSON (entrySmartIdent entry) coqForPropertyName, coqInPropertyNames, coqForallName :: Maybe Aeson.Value - coqForPropertyName = Aeson.toJSON <$> (entryForPropertyIdent entry) + coqForPropertyName = Aeson.toJSON <$> entryForPropertyIdent entry - coqInPropertyNames = Aeson.toJSON <$> (entryInPropertyIdents entry) + coqInPropertyNames = Aeson.toJSON <$> entryInPropertyIdents entry - coqForallName = Aeson.toJSON <$> (entryForallIdent entry) + coqForallName = Aeson.toJSON <$> entryForallIdent entry -- @entryAgdaIdent entry@ is undefined because the agda renamer isn't -- implemented at the moment. To allow encoding a dummy value is needed.