├── examples ├── Fsub │ ├── Makefile │ ├── original │ │ ├── metatheory │ │ ├── .depend │ │ ├── custom.css │ │ ├── Makefile │ │ └── Fsub_Lemmas.v │ ├── _CoqProject │ ├── .depend │ └── Fsub.ott ├── Lambda │ ├── Makefile │ ├── _CoqProject │ ├── .depend │ ├── Lambda.ott │ ├── Lambda_ott.v │ └── Lambda_proofs.v ├── LF_hhp93 │ ├── Makefile │ ├── _CoqProject │ ├── .depend │ ├── LF_hhp93.ott │ └── LF_hhp93_ott.v ├── SimpleTypes │ ├── Makefile │ ├── _CoqProject │ ├── .SimpleTypes_ott.aux │ ├── .depend │ ├── SimpleTypes.ott │ ├── SimpleTypes_proofs.v │ ├── SimpleTypes_ott.v │ └── .SimpleTypes_inf.aux ├── issue4 │ ├── Makefile │ └── issue4.ott ├── Makefile ├── custom.css ├── README.txt └── Makefile.example ├── .vscode └── settings.json ├── default.nix ├── .gitignore ├── .github └── workflows │ └── build.yml ├── CHANGELOG.txt ├── src ├── TODO.txt ├── README.md ├── MyLibrary.hs ├── CoqLNOutputThmSwap.hs ├── ASTCheck.hs ├── CoqLNOutput.hs ├── ComputationMonad.hs ├── CoqLNOutputThmOpenClose2.hs ├── CoqLNOutputCombinators.hs ├── CoqLNOutputThmSize.hs ├── Attic │ └── OutputDefinitions.hs ├── Parser.hs ├── AST.hs ├── CoqLNOutputThmOpenClose.hs └── CoqLNOutputCommon.hs ├── LICENSE ├── stack.yaml ├── lngen.cabal ├── app └── Main.hs └── README.md /examples/Fsub/Makefile: -------------------------------------------------------------------------------- 1 | ../Makefile.example -------------------------------------------------------------------------------- /examples/Lambda/Makefile: -------------------------------------------------------------------------------- 1 | ../Makefile.example -------------------------------------------------------------------------------- /examples/LF_hhp93/Makefile: -------------------------------------------------------------------------------- 1 | ../Makefile.example -------------------------------------------------------------------------------- /examples/SimpleTypes/Makefile: -------------------------------------------------------------------------------- 1 | ../Makefile.example -------------------------------------------------------------------------------- /examples/Fsub/original/metatheory: -------------------------------------------------------------------------------- 1 | ../../../metatheory -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "ghcSimple.feature.rangeType": false 3 | } -------------------------------------------------------------------------------- /examples/Fsub/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Fsub 2 | Fsub_inf.v 3 | Fsub_ott.v 4 | Fsub_proofs.v 5 | -------------------------------------------------------------------------------- /examples/LF_hhp93/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . LF_hhp93 2 | LF_hhp93_inf.v 3 | LF_hhp93_ott.v 4 | 5 | -------------------------------------------------------------------------------- /examples/Lambda/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Lambda 2 | Lambda_inf.v 3 | Lambda_ott.v 4 | Lambda_proofs.v 5 | -------------------------------------------------------------------------------- /examples/SimpleTypes/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . SimpleTypes 2 | SimpleTypes_inf.v 3 | SimpleTypes_ott.v 4 | SimpleTypes_proofs.v 5 | -------------------------------------------------------------------------------- /examples/SimpleTypes/.SimpleTypes_ott.aux: -------------------------------------------------------------------------------- 1 | COQAUX1 f8af74f9d7bebc4c253dce810af42be6 /Users/sweirich/github/lngen/examples/SimpleTypes/SimpleTypes_ott.v 2 | 0 0 vo_compile_time "0.319" 3 | -------------------------------------------------------------------------------- /examples/issue4/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ott -coq_lngen true -coq_expand_list_types true -i issue4.ott -o issue4.v 3 | lngen --coq-ott issue4 --coq issue4_inf.v issue4.ott 4 | coqc issue4.v 5 | coqc issue4_inf.v 6 | -------------------------------------------------------------------------------- /examples/Fsub/original/.depend: -------------------------------------------------------------------------------- 1 | Fsub_Definitions.vo: Fsub_Definitions.v metatheory/Metatheory.vo 2 | Fsub_Infrastructure.vo: Fsub_Infrastructure.v Fsub_Definitions.vo 3 | Fsub_Lemmas.vo: Fsub_Lemmas.v Fsub_Infrastructure.vo 4 | Fsub_Soundness.vo: Fsub_Soundness.v Fsub_Lemmas.vo 5 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | ## This makefile re-runs lngen on all example .ott files and then recompiles them with Coq. 2 | 3 | EXAMPLES=Lambda SimpleTypes LF_hhp93 Fsub 4 | 5 | all: 6 | @for i in $(EXAMPLES); do (cd $$i; echo "********* TESTING: $$i *************"; make clean; make rebuild; make); done 7 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let pkgs = import { }; 2 | in 3 | pkgs.haskellPackages.developPackage { 4 | root = ./.; 5 | modifier = drv: 6 | pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages; 7 | [ cabal-install 8 | haskell-language-server 9 | ]); 10 | } -------------------------------------------------------------------------------- /examples/LF_hhp93/.depend: -------------------------------------------------------------------------------- 1 | LF_hhp93_inf.vo LF_hhp93_inf.glob LF_hhp93_inf.v.beautified LF_hhp93_inf.required_vo: LF_hhp93_inf.v LF_hhp93_ott.vo 2 | LF_hhp93_inf.vio: LF_hhp93_inf.v LF_hhp93_ott.vio 3 | LF_hhp93_ott.vo LF_hhp93_ott.glob LF_hhp93_ott.v.beautified LF_hhp93_ott.required_vo: LF_hhp93_ott.v 4 | LF_hhp93_ott.vio: LF_hhp93_ott.v 5 | -------------------------------------------------------------------------------- /examples/Fsub/.depend: -------------------------------------------------------------------------------- 1 | Fsub_inf.vo Fsub_inf.glob Fsub_inf.v.beautified Fsub_inf.required_vo: Fsub_inf.v Fsub_ott.vo 2 | Fsub_inf.vio: Fsub_inf.v Fsub_ott.vio 3 | Fsub_ott.vo Fsub_ott.glob Fsub_ott.v.beautified Fsub_ott.required_vo: Fsub_ott.v 4 | Fsub_ott.vio: Fsub_ott.v 5 | Fsub_proofs.vo Fsub_proofs.glob Fsub_proofs.v.beautified Fsub_proofs.required_vo: Fsub_proofs.v Fsub_inf.vo 6 | Fsub_proofs.vio: Fsub_proofs.v Fsub_inf.vio 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | src/highlight.js 20 | src/style.css 21 | *.glob 22 | *.vo 23 | .coqdeps.d 24 | *.mk.conf 25 | CoqSrc.mk 26 | *~ 27 | stack.yaml.lock 28 | *.lia.cache 29 | *.vok 30 | *.vos 31 | CoqMakefile.conf 32 | .CoqSrc.mk.d 33 | -------------------------------------------------------------------------------- /examples/Lambda/.depend: -------------------------------------------------------------------------------- 1 | Lambda_inf.vo Lambda_inf.glob Lambda_inf.v.beautified Lambda_inf.required_vo: Lambda_inf.v Lambda_ott.vo 2 | Lambda_inf.vio: Lambda_inf.v Lambda_ott.vio 3 | Lambda_ott.vo Lambda_ott.glob Lambda_ott.v.beautified Lambda_ott.required_vo: Lambda_ott.v 4 | Lambda_ott.vio: Lambda_ott.v 5 | Lambda_proofs.vo Lambda_proofs.glob Lambda_proofs.v.beautified Lambda_proofs.required_vo: Lambda_proofs.v Lambda_inf.vo Lambda_ott.vo 6 | Lambda_proofs.vio: Lambda_proofs.v Lambda_inf.vio Lambda_ott.vio 7 | -------------------------------------------------------------------------------- /examples/SimpleTypes/.depend: -------------------------------------------------------------------------------- 1 | SimpleTypes_inf.vo SimpleTypes_inf.glob SimpleTypes_inf.v.beautified SimpleTypes_inf.required_vo: SimpleTypes_inf.v SimpleTypes_ott.vo 2 | SimpleTypes_inf.vio: SimpleTypes_inf.v SimpleTypes_ott.vio 3 | SimpleTypes_ott.vo SimpleTypes_ott.glob SimpleTypes_ott.v.beautified SimpleTypes_ott.required_vo: SimpleTypes_ott.v 4 | SimpleTypes_ott.vio: SimpleTypes_ott.v 5 | SimpleTypes_proofs.vo SimpleTypes_proofs.glob SimpleTypes_proofs.v.beautified SimpleTypes_proofs.required_vo: SimpleTypes_proofs.v SimpleTypes_inf.vo 6 | SimpleTypes_proofs.vio: SimpleTypes_proofs.v SimpleTypes_inf.vio 7 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - '**' 8 | 9 | name: build 10 | 11 | jobs: 12 | build: 13 | runs-on: ubuntu-latest 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | resolver: 18 | - nightly 19 | - lts-22 20 | - lts-21 21 | - lts-20 22 | - lts-19 23 | - lts-18 24 | - lts-17 25 | - lts-16 26 | - lts-15 27 | steps: 28 | - uses: actions/checkout@v4 29 | - uses: haskell-actions/setup@latest 30 | with: 31 | enable-stack: true 32 | stack-no-global: true 33 | - run: stack build --resolver ${{ matrix.resolver }} 34 | -------------------------------------------------------------------------------- /CHANGELOG.txt: -------------------------------------------------------------------------------- 1 | 0.4.1 2 | April 2022 3 | * no longer generates "close" definitions 4 | * requires forked version of ott, available from 5 | https://github.com/sweirich/ott to generate close 6 | * compiles with GHC 9.0.2 7 | * compatible with Metalib-8.15.0 8 | * output compiles with Coq 8.15.0 9 | 10 | 0.3.2 11 | March 2022 12 | * compiles with GHC 8.10.7 13 | * compatible with Metalib-8.15.0 14 | * output compiles with Coq 8.15.0 15 | - #[export] Hints 16 | - remove @ from plus_le_compat 17 | - Combined Scheme 18 | - suppress warning about non-Fixpoint 19 | * issue 4: eauto limit raise 20 | * better treatment of nonterminals with only meta productions 21 | - scheme generation supressed 22 | - size defined to be 1 23 | 24 | 0.3.1 25 | May 2020 26 | compiles with GHC 8.6.5 27 | 28 | 0.3.0 29 | initial release 30 | 31 | -------------------------------------------------------------------------------- /examples/LF_hhp93/LF_hhp93.ott: -------------------------------------------------------------------------------- 1 | % A Framework for Defining Logics. 2 | % Harper, Honsell, and Pfenning, 1993. 3 | 4 | metavar family_constant, a ::= {{ coq atom }} 5 | metavar object_constant, c ::= {{ coq atom }} 6 | metavar var, x, y, z ::= {{ repr-locally-nameless }} 7 | 8 | grammar 9 | 10 | kind, K :: kind_ ::= 11 | | Type :: :: type 12 | | Pi x : A . K :: :: pi (+ bind x in K +) 13 | 14 | family, A, B, C :: family_ ::= 15 | | a :: :: const 16 | | Pi x : A . B :: :: pi (+ bind x in B +) 17 | | \ x : A . B :: :: abs (+ bind x in B +) 18 | | A M :: :: app 19 | 20 | object, M, N :: object_ ::= 21 | | c :: :: const 22 | | x :: :: var 23 | | \ x : A . M :: :: abs (+ bind x in M +) 24 | | M N :: :: app 25 | 26 | substitutions 27 | single M x :: subst 28 | 29 | freevars 30 | M x :: fv 31 | -------------------------------------------------------------------------------- /src/TODO.txt: -------------------------------------------------------------------------------- 1 | - ASTCheck can always do more sanity checks. 2 | * Constructor name collisions. 3 | * SubstFun and FvFun validity. 4 | * More? 5 | 6 | - Lemma names are too long! 7 | * Maybe something like [subst_intro_...] would be better. 8 | * Maybe they should not be so dependent on function and predicate names? 9 | 10 | - Need (or should have) the following combinations of lemmas: 11 | * {open, close, subst} x 12 | * {`in`, `notin`} x 13 | * {conclusion has open/close/subst, premise has open/close/subst}, 14 | a.k.a., {normal, inv} 15 | 16 | - Missing lemmas or ones that need to be moved (probably an incomplete list): 17 | * subst_degree_inv 18 | * subst_fresh_same (inv version, too? should be in the Fv file?) 19 | * subst_fresh (inv version, too? should be in the Fv file?) 20 | * subst_lc (should be in the Lc file?) 21 | - 22 | -------------------------------------------------------------------------------- /examples/Lambda/Lambda.ott: -------------------------------------------------------------------------------- 1 | metavar expvar, x, y, z ::= {{ repr-locally-nameless }} 2 | 3 | grammar 4 | 5 | exp, e, f, g :: '' ::= 6 | | x :: :: var 7 | | e1 e2 :: :: app 8 | | \ x . e :: :: abs (+ bind x in e +) 9 | | ( e ) :: S :: paren {{ coq ([[e]]) }} 10 | | { e2 / x } e1 :: M :: subst {{ coq (open_exp_wrt_exp [[x e1]] [[e2]]) }} 11 | 12 | substitutions 13 | single e x :: subst 14 | 15 | freevars 16 | e x :: fv 17 | 18 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 19 | 20 | grammar 21 | 22 | value, v :: 'value_' ::= 23 | | \ x . e :: :: abs (+ bind x in e +) 24 | 25 | subrules 26 | v <:: e 27 | 28 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 29 | 30 | defns 31 | Jop :: '' ::= 32 | 33 | defn 34 | e1 --> e2 :: :: reduce :: 'red_' by 35 | 36 | --------------------------- :: beta 37 | (\x.e1) e2 --> {e2 / x} e1 38 | 39 | e1 --> e1' 40 | --------------------------- :: app_fun 41 | e1 e2 --> e1' e2 42 | 43 | e2 --> e2' 44 | --------------------------- :: app_arg 45 | v1 e2 --> v1 e2' 46 | -------------------------------------------------------------------------------- /examples/issue4/issue4.ott: -------------------------------------------------------------------------------- 1 | metavar effvar, r ::= {{ repr-locally-nameless }} 2 | metavar expvar, x ::= {{ repr-locally-nameless }} 3 | metavar typvar, X ::= {{ repr-locally-nameless }} 4 | 5 | grammar 6 | 7 | eff, R :: eff_ ::= 8 | | top :: :: top 9 | | r :: :: var 10 | | R1 <+> R2 :: :: dummy 11 | 12 | typ, T, S :: 'typ_' ::= 13 | | base :: :: base 14 | | X :: :: var 15 | | R T :: :: eff 16 | 17 | exp, e, f, g :: 'exp_' ::= 18 | | x :: :: var 19 | | \ x : T . e :: :: abs (+ bind x in e +) 20 | | \ r . e :: :: rabs (+ bind r in e +) 21 | | \ X . e :: :: tabs (+ bind X in e +) 22 | 23 | substitutions 24 | single e x :: subst_ee 25 | 26 | single T X :: subst_tt 27 | single e X :: subst_te 28 | 29 | single R r :: subst_rr 30 | single T r :: subst_rt 31 | single e r :: subst_re 32 | 33 | 34 | freevars 35 | e x :: fv_ee 36 | 37 | T X :: fv_tt 38 | e X :: fv_te 39 | 40 | R r :: fv_rr 41 | T r :: fv_rt 42 | e r :: fv_re 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Brian Aydemir 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | # ghc-8.10.7 5 | resolver: lts-22.38 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /examples/custom.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: #fff; 3 | color: #000; 4 | margin: 0em; 5 | padding: 0em; 6 | } 7 | 8 | a { text-decoration: none; } 9 | h1 { font-size: 200%; font-weight: bolder; } 10 | h2 { font-size: 150%; font-weight: bolder; } 11 | h3 { font-size: 125%; font-weight: bolder; } 12 | 13 | #main{ 14 | padding: 1em; 15 | } 16 | 17 | #main a.idref:visited { background-color: inherit; color: #36f; } 18 | #main a.idref:link { background-color: inherit; color: #36f; } 19 | #main a.idref:hover { } 20 | #main a.idref:active { } 21 | 22 | #main a.modref:visited { background-color: inherit; color: #36f; } 23 | #main a.modref:link { background-color: inherit; color: #36f; } 24 | #main a.modref:hover { } 25 | #main a.modref:active { } 26 | 27 | .doc { 28 | background: rgb(224,224,255); 29 | padding: 1ex; 30 | } 31 | 32 | .code { 33 | display: block; 34 | font-family: monospace; 35 | } 36 | 37 | .inlinecode { 38 | display: inline; 39 | font-family: monospace; 40 | } 41 | 42 | h1.section { 43 | border-bottom: 4px solid black; 44 | } 45 | 46 | #footer { 47 | font-size: 80%; 48 | } 49 | 50 | #footer a:visited { color: #00f; } 51 | #footer a:link { color: #00f; } 52 | #footer a:hover { } 53 | #footer a:active { } 54 | 55 | .id { display: inline; } 56 | .id[type="constructor"] { color: #060; } 57 | .id[type="var"] { color: #606; } 58 | .id[type="definition"] { color: #060; } 59 | .id[type="lemma"] { color: #060; } 60 | .id[type="inductive"] { color: #060; } 61 | .id[type="keyword"] { color: #c00; } 62 | -------------------------------------------------------------------------------- /examples/Fsub/original/custom.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: #fff; 3 | color: #000; 4 | margin: 0em; 5 | padding: 0em; 6 | } 7 | 8 | a { text-decoration: none; } 9 | h1 { font-size: 200%; font-weight: bolder; } 10 | h2 { font-size: 150%; font-weight: bolder; } 11 | h3 { font-size: 125%; font-weight: bolder; } 12 | 13 | #main{ 14 | padding: 1em; 15 | } 16 | 17 | #main a.idref:visited { background-color: inherit; color: #36f; } 18 | #main a.idref:link { background-color: inherit; color: #36f; } 19 | #main a.idref:hover { } 20 | #main a.idref:active { } 21 | 22 | #main a.modref:visited { background-color: inherit; color: #36f; } 23 | #main a.modref:link { background-color: inherit; color: #36f; } 24 | #main a.modref:hover { } 25 | #main a.modref:active { } 26 | 27 | .doc { 28 | background: rgb(224,224,255); 29 | padding: 1ex; 30 | } 31 | 32 | .code { 33 | display: block; 34 | font-family: monospace; 35 | } 36 | 37 | .inlinecode { 38 | display: inline; 39 | font-family: monospace; 40 | } 41 | 42 | h1.section { 43 | border-bottom: 4px solid black; 44 | } 45 | 46 | #footer { 47 | font-size: 80%; 48 | } 49 | 50 | #footer a:visited { color: #00f; } 51 | #footer a:link { color: #00f; } 52 | #footer a:hover { } 53 | #footer a:active { } 54 | 55 | .id { display: inline; } 56 | .id[type="constructor"] { color: #060; } 57 | .id[type="var"] { color: #606; } 58 | .id[type="definition"] { color: #060; } 59 | .id[type="lemma"] { color: #060; } 60 | .id[type="inductive"] { color: #060; } 61 | .id[type="keyword"] { color: #c00; } 62 | -------------------------------------------------------------------------------- /src/README.md: -------------------------------------------------------------------------------- 1 | Caveats 2 | ======= 3 | 4 | I try to keep the following information up to date, but sometimes I fall 5 | a little behind in keeping track of all the modifications and design 6 | decisions that I make while developing LNgen. 7 | 8 | 9 | General implementation notes 10 | ============================ 11 | 12 | - I use the Monad Transformer Library for handling state and errors. 13 | - There is one type for errors in the entire program. 14 | - I usually keep type signatures as polymorphic as possible, even if 15 | this requires using a language extension, e.g., FlexibleContexts. 16 | 17 | 18 | "Non-portable" libraries used 19 | ============================= 20 | 21 | - Control.Monad.State 22 | - Control.Monad.Error 23 | - Data.Generics 24 | 25 | 26 | Language extensions used 27 | ======================== 28 | 29 | - DeriveDataTypeable 30 | - FlexibleContexts 31 | 32 | 33 | Dataflow through various files 34 | ============================== 35 | 36 | The `Main` module ties everything together. The `AST` and 37 | `ComputationMonad` modules more or less cut across everything. 38 | 39 | Parser ( parseOttFile ) 40 | | 41 | | PreAST 42 | | 43 | v AST 44 | ASTCheck ( astOfPreAST ) ---------> ASTAnalysis ( analyzeAST ) 45 | | / 46 | | AST / 47 | | / ASTAnalysis 48 | v / 49 | CoqLNOutput ( coqOfAST ) <---------+ 50 | | 51 | | String 52 | | 53 | v 54 | [final output] 55 | 56 | Dependencies 57 | ============ 58 | - [Parsec](https://hackage.haskell.org/package/parsec) 59 | - [SYB](http://hackage.haskell.org/package/syb) 60 | 61 | You can fulfill the dependencies with `cabal install parsec syb`. 62 | -------------------------------------------------------------------------------- /examples/SimpleTypes/SimpleTypes.ott: -------------------------------------------------------------------------------- 1 | metavar expvar, x, y, z ::= {{ repr-locally-nameless }} 2 | 3 | grammar 4 | 5 | typ, T, S :: '' ::= 6 | | base :: :: base 7 | | T1 -> T2 :: :: arrow 8 | 9 | exp, e, f, g :: '' ::= 10 | | x :: :: var 11 | | \ x : T . e :: :: abs (+ bind x in e +) 12 | | e1 e2 :: :: app 13 | | ( e ) :: S :: paren {{ coq ([[e]]) }} 14 | | { e2 / x } e1 :: M :: subst {{ coq (open_exp_wrt_exp [[x e1]] [[e2]]) }} 15 | 16 | substitutions 17 | single e x :: subst 18 | 19 | freevars 20 | e x :: fv 21 | 22 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 23 | 24 | grammar 25 | 26 | typing_env, G, F, E :: '' ::= {{ coq list (atom*typ) }} 27 | | empty :: :: empty {{ coq nil }} 28 | | G , x : T :: :: cons {{ coq ([[x]]~[[T]] ++ [[G]]) }} 29 | 30 | value, v :: value_ ::= 31 | | \ x : T . e :: :: abs (+ bind x in e +) 32 | 33 | formula :: formula_ ::= 34 | | judgement :: :: judgement 35 | | ( x : T ) in G :: :: binds {{ coq binds ([[x]]) ([[T]]) ([[G]]) }} 36 | | uniq G :: :: uniq {{ coq uniq ([[G]]) }} 37 | 38 | subrules 39 | v <:: e 40 | 41 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 42 | 43 | defns 44 | Jtyping :: '' ::= 45 | 46 | defn 47 | G |- e : T 48 | :: :: typing :: typing_ by 49 | 50 | (x:T) in G 51 | uniq G 52 | ----------- :: var 53 | G |- x : T 54 | 55 | G, x : T1 |- e : T2 56 | ------------------------ :: abs 57 | G |- \x:T1.e : T1 -> T2 58 | 59 | G |- e1 : T1 -> T2 60 | G |- e2 : T1 61 | ------------------- :: app 62 | G |- e1 e2 : T2 63 | 64 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 65 | 66 | defns 67 | Jop :: '' ::= 68 | 69 | defn 70 | e1 --> e2 71 | :: :: step :: step_ by 72 | 73 | e1 --> e1' 74 | ----------------- :: app_1 75 | e1 e2 --> e1' e2 76 | 77 | e2 --> e2' 78 | ----------------- :: app_2 79 | v1 e2 --> v1 e2' 80 | 81 | ----------------------------- :: beta 82 | (\x:T.e1) v2 --> {v2 / x} e1 83 | -------------------------------------------------------------------------------- /lngen.cabal: -------------------------------------------------------------------------------- 1 | name: lngen 2 | version: 0.3.2 3 | synopsis: Tool for generating Locally Nameless definitions and proofs in Coq, working together with Ott. 4 | description: Check out for documentation. 5 | homepage: https://github.com/plclub/lngen 6 | license: MIT 7 | license-file: LICENSE 8 | build-type: Simple 9 | -- extra-source-files: 10 | cabal-version: >=1.10 11 | 12 | library 13 | hs-source-dirs: src 14 | exposed-modules: AST 15 | , ASTAnalysis 16 | , ASTCheck 17 | , ComputationMonad 18 | , CoqLNOutput 19 | , CoqLNOutputCombinators 20 | , CoqLNOutputCommon 21 | , CoqLNOutputDefinitions 22 | , CoqLNOutputThmDegree 23 | , CoqLNOutputThmFv 24 | , CoqLNOutputThmLc 25 | , CoqLNOutputThmOpenClose 26 | , CoqLNOutputThmOpenClose2 27 | , CoqLNOutputThmSize 28 | , CoqLNOutputThmSubst 29 | , CoqLNOutputThmSwap 30 | , MyLibrary 31 | , Parser 32 | build-depends: base >= 4.9.0 33 | , syb 34 | , parsec 35 | , containers 36 | , mtl >= 2.2.1 37 | default-language: Haskell2010 38 | ghc-options: -Wall -fwarn-incomplete-record-updates -Werror 39 | 40 | executable lngen 41 | hs-source-dirs: app 42 | main-is: Main.hs 43 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-incomplete-record-updates 44 | build-depends: base >= 4.9.0 45 | , lngen 46 | default-language: Haskell2010 47 | 48 | source-repository head 49 | type: git 50 | location: https://github.com/plclub/lngen 51 | -------------------------------------------------------------------------------- /examples/Fsub/original/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | # 3 | # Primary targets: 4 | # all - the default target; synonym for 'coq' 5 | # coq - builds all .vo files 6 | # doc - synonym for 'documentation' 7 | # documentation - builds all html documentation 8 | # clean - removes generated files 9 | # 10 | # Other targets (intended to be used by the developers of this library): 11 | # gens - builds generated .v files on demand 12 | # dist - builds a zip file for distribution 13 | # 14 | ############################################################################ 15 | 16 | ## Paths to executables. Do not include options here. 17 | ## Modify these to suit your Coq installation, if necessary. 18 | 19 | COQC = coqc 20 | COQDEP = coqdep 21 | COQDOC = coqdoc 22 | 23 | ## Include directories, one per line. 24 | 25 | INCDIRS = \ 26 | . \ 27 | metatheory \ 28 | 29 | ## Directory where generated HTML documentation should go. 30 | 31 | DOCDIR = html 32 | 33 | ## List of files that should be compiled. 34 | 35 | FILES = \ 36 | Fsub_Definitions \ 37 | Fsub_Infrastructure \ 38 | Fsub_Lemmas \ 39 | Fsub_Soundness \ 40 | 41 | ## Lists calculated from the above. 42 | 43 | VFILES = \ 44 | $(foreach i, $(FILES), $(i).v) \ 45 | 46 | VOFILES = $(VFILES:.v=.vo) 47 | 48 | INCFLAGS = $(foreach i, $(INCDIRS), -I $(i)) 49 | 50 | ############################################################################ 51 | 52 | .PHONY: all clean coq dist doc documentation 53 | .SUFFIXES: .v .vo 54 | 55 | all: coq 56 | 57 | coq: $(VOFILES) 58 | 59 | doc: 60 | +make documentation 61 | 62 | documentation: $(DOCDIR) $(VOFILES) 63 | $(COQDOC) -g --quiet --noindex --html -d $(DOCDIR) $(VFILES) 64 | cp -f custom.css $(DOCDIR)/coqdoc.css 65 | 66 | clean: 67 | rm -f *.vo *.glob *.cmi *.cmx *.o 68 | rm -rf $(DOCDIR) 69 | 70 | ############################################################################ 71 | 72 | %.vo: %.v 73 | $(COQC) -q $(INCFLAGS) $< 74 | 75 | $(DOCDIR): 76 | mkdir -p $(DOCDIR) 77 | 78 | ############################################################################ 79 | 80 | .depend: $(VFILES) 81 | $(COQDEP) $(INCFLAGS) $(VFILES) > .depend 82 | 83 | include .depend 84 | -------------------------------------------------------------------------------- /examples/README.txt: -------------------------------------------------------------------------------- 1 | Overview 2 | ======== 3 | 4 | Each directory contains the Ott language specification and corresponding 5 | Coq development for the following languages: 6 | 7 | * Fsub: System F with subtyping, extended with let-bindings and sum 8 | types. The hand-written proofs prove transitivity of the algorithmic 9 | subtyping relation, progress, and preservation. This constitutes a 10 | solution to parts 1A and 2A of the POPLmark challenge. 11 | 12 | The basis for this example is Subversion revision 3283 of Penn's 13 | metatheory library. 14 | 15 | Substantive changes compared to the original development: 16 | * The output from LNgen has completely replaced the 17 | `Infrastructure` file, while the output from Ott has completely 18 | replaced the `Definitions` file. 19 | * `value_regular` no longer holds, since Ott generates a 20 | completely different definition of the `value` predicate. 21 | 22 | Minor changes compared to the original development: 23 | * The names of a lot of lemmas and functions changed. 24 | * `Coercion`s no longer work as well as they used to. 25 | 26 | * Lambda: Untyped lambda terms. This development includes the Coq 27 | formalizations for the "LNgen: Tool Support for Locally Nameless 28 | Representations" by Aydemir and Weirich (draft). 29 | 30 | * LF_hhp93: LF, as defined in "A Framework for Defining Logics" by 31 | Harper, Honsell, and Plotkin (Journal of the ACM, 1993). 32 | 33 | * SimpleTypes: The simply typed lambda calculus. The hand-written 34 | proofs prove progress and preservation for this language. 35 | 36 | 37 | Naming conventions for files 38 | ============================ 39 | 40 | Unless otherwise noted, files in the directories here are named 41 | according to the following conventions: 42 | 43 | * Ott language specifications end in `.ott`. 44 | * Files generated by Ott end in `_ott.v`. 45 | * Files generated by LNgen end in `_inf.v`. 46 | * Files with hand-written proofs end in `_proofs.v`. 47 | 48 | Examples that include an `original` directory were produced by taking an 49 | existing Coq formalization, writing a corresponding Ott language 50 | specification, running Ott and LNgen on the specification, and then 51 | modifying the existing proofs as needed to use the generated 52 | infrastructure. 53 | -------------------------------------------------------------------------------- /src/MyLibrary.hs: -------------------------------------------------------------------------------- 1 | {- | This module defines a library of assorted functions that I have 2 | not found in (GHC's) standard library. -} 3 | 4 | module MyLibrary where 5 | 6 | import Data.List ( intercalate, nub, minimumBy ) 7 | import Data.Map ( Map ) 8 | import qualified Data.Map as Map 9 | import Data.Maybe ( catMaybes ) 10 | import Text.ParserCombinators.Parsec ( GenParser, manyTill ) 11 | import Control.Monad.Fail as Fail 12 | 13 | 14 | {- ----------------------------------------------------------------------- -} 15 | {- * General purpose parsing combinators -} 16 | 17 | {- | A variant of the 'manyTill' combinator that requires that the 18 | first argument succeed at least once. -} 19 | 20 | manyTill1 :: GenParser tok st t -> 21 | GenParser tok st end -> 22 | GenParser tok st [t] 23 | manyTill1 p end = 24 | do { x <- p 25 | ; xs <- p `manyTill` end 26 | ; return (x:xs) 27 | } 28 | 29 | 30 | {- ----------------------------------------------------------------------- -} 31 | {- * Error handling -} 32 | 33 | {- | Views 'Either' as an error monad and returns the result of the 34 | computation or else calls 'error'. -} 35 | 36 | getResult :: Show a => Either a b -> b 37 | getResult (Right res) = res 38 | getResult (Left err) = error (show err) 39 | 40 | 41 | {- ----------------------------------------------------------------------- -} 42 | {- * Miscellaneous functions -} 43 | 44 | {- | A variant of 'Map.lookup' that either @return@s its result in the 45 | given monad or @fail@s. -} 46 | 47 | mapLookup :: (MonadFail m, Ord k, Show k) => k -> Map k a -> m a 48 | mapLookup k m = case Map.lookup k m of 49 | Just x -> return x 50 | Nothing -> Fail.fail $ "mapLookup: " ++ show k ++ 51 | " not found in: " ++ show (Map.keys m) 52 | 53 | {- | A variant on 'mapM' for when the function returns as a 'Maybe' value. -} 54 | 55 | mapMM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] 56 | mapMM f as = 57 | do { bs <- mapM f as 58 | ; return $ catMaybes bs 59 | } 60 | 61 | {- | Shorthand for @nub . map f@. -} 62 | 63 | nmap :: Eq b => (a -> b) -> [a] -> [b] 64 | nmap f = nub . map f 65 | 66 | {- | Concatenates the result of interspersing the first argument 67 | between the elements of the second argument. -} 68 | 69 | sepStrings :: String -> [String] -> String 70 | sepStrings = intercalate 71 | 72 | {- | Returns the shortest string in the given list. Ties are broken 73 | by choosing the string that appears first in the input. The input 74 | list must be non-empty. -} 75 | 76 | shortestStr :: Foldable f => f String -> String 77 | shortestStr = minimumBy (\x y -> compare (length x) (length y)) 78 | -------------------------------------------------------------------------------- /examples/Makefile.example: -------------------------------------------------------------------------------- 1 | 2 | # NOTE: This Makefile is setup to be used as the Makefile for each 3 | # example development. It makes no sense as a Makefile for the 4 | # top-level `examples` directory. 5 | 6 | ############################################################################ 7 | # 8 | # Primary targets: 9 | # all - the default target; synonym for 'coq' 10 | # coq - builds all .vo files 11 | # doc - synonym for 'documentation' 12 | # documentation - builds all html documentation 13 | # clean - removes generated files 14 | # 15 | # Other targets: 16 | # rebuild - regenerates files from Ott language specifications 17 | # 18 | ############################################################################ 19 | 20 | ## Paths to executables. Do not include options here. 21 | ## Modify these to suit your Coq installation, if necessary. 22 | 23 | LNGEN = stack exec lngen -- 24 | COQC = coqc 25 | COQDEP = coqdep 26 | COQDOC = coqdoc 27 | 28 | ## Include directories, one per line. 29 | 30 | INCDIRS = \ 31 | . \ 32 | 33 | ## Name of the submakefile generated by coq_makefile 34 | COQMKFILENAME=CoqSrc.mk 35 | 36 | ## Directory where generated HTML documentation should go. 37 | 38 | DOCDIR = html 39 | 40 | ## List of files to be compiled and documented. 41 | 42 | FILES = $(patsubst %.v,%,$(wildcard *.v)) 43 | 44 | ## Lists calculated from the above. 45 | 46 | VFILES = $(foreach i, $(FILES), $(i).v) 47 | VOFILES = $(foreach i, $(FILES), $(i).vo) 48 | INCFLAGS = $(foreach i, $(INCDIRS), -I $(i)) 49 | 50 | ############################################################################ 51 | 52 | .PHONY: all clean coq dist doc documentation rebuild 53 | .SUFFIXES: .v .vo 54 | 55 | all: coq 56 | 57 | coq: $(COQMKFILENAME) $(VOFILES) 58 | make -f CoqSrc.mk 59 | 60 | doc: 61 | +make documentation 62 | 63 | documentation: $(DOCDIR) $(VOFILES) 64 | $(COQDOC) -g --quiet --noindex --html -d $(DOCDIR) $(VFILES) 65 | cp -f ../custom.css $(DOCDIR)/coqdoc.css 66 | 67 | clean: 68 | rm -f *.vo *.glob *.cmi *.cmx *.o 69 | rm -rf $(DOCDIR) $(COQMKFILENAME) $(COQMKFILENAME).conf 70 | 71 | realclean: clean 72 | rm -f $(OTT_SOURCE)_ott.v $(OTT_SOURSE)_inf.v 73 | 74 | ############################################################################ 75 | 76 | %.vo: %.v 77 | make -f $(COQMKFILENAME) $*.vo 78 | 79 | $(DOCDIR): 80 | mkdir -p $(DOCDIR) 81 | 82 | 83 | ############################################################################ 84 | 85 | OTT_SOURCE = $(patsubst %.ott,%,$(wildcard *.ott)) 86 | 87 | rebuild: 88 | ott -i $(OTT_SOURCE).ott -o $(OTT_SOURCE)_ott.v -coq_lngen true -coq_expand_list_types true 89 | $(LNGEN) --coq $(OTT_SOURCE)_inf.v --coq-ott $(OTT_SOURCE)_ott $(OTT_SOURCE).ott 90 | 91 | $(COQMKFILENAME): Makefile $(shell ls *.v | grep -v _ott.v | grep -v _inf.v) 92 | coq_makefile -arg '-w -variable-collision,-meta-collision,-require-in-module' -f _CoqProject -o $(COQMKFILENAME) 93 | 94 | ############################################################################ 95 | 96 | .depend: $(VFILES) 97 | $(COQDEP) -f _CoqProject > .depend 98 | 99 | include .depend 100 | -------------------------------------------------------------------------------- /examples/SimpleTypes/SimpleTypes_proofs.v: -------------------------------------------------------------------------------- 1 | 2 | Require Export Coq.Program.Equality. 3 | Require Export SimpleTypes_inf. 4 | Require Import String. 5 | 6 | Ltac gather_atoms ::= 7 | let A := gather_atoms_with (fun x : vars => x) in 8 | let B := gather_atoms_with (fun x : var => {{ x }}) in 9 | let C := gather_atoms_with (fun x : typing_env => dom x) in 10 | let D1 := gather_atoms_with (fun x => fv_exp x) in 11 | constr:(A \u B \u C \u D1). 12 | 13 | 14 | (* *********************************************************************** *) 15 | (** * Regularity lemmas *) 16 | 17 | Lemma typing_regular_1 : forall G e T, 18 | typing G e T -> 19 | lc_exp e. 20 | Proof. induction 1; eauto. Qed. 21 | 22 | #[export] Hint Resolve typing_regular_1 : core. 23 | 24 | Lemma typing_regular_2 : forall G e T, 25 | typing G e T -> 26 | uniq G. 27 | Proof. 28 | induction 1; eauto. 29 | pick fresh z. lapply (H0 z); solve_uniq. 30 | Qed. 31 | 32 | #[export] Hint Resolve typing_regular_2 : core. 33 | 34 | Lemma step_regular_1 : forall e1 e2, 35 | step e1 e2 -> 36 | lc_exp e1. 37 | Proof. induction 1; eauto. Qed. 38 | 39 | #[export] Hint Resolve step_regular_1 : core. 40 | 41 | Lemma step_regular_2 : forall e1 e2, 42 | step e1 e2 -> 43 | lc_exp e1. 44 | Proof. induction 1; eauto. Qed. 45 | 46 | #[export] Hint Resolve step_regular_2 : core. 47 | 48 | 49 | (* *********************************************************************** *) 50 | (** * Main proofs *) 51 | 52 | Lemma typing_weakening : forall F E G e T, 53 | typing (F ++ G) e T -> 54 | uniq (F ++ E ++ G) -> 55 | typing (F ++ E ++ G) e T. 56 | Proof. 57 | intros until 1. dependent induction H; intros; eauto. 58 | Case "typing_abs". 59 | pick fresh x and apply typing_abs. 60 | rewrite_env ((x ~ T1 ++ F) ++ E ++ G). 61 | apply_first_hyp; simpl_env; auto. 62 | Qed. 63 | 64 | Lemma typing_subst : forall F G e u S T x, 65 | typing (F ++ x ~ S ++ G) e T -> 66 | typing G u S -> 67 | typing (F ++ G) (subst_exp u x e) T. 68 | Proof with eauto. 69 | intros until 1. dependent induction H; intros; simpl subst_exp... 70 | Case "typing_var". 71 | destruct (x0 == x); try subst x0. 72 | SCase "x = x0". 73 | analyze_binds_uniq H. 74 | apply typing_weakening with (F := nil)... 75 | SCase "x <> x0". 76 | analyze_binds_uniq H... 77 | Case "typing_abs". 78 | pick fresh z and apply typing_abs. 79 | rewrite_env ((z ~ T1 ++ F) ++ G). 80 | rewrite subst_exp_open_exp_wrt_exp_var... 81 | apply H0 with (S := S)... 82 | Qed. 83 | 84 | Lemma preservation : forall G e1 e2 T, 85 | typing G e1 T -> 86 | step e1 e2 -> 87 | typing G e2 T. 88 | Proof with eauto. 89 | intros G e1 e2 T H. revert e2. 90 | dependent induction H; try solve [intros ? J; inversion J]. 91 | Case "typing_app". 92 | intros ? J; inversion J; subst... 93 | inversion H; subst. 94 | pick fresh z. 95 | rewrite (subst_exp_intro z)... 96 | eapply typing_subst with (F := nil); simpl_env... 97 | Qed. 98 | 99 | Lemma progress : forall e1 T, 100 | typing nil e1 T -> 101 | (exists e2, step e1 e2) \/ is_value_of_exp e1. 102 | Proof with eauto 10. 103 | intros e1 T H. 104 | dependent induction H; simpl... 105 | Case "typing_app". 106 | destruct IHtyping1 as [[e1' ?] | ?]... 107 | destruct IHtyping2 as [[e2' ?] | ?]... 108 | destruct e1; simpl in H1; inversion H1... 109 | Qed. 110 | -------------------------------------------------------------------------------- /examples/Lambda/Lambda_ott.v: -------------------------------------------------------------------------------- 1 | (* generated by Ott 0.32, locally-nameless lngen from: Lambda.ott *) 2 | Require Import Metalib.Metatheory. 3 | (** syntax *) 4 | Definition expvar : Set := var. 5 | 6 | Inductive exp : Set := 7 | | var_b (_:nat) 8 | | var_f (x:expvar) 9 | | app (e1:exp) (e2:exp) 10 | | abs (e:exp). 11 | 12 | (* EXPERIMENTAL *) 13 | (** auxiliary functions on the new list types *) 14 | (** library functions *) 15 | (** subrules *) 16 | Definition is_value_of_exp (e_5:exp) : Prop := 17 | match e_5 with 18 | | (var_b nat) => False 19 | | (var_f x) => False 20 | | (app e1 e2) => False 21 | | (abs e) => (True) 22 | end. 23 | 24 | (** arities *) 25 | (** opening up abstractions *) 26 | Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp := 27 | match e__6 with 28 | | (var_b nat) => 29 | match lt_eq_lt_dec nat k with 30 | | inleft (left _) => var_b nat 31 | | inleft (right _) => e_5 32 | | inright _ => var_b (nat - 1) 33 | end 34 | | (var_f x) => var_f x 35 | | (app e1 e2) => app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2) 36 | | (abs e) => abs (open_exp_wrt_exp_rec (S k) e_5 e) 37 | end. 38 | 39 | Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5. 40 | 41 | (** closing up abstractions *) 42 | Fixpoint close_exp_wrt_exp_rec (k:nat) (e_5:var) (e__6:exp) {struct e__6}: exp := 43 | match e__6 with 44 | | (var_b nat) => 45 | if (lt_dec nat k) 46 | then var_b nat 47 | else var_b (S nat) 48 | | (var_f x) => if (e_5 === x) then (var_b k) else (var_f x) 49 | | (app e1 e2) => app (close_exp_wrt_exp_rec k e_5 e1) (close_exp_wrt_exp_rec k e_5 e2) 50 | | (abs e) => abs (close_exp_wrt_exp_rec (S k) e_5 e) 51 | end. 52 | 53 | Definition close_exp_wrt_exp e__6 e_5 := close_exp_wrt_exp_rec 0 e__6 e_5. 54 | 55 | (** terms are locally-closed pre-terms *) 56 | (** definitions *) 57 | 58 | (* defns LC_exp *) 59 | Inductive lc_exp : exp -> Prop := (* defn lc_exp *) 60 | | lc_var_f : forall (x:expvar), 61 | (lc_exp (var_f x)) 62 | | lc_app : forall (e1 e2:exp), 63 | (lc_exp e1) -> 64 | (lc_exp e2) -> 65 | (lc_exp (app e1 e2)) 66 | | lc_abs : forall (e:exp), 67 | ( forall x , lc_exp ( open_exp_wrt_exp e (var_f x) ) ) -> 68 | (lc_exp (abs e)). 69 | (** free variables *) 70 | Fixpoint fv_exp (e_5:exp) : vars := 71 | match e_5 with 72 | | (var_b nat) => {} 73 | | (var_f x) => {{x}} 74 | | (app e1 e2) => (fv_exp e1) \u (fv_exp e2) 75 | | (abs e) => (fv_exp e) 76 | end. 77 | 78 | (** substitutions *) 79 | Fixpoint subst_exp (e_5:exp) (x5:expvar) (e__6:exp) {struct e__6} : exp := 80 | match e__6 with 81 | | (var_b nat) => var_b nat 82 | | (var_f x) => (if eq_var x x5 then e_5 else (var_f x)) 83 | | (app e1 e2) => app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2) 84 | | (abs e) => abs (subst_exp e_5 x5 e) 85 | end. 86 | 87 | 88 | (** definitions *) 89 | 90 | (* defns Jop *) 91 | Inductive reduce : exp -> exp -> Prop := (* defn reduce *) 92 | | red_beta : forall (e1 e2:exp), 93 | lc_exp (abs e1) -> 94 | lc_exp e2 -> 95 | reduce (app ( (abs e1) ) e2) (open_exp_wrt_exp e1 e2 ) 96 | | red_app_fun : forall (e1 e2 e1':exp), 97 | lc_exp e2 -> 98 | reduce e1 e1' -> 99 | reduce (app e1 e2) (app e1' e2) 100 | | red_app_arg : forall (e2 e2' v1:exp), 101 | is_value_of_exp v1 -> 102 | lc_exp v1 -> 103 | reduce e2 e2' -> 104 | reduce (app v1 e2) (app v1 e2'). 105 | 106 | 107 | (** infrastructure *) 108 | #[export] Hint Constructors reduce lc_exp : core. 109 | 110 | 111 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {- | This module defines the @main@ IO action for this program. -} 2 | 3 | module Main where 4 | 5 | import Control.Monad ( when ) 6 | import System.Environment ( getArgs, getProgName ) 7 | import System.IO ( hPutStr, stderr, stdout ) 8 | import System.Console.GetOpt 9 | import Text.Printf ( printf ) 10 | 11 | import ASTCheck ( astOfPreAST ) 12 | import ComputationMonad ( runM, ProgFlag(..) ) 13 | import CoqLNOutput ( coqOfAST ) 14 | import MyLibrary ( getResult ) 15 | import Parser ( parseOttFile ) 16 | 17 | 18 | {- ----------------------------------------------------------------------- -} 19 | {- * Constants -} 20 | 21 | {- | LNgen's version number. -} 22 | 23 | version :: String 24 | version = "0.3.2" 25 | 26 | 27 | {- ----------------------------------------------------------------------- -} 28 | {- * Parsing command-line arguments -} 29 | 30 | {- | The usage message for this program. It depends on the name this 31 | program was invoked by. -} 32 | 33 | usageMsg :: IO String 34 | usageMsg = do { n <- getProgName 35 | ; return (usageInfo 36 | (printf "Usage: %s [OPTION1 OPTION2 ...] FILE1\n" n) 37 | options) 38 | } 39 | 40 | {- | Command-line options. -} 41 | 42 | options :: [OptDescr ProgFlag] 43 | options = 44 | [ Option ['o'] ["coq"] (ReqArg CoqOutput "FILE") "Coq: destination for output" 45 | , Option [] ["coq-admitted"] (NoArg CoqAdmitted) "Coq: do not generate proofs" 46 | , Option [] ["coq-no-proofs"] (NoArg CoqAdmitted) "Coq: do not generate proofs" 47 | , Option [] ["coq-loadpath"] (ReqArg CoqLoadPath "DIR") "Coq: directory for LoadPath" 48 | , Option [] ["coq-ott"] (ReqArg CoqOtt "LIB") "Coq: name of library to Require" 49 | , Option [] ["coq-stdout"] (NoArg CoqStdout) "Coq: send output to standard out" 50 | , Option [] ["coq-nolcset"] (NoArg CoqNoLCSet) "Coq: suppress the Set version of local closure" 51 | , Option [] ["coq-noclose"] (NoArg CoqNoClose) "Coq: suppress generation of close and close_rec" 52 | , Option ['?'] ["help"] (NoArg Help) "displays usage information" 53 | ] 54 | 55 | {- | Processes the command-line arguments to this program. Returns a 56 | list of flags and a list of non-options. -} 57 | 58 | processArgv :: IO ([ProgFlag], [String]) 59 | processArgv = 60 | do { argv <- getArgs 61 | ; usage <- usageMsg 62 | ; (o, n) <- case getOpt Permute options argv of 63 | (o, n, []) -> return (o, n) 64 | (_, _, es) -> error $ concat es ++ "\n" ++ usage 65 | ; when (Help `elem` o) (error usage) 66 | ; when (length n /= 1) (error $ "Exactly one input file required.\n\n" ++ usage) 67 | ; return (o, n) 68 | } 69 | 70 | 71 | {- ----------------------------------------------------------------------- -} 72 | {- * The \"main\" action -} 73 | 74 | {- | Returns the content of the @--coq-loadpath@ option, if any. -} 75 | 76 | getCoqLoadPath :: [ProgFlag] -> Maybe String 77 | getCoqLoadPath [] = Nothing 78 | getCoqLoadPath (CoqLoadPath s : _) = Just s 79 | getCoqLoadPath (_ : flags) = getCoqLoadPath flags 80 | 81 | {- | Returns the content of the @--coq-ott@ option, if any -} 82 | 83 | getCoqOtt :: [ProgFlag] -> Maybe String 84 | getCoqOtt [] = Nothing 85 | getCoqOtt (CoqOtt s : _) = Just s 86 | getCoqOtt (_ : flags) = getCoqOtt flags 87 | 88 | {- | The main action for this program. -} 89 | 90 | main :: IO () 91 | main = 92 | do { hPutStr stderr (printf "This is version %s of LNgen.\n\n" version) 93 | ; (flags, inputNames) <- processArgv 94 | ; mapM_ (processInput flags) inputNames 95 | } 96 | where 97 | processInput flags file = 98 | do { preAst <- parseOttFile file 99 | ; let ast = getResult (astOfPreAST preAst) 100 | ott = getCoqOtt flags 101 | loadpath = getCoqLoadPath flags 102 | coqOutput = runM flags $ coqOfAST ott loadpath ast 103 | ; mapM_ (output $! coqOutput) flags 104 | } 105 | 106 | output coq (CoqOutput f) = writeFile f coq 107 | output coq (CoqStdout) = hPutStr stdout coq 108 | output _ _ = return () 109 | -------------------------------------------------------------------------------- /examples/SimpleTypes/SimpleTypes_ott.v: -------------------------------------------------------------------------------- 1 | (* generated by Ott 0.32, locally-nameless lngen from: SimpleTypes.ott *) 2 | Require Import Metalib.Metatheory. 3 | (** syntax *) 4 | Definition expvar : Set := var. 5 | 6 | Inductive typ : Set := 7 | | base : typ 8 | | arrow (T1:typ) (T2:typ). 9 | 10 | Inductive exp : Set := 11 | | var_b (_:nat) 12 | | var_f (x:expvar) 13 | | abs (T:typ) (e:exp) 14 | | app (e1:exp) (e2:exp). 15 | 16 | Definition typing_env : Set := list (atom*typ). 17 | 18 | (* EXPERIMENTAL *) 19 | (** auxiliary functions on the new list types *) 20 | (** library functions *) 21 | (** subrules *) 22 | Definition is_value_of_exp (e_5:exp) : Prop := 23 | match e_5 with 24 | | (var_b nat) => False 25 | | (var_f x) => False 26 | | (abs T e) => (True) 27 | | (app e1 e2) => False 28 | end. 29 | 30 | (** arities *) 31 | (** opening up abstractions *) 32 | Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp := 33 | match e__6 with 34 | | (var_b nat) => 35 | match lt_eq_lt_dec nat k with 36 | | inleft (left _) => var_b nat 37 | | inleft (right _) => e_5 38 | | inright _ => var_b (nat - 1) 39 | end 40 | | (var_f x) => var_f x 41 | | (abs T e) => abs T (open_exp_wrt_exp_rec (S k) e_5 e) 42 | | (app e1 e2) => app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2) 43 | end. 44 | 45 | Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5. 46 | 47 | (** closing up abstractions *) 48 | Fixpoint close_exp_wrt_exp_rec (k:nat) (e_5:var) (e__6:exp) {struct e__6}: exp := 49 | match e__6 with 50 | | (var_b nat) => 51 | if (lt_dec nat k) 52 | then var_b nat 53 | else var_b (S nat) 54 | | (var_f x) => if (e_5 === x) then (var_b k) else (var_f x) 55 | | (abs T e) => abs T (close_exp_wrt_exp_rec (S k) e_5 e) 56 | | (app e1 e2) => app (close_exp_wrt_exp_rec k e_5 e1) (close_exp_wrt_exp_rec k e_5 e2) 57 | end. 58 | 59 | Definition close_exp_wrt_exp e__6 e_5 := close_exp_wrt_exp_rec 0 e__6 e_5. 60 | 61 | (** terms are locally-closed pre-terms *) 62 | (** definitions *) 63 | 64 | (* defns LC_exp *) 65 | Inductive lc_exp : exp -> Prop := (* defn lc_exp *) 66 | | lc_var_f : forall (x:expvar), 67 | (lc_exp (var_f x)) 68 | | lc_abs : forall (T:typ) (e:exp), 69 | ( forall x , lc_exp ( open_exp_wrt_exp e (var_f x) ) ) -> 70 | (lc_exp (abs T e)) 71 | | lc_app : forall (e1 e2:exp), 72 | (lc_exp e1) -> 73 | (lc_exp e2) -> 74 | (lc_exp (app e1 e2)). 75 | (** free variables *) 76 | Fixpoint fv_exp (e_5:exp) : vars := 77 | match e_5 with 78 | | (var_b nat) => {} 79 | | (var_f x) => {{x}} 80 | | (abs T e) => (fv_exp e) 81 | | (app e1 e2) => (fv_exp e1) \u (fv_exp e2) 82 | end. 83 | 84 | (** substitutions *) 85 | Fixpoint subst_exp (e_5:exp) (x5:expvar) (e__6:exp) {struct e__6} : exp := 86 | match e__6 with 87 | | (var_b nat) => var_b nat 88 | | (var_f x) => (if eq_var x x5 then e_5 else (var_f x)) 89 | | (abs T e) => abs T (subst_exp e_5 x5 e) 90 | | (app e1 e2) => app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2) 91 | end. 92 | 93 | 94 | (** definitions *) 95 | 96 | (* defns Jtyping *) 97 | Inductive typing : typing_env -> exp -> typ -> Prop := (* defn typing *) 98 | | typing_var : forall (G:typing_env) (x:expvar) (T:typ), 99 | binds ( x ) ( T ) ( G ) -> 100 | uniq ( G ) -> 101 | typing G (var_f x) T 102 | | typing_abs : forall (L:vars) (G:typing_env) (T1:typ) (e:exp) (T2:typ), 103 | ( forall x , x \notin L -> typing ( x ~ T1 ++ G ) ( open_exp_wrt_exp e (var_f x) ) T2 ) -> 104 | typing G (abs T1 e) (arrow T1 T2) 105 | | typing_app : forall (G:typing_env) (e1 e2:exp) (T2 T1:typ), 106 | typing G e1 (arrow T1 T2) -> 107 | typing G e2 T1 -> 108 | typing G (app e1 e2) T2. 109 | 110 | (* defns Jop *) 111 | Inductive step : exp -> exp -> Prop := (* defn step *) 112 | | step_app_1 : forall (e1 e2 e1':exp), 113 | lc_exp e2 -> 114 | step e1 e1' -> 115 | step (app e1 e2) (app e1' e2) 116 | | step_app_2 : forall (e2 e2' v1:exp), 117 | is_value_of_exp v1 -> 118 | lc_exp v1 -> 119 | step e2 e2' -> 120 | step (app v1 e2) (app v1 e2') 121 | | step_beta : forall (T:typ) (e1 v2:exp), 122 | is_value_of_exp v2 -> 123 | lc_exp (abs T e1) -> 124 | lc_exp v2 -> 125 | step (app ( (abs T e1) ) v2) (open_exp_wrt_exp e1 v2 ) . 126 | 127 | 128 | (** infrastructure *) 129 | #[export] Hint Constructors typing step lc_exp : core. 130 | 131 | 132 | -------------------------------------------------------------------------------- /src/CoqLNOutputThmSwap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# OPTIONS_GHC -freduction-depth=50 #-} 3 | 4 | module CoqLNOutputThmSwap where 5 | 6 | import Text.Printf ( printf ) 7 | 8 | import AST 9 | import ASTAnalysis 10 | import ComputationMonad 11 | import CoqLNOutputCommon 12 | import CoqLNOutputCombinators 13 | 14 | swapThms :: ASTAnalysis -> [[NtRoot]] -> M String 15 | swapThms aa nts = 16 | do { swap_distribs <- mapM (swap_distrib aa) nts 17 | ; swap_instances <- mapM (swap_instance aa) nts 18 | ; swap_invols <- mapM (swap_invol aa) nts 19 | ; swap_sames <- mapM (swap_same aa) nts 20 | ; return $ "Strategy opaque [ " ++ swapAtomName ++ " ].\n\n" ++ 21 | concat swap_sames ++ 22 | concat swap_invols ++ 23 | concat swap_distribs ++ 24 | concat swap_instances ++ 25 | "Strategy transparent [ " ++ swapAtomName ++ " ].\n\n" ++ "\n" 26 | } 27 | 28 | {- | @swap ab (swap (c, d) e) = ...@. -} 29 | 30 | swap_distrib :: ASTAnalysis -> [NtRoot] -> M String 31 | swap_distrib aaa nt1s = 32 | do { thms <- processNt1 aaa nt1s thm 33 | ; names <- processNt1 aaa nt1s name 34 | ; types <- processNt1 aaa nt1s ntType 35 | ; let proof = mutPfStart Prop types ++ defaultSimp ++ "." 36 | ; mutualLemmaText Resolve NoRewrite NoHide [hintDb] Prop names thms proof 37 | } 38 | where 39 | name aa nt1 = 40 | do { swap <- swapImplName aa nt1 41 | ; return $ swap ++ "_distrib" 42 | } 43 | thm :: ASTAnalysis -> NtRoot -> M String 44 | thm aa nt1 = 45 | do { ab <- newName "ab" 46 | ; c <- newName "c" 47 | ; d <- newName "d" 48 | ; e <- newName nt1 49 | ; swap <- swapImplName aa nt1 50 | ; return $ printf 51 | "forall %s %s %s %s,\n\ 52 | \ %s %s (%s (%s, %s) %s) =\n\ 53 | \ %s (%s %s %s, %s %s %s) (%s %s %s)" 54 | e ab c d 55 | swap ab swap c d e 56 | swap swapAtomName ab c swapAtomName ab d swap ab e 57 | } 58 | 59 | {- | Theorem: @Swap@ instance declaration. -} 60 | 61 | swap_instance :: ASTAnalysis -> [NtRoot] -> M String 62 | swap_instance aa nts = 63 | do { defs <- mapM (local . def) nts 64 | ; return $ concat defs 65 | } 66 | where 67 | def nt = 68 | do { t <- ntType aa nt 69 | ; swap <- swapImplName aa nt 70 | ; return $ printf 71 | "Instance %s_%s : %s %s := {\n\ 72 | \ %s := %s\n\ 73 | \}.\n\ 74 | \Proof.\n\ 75 | \ auto with %s.\n\ 76 | \ auto with %s.\n\ 77 | \ auto with %s.\n\ 78 | \Defined.\n\ 79 | \\n" 80 | swapClass t swapClass t 81 | swapName swap 82 | hintDb 83 | hintDb 84 | hintDb 85 | } 86 | 87 | {- | @swap ab (swap ab e) = e@. -} 88 | 89 | swap_invol :: ASTAnalysis -> [NtRoot] -> M String 90 | swap_invol aaa nt1s = 91 | do { thms <- processNt1 aaa nt1s thm 92 | ; names <- processNt1 aaa nt1s name 93 | ; types <- processNt1 aaa nt1s ntType 94 | ; let proof = mutPfStart Prop types ++ defaultSimp ++ "." 95 | ; mutualLemmaText Resolve NoRewrite NoHide [hintDb] Prop names thms proof 96 | } 97 | where 98 | name aa nt1 = 99 | do { swap <- swapImplName aa nt1 100 | ; return $ swap ++ "_invol" 101 | } 102 | 103 | thm aa nt1 = 104 | do { ab <- newName "ab" 105 | ; e <- newName nt1 106 | ; swap <- swapImplName aa nt1 107 | ; return $ printf 108 | "forall %s %s,\n\ 109 | \ %s %s (%s %s %s) = %s" 110 | e ab 111 | swap ab swap ab e e 112 | } 113 | 114 | {- | @swap (a, a) e = e@. -} 115 | 116 | swap_same :: ASTAnalysis -> [NtRoot] -> M String 117 | swap_same aaa nt1s = 118 | do { thms <- processNt1 aaa nt1s thm 119 | ; names <- processNt1 aaa nt1s name 120 | ; types <- processNt1 aaa nt1s ntType 121 | ; let proof = mutPfStart Prop types ++ defaultSimp ++ "." 122 | ; mutualLemmaText Resolve NoRewrite NoHide [hintDb] Prop names thms proof 123 | } 124 | where 125 | name aa nt1 = 126 | do { swap <- swapImplName aa nt1 127 | ; return $ swap ++ "_same" 128 | } 129 | thm :: ASTAnalysis -> NtRoot -> M String 130 | thm aa nt1 = 131 | do { a <- newName "a" 132 | ; e <- newName nt1 133 | ; swap <- swapImplName aa nt1 134 | ; return $ printf 135 | "forall %s %s,\n\ 136 | \ %s (%s, %s) %s = %s" 137 | e a 138 | swap a a e e 139 | } 140 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lngen [![build](https://github.com/plclub/lngen/actions/workflows/build.yml/badge.svg)](https://github.com/plclub/lngen/actions/workflows/build.yml) 2 | Tool for generating Locally Nameless definitions and proofs in Coq, working together with Ott 3 | 4 | Overview 5 | ======== 6 | 7 | LNgen generates statements and proofs of "infrastructure" lemmas for locally 8 | nameless representations in the [Coq proof assistant] [1]. It takes as input 9 | language definitions written in the [Ott specification language] [2]. LNgen 10 | is not a complete replacement for Ott's Coq back end: the output from LNgen 11 | relies on the definitions generated by Ott. 12 | 13 | [1]: http://coq.inria.fr/ 14 | [2]: http://www.cl.cam.ac.uk/~pes20/ott/ 15 | 16 | 17 | 18 | 19 | Dependencies 20 | ============ 21 | 22 | * [GHC](https://www.haskell.org/ghc/) is required in order to compile 23 | LNgen. 24 | 25 | Recently tested with GHC 8.10.7 26 | 27 | * LNgen's output must be combined with the output of 28 | [Ott](https://github.com/ott-lang/ott). Obtain Ott from opam. 29 | 30 | * The Coq Proof assistant. 31 | 32 | This version works with Coq 8.15.0 33 | 34 | * LNgen's output requires a copy of Penn's metatheory library. The most 35 | recent version of the library can be found at 36 | 37 | 38 | 39 | Last tested with the 8.15.0 version of metalib. 40 | 41 | Building LNgen 42 | ============== 43 | 44 | You can use either the Haskell tools `cabal` or `stack` to build lngen. 45 | 46 | To compile and run with cabal (new style, uses system GHC) 47 | 48 | cabal new-build 49 | cabal new-exec lngen 50 | 51 | To compile and run with stack (GHC version determined by stack.yaml) 52 | 53 | stack build 54 | stack exec lngen 55 | 56 | To compile with cabal (old style, installs lngen in your path): 57 | 58 | cabal v1-build 59 | lngen 60 | 61 | 62 | Using LNgen 63 | =========== 64 | 65 | 1. Write an Ott specification for your language, e.g., `lang.ott`, 66 | keeping in mind the restrictions below. 67 | 68 | 2. Run `ott` on the specification to produce a Coq file containing the 69 | language's definitions, e.g., 70 | 71 | ott --coq lang_ott.v lang.ott 72 | 73 | 3. Run `lngen` on the specification to produce a Coq file containing 74 | additional infrastructure for the language, e.g., 75 | 76 | lngen --coq lang_inf.v lang.ott 77 | 78 | 79 | Options 80 | ======= 81 | 82 | The following options to `lngen` may be useful: 83 | 84 | * --coq-admitted : Tells LNgen to emit every infrastructure lemma as an 85 | axiom. This is useful if you're still tweaking your language's 86 | definition and do not wish to spend time recompiling the 87 | infrastructure file. 88 | 89 | * --coq-loadpath dir : Tells LNgen to include a line 90 | 91 | Add LoadPath "dir". 92 | 93 | at the beginning of the file that it generates. For example, this 94 | option can be used to specify the directory containing the metatheory 95 | library. 96 | 97 | * --coq-no-proofs : Same as --coq-admitted. 98 | 99 | * --coq-ott lib : Tells LNgen to include a line 100 | 101 | Require Import lib. 102 | 103 | at the beginning of the file that it generates. For example, this 104 | option can be used to `Require` the library generated by Ott. (In 105 | fact, LNgen's output won't compile without it.) 106 | 107 | * --coq-nolcset : Suppress the Set version of local closure 108 | 109 | * --coq-noclose : Suppress generation of `close` and `close_rec` definitions 110 | 111 | 112 | Restrictions on Ott specifications 113 | ================================== 114 | 115 | * LNgen handles no more than what Ott's locally nameless back-end can 116 | handle. In particular, LNgen doesn't handle multi-substitutions and 117 | list forms. 118 | 119 | * Every `metavar` that is used as a binder must include 120 | 121 | {{ repr-locally-nameless }} 122 | 123 | as a homomorphism. 124 | 125 | * LNgen reads only the initial part of a single Ott file. This initial 126 | part should be ordered as follows: 127 | 128 | * `metavar` declarations 129 | * a `grammar` block 130 | * a `substitutions` block 131 | * a `freevars` block 132 | 133 | Anything after this initial part will be ignored by LNgen but still 134 | processed by Ott. Note that you may declare `indexvar`s and `embed`s 135 | between the parts listed above. 136 | 137 | The initial `grammar` block should include only those grammars for 138 | which you expect Ott to generate an inductive datatype declaration. 139 | The initial `substitutions` and `freevars` blocks must declare names 140 | for all possible (sensible) substitution and free-variables functions. 141 | 142 | 143 | Examples 144 | ======== 145 | 146 | The `examples` directory contains examples of Ott specifications and the 147 | corresponding outputs generated by Ott and LNgen. Each example uses 148 | `LoadPath` directives and symlinks to import copy the metatheory library 149 | that comes with the LNgen distribution. The README file in the 150 | `examples` directory contains additional information about each example. 151 | 152 | To compile the Coq code for all the examples, run `make examples`. 153 | 154 | 155 | Credit 156 | ------ 157 | Original code by Brian Aydemir 158 | 159 | 160 | 161 | -------------------------------------------------------------------------------- /src/ASTCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | {- | This module implements a means of turning a 'PreAST' into an 4 | 'AST'. In the process, the abstract syntax tree is checked for 5 | well-formedness. -} 6 | 7 | module ASTCheck ( astOfPreAST ) where 8 | 9 | import Control.Monad ( foldM, when ) 10 | import Control.Monad.Except ( MonadError ) 11 | import Data.List ( nub, intersect ) 12 | import qualified Data.List.NonEmpty as NE 13 | -- import Monad ( when ) 14 | 15 | import AST 16 | import ComputationMonad ( ProgramError(..), abort ) 17 | 18 | 19 | {- ----------------------------------------------------------------------- -} 20 | {- * Pre-AST translation and sanity checking -} 21 | 22 | {- Returns the set of metavariable roots defined by the given list of 23 | declarations, raising an error instead if a root is defined 24 | multiple times. -} 25 | 26 | getMvRoots :: (MonadError ProgramError m, Foldable f) => f MetavarDecl -> m [MvRoot] 27 | getMvRoots mvds = foldM f [] mvds 28 | where 29 | f acc (MetavarDecl pos rs _) = 30 | if not $ null $ intersect (NE.toList rs) acc 31 | then abort $ ASTDupRoots pos (intersect (NE.toList rs) acc) 32 | else return $ nub (NE.toList rs) ++ acc 33 | 34 | {- Returns the set of nonterminal roots defined by the given list of 35 | declarations, raising an error instead if a root is defined 36 | multiple times. The given list of metavariable roots is used to 37 | check whether a root is defined both as a nonterminal and as a 38 | metavariable (an error). -} 39 | 40 | getNtRoots :: (MonadError ProgramError m, Foldable f) => [MvRoot] -> f PreRule -> m [MvRoot] 41 | getNtRoots mvs rls = foldM f [] rls 42 | where 43 | f acc (Rule pos _ rs _ _) = 44 | if not $ null $ intersect (NE.toList rs) (acc ++ mvs) 45 | then abort $ ASTDupRoots pos (intersect (NE.toList rs) (acc ++ mvs)) 46 | else return $ nub (NE.toList rs) ++ acc 47 | 48 | {- | Disambiguates the symbols in the given rule, in the process 49 | checking that the rule's productions are well-formed. Binding 50 | specifications are checked only on a per-production basis. Checks 51 | that require more \"global\" knowledge are not performed here. 52 | 53 | The supplied lists of roots are necessary in order to determine 54 | whether a symbol is a metavariable or a nonterminal. -} 55 | 56 | toRule :: (MonadError ProgramError m) => [MvRoot] -> [NtRoot] -> PreRule -> m Rule 57 | toRule mvs nts (Rule pos hom ns n ps) = 58 | do { ps' <- mapM toProduction ps 59 | ; return $ Rule pos hom ns n ps' 60 | } 61 | where 62 | toProduction (Production p es flag constr bs) = 63 | do { es' <- foldM toElement [] es 64 | ; (_, _, bs') <- foldM (toBindingSpec es') ([], [], []) bs 65 | ; return $ Production p (reverse es') flag constr bs' 66 | } 67 | 68 | toElement acc (Unknown s) = return (acc ++ [TElement s]) 69 | toElement acc (Variable v@(UnknownSym p r s)) 70 | | r `elem` mvs && mv `notElem` acc = return (mv : acc) 71 | | r `elem` nts && nt `notElem` acc = return (nt : acc) 72 | | r `elem` mvs && mv `elem` acc = abort (ASTDupElt v) 73 | | r `elem` nts && nt `elem` acc = abort (ASTDupElt v) 74 | | otherwise = return (tm : acc) 75 | where 76 | mv = MvElement (Metavariable p r s) 77 | nt = NtElement (Nonterminal p r s) 78 | tm = TElement (r ++ s) 79 | 80 | toBindingSpec es (ls, rs, bss) (BindDecl p v1 v2) = 81 | do { v1' <- toMetavariable v1 82 | ; v2' <- toNonterminal v2 83 | ; when (MvElement v1' `notElem` es) (abort $ ASTUnknownVar v1) 84 | ; when (NtElement v2' `notElem` es) (abort $ ASTUnknownVar v2) 85 | ; when (v1' `elem` ls) (abort $ ASTDupBinderL v1) 86 | ; when (v2' `elem` rs) (abort $ ASTDupBinderR v2) 87 | ; return $ (v1' : ls, v2' : rs, BindDecl p v1' v2' : bss) 88 | } 89 | 90 | toMetavariable x@(UnknownSym p r s) 91 | | r `elem` mvs = return $ Metavariable p r s 92 | | otherwise = abort $ ASTNotMv x 93 | 94 | toNonterminal x@(UnknownSym p r s) 95 | | r `elem` nts = return $ Nonterminal p r s 96 | | otherwise = abort $ ASTNotNt x 97 | 98 | 99 | {- ----------------------------------------------------------------------- -} 100 | {- * Exported functions -} 101 | 102 | {- | Checks the abstract syntax tree for well-formedness and 103 | disambiguates the variables appearing in it. Nonformal rules and 104 | metaproductions will be removed in the process. -} 105 | 106 | astOfPreAST :: (MonadError ProgramError m) => PreAST -> m AST 107 | astOfPreAST (PreAST mvds rls substs fvs) = 108 | do { mvs <- getMvRoots mvds 109 | ; nts <- getNtRoots mvs rls 110 | ; rs <- mapM (toRule mvs nts) formalRules 111 | ; return $ AST mvds rs substs fvs 112 | } 113 | where 114 | formalRules = map deleteMetaprods $ filter isNonformal rls 115 | 116 | isNonformal (Rule _ _ es _ _) = "terminals" `notElem` es && 117 | "formula" `notElem` es 118 | 119 | deleteMetaprods (Rule pos hom es n ps) = Rule pos hom es n (filter f ps) 120 | where 121 | f (Production _ _ fs _ _) = null fs 122 | -------------------------------------------------------------------------------- /src/CoqLNOutput.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -freduction-depth=50 #-} 2 | 3 | {- | This module defines the functions necessary to transform an 'AST' 4 | into a 'String' containing output for the Coq proof assistant. 5 | Definitions are encoded using a locally nameless representation. -} 6 | 7 | module CoqLNOutput ( coqOfAST ) where 8 | 9 | import Data.Graph ( SCC(..), stronglyConnComp ) 10 | import Text.Printf ( printf ) 11 | 12 | import AST 13 | import ASTAnalysis 14 | import ComputationMonad 15 | import CoqLNOutputCommon 16 | import CoqLNOutputDefinitions 17 | import CoqLNOutputThmDegree 18 | import CoqLNOutputThmFv 19 | import CoqLNOutputThmLc 20 | import CoqLNOutputThmOpenClose 21 | import CoqLNOutputThmOpenClose2 22 | import CoqLNOutputThmSize 23 | import CoqLNOutputThmSwap 24 | import CoqLNOutputThmSubst 25 | import MyLibrary ( nmap ) 26 | import Control.Monad (filterM) 27 | import Control.Monad.State (get) 28 | 29 | 30 | {- ----------------------------------------------------------------------- -} 31 | {- * Exported functionality -} 32 | 33 | {- | Generates Coq output for the given 'AST'. The first argument is 34 | the name of the library for the output generated by Ott. The 35 | second is the directory name for a @LoadPath@ declaration. -} 36 | 37 | coqOfAST :: Maybe String -> Maybe String -> AST -> M String 38 | coqOfAST ott loadpath ast = 39 | do { nts' <- filter (not . null) <$> 40 | mapM (local . filterM (notPhantomNtRoot aa)) nts 41 | ; (flags, _) <- get 42 | ; let suppress x = if noclose flags then "" else x 43 | ; bodyStrs <- mapM (local . processBody aa) nts' 44 | ; closeStrs <- mapM (local . processClose aa) nts 45 | ; degreeStrs <- mapM (local . processDegree aa) nts' 46 | ; lcStrs <- mapM (local . processLc aa) nts' 47 | ; ntStrs <- mapM (local . processNt aa) nts' 48 | ; sizeStrs <- mapM (local . processSize aa) nts' 49 | ; _swapStrs <- mapM (local . processSwap aa) nts' 50 | ; tacticStrs <- local $ processTactics aa 51 | 52 | ; degree_thms <- degreeThms aa nts' 53 | ; fv_thms <- fvThms aa nts' 54 | ; lc_thms <- lcThms aa nts' 55 | ; open_close_thms <- openCloseThms aa nts' 56 | ; open_close_thms2 <- openCloseThms2 aa nts' 57 | ; size_thms <- sizeThms aa nts' 58 | ; _swap_thms <- swapThms aa nts' 59 | ; subst_thms <- substThms aa nts' 60 | 61 | ; return $ (case loadpath of 62 | Nothing -> "" 63 | Just s -> "Add LoadPath \"" ++ s ++ "\".\n") ++ 64 | "Require Import Coq.Arith.Wf_nat.\n\ 65 | \Require Import Coq.Logic.FunctionalExtensionality.\n\ 66 | \Require Import Coq.Program.Equality.\n\ 67 | \\n\ 68 | \Require Export Metalib.Metatheory.\n\ 69 | \Require Export Metalib.LibLNgen.\n" ++ 70 | (case ott of 71 | Nothing -> "" 72 | Just s -> "\nRequire Export " ++ s ++ ".\n") ++ 73 | "\n\ 74 | \Local Set Warnings \"-non-recursive\". \n\ 75 | \\n\ 76 | \(** NOTE: Auxiliary theorems are hidden in generated documentation.\n\ 77 | \ In general, there is a [_rec] version of every lemma involving\n\ 78 | \ [open] and [close]. *)\n\ 79 | \\n\ 80 | \\n" ++ 81 | coqSep ++ "(** * Induction principles for nonterminals *)\n\n" ++ 82 | concat ntStrs ++ "\n" ++ 83 | suppress (coqSep ++ "(** * Close *)\n\n" ++ 84 | concat closeStrs ++ "\n") ++ 85 | coqSep ++ "(** * Size *)\n\n" ++ 86 | concat sizeStrs ++ "\n" ++ 87 | coqSep ++ "(** * Degree *)\n\ 88 | \\n\ 89 | \(** These define only an upper bound, not a strict upper bound. *)\n\ 90 | \\n" ++ 91 | concat degreeStrs ++ "\n" ++ 92 | coqSep ++ "(** * Local closure (version in [Set], induction principles) *)\n\n" ++ 93 | concat lcStrs ++ "\n" ++ 94 | coqSep ++ "(** * Body *)\n\n" ++ 95 | concat bodyStrs ++ "\n" ++ 96 | -- coqSep ++ "(** * Swapping *)\n\n" ++ 97 | -- concat swapStrs ++ "\n" ++ 98 | coqSep ++ "(** * Tactic support *)\n\n" ++ 99 | tacticStrs ++ "\n" ++ 100 | coqSep ++ "(** * Theorems about [size] *)\n\n" ++ 101 | size_thms ++ 102 | coqSep ++ "(** * Theorems about [degree] *)\n\n" ++ 103 | degree_thms ++ 104 | coqSep ++ "(** * Theorems about [open] and [close] *)\n\n" ++ 105 | open_close_thms ++ 106 | coqSep ++ "(** * Theorems about [lc] *)\n\n" ++ 107 | lc_thms ++ 108 | coqSep ++ "(** * More theorems about [open] and [close] *)\n\n" ++ 109 | open_close_thms2 ++ 110 | coqSep ++ "(** * Theorems about [fv] *)\n\n" ++ 111 | fv_thms ++ 112 | coqSep ++ "(** * Theorems about [subst] *)\n\n" ++ 113 | subst_thms ++ 114 | -- coqSep ++ "(** * Theorems about [swap] *)\n\n" ++ 115 | -- swap_thms ++ 116 | coqSep ++ printf "(** * \"Restore\" tactics *)\n\ 117 | \\n\ 118 | \Ltac %s ::= auto; tauto.\n\ 119 | \Ltac %s ::= fail.\n" 120 | defaultAuto 121 | defaultAutoRewr 122 | } 123 | where 124 | fixSCC (AcyclicSCC n) = [canon n] 125 | fixSCC (CyclicSCC ns) = nmap canon ns 126 | aa = analyzeAST ast 127 | canon = canonRoot aa 128 | nts = reverse $ nmap fixSCC $ stronglyConnComp $ ntGraph aa 129 | -------------------------------------------------------------------------------- /src/ComputationMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | {- | This module implements the errors and monads that are used to 7 | structure many of the computations in this program. -} 8 | 9 | module ComputationMonad where 10 | 11 | import Control.Monad.Except 12 | import Control.Monad.Fail() 13 | import Control.Monad.State 14 | import Data.Map ( Map ) 15 | import qualified Data.Map as Map 16 | import Text.ParserCombinators.Parsec ( SourcePos ) 17 | 18 | import AST 19 | import MyLibrary ( getResult, sepStrings ) 20 | 21 | 22 | {- ----------------------------------------------------------------------- -} 23 | {- * \"Global state\" -} 24 | 25 | {- | Datatype for command-line flags. -} 26 | 27 | data ProgFlag 28 | = CoqAdmitted -- ^ Do not generate proofs. 29 | | CoqLoadPath String -- ^ The path component of the LoadPath declaration. 30 | | CoqOtt String -- ^ Name of the library to @Require@ in generated output. 31 | | CoqOutput String -- ^ Destination for output. 32 | | CoqStdout -- ^ Send output to standard out. 33 | | CoqNoLCSet -- ^ Suppress the Set version of Local Closure. 34 | | CoqNoClose -- ^ Suppress generation of close and close_rec. 35 | | Help -- ^ Display usage information. 36 | deriving ( Eq ) 37 | 38 | 39 | {- ----------------------------------------------------------------------- -} 40 | {- * Errors -} 41 | 42 | {- | This is the datatype for all errors that might be generated in 43 | the course of this program's execution. The 'Show' instance for 44 | the datatype defines the meaning of the errors. They are all fatal 45 | errors, in the sense that there are no guarantees about the 46 | validity of any proof assistant output that might be output from 47 | this program. -} 48 | 49 | data ProgramError 50 | -- Errors encountered while traversing an AST or PreAST. 51 | = ASTDupBinderL UnknownSym 52 | | ASTDupBinderR UnknownSym 53 | | ASTDupElt UnknownSym 54 | | ASTDupRoots SourcePos [Root] 55 | | ASTNotMv UnknownSym 56 | | ASTNotNt UnknownSym 57 | | ASTUnknownVar UnknownSym 58 | 59 | -- Errors encountered during AST analysis. 60 | | AmbiguousMvSort SourcePos MvRoot [NtRoot] 61 | | NoMvSort SourcePos MvRoot 62 | | NonBindingMv SourcePos 63 | 64 | -- An unknown, or generic, error. 65 | | GenericError String 66 | 67 | instance Show ProgramError where 68 | -- Errors encountered during AST sanity checking. 69 | show (ASTDupBinderL v) = toPosS v ++ ": " ++ show v ++ " already binds in something" 70 | show (ASTDupBinderR v) = toPosS v ++ ": " ++ show v ++ " already has a binder" 71 | show (ASTDupElt v) = toPosS v ++ ": " ++ show v ++ " is already defined in this production" 72 | show (ASTDupRoots pos rs) = show pos ++ ": " ++ (sepStrings ", " rs) ++ " is/are already defined" 73 | show (ASTNotMv v) = toPosS v ++ ": " ++ show v ++ " is not a metavariable" 74 | show (ASTNotNt v) = toPosS v ++ ": " ++ show v ++ " is not a nonterminal" 75 | show (ASTUnknownVar v) = toPosS v ++ ": " ++ show v ++ " is not in scope" 76 | 77 | -- Errors encountered during AST analysis. 78 | show (AmbiguousMvSort pos mv nts) = show pos ++ ": Ambiguous type for " ++ show mv ++ ": " ++ sepStrings ", " nts ++ "." 79 | show (NoMvSort pos mv) = show pos ++ ": No discernable type for " ++ show mv ++ "." 80 | show (NonBindingMv pos) = show pos ++ ": Production has a non-binding metavariable." 81 | 82 | -- An unknown, or generic, error. 83 | show (GenericError s) = "Error: " ++ s 84 | 85 | 86 | {- ----------------------------------------------------------------------- -} 87 | {- * Combining error and state -} 88 | 89 | {- | The following monad allows to program in the presence of errors 90 | ('ProgramError') while maintaining state. The idea is that 91 | generated names take the form \"root + integer suffix\". The map 92 | in the state keeps track of the most recent suffix that was handed 93 | out. -} 94 | 95 | newtype M a = M { getM :: ExceptT ProgramError (State ([ProgFlag], Map String Int)) a } 96 | deriving (Functor, Applicative, Monad, MonadError ProgramError, MonadState ([ProgFlag], Map String Int)) 97 | 98 | 99 | instance MonadFail M where 100 | fail s = throwError (GenericError s) 101 | 102 | {- | Runs a computation that lives in 'M'. -} 103 | 104 | runM :: [ProgFlag] -> M a -> a 105 | runM flags = 106 | getResult . fst . flip runState (flags, Map.empty) . runExceptT . getM 107 | 108 | {- | Another name for 'throwError'. -} 109 | 110 | abort :: (MonadError e m) => e -> m a 111 | abort = throwError 112 | 113 | {- | Saves the current state, does the given computation, and then 114 | restores the saved state. The result returned is that of the given 115 | computation. 'M' is a suitable monad here. -} 116 | 117 | local :: (MonadState s m) => m a -> m a 118 | local comp = 119 | do { s <- get 120 | ; res <- comp 121 | ; put s 122 | ; return res 123 | } 124 | 125 | {- | Computes a new name with the given root string. 'M' is a 126 | suitable monad here. -} 127 | 128 | newName :: (Show t, Num t, MonadState (b, Map String t) m) => String -> m String 129 | newName r = 130 | do { (b, m) <- get 131 | ; let i = Map.findWithDefault 1 r m 132 | ; put (b, Map.insert r (i+1) m) 133 | ; return $ r ++ show i 134 | } 135 | 136 | {- | Reset the map so that it is empty. 'M' is a suitable monad here. 137 | With respect to fresh name generation, it will be as if no names 138 | have ever been generated. -} 139 | 140 | reset :: (MonadState (b, Map k a) m) => m () 141 | reset = 142 | do { (b, _) <- get 143 | ; put (b, Map.empty) 144 | } 145 | 146 | {- | Check whether to not generate lc set -} 147 | nolcset :: [ProgFlag] -> Bool 148 | nolcset = elem CoqNoLCSet 149 | 150 | {- | Check whether to not generate close -} 151 | noclose :: [ProgFlag] -> Bool 152 | noclose = elem CoqNoClose 153 | -------------------------------------------------------------------------------- /src/CoqLNOutputThmOpenClose2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# OPTIONS_GHC -freduction-depth=50 #-} 3 | 4 | module CoqLNOutputThmOpenClose2 where 5 | 6 | import Text.Printf ( printf ) 7 | 8 | import AST 9 | import ASTAnalysis 10 | import ComputationMonad 11 | import CoqLNOutputCommon 12 | import CoqLNOutputCombinators 13 | 14 | openCloseThms2 :: ASTAnalysis -> [[NtRoot]] -> M String 15 | openCloseThms2 aa nts = 16 | do { close_degree_recs <- mapM (local . close_degree_rec aa) nts 17 | ; close_lcs <- mapM (local . close_lc aa) nts 18 | ; open_degree_recs <- mapM (local . open_degree_rec aa) nts 19 | ; open_lcs <- mapM (local . open_lc aa) nts 20 | ; return $ printf "Ltac %s ::= auto with %s; tauto.\n\ 21 | \Ltac %s ::= fail.\n\ 22 | \\n" 23 | defaultAuto hintDb 24 | defaultAutoRewr ++ 25 | concat close_degree_recs ++ 26 | concat close_lcs ++ 27 | concat open_degree_recs ++ 28 | concat open_lcs ++ "\n" 29 | } 30 | 31 | {- | @close_rec k x e = e@ when @degree k e@ and @x `notin` fv e@. -} 32 | 33 | close_degree_rec :: ASTAnalysis -> [NtRoot] -> M String 34 | close_degree_rec aaa nt1s = 35 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 36 | ; names <- processNt1Nt2Mv2 aaa nt1s name 37 | ; types <- processNt1 aaa nt1s ntType 38 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 39 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 40 | } 41 | where 42 | name aa nt1 _ mv2 = 43 | do { close_fn <- closeRecName aa nt1 mv2 44 | ; degree <- degreeName aa nt1 mv2 45 | ; return $ close_fn ++ "_" ++ degree 46 | } 47 | 48 | thm aa nt1 _ mv2 = 49 | do { close_fn <- closeRecName aa nt1 mv2 50 | ; degree <- degreeName aa nt1 mv2 51 | ; fv_fn <- fvName aa nt1 mv2 52 | ; e <- newName nt1 53 | ; x <- newName mv2 54 | ; k <- newName bvarRoot 55 | ; return $ printf "forall %s %s %s,\n\ 56 | \ %s %s %s ->\n\ 57 | \ %s %s %s %s ->\n\ 58 | \ %s %s %s %s = %s" 59 | e x k 60 | degree k e 61 | x mvSetNotin fv_fn e 62 | close_fn k x e e 63 | } 64 | 65 | {- | @close x e = e@ when @lc e@ and @x `notin` fv e@. -} 66 | 67 | close_lc :: ASTAnalysis -> [NtRoot] -> M String 68 | close_lc aaa nt1s = 69 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 70 | ; names <- processNt1Nt2Mv2 aaa nt1s name 71 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 72 | } 73 | where 74 | name aa nt1 _ mv2 = 75 | do { close_fn <- closeName aa nt1 mv2 76 | ; lc <- lcName aa nt1 77 | ; return $ close_fn ++ "_" ++ lc 78 | } 79 | 80 | gen aa nt1 _ mv2 = 81 | do { close_fn <- closeName aa nt1 mv2 82 | ; lc <- lcName aa nt1 83 | ; fv_fn <- fvName aa nt1 mv2 84 | ; e <- newName nt1 85 | ; x <- newName mv2 86 | ; let stmt = printf "forall %s %s,\n\ 87 | \ %s %s ->\n\ 88 | \ %s %s %s %s ->\n\ 89 | \ %s %s %s = %s" 90 | e x 91 | lc e 92 | x mvSetNotin fv_fn e 93 | close_fn x e e 94 | ; let proof = printf "unfold %s; %s." close_fn defaultSimp 95 | ; return (stmt, proof) 96 | } 97 | 98 | {- | @open_rec n u e = e@ when @degree n e@. -} 99 | 100 | open_degree_rec :: ASTAnalysis -> [NtRoot] -> M String 101 | open_degree_rec aaa nt1s = 102 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 103 | ; names <- processNt1Nt2Mv2 aaa nt1s name 104 | ; types <- processNt1 aaa nt1s ntType 105 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 106 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 107 | } 108 | where 109 | name aa nt1 _ mv2 = 110 | do { open_fn <- openRecName aa nt1 mv2 111 | ; degree <- degreeName aa nt1 mv2 112 | ; return $ open_fn ++ "_" ++ degree 113 | } 114 | 115 | thm aa nt1 nt2 mv2 = 116 | do { open_fn <- openRecName aa nt1 mv2 117 | ; degree <- degreeName aa nt1 mv2 118 | ; n <- newName bvarRoot 119 | ; u <- newName nt2 120 | ; e <- newName nt1 121 | ; return $ printf "forall %s %s %s,\n\ 122 | \ %s %s %s ->\n\ 123 | \ %s %s %s %s = %s" 124 | e u n 125 | degree n e 126 | open_fn n u e e 127 | } 128 | 129 | 130 | {- | @open u e = e@ when @lc e@. -} 131 | 132 | open_lc :: ASTAnalysis -> [NtRoot] -> M String 133 | open_lc aaa nt1s = 134 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 135 | ; names <- processNt1Nt2Mv2 aaa nt1s name 136 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 137 | } 138 | where 139 | name aa nt1 _ mv2 = 140 | do { open_fn <- openName aa nt1 mv2 141 | ; lc <- lcName aa nt1 142 | ; return $ open_fn ++ "_" ++ lc 143 | } 144 | 145 | gen aa nt1 nt2 mv2 = 146 | do { open_fn <- openName aa nt1 mv2 147 | ; lc <- lcName aa nt1 148 | ; u <- newName nt2 149 | ; e <- newName nt1 150 | -- ORDER TO OPEN 151 | ; let stmt = printf "forall %s %s,\n\ 152 | \ %s %s ->\n\ 153 | \ %s %s %s = %s" 154 | e u 155 | lc e 156 | open_fn e u e 157 | ; let proof = printf "unfold %s; %s." open_fn defaultSimp 158 | ; return (stmt, proof) 159 | } 160 | -------------------------------------------------------------------------------- /examples/Fsub/Fsub.ott: -------------------------------------------------------------------------------- 1 | metavar typvar, X, Y, Z ::= {{ repr-locally-nameless }} 2 | metavar expvar, x, y, z ::= {{ repr-locally-nameless }} 3 | 4 | grammar 5 | 6 | typ, T, S, U :: typ_ ::= 7 | | top :: :: top 8 | | X :: :: var 9 | | T1 -> T2 :: :: arrow 10 | | \ X <: T1 . T2 :: :: all (+ bind X in T2 +) 11 | | T1 + T2 :: :: sum 12 | | ( T ) :: S :: paren {{ coq ([[T]]) }} 13 | | { T2 / X } T1 :: M :: subst {{ coq (open_typ_wrt_typ [[X T1]] [[T2]]) }} 14 | 15 | exp, e, f, g :: exp_ ::= 16 | | x :: :: var 17 | | \ x : T . e :: :: abs (+ bind x in e +) 18 | | e1 e2 :: :: app 19 | | \ X <: T . e :: :: tabs (+ bind X in e +) 20 | | e [ T ] :: :: tapp 21 | | let x = e1 in e2 :: :: let (+ bind x in e2 +) 22 | | inl e :: :: inl 23 | | inr e :: :: inr 24 | | case e of inl x -> e2 | inr y -> e3 :: :: case (+ bind x in e2 +) (+ bind y in e3 +) 25 | | ( e ) :: S :: paren {{ coq ([[e]]) }} 26 | | { e2 / x } e1 :: M :: subst1 {{ coq (open_exp_wrt_exp [[x e1]] [[e2]]) }} 27 | | { T2 / X } e1 :: M :: subst2 {{ coq (open_exp_wrt_typ [[X e1]] [[T2]]) }} 28 | 29 | binding, b :: bind_ ::= 30 | | <: T :: :: sub 31 | | : T :: :: typ 32 | 33 | substitutions 34 | single T X :: subst_typ_in 35 | single e x :: subst_exp_in 36 | 37 | freevars 38 | T X :: fv_typ_in 39 | e x :: fv_exp_in 40 | 41 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 42 | 43 | grammar 44 | 45 | env, E, F, G:: '' ::= {{ coq list (atom*binding) }} 46 | | empty :: :: empty {{ coq nil }} 47 | | E , x b :: :: cons1 {{ coq ([[x]]~[[b]] ++ [[E]]) }} 48 | | E , X b :: :: cons2 {{ coq ([[X]]~[[b]] ++ [[E]]) }} 49 | 50 | value, v :: value_ ::= 51 | | \ x : T . e :: :: abs (+ bind x in e +) 52 | | \ X <: T . e :: :: tabs (+ bind X in e +) 53 | | inl v :: :: inl 54 | | inr v :: :: inr 55 | 56 | formula :: formula_ ::= 57 | | judgement :: :: judgement 58 | | ( x b ) in E :: :: binds1 {{ coq binds ([[x]]) ([[b]]) ([[E]]) }} 59 | | ( X b ) in E :: :: binds2 {{ coq binds ([[X]]) ([[b]]) ([[E]]) }} 60 | | uniq E :: :: uniq {{ coq uniq ([[E]]) }} 61 | | x `notin` dom E :: :: fresh1 {{ coq ([[x]] `notin` dom ([[E]])) }} 62 | | X `notin` dom E :: :: fresh2 {{ coq ([[X]] `notin` dom ([[E]])) }} 63 | 64 | subrules 65 | v <:: e 66 | 67 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 68 | 69 | defns 70 | Jwf_typ :: '' ::= 71 | 72 | defn 73 | E |- T :: :: wf_typ :: 'wf_typ_' by 74 | 75 | --------- :: top 76 | E |- top 77 | 78 | (X <: U) in E 79 | -------------- :: var 80 | E |- X 81 | 82 | E |- T1 83 | E |- T2 84 | -------------- :: arrow 85 | E |- T1 -> T2 86 | 87 | E |- T1 88 | E, X <: T1 |- T2 89 | -------------------- :: all 90 | E |- \ X <: T1 . T2 91 | 92 | E |- T1 93 | E |- T2 94 | ------------- :: sum 95 | E |- T1 + T2 96 | 97 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 98 | 99 | defns 100 | Jwf_env :: '' ::= 101 | 102 | defn 103 | |- E :: :: wf_env :: 'wf_env_' by 104 | 105 | --------- :: empty 106 | |- empty 107 | 108 | |- E 109 | E |- T 110 | X `notin` dom E 111 | ---------------- :: sub 112 | |- E , X <: T 113 | 114 | |- E 115 | E |- T 116 | x `notin` dom E 117 | ---------------- :: typ 118 | |- E , x : T 119 | 120 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 121 | 122 | defns 123 | Jsub :: '' ::= 124 | 125 | defn 126 | E |- T1 <: T2 :: :: sub :: 'sub_' by 127 | 128 | |- E 129 | E |- S 130 | -------------- :: top 131 | E |- S <: top 132 | 133 | |- E 134 | E |- X 135 | ------------ :: refl_tvar 136 | E |- X <: X 137 | 138 | (X <: U) in E 139 | E |- U <: T 140 | -------------- :: trans_tvar 141 | E |- X <: T 142 | 143 | E |- T1 <: S1 144 | E |- S2 <: T2 145 | -------------------------- :: arrow 146 | E |- S1 -> S2 <: T1 -> T2 147 | 148 | E |- T1 <: S1 149 | E, X <: T1 |- S2 <: T2 150 | ---------------------------- :: all 151 | E |- \X<:S1.S2 <: \X<:T1.T2 152 | 153 | E |- S1 <: T1 154 | E |- S2 <: T2 155 | ------------------------ :: sum 156 | E |- S1 + S2 <: T1 + T2 157 | 158 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 159 | 160 | defns 161 | Jtyping :: '' ::= 162 | 163 | defn 164 | E |- e : T :: :: typing :: 'typing_' by 165 | 166 | |- E 167 | (x:T) in E 168 | ----------- :: var 169 | E |- x : T 170 | 171 | E, x : T1 |- e : T2 172 | --------------------------- :: abs 173 | E |- \x : T1. e : T1 -> T2 174 | 175 | E |- e1 : T1 -> T2 176 | E |- e2 : T1 177 | --------------------- :: app 178 | E |- e1 e2 : T2 179 | 180 | E, X <: T1 |- e : T2 181 | -------------------------- :: tabs 182 | E |- \X<:T1.e : \X<:T1.T2 183 | 184 | E |- e1 : \X<:T1.T2 185 | E |- T <: T1 186 | --------------------------- :: tapp 187 | E |- e1 [ T ] : {T / X} T2 188 | 189 | E |- e : S 190 | E |- S <: T 191 | ------------ :: sub 192 | E |- e : T 193 | 194 | E |- e1 : T1 195 | E, x : T1 |- e2 : T2 196 | --------------------------- :: let 197 | E |- let x = e1 in e2 : T2 198 | 199 | E |- e1 : T1 200 | E |- T2 201 | ---------------------- :: inl 202 | E |- inl e1 : T1 + T2 203 | 204 | E |- e1 : T2 205 | E |- T1 206 | ---------------------- :: inr 207 | E |- inr e1 : T1 + T2 208 | 209 | E |- e1 : T1 + T2 210 | E, x : T1 |- e2 : T 211 | E, y : T2 |- e3 : T 212 | ---------------------------------------------- :: case 213 | E |- case e1 of inl x -> e2 | inr y -> e3 : T 214 | 215 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 216 | 217 | defns 218 | Jop :: '' ::= 219 | 220 | defn 221 | e1 --> e2 :: :: red :: 'red_' by 222 | 223 | e1 --> e1' 224 | ----------------- :: app_1 225 | e1 e2 --> e1' e2 226 | 227 | e2 --> e2' 228 | ----------------- :: app_2 229 | v1 e2 --> v1 e2' 230 | 231 | e1 --> e1' 232 | ----------------------- :: tapp_1 233 | e1 [ T ] --> e1' [ T ] 234 | 235 | ------------------------------- :: abs 236 | (\x:T. e1) v2 --> {v2 / x} e1 237 | 238 | ------------------------------------ :: tabs 239 | (\X<:T1. e1) [ T2 ] --> {T2 / X} e1 240 | 241 | e1 --> e1' 242 | --------------------------------------- :: let_1 243 | let x = e1 in e2 --> let x = e1' in e2 244 | 245 | --------------------------------- :: let 246 | let x = v1 in e2 --> {v1 / x} e2 247 | 248 | e1 --> e1' 249 | ------------------- :: inl_1 250 | inl e1 --> inl e1' 251 | 252 | e1 --> e1' 253 | ------------------- :: inr_1 254 | inr e1 --> inr e1' 255 | 256 | e1 --> e1' 257 | ------------------------------------------------------------------------------- :: case_1 258 | case e1 of inl x -> e2 | inr y -> e3 --> case e1' of inl x -> e2 | inr y -> e3 259 | 260 | --------------------------------------------------------- :: case_inl 261 | case inl v1 of inl x -> e2 | inr y -> e3 --> {v1 / x} e2 262 | 263 | --------------------------------------------------------- :: case_inr 264 | case inr v1 of inl x -> e2 | inr y -> e3 --> {v1 / y} e3 265 | -------------------------------------------------------------------------------- /src/CoqLNOutputCombinators.hs: -------------------------------------------------------------------------------- 1 | {- | This module defines a collection of combinators for looping over 2 | nonterminals and metavariables, as well as for assembling output 3 | for Coq. -} 4 | 5 | module CoqLNOutputCombinators where 6 | 7 | import Control.Monad.State 8 | import Text.Printf ( printf ) 9 | 10 | import AST 11 | import ASTAnalysis 12 | import ComputationMonad 13 | import CoqLNOutputCommon 14 | import MyLibrary ( sepStrings ) 15 | 16 | 17 | {- ----------------------------------------------------------------------- -} 18 | {- * Generating text for lemmas -} 19 | 20 | {- Flag for Coq's sorts. -} 21 | 22 | data Sort = Prop | Set 23 | 24 | instance Show Sort where 25 | show Prop = "Prop" 26 | show Set = "Set" 27 | 28 | {- Flag indicating what sort of @Resolve@ hint to generate. -} 29 | 30 | data ResolveHint = NoResolve | Resolve | Immediate 31 | 32 | {- Flag indicating what sort of @Rewrite@ hint to generate. -} 33 | 34 | data RewriteHint = NoRewrite | Rewrite 35 | 36 | {- Flag indicating whether to generate @hide@ directives for @coqdoc@. -} 37 | 38 | data DocHide = NoHide | Hide 39 | 40 | {- Basic combinator for generating the text of a lemma declaration. -} 41 | 42 | lemmaText :: ResolveHint -- Resolve hint? 43 | -> RewriteHint -- Rewrite hint? 44 | -> DocHide -- Hide documentation? 45 | -> [String] -- Hint databases. 46 | -> String -- Name of the lemma 47 | -> String -- Statment of the lemma 48 | -> String -- Proof of the lemma 49 | -> M String 50 | lemmaText resolve rewrite hide dbs name stmt proof = 51 | do { (flags, _) <- get 52 | ; return $ printf "%s\ 53 | \Lemma %s :\n\ 54 | \%s.\n\ 55 | \%s\ 56 | \%s%s%s%s" 57 | (case hide of 58 | NoHide -> "" 59 | Hide -> "(* begin hide *)\n\n") 60 | name 61 | stmt 62 | (if CoqAdmitted `elem` flags 63 | then "Proof. Admitted.\n\n" 64 | else printf "Proof.\n\ 65 | \%s\n\ 66 | \Qed.\n\ 67 | \\n" 68 | proof) 69 | (case resolve of 70 | NoResolve -> "" 71 | Resolve -> printf "#[export] Hint Resolve %s : %s.\n" name (sepStrings " " dbs) 72 | Immediate -> printf "#[export] Hint Immediate %s : %s.\n" name (sepStrings " " dbs)) 73 | (case rewrite of 74 | NoRewrite -> "" 75 | Rewrite -> printf "#[export] Hint Rewrite %s using solve [auto] : %s.\n" name (sepStrings " " dbs)) 76 | (case (resolve, rewrite) of 77 | (NoResolve, NoRewrite) -> "" 78 | _ -> "\n") 79 | (case hide of 80 | NoHide -> "" 81 | Hide -> "(* end hide *)\n\n") 82 | } 83 | 84 | {- Basic combinator for generating the text of a lemma declaration. -} 85 | 86 | lemmaText2 :: ResolveHint -- Resolve hint? 87 | -> RewriteHint -- Rewrite hint? 88 | -> DocHide -- Hide documentation? 89 | -> [String] -- Hint databases. 90 | -> [[String]] -- Names for the parts. 91 | -> [[(String, String)]] -- Statments and proofs for the parts. 92 | -> M String 93 | lemmaText2 resolve rewrite hide dbs names gens = 94 | do { strs <- mapM (\(name, (stmt, pf)) -> 95 | lemmaText resolve rewrite hide dbs name stmt pf) 96 | (zip (concat names) (concat gens)) 97 | ; return $ concat strs 98 | } 99 | 100 | {- Combinator used for generating the text of a lemma proved by mutual 101 | induction/recursion. -} 102 | 103 | mutualLemmaText :: ResolveHint -- Resolve hint? 104 | -> RewriteHint -- Rewrite hint? 105 | -> DocHide -- Hide documentation? 106 | -> [String] -- Hint databases. 107 | -> Sort -- Sort 108 | -> [String] -- Names for the parts. 109 | -> [String] -- Statments for the parts. 110 | -> String -- Proof of the lemma. 111 | -> M String 112 | mutualLemmaText resolve rewrite hide dbs sort names stmts proof = 113 | do { let mut_name = sepStrings "_" names ++ "_mutual" 114 | mut_stmts = combine sort $ map wrap stmts 115 | cproof = printf "pose proof %s as H; intuition eauto." mut_name 116 | ; lemma <- lemmaText NoResolve NoRewrite Hide dbs mut_name mut_stmts proof 117 | ; corollaries <- mapM (\(name, stmt) -> 118 | lemmaText resolve rewrite hide dbs name stmt cproof) 119 | (zip names stmts) 120 | ; return $ lemma ++ concat corollaries 121 | } 122 | where 123 | combine Set = sepStrings " *\n" 124 | combine Prop = sepStrings " /\\\n" 125 | wrap str = printf "(%s)" str 126 | 127 | {- Combinator used for generating the text of a lemma proved by mutual 128 | induction/recursion. -} 129 | 130 | mutualLemmaText2 :: ResolveHint -- Resolve hint? 131 | -> RewriteHint -- Rewrite hint? 132 | -> DocHide -- Hide documentation? 133 | -> [String] -- Hint databases. 134 | -> Sort -- Sort 135 | -> [[String]] -- Names for the parts. 136 | -> [[String]] -- Statments for the parts. 137 | -> [String] -- Proof of the lemma. 138 | -> M String 139 | mutualLemmaText2 resolve rewrite hide dbs sort names stmts proof = 140 | do { strs <- mapM (\(name, stmt, pf) -> 141 | mutualLemmaText resolve rewrite hide dbs sort name stmt pf) 142 | (zip3 names stmts proof) 143 | ; return $ concat strs 144 | } 145 | 146 | {- Combinator used to generate the application of the mutual 147 | induction/recursion principle. -} 148 | 149 | mutPfStart :: Sort 150 | -> [Name] -- Names of types. 151 | -> String 152 | mutPfStart s ns = f (case s of { Prop -> mutIndName ; Set -> mutRecName }) 153 | where 154 | f g = printf "%s %s;\n" applyMutInd (g ns) 155 | 156 | 157 | {- ----------------------------------------------------------------------- -} 158 | {- * Looping patterns -} 159 | 160 | {- Combinator used to loop over a set of @nt1s@. -} 161 | 162 | processNt1 :: ASTAnalysis 163 | -> [NtRoot] 164 | -> (ASTAnalysis -> NtRoot -> M a) 165 | -> M [a] 166 | processNt1 aa nt1s f = mapM (local . f aa) nt1s 167 | 168 | {- Combinator used to loop over @(nt1, nt2, mv2)@ triples. -} 169 | 170 | processNt1Nt2Mv2 :: ASTAnalysis 171 | -> [NtRoot] 172 | -> (ASTAnalysis -> NtRoot -> NtRoot -> MvRoot -> M a) 173 | -> M [[a]] 174 | processNt1Nt2Mv2 aa nt1s f = 175 | sequence $ 176 | do { nt2 <- filter (canBindOver aa (head nt1s)) (ntRoots aa) 177 | ; mv2 <- mvsOfNt aa nt2 178 | ; return $ sequence $ do { nt1 <- nt1s 179 | ; return (local $ f aa nt1 nt2 mv2) 180 | } 181 | } 182 | 183 | {- Combinator used to loop over @(nt1, nt2, mv2, nt2', mv2')@ tuples. -} 184 | 185 | processNt1Nt2Mv2' :: ASTAnalysis 186 | -> [NtRoot] 187 | -> (ASTAnalysis -> NtRoot -> NtRoot -> MvRoot -> NtRoot -> MvRoot -> M a) 188 | -> M [[a]] 189 | processNt1Nt2Mv2' aa nt1s f = 190 | sequence $ 191 | do { nt2 <- filter (canBindOver aa (head nt1s)) (ntRoots aa) 192 | ; mv2 <- mvsOfNt aa nt2 193 | ; nt2' <- filter (canBindOver aa (head nt1s)) (ntRoots aa) 194 | ; mv2' <- mvsOfNt aa nt2' 195 | ; return $ sequence $ do { nt1 <- nt1s 196 | ; return (local $ f aa nt1 nt2 mv2 nt2' mv2') 197 | } 198 | } 199 | -------------------------------------------------------------------------------- /examples/LF_hhp93/LF_hhp93_ott.v: -------------------------------------------------------------------------------- 1 | (* generated by Ott 0.32, locally-nameless lngen from: LF_hhp93.ott *) 2 | Require Import Metalib.Metatheory. 3 | (** syntax *) 4 | Definition family_constant : Set := atom. 5 | Definition object_constant : Set := atom. 6 | 7 | Inductive family : Set := 8 | | family_const (a:family_constant) 9 | | family_pi (A:family) (B:family) 10 | | family_abs (A:family) (B:family) 11 | | family_app (A:family) (M:object) 12 | with object : Set := 13 | | object_const (c:object_constant) 14 | | object_var_b (_:nat) 15 | | object_var_f (x:var) 16 | | object_abs (A:family) (M:object) 17 | | object_app (M:object) (N:object). 18 | 19 | Inductive kind : Set := 20 | | kind_type : kind 21 | | kind_pi (A:family) (K:kind). 22 | 23 | (* EXPERIMENTAL *) 24 | (** auxiliary functions on the new list types *) 25 | (** library functions *) 26 | (** subrules *) 27 | (** arities *) 28 | (** opening up abstractions *) 29 | Fixpoint open_object_wrt_object_rec (k:nat) (M5:object) (M_6:object) {struct M_6}: object := 30 | match M_6 with 31 | | (object_const c) => object_const c 32 | | (object_var_b nat) => 33 | match lt_eq_lt_dec nat k with 34 | | inleft (left _) => object_var_b nat 35 | | inleft (right _) => M5 36 | | inright _ => object_var_b (nat - 1) 37 | end 38 | | (object_var_f x) => object_var_f x 39 | | (object_abs A M) => object_abs (open_family_wrt_object_rec k M5 A) (open_object_wrt_object_rec (S k) M5 M) 40 | | (object_app M N) => object_app (open_object_wrt_object_rec k M5 M) (open_object_wrt_object_rec k M5 N) 41 | end 42 | with open_family_wrt_object_rec (k:nat) (M5:object) (A5:family) {struct A5}: family := 43 | match A5 with 44 | | (family_const a) => family_const a 45 | | (family_pi A B) => family_pi (open_family_wrt_object_rec k M5 A) (open_family_wrt_object_rec (S k) M5 B) 46 | | (family_abs A B) => family_abs (open_family_wrt_object_rec k M5 A) (open_family_wrt_object_rec (S k) M5 B) 47 | | (family_app A M) => family_app (open_family_wrt_object_rec k M5 A) (open_object_wrt_object_rec k M5 M) 48 | end. 49 | 50 | Fixpoint open_kind_wrt_object_rec (k:nat) (M5:object) (K5:kind) {struct K5}: kind := 51 | match K5 with 52 | | kind_type => kind_type 53 | | (kind_pi A K) => kind_pi (open_family_wrt_object_rec k M5 A) (open_kind_wrt_object_rec (S k) M5 K) 54 | end. 55 | 56 | Definition open_kind_wrt_object M5 K5 := open_kind_wrt_object_rec 0 K5 M5. 57 | 58 | Definition open_family_wrt_object M5 A5 := open_family_wrt_object_rec 0 A5 M5. 59 | 60 | Definition open_object_wrt_object M5 M_6 := open_object_wrt_object_rec 0 M_6 M5. 61 | 62 | (** closing up abstractions *) 63 | Fixpoint close_object_wrt_object_rec (k:nat) (M5:var) (M_6:object) {struct M_6}: object := 64 | match M_6 with 65 | | (object_const c) => object_const c 66 | | (object_var_b nat) => 67 | if (lt_dec nat k) 68 | then object_var_b nat 69 | else object_var_b (S nat) 70 | | (object_var_f x) => if (M5 === x) then (object_var_b k) else (object_var_f x) 71 | | (object_abs A M) => object_abs (close_family_wrt_object_rec k M5 A) (close_object_wrt_object_rec (S k) M5 M) 72 | | (object_app M N) => object_app (close_object_wrt_object_rec k M5 M) (close_object_wrt_object_rec k M5 N) 73 | end 74 | with close_family_wrt_object_rec (k:nat) (M5:var) (A5:family) {struct A5}: family := 75 | match A5 with 76 | | (family_const a) => family_const a 77 | | (family_pi A B) => family_pi (close_family_wrt_object_rec k M5 A) (close_family_wrt_object_rec (S k) M5 B) 78 | | (family_abs A B) => family_abs (close_family_wrt_object_rec k M5 A) (close_family_wrt_object_rec (S k) M5 B) 79 | | (family_app A M) => family_app (close_family_wrt_object_rec k M5 A) (close_object_wrt_object_rec k M5 M) 80 | end. 81 | 82 | Fixpoint close_kind_wrt_object_rec (k:nat) (M5:var) (K5:kind) {struct K5}: kind := 83 | match K5 with 84 | | kind_type => kind_type 85 | | (kind_pi A K) => kind_pi (close_family_wrt_object_rec k M5 A) (close_kind_wrt_object_rec (S k) M5 K) 86 | end. 87 | 88 | Definition close_kind_wrt_object K5 M5 := close_kind_wrt_object_rec 0 K5 M5. 89 | 90 | Definition close_family_wrt_object A5 M5 := close_family_wrt_object_rec 0 A5 M5. 91 | 92 | Definition close_object_wrt_object M_6 M5 := close_object_wrt_object_rec 0 M_6 M5. 93 | 94 | (** terms are locally-closed pre-terms *) 95 | (** definitions *) 96 | 97 | (* defns LC_object_family *) 98 | Inductive lc_object : object -> Prop := (* defn lc_object *) 99 | | lc_object_const : forall (c:object_constant), 100 | (lc_object (object_const c)) 101 | | lc_object_var_f : forall (x:var), 102 | (lc_object (object_var_f x)) 103 | | lc_object_abs : forall (A:family) (M:object), 104 | (lc_family A) -> 105 | ( forall x , lc_object ( open_object_wrt_object M (object_var_f x) ) ) -> 106 | (lc_object (object_abs A M)) 107 | | lc_object_app : forall (M N:object), 108 | (lc_object M) -> 109 | (lc_object N) -> 110 | (lc_object (object_app M N)) 111 | with lc_family : family -> Prop := (* defn lc_family *) 112 | | lc_family_const : forall (a:family_constant), 113 | (lc_family (family_const a)) 114 | | lc_family_pi : forall (A B:family), 115 | (lc_family A) -> 116 | ( forall x , lc_family ( open_family_wrt_object B (object_var_f x) ) ) -> 117 | (lc_family (family_pi A B)) 118 | | lc_family_abs : forall (A B:family), 119 | (lc_family A) -> 120 | ( forall x , lc_family ( open_family_wrt_object B (object_var_f x) ) ) -> 121 | (lc_family (family_abs A B)) 122 | | lc_family_app : forall (A:family) (M:object), 123 | (lc_family A) -> 124 | (lc_object M) -> 125 | (lc_family (family_app A M)). 126 | 127 | (* defns LC_kind *) 128 | Inductive lc_kind : kind -> Prop := (* defn lc_kind *) 129 | | lc_kind_type : 130 | (lc_kind kind_type) 131 | | lc_kind_pi : forall (A:family) (K:kind), 132 | (lc_family A) -> 133 | ( forall x , lc_kind ( open_kind_wrt_object K (object_var_f x) ) ) -> 134 | (lc_kind (kind_pi A K)). 135 | (** free variables *) 136 | Fixpoint fv_object (M5:object) : vars := 137 | match M5 with 138 | | (object_const c) => {} 139 | | (object_var_b nat) => {} 140 | | (object_var_f x) => {{x}} 141 | | (object_abs A M) => (fv_family A) \u (fv_object M) 142 | | (object_app M N) => (fv_object M) \u (fv_object N) 143 | end 144 | with fv_family (A5:family) : vars := 145 | match A5 with 146 | | (family_const a) => {} 147 | | (family_pi A B) => (fv_family A) \u (fv_family B) 148 | | (family_abs A B) => (fv_family A) \u (fv_family B) 149 | | (family_app A M) => (fv_family A) \u (fv_object M) 150 | end. 151 | 152 | Fixpoint fv_kind (K5:kind) : vars := 153 | match K5 with 154 | | kind_type => {} 155 | | (kind_pi A K) => (fv_family A) \u (fv_kind K) 156 | end. 157 | 158 | (** substitutions *) 159 | Fixpoint subst_object (M5:object) (x5:var) (M_6:object) {struct M_6} : object := 160 | match M_6 with 161 | | (object_const c) => object_const c 162 | | (object_var_b nat) => object_var_b nat 163 | | (object_var_f x) => (if eq_var x x5 then M5 else (object_var_f x)) 164 | | (object_abs A M) => object_abs (subst_family M5 x5 A) (subst_object M5 x5 M) 165 | | (object_app M N) => object_app (subst_object M5 x5 M) (subst_object M5 x5 N) 166 | end 167 | with subst_family (M5:object) (x5:var) (A5:family) {struct A5} : family := 168 | match A5 with 169 | | (family_const a) => family_const a 170 | | (family_pi A B) => family_pi (subst_family M5 x5 A) (subst_family M5 x5 B) 171 | | (family_abs A B) => family_abs (subst_family M5 x5 A) (subst_family M5 x5 B) 172 | | (family_app A M) => family_app (subst_family M5 x5 A) (subst_object M5 x5 M) 173 | end. 174 | 175 | Fixpoint subst_kind (M5:object) (x5:var) (K5:kind) {struct K5} : kind := 176 | match K5 with 177 | | kind_type => kind_type 178 | | (kind_pi A K) => kind_pi (subst_family M5 x5 A) (subst_kind M5 x5 K) 179 | end. 180 | 181 | 182 | (** definitions *) 183 | 184 | 185 | (** infrastructure *) 186 | #[export] Hint Constructors lc_object lc_family lc_kind : core. 187 | 188 | 189 | -------------------------------------------------------------------------------- /examples/Lambda/Lambda_proofs.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Logic.FunctionalExtensionality. 2 | Require Import Coq.Program.Equality. 3 | Require Import Metalib.Metatheory. 4 | Require Import Lambda_inf. 5 | Require Import Lambda_ott. 6 | 7 | 8 | (* *********************************************************************** *) 9 | (** * Lemmas *) 10 | 11 | (** Ideally, LNgen would generate these lemmas. They're nothing more 12 | than casting some lemmas stated for [lc_exp] into lemmas stated for 13 | [lc_set_exp]. *) 14 | 15 | Lemma lc_set_abs_exists : forall x1 e1, 16 | lc_set_exp (open_exp_wrt_exp e1 (var_f x1)) -> lc_set_exp (abs e1). 17 | Proof. 18 | eauto using lc_set_exp_of_lc_exp, lc_exp_of_lc_set_exp, lc_abs_exists. 19 | Qed. 20 | 21 | Lemma lc_set_exp_unique : forall e1 (lcp1 lcp2 : lc_set_exp e1), 22 | lcp1 = lcp2. 23 | Proof. 24 | apply_mutual_ind lc_set_exp_mutind; 25 | intros; 26 | let proof1 := fresh "proof1" in 27 | rename_last_into proof1; dependent destruction proof1; 28 | f_equal; default_simp; auto using @functional_extensionality_dep with lngen. 29 | Qed. 30 | 31 | Lemma subst_exp_lc_set_exp : forall e1 e2 x1, 32 | lc_set_exp e1 -> 33 | lc_set_exp e2 -> 34 | lc_set_exp (subst_exp e2 x1 e1). 35 | Proof. 36 | auto using lc_set_exp_of_lc_exp, lc_exp_of_lc_set_exp, subst_exp_lc_exp. 37 | Qed. 38 | 39 | 40 | (* *********************************************************************** *) 41 | (** * Beta reduction *) 42 | 43 | Fixpoint beta (e : exp) (lcp : lc_set_exp e) {struct lcp} : exp := 44 | match lcp with 45 | | lc_set_var_f x => var_f x 46 | | lc_set_app e1 e2 lcp1 lcp2 => 47 | match beta e1 lcp1 with 48 | | abs e1' => open_exp_wrt_exp e1' (beta e2 lcp2) 49 | | _ => app (beta e1 lcp1) (beta e2 lcp2) 50 | end 51 | | lc_set_abs e1 lcp1 => 52 | let (x, _) := atom_fresh (fv_exp e1) in 53 | abs (close_exp_wrt_exp x (beta (open_exp_wrt_exp e1 (var_f x)) (lcp1 x))) 54 | end. 55 | 56 | 57 | (* *********************************************************************** *) 58 | (** * Model of Gordon and Melham's "Five Axioms" *) 59 | 60 | (** ** Definitions *) 61 | 62 | Definition Term := (sigT lc_set_exp). 63 | 64 | Definition Var (x : expvar) : Term := 65 | existT _ (var_f x) (lc_set_var_f x). 66 | 67 | Definition App (t1 t2 : Term) : Term := 68 | let (e1, lcp1) := t1 in 69 | let (e2, lcp2) := t2 in 70 | existT _ (app e1 e2) (lc_set_app e1 e2 lcp1 lcp2). 71 | 72 | Definition Lam (x : expvar) (t : Term) : Term := 73 | let (e1, lcp1) := t in 74 | existT _ (abs (close_exp_wrt_exp x e1)) 75 | (lc_set_abs_exists x (close_exp_wrt_exp x e1) 76 | (eq_rec_r _ lcp1 (open_exp_wrt_exp_close_exp_wrt_exp e1 x))). 77 | 78 | Definition Fv (t : Term) : vars := 79 | let (e1, _) := t in 80 | fv_exp e1. 81 | 82 | Definition Subst (t : Term) (ux : Term * expvar) : Term := 83 | let (e1, lcp1) := t in 84 | let (u, x) := ux in 85 | let (e2, lcp2) := u in 86 | existT _ (subst_exp e2 x e1) (subst_exp_lc_set_exp e1 e2 x lcp1 lcp2). 87 | 88 | Definition Abs (f : expvar -> Term) : Term := 89 | let (arbitrary, _) := atom_fresh empty in 90 | let (e1, _) := f arbitrary in 91 | let (y, _) := atom_fresh (fv_exp e1) in 92 | let (e2, lcp2) := f y in 93 | existT _ (abs (close_exp_wrt_exp y e2)) 94 | (lc_set_abs_exists y (close_exp_wrt_exp y e2) 95 | (eq_rec_r _ lcp2 (open_exp_wrt_exp_close_exp_wrt_exp e2 y))). 96 | 97 | (** ** Reasoning about uniqueness of [lc_exp] proofs *) 98 | 99 | Lemma Term_eq : forall e1 lcp1 e2 lcp2, 100 | e1 = e2 -> 101 | existT lc_set_exp e1 lcp1 = existT lc_set_exp e2 lcp2. 102 | Proof. 103 | intros e1 lcp1 e2 lcp2 Eq. 104 | subst e1. f_equal. apply lc_set_exp_unique. 105 | Qed. 106 | 107 | (** ** Axiom 1: Free variables *) 108 | 109 | Theorem Fv1 : forall x, 110 | Fv (Var x) = singleton x. 111 | Proof. reflexivity. Qed. 112 | 113 | Theorem Fv2 : forall t1 t2, 114 | Fv (App t1 t2) = Fv t1 `union` Fv t2. 115 | Proof. destruct t1. destruct t2. reflexivity. Qed. 116 | 117 | Theorem Fv3 : forall x t, 118 | Fv (Lam x t) [=] remove x (Fv t). 119 | Proof. destruct t. simpl. apply fv_exp_close_exp_wrt_exp. Qed. 120 | 121 | (** ** Axiom 2: Substitution *) 122 | 123 | Theorem Subst1 : forall x u, 124 | Subst (Var x) (u, x) = u. 125 | Proof. destruct u. simpl. apply Term_eq. default_simp. Qed. 126 | 127 | Theorem Subst2 : forall x y u, 128 | x <> y -> 129 | Subst (Var y) (u, x) = Var y. 130 | Proof. intros. destruct u. simpl. apply Term_eq. default_simp. Qed. 131 | 132 | Theorem Subst3 : forall t1 t2 u x, 133 | Subst (App t1 t2) (u, x) = App (Subst t1 (u, x)) (Subst t2 (u, x)). 134 | Proof. 135 | destruct t1. destruct t2. destruct u. 136 | intros. simpl. apply Term_eq. reflexivity. 137 | Qed. 138 | 139 | Theorem Subst4 : forall t u x, 140 | Subst (Lam x t) (u, x) = Lam x t. 141 | Proof. 142 | destruct t. destruct u. 143 | intros. simpl. apply Term_eq. 144 | rewrite subst_exp_fresh_eq. 145 | reflexivity. 146 | rewrite fv_exp_close_exp_wrt_exp. solve_notin. 147 | Qed. 148 | 149 | Theorem Subst5 : forall y t u x, 150 | x <> y -> 151 | y `notin` Fv u -> 152 | Subst (Lam y t) (u, x) = Lam y (Subst t (u, x)). 153 | Proof. 154 | destruct t. destruct u. 155 | intros. simpl. apply Term_eq. 156 | rewrite subst_exp_close_exp_wrt_exp; trivial. 157 | apply lc_exp_of_lc_set_exp; trivial. 158 | Qed. 159 | 160 | (** ** Axiom 3: Alpha-conversion *) 161 | 162 | Theorem Alpha : forall x t y, 163 | y `notin` Fv (Lam x t) -> 164 | Lam x t = Lam y (Subst t (Var y, x)). 165 | Proof. 166 | destruct t. 167 | intros. simpl. apply Term_eq. 168 | rewrite subst_exp_spec. 169 | rewrite close_exp_wrt_exp_open_exp_wrt_exp; trivial. 170 | Qed. 171 | 172 | (** ** Axiom 4: Recursion scheme *) 173 | 174 | Section FiveAxiomsRecursion. 175 | 176 | Variable R : Set. 177 | Variable fvar : expvar -> R. 178 | Variable fapp : R -> R -> Term -> Term -> R. 179 | Variable fabs : (expvar -> R) -> (expvar -> Term) -> R. 180 | 181 | Definition gm_rec (t : Term) : R := 182 | let (e, lcp) := t in 183 | lc_set_exp_rec (fun _ _ => R) 184 | fvar 185 | (fun e1 e2 lcp1 r1 lcp2 r2 => fapp r1 r2 (existT _ e1 lcp1) (existT _ e2 lcp2)) 186 | (fun e1 lcp1 r1 => fabs r1 (fun x => existT _ (open_exp_wrt_exp e1 (var_f x)) (lcp1 x))) 187 | e 188 | lcp. 189 | 190 | Theorem Recursion1 : forall x, 191 | gm_rec (Var x) = fvar x. 192 | Proof. reflexivity. Qed. 193 | 194 | Theorem Recursion2 : forall t1 t2, 195 | gm_rec (App t1 t2) = fapp (gm_rec t1) (gm_rec t2) t1 t2. 196 | Proof. destruct t1. destruct t2. reflexivity. Qed. 197 | 198 | Theorem Recursion3 : forall x t, 199 | gm_rec (Lam x t) = fabs (fun y => gm_rec (Subst t (Var y, x))) (fun y => Subst t (Var y, x)). 200 | Proof. 201 | (* Allow [gm_rec] and everything else to reduce. *) 202 | unfold Lam. destruct t as [e1 lcp1]. simpl gm_rec at 1. 203 | 204 | (* [lc_set_exp_rec] will reduce once we invert the proof. *) 205 | match goal with |- lc_set_exp_rec _ _ _ _ _ ?pf = _ => set (proof := pf) end. 206 | dependent inversion proof. 207 | simpl lc_set_exp_rec. 208 | 209 | (* [fabs] takes two arguments. Prove them each equal to each other. *) 210 | f_equal. 211 | 212 | (* Argument 1: Go through contortions to apply [subst_spec]. *) 213 | + simpl. 214 | apply functional_extensionality; intros z. 215 | 216 | set (t := (existT _ (open_exp_wrt_exp (close_exp_wrt_exp x e1) (var_f z)) (l z))). 217 | set (u := (existT _ (subst_exp (var_f z) x e1) (subst_exp_lc_set_exp e1 (var_f z) x lcp1 (lc_set_var_f z)))). 218 | 219 | match goal with |- ?lhs = _ => change lhs with (gm_rec t) end. 220 | match goal with |- _ = ?rhs => change rhs with (gm_rec u) end. 221 | f_equal. unfold t. unfold u. 222 | apply Term_eq. 223 | rewrite subst_exp_spec. 224 | reflexivity. 225 | 226 | (* Argument 2: Straightforward. *) 227 | + apply functional_extensionality; intros. 228 | simpl. 229 | apply Term_eq. 230 | rewrite subst_exp_spec. 231 | reflexivity. 232 | Qed. 233 | 234 | End FiveAxiomsRecursion. 235 | 236 | (** ** Axiom 5: Abstraction *) 237 | 238 | Theorem Abstraction : forall x u, 239 | Abs (fun y => Subst u (Var y, x)) = Lam x u. 240 | Proof. 241 | intros x u. unfold Abs, Subst, Lam, Var. destruct u. 242 | do 2 destruct_exists. apply Term_eq. 243 | rewrite subst_exp_spec. 244 | rewrite close_exp_wrt_exp_open_exp_wrt_exp. 245 | reflexivity. 246 | rewrite fv_exp_close_exp_wrt_exp. 247 | assert (remove x (fv_exp x0) [<=] fv_exp (subst_exp (var_f x1) x x0)). 248 | apply fv_exp_subst_exp_lower. 249 | fsetdec. 250 | Qed. 251 | -------------------------------------------------------------------------------- /src/CoqLNOutputThmSize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module CoqLNOutputThmSize where 3 | 4 | import Text.Printf ( printf ) 5 | 6 | import AST 7 | import ASTAnalysis 8 | import ComputationMonad 9 | import CoqLNOutputCommon 10 | import CoqLNOutputCombinators 11 | 12 | sizeThms :: ASTAnalysis -> [[NtRoot]] -> M String 13 | sizeThms aa nts = 14 | do { size_close_recs <- mapM (local . size_close_rec aa) nts 15 | ; size_closes <- mapM (local . size_close aa) nts 16 | ; size_mins <- mapM (local . size_min aa) nts 17 | ; size_open_recs <- mapM (local . size_open_rec aa) nts 18 | ; size_opens <- mapM (local . size_open aa) nts 19 | ; size_open_var_recs <- mapM (local . size_open_var_rec aa) nts 20 | ; size_open_vars <- mapM (local . size_open_var aa) nts 21 | ; return $ printf "Ltac %s ::= auto with arith %s; tauto.\n\ 22 | \Ltac %s ::= fail.\n\ 23 | \\n" 24 | defaultAuto hintDb 25 | defaultAutoRewr ++ 26 | concat size_mins ++ 27 | concat size_close_recs ++ 28 | concat size_closes ++ 29 | concat size_open_recs ++ 30 | concat size_opens ++ 31 | concat size_open_var_recs ++ 32 | concat size_open_vars ++ "\n" 33 | } 34 | 35 | {- | @size (close_rec n x e) = size e@. -} 36 | 37 | size_close_rec :: ASTAnalysis -> [NtRoot] -> M String 38 | size_close_rec aaa nt1s = 39 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 40 | ; names <- processNt1Nt2Mv2 aaa nt1s name 41 | ; types <- processNt1 aaa nt1s ntType 42 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 43 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 44 | } 45 | where 46 | name aa nt1 _ mv2 = 47 | do { close_fn <- closeRecName aa nt1 mv2 48 | ; size_fn <- sizeName aa nt1 49 | ; return $ size_fn ++ "_" ++ close_fn 50 | } 51 | thm aa nt1 _ mv2 = 52 | do { k <- newName bvarRoot 53 | ; x <- newName mv2 54 | ; e <- newName nt1 55 | ; close_fn <- closeRecName aa nt1 mv2 56 | ; size_fn <- sizeName aa nt1 57 | ; return $ printf 58 | "forall %s %s %s,\n\ 59 | \ %s (%s %s %s %s) = %s %s" 60 | e x k size_fn close_fn k x e size_fn e 61 | } 62 | 63 | {- | @size (close e x) = size e@. -} 64 | 65 | size_close :: ASTAnalysis -> [NtRoot] -> M String 66 | size_close aaa nt1s = 67 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 68 | ; names <- processNt1Nt2Mv2 aaa nt1s name 69 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 70 | } 71 | where 72 | name aa nt1 _ mv2 = 73 | do { close_fn <- closeName aa nt1 mv2 74 | ; size_fn <- sizeName aa nt1 75 | ; return $ size_fn ++ "_" ++ close_fn 76 | } 77 | 78 | gen aa nt1 _ mv2 = 79 | do { x <- newName mv2 80 | ; e <- newName nt1 81 | ; close_fn <- closeName aa nt1 mv2 82 | ; size_fn <- sizeName aa nt1 83 | ; let stmt = printf "forall %s %s,\n\ 84 | \ %s (%s %s %s) = %s %s" 85 | e x size_fn close_fn x e size_fn e 86 | ; let proof = printf "unfold %s; %s." close_fn defaultSimp 87 | ; return (stmt, proof) 88 | } 89 | 90 | {- | @1 <= size e@. -} 91 | 92 | size_min :: ASTAnalysis -> [NtRoot] -> M String 93 | size_min aaa nt1s = 94 | do { thms <- processNt1 aaa nt1s thm 95 | ; names <- processNt1 aaa nt1s name 96 | ; types <- processNt1 aaa nt1s ntType 97 | ; let proof = mutPfStart Prop types ++ defaultSimp ++ "." 98 | ; mutualLemmaText Resolve NoRewrite NoHide [hintDb] Prop names thms proof 99 | } 100 | where 101 | name aa nt1 = 102 | do { fn <- sizeName aa nt1 103 | ; return $ fn ++ "_min" 104 | } 105 | 106 | thm aa nt1 = 107 | do { e <- newName nt1 108 | ; n <- sizeName aa nt1 109 | ; return $ printf "forall %s, 1 <= %s %s" e n e 110 | } 111 | 112 | {- | @size e <= size (open_rec n e' e)@. -} 113 | 114 | size_open_rec :: ASTAnalysis -> [NtRoot] -> M String 115 | size_open_rec aaa nt1s = 116 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 117 | ; names <- processNt1Nt2Mv2 aaa nt1s name 118 | ; types <- processNt1 aaa nt1s ntType 119 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 120 | ; mutualLemmaText2 Resolve NoRewrite Hide [hintDb] Prop names thms proof 121 | } 122 | where 123 | name aa nt1 _ mv2 = 124 | do { open_fn <- openRecName aa nt1 mv2 125 | ; size_fn <- sizeName aa nt1 126 | ; return $ size_fn ++ "_" ++ open_fn 127 | } 128 | 129 | thm aa nt1 nt2 mv2 = 130 | do { k <- newName bvarRoot 131 | ; e <- newName nt1 132 | ; u <- newName nt2 133 | ; open_fn <- openRecName aa nt1 mv2 134 | ; size_fn <- sizeName aa nt1 135 | ; return $ printf "forall %s %s %s,\n\ 136 | \ %s %s <= %s (%s %s %s %s)" 137 | e u k 138 | size_fn e size_fn open_fn k u e 139 | } 140 | 141 | {- | @size e <= size (open e e')@. -} 142 | 143 | size_open :: ASTAnalysis -> [NtRoot] -> M String 144 | size_open aaa nt1s = 145 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 146 | ; names <- processNt1Nt2Mv2 aaa nt1s name 147 | ; lemmaText2 Resolve NoRewrite NoHide [hintDb] names gens 148 | } 149 | where 150 | name aa nt1 _ mv2 = 151 | do { open_fn <- openName aa nt1 mv2 152 | ; size_fn <- sizeName aa nt1 153 | ; return $ size_fn ++ "_" ++ open_fn 154 | } 155 | 156 | gen aa nt1 nt2 mv2 = 157 | do { open_fn <- openName aa nt1 mv2 158 | ; size_fn <- sizeName aa nt1 159 | ; e <- newName nt1; 160 | ; u <- newName nt2; 161 | -- ORDER TO OPEN 162 | ; let stmt = printf "forall %s %s,\n\ 163 | \ %s %s <= %s (%s %s %s)" 164 | e u 165 | size_fn e size_fn open_fn e u 166 | ; let proof = printf "unfold %s; %s." open_fn defaultSimp 167 | ; return (stmt, proof) 168 | } 169 | 170 | {- | @size (open_rec n (var x) e) = size e@. -} 171 | 172 | size_open_var_rec :: ASTAnalysis -> [NtRoot] -> M String 173 | size_open_var_rec aaa nt1s = 174 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 175 | ; names <- processNt1Nt2Mv2 aaa nt1s name 176 | ; types <- processNt1 aaa nt1s ntType 177 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 178 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 179 | } 180 | where 181 | name aa nt1 _ mv2 = 182 | do { open_fn <- openRecName aa nt1 mv2 183 | ; size_fn <- sizeName aa nt1 184 | ; return $ size_fn ++ "_" ++ open_fn ++ "_var" 185 | } 186 | 187 | thm aa nt1 nt2 mv2 = 188 | do { open_fn <- openRecName aa nt1 mv2 189 | ; size_fn <- sizeName aa nt1 190 | ; constr <- getFreeVarConstr aa nt2 mv2 191 | ; e <- newName nt1 192 | ; x <- newName mv2 193 | ; k <- newName bvarRoot 194 | ; return $ printf 195 | "forall %s %s %s,\n\ 196 | \ %s (%s %s (%s %s) %s) = %s %s" 197 | e x k 198 | size_fn open_fn k (toName constr) x e size_fn e 199 | } 200 | 201 | {- | @size (open e (var x)) = size e@. -} 202 | 203 | size_open_var :: ASTAnalysis -> [NtRoot] -> M String 204 | size_open_var aaa nt1s = 205 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 206 | ; names <- processNt1Nt2Mv2 aaa nt1s name 207 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 208 | } 209 | where 210 | name aa nt1 _ mv2 = 211 | do { open_fn <- openName aa nt1 mv2 212 | ; size_fn <- sizeName aa nt1 213 | ; return $ size_fn ++ "_" ++ open_fn ++ "_var" 214 | } 215 | 216 | gen aa nt1 nt2 mv2 = 217 | do { open_fn <- openName aa nt1 mv2 218 | ; size_fn <- sizeName aa nt1 219 | ; constr <- getFreeVarConstr aa nt2 mv2 220 | ; e <- newName nt1 221 | ; x <- newName mv2 222 | -- ORDER TO OPEN 223 | ; let stmt = printf "forall %s %s,\n\ 224 | \ %s (%s %s (%s %s)) = %s %s" 225 | e x 226 | size_fn open_fn e (toName constr) x size_fn e 227 | ; let proof = printf "unfold %s; %s." open_fn defaultSimp 228 | ; return (stmt, proof) 229 | } 230 | -------------------------------------------------------------------------------- /src/Attic/OutputDefinitions.hs: -------------------------------------------------------------------------------- 1 | {- ----------------------------------------------------------------------- -} 2 | {- * Output for substitution -} 3 | 4 | {- | Generates text for the @subst@ functions. -} 5 | 6 | processSubst :: ASTAnalysis -> [NtRoot] -> M String 7 | processSubst aaa nt1s = 8 | do { ss <- processNt1Nt2Mv2 aaa nt1s f 9 | ; return $ concat $ map join ss 10 | } 11 | where 12 | join strs = printf "Fixpoint %s.\n\n" (sepStrings "\n\nwith " strs) 13 | 14 | f aa nt1 nt2 mv2 = 15 | do { subst_fn <- substName aa nt1 mv2 16 | ; x <- newName mv2 17 | ; xtype <- mvType aa mv2 18 | ; u <- newName nt2 19 | ; utype <- ntType aa nt2 20 | ; e <- newName nt1 21 | ; etype <- ntType aa nt1 22 | ; (Syntax _ _ cs) <- getSyntax aa nt1 23 | ; branches <- mapM (local . branch nt1 nt2 mv2 x u) cs 24 | ; return $ printf 25 | "%s (%s : %s) (%s : %s) (%s : %s) {struct %s} : %s :=\n\ 26 | \ match %s with\n\ 27 | \%s\n\ 28 | \ end" 29 | subst_fn u utype x xtype e etype e etype 30 | e 31 | (sepStrings "\n" branches) 32 | } 33 | 34 | branch nt1 nt2 mv2 x u c@(SConstr _ _ _ _ (Free mv')) 35 | | canonRoot aaa nt1 == canonRoot aaa nt2 && 36 | canonRoot aaa mv2 == canonRoot aaa mv' = 37 | do { y <- newName mv2 38 | ; return $ printf 39 | " | %s %s => if (%s == %s) then (%s) else (%s %s)" 40 | (toName c) y 41 | x y 42 | u 43 | (toName c) y 44 | } 45 | branch _ nt2 mv2 x u c@(SConstr _ _ _ ts _) = 46 | do { args <- mapM (newName . toRoot) ts 47 | ; calls <- mapM call (zip ts args) 48 | ; return $ printf 49 | " | %s%s => %s%s" 50 | (toName c) 51 | (sepStrings " " ("" : args)) 52 | (toName c) 53 | (sepStrings " " ("" : calls)) 54 | } 55 | where 56 | call (IndexArg, z) = return z 57 | call (MvArg _, z) = return z 58 | 59 | call (BindingArg _ _ nt, z) = call (NtArg nt, z) 60 | 61 | call (NtArg nt, z) 62 | | canBindIn aaa nt2 nt = 63 | do { fn <- substName aaa nt mv2 64 | ; return $ printf "(%s %s %s %s)" fn u x z 65 | } 66 | | otherwise = 67 | return z 68 | 69 | 70 | {- ----------------------------------------------------------------------- -} 71 | {- * Output for metavariables -} 72 | 73 | {- | Generates text for metavariable declarations. -} 74 | 75 | processMv :: ASTAnalysis -> MvRoot -> M String 76 | processMv aa mv = 77 | do { mvd <- getMvDecl aa mv 78 | ; name <- mvType aa mv 79 | ; return $ printf "Definition %s := (%s).\n\n" name (coqMvImplType mvd) 80 | } 81 | 82 | 83 | {- ----------------------------------------------------------------------- -} 84 | {- * Output for phantoms -} 85 | 86 | {- | Generates text for phantom metavariable declarations. -} 87 | 88 | processPhantom :: ASTAnalysis -> MvRoot -> M String 89 | processPhantom aa mv = 90 | do { name <- mvType aa mv 91 | ; return $ printf "Parameter %s : Set.\n\n" name 92 | } 93 | 94 | 95 | {- ----------------------------------------------------------------------- -} 96 | {- * Output for \"fv\" -} 97 | 98 | {- Generates the text for the @fv@ functions. -} 99 | 100 | processFv :: ASTAnalysis -> [NtRoot] -> M String 101 | processFv aa nts = 102 | do { s1 <- processFvDefs aa nts 103 | ; return $ s1 104 | } 105 | 106 | {- Generates the text for the @fv@ functions. -} 107 | 108 | processFvDefs :: ASTAnalysis -> [NtRoot] -> M String 109 | processFvDefs aaa nt1s = 110 | do { ss <- processNt1Nt2Mv2 aaa nt1s f 111 | ; return $ concat $ map join ss 112 | } 113 | where 114 | join strs = printf "Fixpoint %s.\n\n" (sepStrings "\n\nwith " strs) 115 | 116 | f aa nt1 nt2 mv2 = 117 | do { fv_fn <- fvName aa nt1 mv2 118 | ; e <- newName nt1 119 | ; etype <- ntType aa nt1 120 | ; mvt <- mvType aa mv2 121 | ; (Syntax _ _ cs) <- getSyntax aa nt1 122 | ; branches <- mapM (local . branch nt1 nt2 mv2) cs 123 | ; return $ printf 124 | "%s (%s : %s) {struct %s} : %s %s :=\n\ 125 | \ match %s with\n\ 126 | \%s\n\ 127 | \ end" 128 | fv_fn e etype e mvSetType mvt 129 | e 130 | (sepStrings "\n" branches) 131 | } 132 | 133 | branch nt1 nt2 mv2 c@(SConstr _ _ _ ts _) = 134 | do { args <- mapM (newName . toRoot) ts 135 | ; calls' <- mapMM (call nt1 nt2 mv2) (zip ts args) 136 | ; let calls = if null calls' then [mvSetEmpty] else calls' 137 | ; return $ printf 138 | " | %s%s => %s" 139 | (toName c) 140 | (sepStrings " " ("" : args)) 141 | (sepStrings (" " ++ mvSetUnion ++ " ") calls) 142 | } 143 | 144 | call _ _ _ (IndexArg, _) = return Nothing 145 | call nt1 nt2 mv2 (BindingArg _ _ nt, x) = call nt1 nt2 mv2 (NtArg nt, x) 146 | 147 | call _ _ mv2 (MvArg mv', x) 148 | | canonRoot aaa mv2 == canonRoot aaa mv' = 149 | return $ Just $ printf "(%s %s)" mvSetSingleton x 150 | | otherwise = 151 | return Nothing 152 | 153 | call _ nt2 mv2 (NtArg nt, x) 154 | | canBindIn aaa nt2 nt = 155 | do { fn <- fvName aaa nt mv2 156 | ; return $ Just $ printf "(%s %s)" fn x 157 | } 158 | | otherwise = 159 | return Nothing 160 | 161 | 162 | {- ----------------------------------------------------------------------- -} 163 | {- * Output for \"open\" -} 164 | 165 | {- | Generates the text for the @open@ and @open_rec@ functions. -} 166 | 167 | processOpen :: ASTAnalysis -> [NtRoot] -> M String 168 | processOpen aa nts = 169 | do { s1 <- processOpenRecs aa nts 170 | ; s2 <- processOpenDefs aa nts 171 | ; return $ s1 ++ s2 172 | } 173 | 174 | {- | Generates the text for the definitions of @open@. -} 175 | 176 | processOpenDefs :: ASTAnalysis -> [NtRoot] -> M String 177 | processOpenDefs aaa nt1s = 178 | do { ss <- processNt1Nt2Mv2 aaa nt1s f 179 | ; return $ concat $ concat $ ss 180 | } 181 | where 182 | f aa nt1 nt2 mv2 = 183 | do { fn <- openName aa nt1 mv2 184 | ; fnrec <- openRecName aa nt1 mv2 185 | ; e <- newName nt1 186 | ; u <- newName nt2 187 | ; return $ printf 188 | "Definition %s %s %s := %s 0 %s %s.\n\n" 189 | fn u e fnrec u e 190 | } 191 | 192 | {- | Generates the text for the definitions of @open_rec@. -} 193 | 194 | processOpenRecs :: ASTAnalysis -> [NtRoot] -> M String 195 | processOpenRecs aaa nt1s = 196 | do { ss <- processNt1Nt2Mv2 aaa nt1s f 197 | ; return $ concat $ map join ss 198 | } 199 | where 200 | join strs = printf "Fixpoint %s.\n\n" (sepStrings "\n\nwith " strs) 201 | 202 | f aa nt1 nt2 mv2 = 203 | do { open_fn <- openRecName aa nt1 mv2 204 | ; k <- newName bvarRoot 205 | ; u <- newName nt2 206 | ; utype <- ntType aa nt2 207 | ; e <- newName nt1 208 | ; etype <- ntType aa nt1 209 | ; (Syntax _ _ cs) <- getSyntax aa nt1 210 | ; branches <- mapM (local . branch nt1 nt2 mv2 k u) cs 211 | ; return $ printf 212 | "%s (%s : %s) (%s : %s) (%s : %s) {struct %s} : %s :=\n\ 213 | \ match %s with\n\ 214 | \%s\n\ 215 | \ end" 216 | open_fn k bvarType u utype e etype e etype 217 | e 218 | (sepStrings "\n" branches) 219 | } 220 | 221 | branch nt1 nt2 mv2 k u c@(SConstr _ _ _ _ (Bound mv')) 222 | | canonRoot aaa nt1 == canonRoot aaa nt2 && 223 | canonRoot aaa mv2 == canonRoot aaa mv' = 224 | do { n <- newName bvarRoot 225 | ; return $ printf 226 | " | %s %s =>\n\ 227 | \ match %s %s %s with\n\ 228 | \ | inleft (left _) => %s %s\n\ 229 | \ | inleft (right _) => %s\n\ 230 | \ | inright _ => %s (%s - 1)\n\ 231 | \ end" 232 | (toName c) n 233 | bvarLtEqLtDec n k 234 | (toName c) n 235 | u 236 | (toName c) n 237 | } 238 | branch nt1 nt2 mv2 k u c@(SConstr _ _ _ ts _) = 239 | do { args <- mapM (newName . toRoot) ts 240 | ; calls <- mapM (call k u nt1 nt2 mv2) (zip ts args) 241 | ; return $ printf 242 | " | %s%s => %s%s" 243 | (toName c) 244 | (sepStrings " " ("" : args)) 245 | (toName c) 246 | (sepStrings " " ("" : calls)) 247 | } 248 | 249 | call _ _ _ _ _ (IndexArg, x) = return x 250 | call _ _ _ _ _ (MvArg _, x) = return x 251 | 252 | call k u _ nt2 mv2 (NtArg nt, x) 253 | | canBindIn aaa nt2 nt = 254 | do { fn <- openRecName aaa nt mv2 255 | ; return $ printf "(%s %s %s %s)" fn k u x 256 | } 257 | | otherwise = 258 | return x 259 | 260 | call k u nt1 nt2 mv2 (BindingArg mv' ntm nt, x) 261 | | canonRoot aaa ntm == canonRoot aaa nt2 && 262 | canonRoot aaa mv2 == canonRoot aaa mv' = 263 | do { fn <- openRecName aaa nt mv2 264 | ; let k' = "(S " ++ k ++ ")" 265 | ; return $ printf "(%s %s %s %s)" fn k' u x 266 | } 267 | | otherwise = 268 | call k u nt1 nt2 mv2 (NtArg nt, x) 269 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | {- | This module defines the functions necessary to parse an Ott input 2 | file and check that it is well formed. 3 | 4 | Implementation notes (BEA): 5 | 6 | 1. The comments below assume some level of familiarity with Parsec. 7 | 8 | 2. Parsers below are implemented assuming that they don't need to 9 | consume any initial whitespace. This means that they all need 10 | to be implemented as lexeme parsers, ones that consume trailing 11 | whitespace. A few parsers are not lexeme parsers; these are 12 | noted below. 13 | -} 14 | 15 | module Parser ( parseOttFile ) where 16 | 17 | import Data.Maybe ( catMaybes ) 18 | import Text.ParserCombinators.Parsec 19 | import Text.ParserCombinators.Parsec.Language ( emptyDef ) 20 | import qualified Text.ParserCombinators.Parsec.Token as P 21 | import Data.List.NonEmpty as NE 22 | 23 | import AST 24 | import MyLibrary ( getResult, manyTill1 ) 25 | 26 | 27 | {- ----------------------------------------------------------------------- -} 28 | {- * Basic, language specific parsers -} 29 | 30 | {- | A parser \"module\" used mainly for handling whitespace, 31 | comments, and reserved words in Ott input files. -} 32 | 33 | ottTokenParser :: P.TokenParser st 34 | ottTokenParser = P.makeTokenParser (emptyDef { P.commentLine = "%" }) 35 | 36 | {- | A parser for whitespace, including comments. -} 37 | 38 | whiteSpace :: CharParser st () 39 | whiteSpace = P.whiteSpace ottTokenParser 40 | 41 | {- | Constructs a lexeme parser from its argument. -} 42 | 43 | lexeme :: CharParser st a -> CharParser st a 44 | lexeme = P.lexeme ottTokenParser 45 | 46 | {- | A lexeme parser for identifiers. -} 47 | 48 | identifier :: CharParser st String 49 | identifier = P.identifier ottTokenParser 50 | 51 | {- | A lexeme parser for reserved words. -} 52 | 53 | reserved :: String -> CharParser st () 54 | reserved = P.reserved ottTokenParser 55 | 56 | {- | A lexeme parser that is otherwise similar to the 'string' parser. 57 | It does not consume any input on failure. -} 58 | 59 | text :: String -> CharParser st String 60 | text str = lexeme $ try $ string str 61 | 62 | 63 | {- | sepBy1, but produce a nonempty list of results -} 64 | ne_sepBy1 :: Parser a1 -> Parser a2 -> Parser (NonEmpty a1) 65 | ne_sepBy1 p sep = do{ x <- p 66 | ; xs <- many (sep >> p) 67 | ; return (x :| xs) 68 | } 69 | 70 | {- ----------------------------------------------------------------------- -} 71 | {- * Parsing names -} 72 | 73 | {- | A variable (e.g., metavariable, nonterminal, etc.) consists of a 74 | root and suffix followed by at least one whitespace character. -} 75 | 76 | var :: Parser UnknownSym 77 | var = lexeme $ do { pos <- getPosition 78 | ; r <- root 79 | ; s <- suffix 80 | ; _ <- space 81 | ; return $ UnknownSym pos r s 82 | } 83 | 84 | {- | The root of a variable consists of a non-empty sequence of 85 | letters and underscores. This is NOT a lexeme parser. -} 86 | 87 | root :: Parser Root 88 | root = many1 ((letter <|> char '_') "") "name" 89 | 90 | {- | A suffix of a variable is a (possibly empty) sequence of digits 91 | and primes. This is NOT a lexeme parser. -} 92 | 93 | suffix :: Parser Suffix 94 | suffix = many (digit <|> char '\'') 95 | 96 | {- | 'name' is a lexeme parser version of 'root'. -} 97 | 98 | name :: Parser Root 99 | name = lexeme root 100 | 101 | {- | 'nameHom' is a version of 'name' that consumes all trailing 102 | homomorphisms. -} 103 | 104 | nameHom :: Parser Root 105 | nameHom = do { n <- name ; ignoreHoms ; return n } 106 | 107 | 108 | {- ----------------------------------------------------------------------- -} 109 | {- * Ignoring homomorphisms -} 110 | 111 | {- | Consumes a homomorphism from the input stream. -} 112 | 113 | ruleHom :: Parser RuleHom 114 | ruleHom = 115 | do { _ <- text "{{" "homomorphism \"{{ ... }}\"" 116 | ; do { reserved "phantom" 117 | ; _ <- text "}}" 118 | ; return RuleHom {ruleHomPhantom = True} 119 | } 120 | <|> 121 | mempty <$ anyChar `manyTill` text "}}" 122 | } 123 | 124 | ignoreHom :: Parser () 125 | ignoreHom = 126 | do { _ <- text "{{" "homomorphism \"{{ ... }}\"" 127 | ; _ <- anyChar `manyTill` text "}}" 128 | ; return () 129 | } 130 | 131 | {- | Consumes zero or more homomorphisms from the input stream. -} 132 | 133 | ignoreHoms :: Parser () 134 | ignoreHoms = do { _ <- many ignoreHom ; return () } 135 | 136 | 137 | {- ----------------------------------------------------------------------- -} 138 | {- * Parsing metavariable declarations -} 139 | 140 | {- | A metavariable declaration consists of a non-empty list of 141 | metavariable roots and a possibly empty list of homomorphisms -} 142 | 143 | 144 | 145 | 146 | metavarDecl :: Parser MetavarDecl 147 | metavarDecl = 148 | do { pos <- getPosition 149 | ; reserved "metavar" "metavariable declaration \"metavar ...\"" 150 | ; names <- nameHom `ne_sepBy1` (text "," "\",\" and another name") 151 | ; _ <- text "::=" 152 | ; homs <- many metavarHom 153 | ; return (MetavarDecl pos names (NE.prependList (catMaybes homs) defaults)) 154 | } 155 | where 156 | defaults = CoqMvImplHom "atom" :| [] 157 | 158 | metavarHom = 159 | do { _ <- text "{{" "homomorphism \"{{ ... }}\"" 160 | ; do { reserved "phantom" 161 | ; _ <- text "}}" 162 | ; return $ Just $ MvPhantom 163 | } 164 | <|> 165 | do { _ <- anyChar `manyTill` text "}}" 166 | ; return Nothing 167 | } 168 | } 169 | 170 | {- ----------------------------------------------------------------------- -} 171 | {- * Parsing definitions of nonterminals -} 172 | 173 | {- | A rule defines a nonterminal. The definition begins with a list 174 | of roots, followed by a name and homomorphisms. The remainder of 175 | the rule is a sequence of productions. -} 176 | 177 | rule :: Parser PreRule 178 | rule = 179 | do { pos <- getPosition 180 | ; es <- nameHom `ne_sepBy1` (text "," "\",\" and another name") 181 | ; _ <- text "::" 182 | ; n <- ruleName 183 | ; _ <- text "::=" 184 | ; hom <- mconcat <$> many ruleHom 185 | ; prods <- many production 186 | ; return $ Rule pos hom es n prods 187 | } 188 | where 189 | ruleName = 190 | lexeme (try (many1 (letter <|> char '_' "")) "name") 191 | <|> 192 | -- BEA: Seems like unnecessary flexbility in the input language. 193 | lexeme (do { _ <- char '\'' 194 | ; (letter <|> char '_') `manyTill` char '\'' 195 | }) 196 | 197 | {- | Each production in a rule starts with a \"|\" followed by a 198 | non-empty sequence of elements. This is followed by flags, a name 199 | for this production, binding specifications, and homomorphisms. -} 200 | 201 | production :: Parser PreProduction 202 | production = 203 | do { pos <- getPosition 204 | ; _ <- text "|" 205 | ; es <- element `manyTill` text "::" 206 | ; flag <- many productionFlag 207 | ; _ <- text "::" 208 | ; constr <- identifier 209 | ; bs <- many bindingSpec 210 | ; _ <- many ignoreHom 211 | ; return $ Production pos es flag constr bs 212 | } 213 | where 214 | productionFlag = 215 | do { reserved "I"; return IFlag } 216 | <|> 217 | do { reserved "M"; return MFlag } 218 | <|> 219 | do { reserved "S"; return SFlag } 220 | 221 | {- | An element is a terminal, nonterminal, or metavariable. 222 | 223 | Implementation note (BEA): The difference between these three is 224 | sorted out later since we don't have enough information at this 225 | stage to make this distinction. We are careful to identify 226 | potential nonterminals and metavariables as such. -} 227 | 228 | element :: Parser UnknownElement 229 | element = 230 | try (do { v <- var 231 | ; return $ Variable v 232 | }) 233 | <|> 234 | try (do { s <- noneOf " \v\f\t\r\n" `manyTill1` whiteSpace 235 | ; return $ Unknown s 236 | }) 237 | 238 | {- | A binding specification helps define the binding structure of a 239 | given production. Similar to 'element', we sort out references to 240 | variables later. -} 241 | 242 | bindingSpec :: Parser PreBindingSpec 243 | bindingSpec = 244 | do { pos <- getPosition 245 | ; _ <- text "(+" 246 | ; b <- do { reserved "bind" 247 | ; v1 <- var 248 | ; reserved "in" 249 | ; v2 <- var 250 | ; return $ BindDecl pos v1 v2 251 | } 252 | ; _ <- text "+)" 253 | ; return b 254 | } 255 | 256 | 257 | {- ----------------------------------------------------------------------- -} 258 | {- * Function names -} 259 | 260 | {- | Parses a @substitutions@ block. -} 261 | 262 | substitutions :: Parser [SubstFun] 263 | substitutions = 264 | do { reserved "substitutions" 265 | ; many (try substitution) 266 | } 267 | where 268 | substitution = 269 | do { reserved "single" 270 | ; nt <- name 271 | ; mv <- name 272 | ; _ <- text "::" 273 | ; n <- name 274 | ; return $ SingleSubstFun nt mv n 275 | } 276 | 277 | {- | Parses a @freevars@ block. -} 278 | 279 | freevars :: Parser [FvFun] 280 | freevars = 281 | do { reserved "freevars" 282 | ; many (try freevar) 283 | } 284 | where 285 | freevar = 286 | do { nt <- name 287 | ; mv <- name 288 | ; _ <- text "::" 289 | ; n <- name 290 | ; return $ FvFun nt mv n 291 | } 292 | 293 | 294 | {- ----------------------------------------------------------------------- -} 295 | {- * Ignoring Ott code -} 296 | 297 | indexVarDecl :: Parser () 298 | indexVarDecl = 299 | do { reserved "indexvar" "indexvar declaration \"indexvar ...\"" 300 | ; _ <- nameHom `sepBy1` (text "," "\",\" and another name") 301 | ; _ <- text "::=" 302 | ; _ <- many ignoreHom 303 | ; return () 304 | } 305 | 306 | embed :: Parser () 307 | embed = 308 | do { reserved "embed" 309 | ; _ <- many ignoreHom 310 | ; return () 311 | } 312 | 313 | ignoreBlocks :: Parser () 314 | ignoreBlocks = 315 | do { _ <- many (indexVarDecl <|> embed) 316 | ; return () 317 | } 318 | 319 | 320 | {- ----------------------------------------------------------------------- -} 321 | {- * Parsing an entire file -} 322 | 323 | {- | A parser for an entire Ott file. -} 324 | 325 | ottFileParser :: Parser PreAST 326 | ottFileParser = do { whiteSpace 327 | ; ignoreBlocks 328 | ; mvds <- many metavarDecl 329 | ; ignoreBlocks 330 | ; reserved "grammar" 331 | ; rs <- many (try rule) 332 | ; ignoreBlocks 333 | ; substs <- option [] substitutions 334 | ; ignoreBlocks 335 | ; fvs <- option [] freevars 336 | -- ; BEA: Really rough debugging code. 337 | -- ; pos <- getPosition 338 | -- ; let x = unsafePerformIO (putStrLn (show pos)) 339 | -- ; case x of () -> return () 340 | ; return $ PreAST mvds rs substs fvs 341 | } 342 | 343 | {- | Parses an entire Ott file given its name. -} 344 | 345 | parseOttFile :: String -> IO PreAST 346 | parseOttFile filename = 347 | do { answer <- parseFromFile ottFileParser filename 348 | ; return (getResult answer) 349 | } 350 | -------------------------------------------------------------------------------- /src/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | {- | This module defines the abstract syntax tree for an Ott input 5 | file. Only the following parts of an Ott file are representable: 6 | 7 | * some homomorphisms, 8 | * metavariable declarations, 9 | * nonterminal declarations, 10 | * binding specifications of the form \"(+ bind mv in nt +)\". 11 | -} 12 | 13 | module AST where 14 | 15 | import Data.Typeable ( Typeable ) 16 | import Data.Data ( Data(..) ) 17 | import Data.Foldable ( msum ) 18 | import Data.Maybe ( fromJust ) 19 | import Text.ParserCombinators.Parsec ( SourcePos ) 20 | import Data.List.NonEmpty as NE 21 | 22 | import MyLibrary ( sepStrings ) 23 | 24 | 25 | {- ----------------------------------------------------------------------- -} 26 | {- * Orphan instances -} 27 | 28 | {- Implementation note (BEA): These instances are not provided by 29 | Parsec, so I define them here. I'm not entirely sure that they 30 | work, but they're the best that I can come up with given that 31 | 'SourcePos' is opaque. -} 32 | 33 | deriving instance (Typeable SourcePos) 34 | 35 | {- 36 | instance Typeable SourcePos where 37 | typeOf _ = mkTyConApp (mkTyCon "Text.ParserCombinators.Parsec.SourcePos") [] 38 | 39 | 40 | instance Data SourcePos where 41 | gfoldl _ z c = z c 42 | gunfold _ _ _ = undefined 43 | toConstr _ = undefined 44 | dataTypeOf _ = mkNoRepType "Text.ParserCombinators.Parsec.SourcePos" 45 | -} 46 | 47 | {- ----------------------------------------------------------------------- -} 48 | {- * Names and symbols -} 49 | 50 | {- | A name is a non-empty string. -} 51 | 52 | type Name = String 53 | 54 | {- | A root is a non-empty sequence of letters. -} 55 | 56 | type Root = String 57 | 58 | {- | A suffix is a sequence of digits and primes. -} 59 | 60 | type Suffix = String 61 | 62 | {- | An unknown symbol consists of a root and a suffix. It may stand 63 | for a metavariable or a nonterminal. -} 64 | 65 | data UnknownSym 66 | = UnknownSym SourcePos Root Suffix 67 | deriving ( Data, Typeable ) 68 | 69 | instance Eq UnknownSym where 70 | (UnknownSym _ r1 s1) == (UnknownSym _ r2 s2) = r1 == r2 && s1 == s2 71 | 72 | instance Show UnknownSym where 73 | show (UnknownSym _ r s) = r ++ s 74 | 75 | {- | A metavariable consists of a root and a suffix. -} 76 | 77 | data Metavariable 78 | = Metavariable SourcePos MvRoot MvSuffix 79 | deriving ( Data, Typeable ) 80 | type MvRoot = Root 81 | type MvSuffix = Suffix 82 | 83 | instance Eq Metavariable where 84 | (Metavariable _ r1 s1) == (Metavariable _ r2 s2) = r1 == r2 && s1 == s2 85 | 86 | instance Show Metavariable where 87 | show (Metavariable _ r s) = r ++ s 88 | 89 | {- | A nonterminal consists of a root and a suffix. -} 90 | 91 | data Nonterminal 92 | = Nonterminal SourcePos NtRoot NtSuffix 93 | deriving ( Data, Typeable ) 94 | type NtRoot = Root 95 | type NtSuffix = Suffix 96 | 97 | instance Eq Nonterminal where 98 | (Nonterminal _ r1 s1) == (Nonterminal _ r2 s2) = r1 == r2 && s1 == s2 99 | 100 | instance Show Nonterminal where 101 | show (Nonterminal _ r s) = r ++ s 102 | 103 | 104 | {- ----------------------------------------------------------------------- -} 105 | {- * Homomorphisms -} 106 | 107 | {- | A homomorphism used to annotate a metavariable declaration. -} 108 | 109 | data MetavarHom 110 | = CoqMvImplHom String 111 | -- ^ Specifies the implementation type for Coq. 112 | | MvPhantom 113 | -- ^ Specifies that no implementation should be provided. 114 | deriving ( Eq, Show ) 115 | 116 | {- | A homomorphism used to annotate a rule declaration. -} 117 | newtype RuleHom = RuleHom { 118 | ruleHomPhantom :: Bool 119 | } 120 | deriving ( Eq, Show, Data ) 121 | 122 | instance Semigroup RuleHom where 123 | RuleHom {ruleHomPhantom = p1} <> RuleHom {ruleHomPhantom = p2} = 124 | RuleHom {ruleHomPhantom = p1 || p2} 125 | 126 | instance Monoid RuleHom where 127 | mempty = RuleHom {ruleHomPhantom = False} 128 | 129 | {- ----------------------------------------------------------------------- -} 130 | {- * Metavariable declarations -} 131 | 132 | {- | A metavariable declaration consists of a non-empty list of 133 | metavariable roots, which are all taken to denote a particular sort 134 | of variable in the language being defined, and a list of 135 | homomorphisms. The list of homomorphisms should include at least 136 | one instance of anything "essential," e.g., an implementation 137 | type. -} 138 | 139 | data MetavarDecl 140 | = MetavarDecl SourcePos (NE.NonEmpty MvRoot) (NE.NonEmpty MetavarHom) 141 | deriving ( Show ) 142 | 143 | 144 | {- ----------------------------------------------------------------------- -} 145 | {- * Rules -} 146 | 147 | {- | A rule defines a syntactic category in the language being 148 | defined. It consists of a list of names used to denote terms 149 | defined by it, a name to be used in generating proof assistant 150 | output (e.g., as a prefix to all the constructor names), and a list 151 | of productions. 152 | 153 | The type arguments specify the following (in order): the type for 154 | elements in each production, the type for metavariables, and the 155 | type for nonterminals. -} 156 | 157 | data GenRule a b c 158 | = Rule SourcePos RuleHom (NE.NonEmpty NtRoot) Name [GenProduction a b c] 159 | deriving ( Data, Show, Typeable ) 160 | 161 | {- | A production consists of a list of elements, a list of flags, a 162 | constructor name, and a list binding specifications. The type 163 | arguments are the same as for 'GenRule'. -} 164 | 165 | data GenProduction a b c 166 | = Production SourcePos [a] [Flag] Name [GenBindingSpec b c] 167 | deriving ( Data, Typeable ) 168 | 169 | instance Show a => Show (GenProduction a b c) where 170 | show (Production _ es _ _ _) = sepStrings " " (fmap show es) 171 | 172 | {- | A flag indicates that production is not a \"real\" constructor 173 | for the corresponding nonterminal. -} 174 | 175 | data Flag 176 | = MFlag -- ^ Metaproduction, e.g., for parsing. 177 | | IFlag -- ^ Meaning unknown. 178 | | SFlag -- ^ Meaning unknown. 179 | deriving ( Data, Typeable ) 180 | 181 | {- | An element defines one symbol in a production. -} 182 | 183 | data Element 184 | = MvElement Metavariable -- ^ Metavariable. 185 | | NtElement Nonterminal -- ^ Nonterminal. 186 | | TElement String -- ^ Terminal. 187 | deriving ( Data, Eq, Typeable ) 188 | 189 | instance Show Element where 190 | show (MvElement mv) = show mv 191 | show (NtElement nt) = show nt 192 | show (TElement s) = s 193 | 194 | {- | An unknown element is one in which we cannot distinguish between 195 | a metavariable and a nonterminal. -} 196 | 197 | data UnknownElement 198 | = Variable UnknownSym -- ^ Metavariable or nonterminal. 199 | | Unknown String -- ^ Terminal. 200 | deriving ( Data, Eq, Typeable ) 201 | 202 | instance Show UnknownElement where 203 | show (Variable v) = show v 204 | show (Unknown s) = s 205 | 206 | {- | A binding specification specifies how the elements in a 207 | production form binding occurrences of variables. The first type 208 | argument specifies the type for metavariables, and the second type 209 | argument specifies the type for nonterminals. -} 210 | 211 | data GenBindingSpec a b 212 | = BindDecl SourcePos a b -- ^ (+ bind mv in nt +) 213 | deriving ( Data, Typeable ) 214 | 215 | instance (Show a, Show b) => Show (GenBindingSpec a b) where 216 | show (BindDecl _ v1 v2) = 217 | "(+ bind " ++ show v1 ++ " in " ++ show v2 ++ " +)" 218 | 219 | 220 | {- ----------------------------------------------------------------------- -} 221 | {- * Function names -} 222 | 223 | {- | Records the user-supplied name for a generated substitution 224 | function. -} 225 | 226 | data SubstFun 227 | = SingleSubstFun NtRoot MvRoot Name 228 | 229 | {- | Records the user-supplied name for a generated free variables 230 | function. -} 231 | 232 | data FvFun 233 | = FvFun NtRoot MvRoot Name 234 | 235 | 236 | {- ----------------------------------------------------------------------- -} 237 | {- * Abstract syntax trees -} 238 | 239 | {- | A 'PreAST' is one in which metavariables and nonterminals have not 240 | yet been disambiguated. -} 241 | 242 | data PreAST = PreAST [MetavarDecl] [PreRule] [SubstFun] [FvFun] 243 | type PreRule = GenRule UnknownElement UnknownSym UnknownSym 244 | type PreProduction = GenProduction UnknownElement UnknownSym UnknownSym 245 | type PreBindingSpec = GenBindingSpec UnknownSym UnknownSym 246 | 247 | {- | An 'AST' is one in which metavariables and nonterminals have been 248 | disambiguated. -} 249 | 250 | data AST = AST [MetavarDecl] [Rule] [SubstFun] [FvFun] 251 | type Rule = GenRule Element Metavariable Nonterminal 252 | type Production = GenProduction Element Metavariable Nonterminal 253 | type BindingSpec = GenBindingSpec Metavariable Nonterminal 254 | 255 | 256 | {- ----------------------------------------------------------------------- -} 257 | {- * Type classes -} 258 | 259 | {- | A nameable entity is any type for which we can extract a name, 260 | e.g., something usable as a proof assistant implementation type or 261 | constructor name. -} 262 | 263 | class Nameable a where 264 | toName :: a -> Name 265 | 266 | -- | By default, the same as 'toName'. 267 | toShortName :: a -> Name 268 | toShortName = toName 269 | 270 | instance Nameable MetavarDecl where 271 | toName (MetavarDecl _ mvrs _) = NE.head mvrs 272 | 273 | instance Nameable (GenRule a b c) where 274 | toName (Rule _ _ ntrs _ _) = NE.head ntrs 275 | 276 | {- | A source entity is any type for which we can extract position 277 | information. -} 278 | 279 | class SourceEntity a where 280 | -- | Extracts the source position of a symbol. 281 | toPos :: a -> SourcePos 282 | -- | Extracts the source position of a symbol. 283 | -- Defined as @'show' . 'toPos'@ by default. 284 | toPosS :: a -> String 285 | toPosS = show . toPos 286 | 287 | instance SourceEntity UnknownSym where 288 | toPos (UnknownSym pos _ _) = pos 289 | 290 | instance SourceEntity Metavariable where 291 | toPos (Metavariable pos _ _) = pos 292 | 293 | instance SourceEntity Nonterminal where 294 | toPos (Nonterminal pos _ _) = pos 295 | 296 | instance SourceEntity MetavarDecl where 297 | toPos (MetavarDecl pos _ _) = pos 298 | 299 | instance SourceEntity (GenRule a b c) where 300 | toPos (Rule pos _ _ _ _) = pos 301 | 302 | instance SourceEntity (GenProduction a b c) where 303 | toPos (Production pos _ _ _ _) = pos 304 | 305 | instance SourceEntity (GenBindingSpec a b) where 306 | toPos (BindDecl pos _ _) = pos 307 | 308 | {- | A symbol is any type for which we can extract a \"root\". -} 309 | 310 | class Symbol a where 311 | -- | Extracts the root of a symbol. 312 | toRoot :: a -> Root 313 | 314 | instance Symbol UnknownSym where 315 | toRoot (UnknownSym _ r _) = r 316 | 317 | instance Symbol Metavariable where 318 | toRoot (Metavariable _ r _) = r 319 | 320 | instance Symbol Nonterminal where 321 | toRoot (Nonterminal _ r _) = r 322 | 323 | 324 | {- ----------------------------------------------------------------------- -} 325 | {- * Simple AST constants and queries -} 326 | 327 | {- | Returns the Coq implementation type for the given metavariable. -} 328 | 329 | 330 | 331 | coqMvImplType :: MetavarDecl -> String 332 | coqMvImplType (MetavarDecl _ _ homs) = fromJust (msum $ fmap f homs) 333 | where 334 | f (CoqMvImplHom s) = Just s 335 | f _ = Nothing 336 | 337 | {- | 'True' if and only if the declaration is for a \"phantom\" 338 | metavariable. -} 339 | 340 | isPhantomMvDecl :: MetavarDecl -> Bool 341 | isPhantomMvDecl (MetavarDecl _ _ homs) = MvPhantom `elem` homs 342 | 343 | {- | 'True' if and only if the rule is for a \"phantom\" 344 | AST. -} 345 | isPhantomRule :: Rule -> Bool 346 | isPhantomRule (Rule _ hom _ _ _) = ruleHomPhantom hom 347 | -------------------------------------------------------------------------------- /src/CoqLNOutputThmOpenClose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# OPTIONS_GHC -freduction-depth=50 #-} 3 | 4 | module CoqLNOutputThmOpenClose where 5 | 6 | import Text.Printf ( printf ) 7 | 8 | import AST 9 | import ASTAnalysis 10 | import ComputationMonad 11 | import CoqLNOutputCommon 12 | import CoqLNOutputCombinators 13 | 14 | openCloseThms :: ASTAnalysis -> [[NtRoot]] -> M String 15 | openCloseThms aa nts = 16 | do { close_inj_recs <- mapM (local . close_inj_rec aa) nts 17 | ; close_injs <- mapM (local . close_inj aa) nts 18 | ; close_open_recs <- mapM (local . close_open_rec aa) nts 19 | ; close_opens <- mapM (local . close_open aa) nts 20 | ; open_close_recs <- mapM (local . open_close_rec aa) nts 21 | ; open_closes <- mapM (local . open_close aa) nts 22 | ; open_inj_recs <- mapM (local . open_inj_rec aa) nts 23 | ; open_injs <- mapM (local . open_inj aa) nts 24 | ; return $ printf "Ltac %s ::= auto with %s %s; tauto.\n\ 25 | \Ltac %s ::= fail.\n\ 26 | \\n" 27 | defaultAuto hintDb bruteDb 28 | defaultAutoRewr ++ 29 | concat close_inj_recs ++ 30 | concat close_injs ++ 31 | concat close_open_recs ++ 32 | concat close_opens ++ 33 | concat open_close_recs ++ 34 | concat open_closes ++ 35 | concat open_inj_recs ++ 36 | concat open_injs ++ "\n" 37 | } 38 | 39 | {- | @close_rec k x e1 = close_rec k x e2@ implies @e1 = e2@. -} 40 | 41 | close_inj_rec :: ASTAnalysis -> [NtRoot] -> M String 42 | close_inj_rec aaa nt1s = 43 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 44 | ; names <- processNt1Nt2Mv2 aaa nt1s name 45 | ; types <- processNt1 aaa nt1s ntType 46 | ; let proof = mutPfStart Prop types ++ 47 | "intros; match goal with\n\ 48 | \ | |- _ = ?term => destruct term\n\ 49 | \ end;\n" ++ 50 | defaultSimp ++ printf "; eauto with %s." hintDb 51 | ; mutualLemmaText2 Immediate NoRewrite Hide [hintDb] Prop names thms (repeat proof) 52 | } 53 | where 54 | name aa nt1 _ mv2 = 55 | do { close_fn <- closeRecName aa nt1 mv2 56 | ; return $ close_fn ++ "_inj" 57 | } 58 | 59 | thm aa nt1 _ mv2 = 60 | do { close_fn <- closeRecName aa nt1 mv2 61 | ; e1 <- newName nt1 62 | ; e2 <- newName nt1 63 | ; x <- newName mv2 64 | ; k <- newName bvarRoot 65 | ; return $ printf "forall %s %s %s %s,\n\ 66 | \ %s %s %s %s = %s %s %s %s ->\n\ 67 | \ %s = %s" 68 | e1 e2 x k 69 | close_fn k x e1 close_fn k x e2 70 | e1 e2 71 | } 72 | 73 | {- | @close x e1 = close x e2@ implies @e1 = e2@. -} 74 | 75 | close_inj :: ASTAnalysis -> [NtRoot] -> M String 76 | close_inj aaa nt1s = 77 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 78 | ; names <- processNt1Nt2Mv2 aaa nt1s name 79 | ; lemmaText2 Immediate NoRewrite NoHide [hintDb] names gens 80 | } 81 | where 82 | name aa nt1 _ mv2 = 83 | do { close_fn <- closeName aa nt1 mv2 84 | ; return $ close_fn ++ "_inj" 85 | } 86 | 87 | gen aa nt1 _ mv2 = 88 | do { close_fn <- closeName aa nt1 mv2 89 | ; e1 <- newName nt1 90 | ; e2 <- newName nt1 91 | ; x <- newName mv2 92 | ; let stmt = printf "forall %s %s %s,\n\ 93 | \ %s %s %s = %s %s %s ->\n\ 94 | \ %s = %s" 95 | e1 e2 x 96 | close_fn x e1 close_fn x e2 97 | e1 e2 98 | ; let proof = printf "unfold %s; eauto with %s." close_fn hintDb 99 | ; return (stmt, proof) 100 | } 101 | 102 | {- | @close_rec k x (open_rec k x e) = e@ when @x `notin` fv e@. -} 103 | 104 | close_open_rec :: ASTAnalysis -> [NtRoot] -> M String 105 | close_open_rec aaa nt1s = 106 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 107 | ; names <- processNt1Nt2Mv2 aaa nt1s name 108 | ; types <- processNt1 aaa nt1s ntType 109 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 110 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 111 | } 112 | where 113 | name aa nt1 _ mv2 = 114 | do { close_fn <- closeRecName aa nt1 mv2 115 | ; open_fn <- openRecName aa nt1 mv2 116 | ; return $ close_fn ++ "_" ++ open_fn 117 | } 118 | 119 | thm aa nt1 nt2 mv2 = 120 | do { close_fn <- closeRecName aa nt1 mv2 121 | ; open_fn <- openRecName aa nt1 mv2 122 | ; fv_fn <- fvName aa nt1 mv2 123 | ; e <- newName nt1 124 | ; x <- newName mv2 125 | ; k <- newName bvarRoot 126 | ; constr <- getFreeVarConstr aa nt2 mv2 127 | ; return $ printf "forall %s %s %s,\n\ 128 | \ %s %s %s %s ->\n\ 129 | \ %s %s %s (%s %s (%s %s) %s) = %s" 130 | e x k 131 | x mvSetNotin fv_fn e 132 | close_fn k x open_fn k (toName constr) x e e 133 | } 134 | 135 | {- | @close x (open x e) = e@ when @x `notin` fv e@. -} 136 | 137 | close_open :: ASTAnalysis -> [NtRoot] -> M String 138 | close_open aaa nt1s = 139 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 140 | ; names <- processNt1Nt2Mv2 aaa nt1s name 141 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 142 | } 143 | where 144 | name aa nt1 _ mv2 = 145 | do { close_fn <- closeName aa nt1 mv2 146 | ; open_fn <- openName aa nt1 mv2 147 | ; return $ close_fn ++ "_" ++ open_fn 148 | } 149 | 150 | gen aa nt1 nt2 mv2 = 151 | do { close_fn <- closeName aa nt1 mv2 152 | ; open_fn <- openName aa nt1 mv2 153 | ; fv_fn <- fvName aa nt1 mv2 154 | ; e <- newName nt1 155 | ; x <- newName mv2 156 | ; constr <- getFreeVarConstr aa nt2 mv2 157 | -- ORDER TO OPEN 158 | ; let stmt = printf "forall %s %s,\n\ 159 | \ %s %s %s %s ->\n\ 160 | \ %s %s (%s %s (%s %s)) = %s" 161 | e x 162 | x mvSetNotin fv_fn e 163 | close_fn x open_fn e (toName constr) x e 164 | ; let proof = printf "unfold %s; unfold %s; %s." close_fn open_fn defaultSimp 165 | ; return (stmt, proof) 166 | } 167 | 168 | {- | @open_rec k x (close_rec k x e) = e@ -} 169 | 170 | open_close_rec :: ASTAnalysis -> [NtRoot] -> M String 171 | open_close_rec aaa nt1s = 172 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 173 | ; names <- processNt1Nt2Mv2 aaa nt1s name 174 | ; types <- processNt1 aaa nt1s ntType 175 | ; let proof = repeat (mutPfStart Prop types ++ defaultSimp ++ ".") 176 | ; mutualLemmaText2 Resolve Rewrite Hide [hintDb] Prop names thms proof 177 | } 178 | where 179 | name aa nt1 _ mv2 = 180 | do { close_fn <- closeRecName aa nt1 mv2 181 | ; open_fn <- openRecName aa nt1 mv2 182 | ; return $ open_fn ++ "_" ++ close_fn 183 | } 184 | 185 | thm aa nt1 nt2 mv2 = 186 | do { k <- newName bvarRoot 187 | ; x <- newName mv2 188 | ; e <- newName nt1 189 | ; close_fn <- closeRecName aa nt1 mv2 190 | ; open_fn <- openRecName aa nt1 mv2 191 | ; constr <- getFreeVarConstr aa nt2 mv2 192 | ; return $ printf 193 | "forall %s %s %s,\n\ 194 | \ %s %s (%s %s) (%s %s %s %s) = %s" 195 | e x k 196 | open_fn k (toName constr) x close_fn k x e e 197 | } 198 | 199 | {- | @open x (close x e) = e@ -} 200 | 201 | open_close :: ASTAnalysis -> [NtRoot] -> M String 202 | open_close aaa nt1s = 203 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 204 | ; names <- processNt1Nt2Mv2 aaa nt1s name 205 | ; lemmaText2 Resolve Rewrite NoHide [hintDb] names gens 206 | } 207 | where 208 | name aa nt1 _ mv2 = 209 | do { close_fn <- closeName aa nt1 mv2 210 | ; open_fn <- openName aa nt1 mv2 211 | ; return $ open_fn ++ "_" ++ close_fn 212 | } 213 | 214 | gen aa nt1 nt2 mv2 = 215 | do { x <- newName mv2 216 | ; e <- newName nt1 217 | ; close_fn <- closeName aa nt1 mv2 218 | ; open_fn <- openName aa nt1 mv2 219 | ; constr <- getFreeVarConstr aa nt2 mv2 220 | -- ORDER TO OPEN 221 | ; let stmt = printf "forall %s %s,\n\ 222 | \ %s (%s %s %s) (%s %s) = %s" 223 | e x 224 | open_fn close_fn x e (toName constr) x e 225 | ; let proof = printf "unfold %s; unfold %s; %s." 226 | close_fn open_fn defaultSimp 227 | ; return (stmt, proof) 228 | } 229 | 230 | {- | @open_rec k x e1 = open_rec k x e2@ implies @e1 = e2@ when 231 | @x `notin` fv e1 `union` fv e2@. -} 232 | 233 | open_inj_rec :: ASTAnalysis -> [NtRoot] -> M String 234 | open_inj_rec aaa nt1s = 235 | do { thms <- processNt1Nt2Mv2 aaa nt1s thm 236 | ; names <- processNt1Nt2Mv2 aaa nt1s name 237 | ; types <- processNt1 aaa nt1s ntType 238 | ; let proof = mutPfStart Prop types ++ 239 | "intros; match goal with\n\ 240 | \ | |- _ = ?term => destruct term\n\ 241 | \ end;\n" ++ 242 | printf "%s; eauto with %s." defaultSimp hintDb 243 | ; mutualLemmaText2 Immediate NoRewrite Hide [hintDb] Prop names thms (repeat proof) 244 | } 245 | where 246 | name aa nt1 _ mv2 = 247 | do { open_fn <- openRecName aa nt1 mv2 248 | ; return $ open_fn ++ "_inj" 249 | } 250 | 251 | thm aa nt1 nt2 mv2 = 252 | do { e2 <- newName nt1 253 | ; e1 <- newName nt1 254 | ; k <- newName bvarRoot 255 | ; x <- newName mv2 256 | ; open_fn <- openRecName aa nt1 mv2 257 | ; fv_fn <- fvName aa nt1 mv2 258 | ; constr <- getFreeVarConstr aa nt2 mv2 259 | ; return $ printf "forall %s %s %s %s,\n\ 260 | \ %s %s %s %s ->\n\ 261 | \ %s %s %s %s ->\n\ 262 | \ %s %s (%s %s) %s = %s %s (%s %s) %s ->\n\ 263 | \ %s = %s" 264 | e1 e2 x k 265 | x mvSetNotin fv_fn e1 266 | x mvSetNotin fv_fn e2 267 | open_fn k (toName constr) x e1 open_fn k (toName constr) x e2 268 | e1 e2 269 | } 270 | 271 | {- | @open e1 x = open e2 x@ implies @e1 = e2@ when 272 | @x `notin` fv e1 `union` fv e2@. -} 273 | 274 | open_inj :: ASTAnalysis -> [NtRoot] -> M String 275 | open_inj aaa nt1s = 276 | do { gens <- processNt1Nt2Mv2 aaa nt1s gen 277 | ; names <- processNt1Nt2Mv2 aaa nt1s name 278 | ; lemmaText2 Immediate NoRewrite NoHide [hintDb] names gens 279 | } 280 | where 281 | name aa nt1 _ mv2 = 282 | do { open_fn <- openName aa nt1 mv2 283 | ; return $ open_fn ++ "_inj" 284 | } 285 | 286 | gen aa nt1 nt2 mv2 = 287 | do { e2 <- newName nt1 288 | ; e1 <- newName nt1 289 | ; x <- newName mv2 290 | ; open_fn <- openName aa nt1 mv2 291 | ; fv_fn <- fvName aa nt1 mv2 292 | ; constr <- getFreeVarConstr aa nt2 mv2 293 | -- ORDER TO OPEN 294 | ; let stmt = printf"forall %s %s %s,\n\ 295 | \ %s %s %s %s ->\n\ 296 | \ %s %s %s %s ->\n\ 297 | \ %s %s (%s %s) = %s %s (%s %s) ->\n\ 298 | \ %s = %s" 299 | e1 e2 x 300 | x mvSetNotin fv_fn e1 301 | x mvSetNotin fv_fn e2 302 | open_fn e1 (toName constr) x open_fn e2 (toName constr) x 303 | e1 e2 304 | ; let proof = printf "unfold %s; eauto with %s." open_fn hintDb 305 | ; return (stmt, proof) 306 | } 307 | 308 | -------------------------------------------------------------------------------- /examples/Fsub/original/Fsub_Lemmas.v: -------------------------------------------------------------------------------- 1 | (** Administrative lemmas for Fsub. 2 | 3 | Authors: Brian Aydemir and Arthur Chargu\'eraud, with help from 4 | Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis. 5 | 6 | This file contains a number of administrative lemmas that we 7 | require for proving type-safety. The lemmas mainly concern the 8 | relations [wf_typ] and [wf_env]. 9 | 10 | This file also contains regularity lemmas, which show that various 11 | relations hold only for locally closed terms. In addition to 12 | being necessary to complete the proof of type-safety, these lemmas 13 | help demonstrate that our definitions are correct; they would be 14 | worth proving even if they are unneeded for any "real" proofs. 15 | 16 | Table of contents: 17 | - #Properties of wf_typ# 18 | - #Properties of wf_env and wf_typ# 19 | - #Properties of wf_env# 20 | - #Properties of substitution# 21 | - #Regularity lemmas# 22 | - #Automation# *) 23 | 24 | Require Export Fsub_Infrastructure. 25 | 26 | 27 | (* ********************************************************************** *) 28 | (** * ## Properties of [wf_typ] *) 29 | 30 | (** If a type is well-formed in an environment, then it is locally 31 | closed. *) 32 | 33 | Lemma type_from_wf_typ : forall E T, 34 | wf_typ E T -> type T. 35 | Proof. 36 | intros E T H; induction H; eauto. 37 | Qed. 38 | 39 | (** The remaining properties are analogous to the properties that we 40 | need to show for the subtyping and typing relations. *) 41 | 42 | Lemma wf_typ_weakening : forall T E F G, 43 | wf_typ (G ++ E) T -> 44 | uniq (G ++ F ++ E) -> 45 | wf_typ (G ++ F ++ E) T. 46 | Proof with simpl_env; eauto. 47 | intros T E F G Hwf_typ Hk. 48 | remember (G ++ E) as F'. 49 | generalize dependent G. 50 | induction Hwf_typ; intros G Hok Heq; subst... 51 | Case "type_all". 52 | pick fresh Y and apply wf_typ_all... 53 | rewrite <- app_assoc. 54 | apply H0... 55 | Qed. 56 | 57 | Lemma wf_typ_weaken_head : forall T E F, 58 | wf_typ E T -> 59 | uniq (F ++ E) -> 60 | wf_typ (F ++ E) T. 61 | Proof. 62 | intros. 63 | rewrite_env (empty ++ F++ E). 64 | auto using wf_typ_weakening. 65 | Qed. 66 | 67 | Lemma wf_typ_narrowing : forall V U T E F X, 68 | wf_typ (F ++ X ~ bind_sub V ++ E) T -> 69 | wf_typ (F ++ X ~ bind_sub U ++ E) T. 70 | Proof with simpl_env; eauto. 71 | intros V U T E F X Hwf_typ. 72 | remember (F ++ X ~ bind_sub V ++ E) as G. 73 | generalize dependent F. 74 | induction Hwf_typ; intros F Heq; subst... 75 | Case "wf_typ_var". 76 | analyze_binds H... 77 | Case "typ_all". 78 | pick fresh Y and apply wf_typ_all... 79 | rewrite <- app_assoc. 80 | apply H0... 81 | Qed. 82 | 83 | Lemma wf_typ_strengthening : forall E F x U T, 84 | wf_typ (F ++ x ~ bind_typ U ++ E) T -> 85 | wf_typ (F ++ E) T. 86 | Proof with simpl_env; eauto. 87 | intros E F x U T H. 88 | remember (F ++ x ~ bind_typ U ++ E) as G. 89 | generalize dependent F. 90 | induction H; intros F Heq; subst... 91 | Case "wf_typ_var". 92 | analyze_binds H... 93 | Case "wf_typ_all". 94 | pick fresh Y and apply wf_typ_all... 95 | rewrite <- app_assoc. 96 | apply H1... 97 | Qed. 98 | 99 | Lemma wf_typ_subst_tb : forall F Q E Z P T, 100 | wf_typ (F ++ Z ~ bind_sub Q ++ E) T -> 101 | wf_typ E P -> 102 | uniq (map (subst_tb Z P) F ++ E) -> 103 | wf_typ (map (subst_tb Z P) F ++ E) (subst_tt Z P T). 104 | Proof with simpl_env; eauto using wf_typ_weaken_head, type_from_wf_typ. 105 | intros F Q E Z P T WT WP. 106 | remember (F ++ Z ~ bind_sub Q ++ E) as G. 107 | generalize dependent F. 108 | induction WT; intros F EQ Ok; subst; simpl subst_tt... 109 | Case "wf_typ_var". 110 | destruct (X == Z); subst... 111 | SCase "X <> Z". 112 | analyze_binds H... 113 | apply (wf_typ_var (subst_tt Z P U))... 114 | Case "wf_typ_all". 115 | pick fresh Y and apply wf_typ_all... 116 | rewrite subst_tt_open_tt_var... 117 | rewrite_env (map (subst_tb Z P) (Y ~ bind_sub T1 ++ F) ++ E). 118 | apply H0... 119 | Qed. 120 | 121 | Lemma wf_typ_open : forall E U T1 T2, 122 | uniq E -> 123 | wf_typ E (typ_all T1 T2) -> 124 | wf_typ E U -> 125 | wf_typ E (open_tt T2 U). 126 | Proof with simpl_env; eauto. 127 | intros E U T1 T2 Ok WA WU. 128 | inversion WA; subst. 129 | pick fresh X. 130 | rewrite (subst_tt_intro X)... 131 | rewrite_env (map (subst_tb X U) empty ++ E). 132 | eapply wf_typ_subst_tb... 133 | Qed. 134 | 135 | 136 | (* ********************************************************************** *) 137 | (** * ## Properties of [wf_env] and [wf_typ] *) 138 | 139 | Lemma uniq_from_wf_env : forall E, 140 | wf_env E -> 141 | uniq E. 142 | Proof. 143 | intros E H; induction H; auto. 144 | Qed. 145 | 146 | (** We add [uniq_from_wf_env] as a hint here since it helps blur the 147 | distinction between [wf_env] and [uniq] in proofs. The lemmas in 148 | the MetatheoryEnv library use [uniq], whereas here we naturally 149 | have (or can easily show) the stronger [wf_env]. Thus, 150 | [uniq_from_wf_env] serves as a bridge that allows us to use the 151 | environments library. *) 152 | 153 | Hint Resolve uniq_from_wf_env. 154 | 155 | Lemma wf_typ_from_binds_typ : forall x U E, 156 | wf_env E -> 157 | binds x (bind_typ U) E -> 158 | wf_typ E U. 159 | Proof with auto using wf_typ_weaken_head. 160 | induction 1; intros J; analyze_binds J... 161 | injection BindsTacVal; intros; subst... 162 | Qed. 163 | 164 | Lemma wf_typ_from_wf_env_typ : forall x T E, 165 | wf_env (x ~ bind_typ T ++ E) -> 166 | wf_typ E T. 167 | Proof. 168 | intros x T E H. inversion H; auto. 169 | Qed. 170 | 171 | Lemma wf_typ_from_wf_env_sub : forall x T E, 172 | wf_env (x ~ bind_sub T ++ E) -> 173 | wf_typ E T. 174 | Proof. 175 | intros x T E H. inversion H; auto. 176 | Qed. 177 | 178 | 179 | (* ********************************************************************** *) 180 | (** * ## Properties of [wf_env] *) 181 | 182 | (** These properties are analogous to the properties that we need to 183 | show for the subtyping and typing relations. *) 184 | 185 | Lemma wf_env_narrowing : forall V E F U X, 186 | wf_env (F ++ X ~ bind_sub V ++ E) -> 187 | wf_typ E U -> 188 | wf_env (F ++ X ~ bind_sub U ++ E). 189 | Proof with eauto using wf_typ_narrowing. 190 | induction F; intros U X Wf_env Wf; 191 | inversion Wf_env; subst; simpl_env in *... 192 | Qed. 193 | 194 | Lemma wf_env_strengthening : forall x T E F, 195 | wf_env (F ++ x ~ bind_typ T ++ E) -> 196 | wf_env (F ++ E). 197 | Proof with eauto using wf_typ_strengthening. 198 | induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *... 199 | Qed. 200 | 201 | Lemma wf_env_subst_tb : forall Q Z P E F, 202 | wf_env (F ++ Z ~ bind_sub Q ++ E) -> 203 | wf_typ E P -> 204 | wf_env (map (subst_tb Z P) F ++ E). 205 | Proof with eauto 6 using wf_typ_subst_tb. 206 | induction F; intros Wf_env WP; simpl_env; 207 | inversion Wf_env; simpl_env in *; simpl subst_tb... 208 | Qed. 209 | 210 | 211 | (* ********************************************************************** *) 212 | (** * ## Environment is unchanged by substitution for a fresh name *) 213 | 214 | Lemma notin_fv_tt_open : forall (Y X : atom) T, 215 | X `notin` fv_tt (open_tt T Y) -> 216 | X `notin` fv_tt T. 217 | Proof. 218 | intros Y X T. unfold open_tt. 219 | generalize 0. 220 | induction T; simpl; intros k Fr; eauto. 221 | Qed. 222 | 223 | Lemma notin_fv_wf : forall E (X : atom) T, 224 | wf_typ E T -> 225 | X `notin` dom E -> 226 | X `notin` fv_tt T. 227 | Proof with auto. 228 | intros E X T Wf_typ. 229 | induction Wf_typ; intros Fr; simpl... 230 | Case "wf_typ_var". 231 | assert (X0 `in` (dom E))... 232 | eapply binds_In; eauto. fsetdec. 233 | Case "wf_typ_all". 234 | apply notin_union... 235 | pick fresh Y. 236 | apply (notin_fv_tt_open Y)... 237 | Qed. 238 | 239 | Lemma map_subst_tb_id : forall G Z P, 240 | wf_env G -> 241 | Z `notin` dom G -> 242 | G = map (subst_tb Z P) G. 243 | Proof with auto. 244 | intros G Z P H. 245 | induction H; simpl; intros Fr; simpl_env... 246 | rewrite <- IHwf_env... 247 | rewrite <- subst_tt_fresh... eapply notin_fv_wf; eauto. 248 | rewrite <- IHwf_env... 249 | rewrite <- subst_tt_fresh... eapply notin_fv_wf; eauto. 250 | Qed. 251 | 252 | 253 | (* ********************************************************************** *) 254 | (** * ## Regularity of relations *) 255 | 256 | Lemma sub_regular : forall E S T, 257 | sub E S T -> 258 | wf_env E /\ wf_typ E S /\ wf_typ E T. 259 | Proof with simpl_env; try solve [auto | intuition auto]. 260 | intros E S T H. 261 | induction H... 262 | Case "sub_trans_tvar". 263 | intuition eauto. 264 | Case "sub_all". 265 | repeat split... 266 | SCase "Second of original three conjuncts". 267 | pick fresh Y and apply wf_typ_all... 268 | destruct (H1 Y)... 269 | rewrite_env (empty ++ Y ~ bind_sub S1 ++ E). 270 | apply (wf_typ_narrowing T1)... 271 | SCase "Third of original three conjuncts". 272 | pick fresh Y and apply wf_typ_all... 273 | destruct (H1 Y)... 274 | Qed. 275 | 276 | Lemma typing_regular : forall E e T, 277 | typing E e T -> 278 | wf_env E /\ expr e /\ wf_typ E T. 279 | Proof with simpl_env; try solve [auto | intuition auto]. 280 | intros E e T H; induction H... 281 | Case "typing_var". 282 | repeat split... 283 | eauto using wf_typ_from_binds_typ. 284 | Case "typing_abs". 285 | pick fresh y. 286 | destruct (H0 y) as [Hok [J K]]... 287 | repeat split. inversion Hok... 288 | SCase "Second of original three conjuncts". 289 | pick fresh x and apply expr_abs. 290 | eauto using type_from_wf_typ, wf_typ_from_wf_env_typ. 291 | destruct (H0 x)... 292 | SCase "Third of original three conjuncts". 293 | apply wf_typ_arrow; eauto using wf_typ_from_wf_env_typ. 294 | rewrite_env (empty ++ E). 295 | eapply wf_typ_strengthening; simpl_env; eauto. 296 | Case "typing_app". 297 | repeat split... 298 | destruct IHtyping1 as [_ [_ K]]. 299 | inversion K... 300 | Case "typing_tabs". 301 | pick fresh Y. 302 | destruct (H0 Y) as [Hok [J K]]... 303 | inversion Hok; subst. 304 | repeat split... 305 | SCase "Second of original three conjuncts". 306 | pick fresh X and apply expr_tabs. 307 | eauto using type_from_wf_typ, wf_typ_from_wf_env_sub... 308 | destruct (H0 X)... 309 | SCase "Third of original three conjuncts". 310 | pick fresh Z and apply wf_typ_all... 311 | destruct (H0 Z)... 312 | Case "typing_tapp". 313 | destruct (sub_regular _ _ _ H0) as [R1 [R2 R3]]. 314 | repeat split... 315 | SCase "Second of original three conjuncts". 316 | apply expr_tapp... 317 | eauto using type_from_wf_typ. 318 | SCase "Third of original three conjuncts". 319 | destruct IHtyping as [R1' [R2' R3']]. 320 | eapply wf_typ_open; eauto. 321 | Case "typing_sub". 322 | repeat split... 323 | destruct (sub_regular _ _ _ H0)... 324 | Case "typing_let". 325 | repeat split... 326 | SCase "Second of original three conjuncts". 327 | pick fresh y and apply expr_let... 328 | destruct (H1 y) as [K1 [K2 K3]]... 329 | SCase "Third of original three conjuncts". 330 | pick fresh y. 331 | destruct (H1 y) as [K1 [K2 K3]]... 332 | rewrite_env (empty ++ E). 333 | eapply wf_typ_strengthening; simpl_env; eauto. 334 | Case "typing_case". 335 | repeat split... 336 | SCase "Second of original three conjuncts". 337 | pick fresh x and apply expr_case... 338 | destruct (H1 x) as [? [? ?]]... 339 | destruct (H3 x) as [? [? ?]]... 340 | SCase "Third of original three conjuncts". 341 | pick fresh y. 342 | destruct (H1 y) as [K1 [K2 K3]]... 343 | rewrite_env (empty ++ E). 344 | eapply wf_typ_strengthening; simpl_env; eauto. 345 | Qed. 346 | 347 | Lemma value_regular : forall e, 348 | value e -> 349 | expr e. 350 | Proof. 351 | intros e H. induction H; auto. 352 | Qed. 353 | 354 | Lemma red_regular : forall e e', 355 | red e e' -> 356 | expr e /\ expr e'. 357 | Proof with try solve [auto | intuition auto]. 358 | intros e e' H. 359 | induction H; assert(J := value_regular); split... 360 | Case "red_abs". 361 | inversion H. pick fresh y. rewrite (subst_ee_intro y)... 362 | Case "red_tabs". 363 | inversion H. pick fresh Y. rewrite (subst_te_intro Y)... 364 | Qed. 365 | 366 | 367 | (* *********************************************************************** *) 368 | (** * ## Automation *) 369 | 370 | (** The lemma [uniq_from_wf_env] was already added above as a hint 371 | since it helps blur the distinction between [wf_env] and [uniq] in 372 | proofs. 373 | 374 | As currently stated, the regularity lemmas are ill-suited to be 375 | used with [auto] and [eauto] since they end in conjunctions. Even 376 | if we were, for example, to split [sub_regularity] into three 377 | separate lemmas, the resulting lemmas would be usable only by 378 | [eauto] and there is no guarantee that [eauto] would be able to 379 | find proofs effectively. Thus, the hints below apply the 380 | regularity lemmas and [type_from_wf_typ] to discharge goals about 381 | local closure and well-formedness, but in such a way as to 382 | minimize proof search. 383 | 384 | The first hint introduces an [wf_env] fact into the context. It 385 | works well when combined with the lemmas relating [wf_env] and 386 | [wf_typ]. We choose to use those lemmas explicitly via [(auto 387 | using ...)] tactics rather than add them as hints. When used this 388 | way, the explicitness makes the proof more informative rather than 389 | more cluttered (with useless details). 390 | 391 | The other three hints try outright to solve their respective 392 | goals. *) 393 | 394 | Hint Extern 1 (wf_env ?E) => 395 | match goal with 396 | | H: sub _ _ _ |- _ => apply (proj1 (sub_regular _ _ _ H)) 397 | | H: typing _ _ _ |- _ => apply (proj1 (typing_regular _ _ _ H)) 398 | end. 399 | 400 | Hint Extern 1 (wf_typ ?E ?T) => 401 | match goal with 402 | | H: typing E _ T |- _ => apply (proj2 (proj2 (typing_regular _ _ _ H))) 403 | | H: sub E T _ |- _ => apply (proj1 (proj2 (sub_regular _ _ _ H))) 404 | | H: sub E _ T |- _ => apply (proj2 (proj2 (sub_regular _ _ _ H))) 405 | end. 406 | 407 | Hint Extern 1 (type ?T) => 408 | let go E := apply (type_from_wf_typ E); auto in 409 | match goal with 410 | | H: typing ?E _ T |- _ => go E 411 | | H: sub ?E T _ |- _ => go E 412 | | H: sub ?E _ T |- _ => go E 413 | end. 414 | 415 | Hint Extern 1 (expr ?e) => 416 | match goal with 417 | | H: typing _ ?e _ |- _ => apply (proj1 (proj2 (typing_regular _ _ _ H))) 418 | | H: red ?e _ |- _ => apply (proj1 (red_regular _ _ H)) 419 | | H: red _ ?e |- _ => apply (proj2 (red_regular _ _ H)) 420 | end. 421 | -------------------------------------------------------------------------------- /src/CoqLNOutputCommon.hs: -------------------------------------------------------------------------------- 1 | {- | Implementation note (BEA): For the sake of consistency, some 2 | functions return a result in a monad, even when the functions are 3 | completely pure. -} 4 | 5 | module CoqLNOutputCommon where 6 | 7 | import Data.Map as Map 8 | import Control.Monad.Fail as Fail 9 | 10 | import AST 11 | import ASTAnalysis 12 | import MyLibrary ( sepStrings ) 13 | 14 | 15 | {- ----------------------------------------------------------------------- -} 16 | {- * Constants: General -} 17 | 18 | {- | Separator to use between parts of the generated output. -} 19 | 20 | coqSep :: String 21 | coqSep = "(* *********************************************************************** *)\n" 22 | 23 | {- | The \"core\" hint database for Coq. -} 24 | 25 | coreDb :: String 26 | coreDb = "core" 27 | 28 | {- | The hint database for \"brute force\" automation. -} 29 | 30 | bruteDb :: String 31 | bruteDb = "brute_force" 32 | 33 | {- | The hint database for @lngen@ specific \"brute force\" automation 34 | via @auto@. -} 35 | 36 | hintDb :: String 37 | hintDb = "lngen" 38 | 39 | {- | The name of the functional extensionality axiom. -} 40 | 41 | funExtEq :: String 42 | funExtEq = "@functional_extensionality_dep" 43 | 44 | {- | The name of the well-founded induction on natural numbers 45 | for @Prop@. -} 46 | 47 | ltWfInd :: String 48 | ltWfInd = "lt_wf" 49 | 50 | {- | The name of the well-founded induction on natural numbers 51 | for @Set@. -} 52 | 53 | ltWfRec :: String 54 | ltWfRec = "lt_wf_rec" 55 | 56 | 57 | {- ----------------------------------------------------------------------- -} 58 | {- * Constants: Related to decidable equality -} 59 | 60 | {- | The infix operator for decidable equality. -} 61 | 62 | decEq :: String 63 | decEq = "==" 64 | 65 | 66 | {- ----------------------------------------------------------------------- -} 67 | {- * Constants: Related to finite sets -} 68 | 69 | {- | The empty metavariable set. -} 70 | 71 | mvSetEmpty :: String 72 | mvSetEmpty = "empty" 73 | 74 | {- | The type of finite sets of atoms. -} 75 | 76 | mvSetType :: String 77 | mvSetType = "atoms" 78 | 79 | {- | The (infix) \"not in\" predicate on metavariable sets. -} 80 | 81 | mvSetNotin :: String 82 | mvSetNotin = "`notin`" 83 | 84 | {- | The (prefix) remove operation on metavariable sets. -} 85 | 86 | mvSetRemove :: String 87 | mvSetRemove = "remove" 88 | 89 | {- | The (prefix) singleton metavariable set constructor. -} 90 | 91 | mvSetSingleton :: String 92 | mvSetSingleton = "singleton" 93 | 94 | {- | The (infix) union operation on metavariable sets. -} 95 | 96 | mvSetUnion :: String 97 | mvSetUnion = "`union`" 98 | 99 | 100 | {- ----------------------------------------------------------------------- -} 101 | {- * Constants: Related to indices -} 102 | 103 | {- | The type of bound variables (indices). -} 104 | 105 | bvarType :: String 106 | bvarType = "nat" 107 | 108 | {- | The root to use for bound variables (indices). -} 109 | 110 | bvarRoot :: String 111 | bvarRoot = "n" 112 | 113 | {- | The name of the \"less-than\" predicate on bound variables. -} 114 | 115 | bvarLt :: String 116 | bvarLt = "lt" 117 | 118 | {- | The name of the \"lt_eq_lt_dec\" predicate on bound variables. -} 119 | 120 | bvarLtEqLtDec :: String 121 | bvarLtEqLtDec = "lt_eq_lt_dec" 122 | 123 | {- | The name of the \"lt_ge_dec\" predicate on bound variables. -} 124 | 125 | bvarLtGeDec :: String 126 | bvarLtGeDec = "lt_ge_dec" 127 | 128 | 129 | {- ----------------------------------------------------------------------- -} 130 | {- * Constructing names: Metavariables and nonterminals -} 131 | 132 | {- | The type of atoms. -} 133 | 134 | atomType :: Name 135 | atomType = "atom" 136 | 137 | {- | Returns the canonical short name for the given metavariable root. -} 138 | 139 | mvRoot :: MonadFail m => ASTAnalysis -> MvRoot -> m Name 140 | mvRoot aa mv = return $ canonRoot aa mv 141 | 142 | {- | Returns the canonical short name for the given nonterminal root. -} 143 | 144 | ntRoot :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 145 | ntRoot aa nt = return $ canonRoot aa nt 146 | 147 | {- | Returns the canonical type for the given metavariable root. -} 148 | 149 | mvType :: MonadFail m => ASTAnalysis -> MvRoot -> m Name 150 | mvType aa mv = getMvDecl aa mv >>= \decl -> return (toName decl) 151 | 152 | {- | Returns the canonical type for the given nonterminal root. -} 153 | 154 | ntType :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 155 | ntType aa nt = getSyntax aa nt >>= \decl -> return (toName decl) 156 | 157 | {- | Checks whether the the given nonterminal root is phantom. -} 158 | isPhantomNtRoot :: MonadFail m => ASTAnalysis -> NtRoot -> m Bool 159 | isPhantomNtRoot aa nt = isPhantomSyntax <$> getSyntax aa nt 160 | 161 | {- | Checks whether the the given nonterminal root is not phantom. -} 162 | notPhantomNtRoot :: MonadFail m => ASTAnalysis -> NtRoot -> m Bool 163 | notPhantomNtRoot aa nt = not . isPhantomSyntax <$> getSyntax aa nt 164 | 165 | {- | Returns the canonical type for the given nonterminal root that is 166 | not marked as phantom. -} 167 | ntTypeNonPhantom :: MonadFail m => ASTAnalysis -> NtRoot -> m (Maybe Name) 168 | ntTypeNonPhantom aa nt = getSyntax aa nt >>= getDeclMb 169 | where getDeclMb decl 170 | | isPhantomSyntax decl = return Nothing 171 | | otherwise = return (Just $ toName decl) 172 | 173 | 174 | 175 | {- ----------------------------------------------------------------------- -} 176 | {- * Constructing names: Functions -} 177 | 178 | 179 | {- | Returns the name of the @close@ function, where the function is 180 | defined by induction on the first given nonterminal. -} 181 | 182 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 183 | -- Ott backend doesn't properly handle the underlying case. 184 | 185 | closeName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 186 | closeName aa nt1 mv2 = 187 | do { n1 <- ntType aa nt1 188 | ; m2 <- ntType aa (ntOfMv aa mv2) 189 | ; return $ "close_" ++ n1 ++ "_wrt_" ++ m2 190 | } 191 | 192 | {- | Returns the name of the @close_rec@ function, where the function 193 | is defined by induction on the first given nonterminal. -} 194 | 195 | closeRecName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 196 | closeRecName aa nt1 mv2 = 197 | closeName aa nt1 mv2 >>= \n -> return $ n ++ "_rec" 198 | 199 | 200 | {- | Returns the name of the @fv@ function, where the function is 201 | defined by induction on the first given nonterminal. -} 202 | 203 | fvName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 204 | fvName aa nt1 mv2 = 205 | case Map.lookup (ntOfMv aa mv2, mv2) (fvMap aa) of 206 | Just n -> do { suffix <- ntType aa nt1 207 | ; return $ n ++ "_" ++ suffix 208 | } 209 | Nothing -> Fail.fail $ "No 'freevars' declaration for: " ++ (ntOfMv aa mv2) ++ " " ++ mv2 ++ "." 210 | 211 | {- | Returns the name of the @open@ function, where the function is 212 | defined by induction on the first given nonterminal. -} 213 | 214 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 215 | -- Ott backend doesn't properly handle the underlying case. 216 | 217 | openName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 218 | openName aa nt1 mv2 = 219 | do { n1 <- ntType aa nt1 220 | ; m2 <- ntType aa (ntOfMv aa mv2) 221 | ; return $ "open_" ++ n1 ++ "_wrt_" ++ m2 222 | } 223 | 224 | {- | Returns the name of the @open_rec@ function, where the function 225 | is defined by induction the first given nonterminal. -} 226 | 227 | openRecName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 228 | openRecName aa nt1 mv2 = 229 | openName aa nt1 mv2 >>= \n -> return $ n ++ "_rec" 230 | 231 | {- | Returns the name of the @size@ function. -} 232 | 233 | sizeName :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 234 | sizeName aa nt = ntType aa nt >>= \n -> return $ "size_" ++ n 235 | 236 | {- | Returns the name of the @subst@ function, where the function is 237 | defined by induction on the second given nonterminal. -} 238 | 239 | substName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 240 | substName aa nt1 mv2 = 241 | case Map.lookup (ntOfMv aa mv2, mv2) (substMap aa) of 242 | Just n -> do { suffix <- ntType aa nt1 243 | ; return $ n ++ "_" ++ suffix 244 | } 245 | Nothing -> Fail.fail $ "No 'substitutions' declaration for: " ++ (ntOfMv aa mv2) ++ " " ++ mv2 ++ "." 246 | 247 | 248 | {- ----------------------------------------------------------------------- -} 249 | {- * Constructing names: Induction principles -} 250 | 251 | {- | Takes a list of names of types and returns the name to use with a 252 | @Combined Scheme@ declarations for @Prop@. -} 253 | 254 | mutIndName :: [Name] -> Name 255 | mutIndName [] = error "mutIndName: Internal error." 256 | mutIndName ns = sepStrings "_" ns ++ "_mutind" 257 | 258 | {- | Takes the name of a type and returns the name to use with a 259 | @Scheme@ declaration for @Prop@. -} 260 | 261 | schemeIndName :: Name -> Name 262 | schemeIndName = (++ "_ind'") 263 | 264 | {- | Takes a list of names of types and returns the name to use with a 265 | @Combined Scheme@ declarations for @Set@. -} 266 | 267 | mutRecName :: [Name] -> Name 268 | mutRecName [] = error "mutRecName: Internal error." 269 | mutRecName ns = sepStrings "_" ns ++ "_mutrec" 270 | 271 | {- | Takes the name of a type and returns the name to use with a 272 | @Scheme@ declaration for @Set@. -} 273 | 274 | schemeRecName :: Name -> Name 275 | schemeRecName = (++ "_rec'") 276 | 277 | 278 | {- ----------------------------------------------------------------------- -} 279 | {- * Constructing names: Predicates -} 280 | 281 | {- | Returns the name of the body predicate, where the main term is 282 | given by the first nonterminal. -} 283 | 284 | bodyName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 285 | bodyName aa nt1 mv2 = 286 | do { n1 <- ntType aa nt1 287 | ; m2 <- ntType aa (ntOfMv aa mv2) 288 | ; return $ "body_" ++ n1 ++ "_wrt_" ++ m2 289 | } 290 | 291 | {- | Returns the name of the degree predicate, where the predicate is 292 | defined by induction on the first given nonterminal. (For @Prop@.) -} 293 | 294 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 295 | -- Ott backend doesn't properly handle the underlying case. 296 | 297 | degreeName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 298 | degreeName aa nt1 mv2 = 299 | do { n1 <- ntType aa nt1 300 | ; m2 <- ntType aa (ntOfMv aa mv2) 301 | ; return $ "degree_" ++ n1 ++ "_wrt_" ++ m2 302 | } 303 | 304 | {- | Returns the name of the degree constructor, where the predicate 305 | is defined by induction on the first given nonterminal. (For @Prop@.) -} 306 | 307 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 308 | -- Ott backend doesn't properly handle the underlying case. 309 | 310 | degreeConstrName :: MonadFail m => ASTAnalysis -> SConstr -> NtRoot -> MvRoot -> m Name 311 | degreeConstrName aa sc _ mv2 = 312 | do { m2 <- ntType aa (ntOfMv aa mv2) 313 | ; return $ "degree_wrt_" ++ m2 ++ "_" ++ (toName sc) 314 | } 315 | 316 | {- | Returns the name of the degree predicate, where the predicate is 317 | defined by induction on the first given nonterminal. (For @Set@.) -} 318 | 319 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 320 | -- Ott backend doesn't properly handle the underlying case. 321 | 322 | degreeSetName :: MonadFail m => ASTAnalysis -> NtRoot -> MvRoot -> m Name 323 | degreeSetName aa nt1 mv2 = 324 | do { n1 <- ntType aa nt1 325 | ; m2 <- ntType aa (ntOfMv aa mv2) 326 | ; return $ "degree_set_" ++ n1 ++ "_wrt_" ++ m2 327 | } 328 | 329 | {- | Returns the name of the degree constructor, where the predicate 330 | is defined by induction on the first given nonterminal. (For @Set@.) -} 331 | 332 | -- XXX BEA: I should use @mv2@ to generate the name, but the current 333 | -- Ott backend doesn't properly handle the underlying case. 334 | 335 | degreeSetConstrName :: MonadFail m => ASTAnalysis -> SConstr -> NtRoot -> MvRoot -> m Name 336 | degreeSetConstrName aa sc _ mv2 = 337 | do { m2 <- ntType aa (ntOfMv aa mv2) 338 | ; return $ "degree_set_wrt_" ++ m2 ++ "_" ++ (toName sc) 339 | } 340 | 341 | {- | Returns the name of the local closure predicate for the given 342 | nonterminal. (For @Prop@.) -} 343 | 344 | lcName :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 345 | lcName aa nt = ntType aa nt >>= \n -> return $ "lc_" ++ n 346 | 347 | {- | Returns the name of the local closure "universal" constructor for 348 | the given constructor, which is assumed to be for the given 349 | nonterminal. (For @Prop@.) -} 350 | 351 | lcConstrName :: MonadFail m => SConstr -> m Name 352 | lcConstrName sc = return $ "lc_" ++ (toName sc) 353 | 354 | {- | Returns the name of the local closure "exists" constructor for 355 | the given constructor, which is assumed to be for the given 356 | nonterminal. (For @Prop@.) -} 357 | 358 | lcExConstrName :: MonadFail m => SConstr -> m Name 359 | lcExConstrName sc = lcConstrName sc >>= \n -> return $ n ++ "_ex" 360 | 361 | {- | Returns the name of the local closure predicate for the given 362 | nonterminal. (For @Set@.) -} 363 | 364 | lcSetName :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 365 | lcSetName aa nt = getSyntax aa nt >>= \n -> return $ "lc_set_" ++ (toName n) 366 | 367 | {- | Returns the name of the local closure "universal" constructor for 368 | the given constructor, which is assumed to be for the given 369 | nonterminal. (For @Set@.) -} 370 | 371 | lcSetConstrName :: MonadFail m => SConstr -> m Name 372 | lcSetConstrName sc = return $ "lc_set_" ++ (toName sc) 373 | 374 | {- | Returns the name of the local closure "exists" constructor for 375 | the given constructor, which is assumed to be for the given 376 | nonterminal. (For @Set@.) -} 377 | 378 | lcSetExConstrName :: MonadFail m => SConstr -> m Name 379 | lcSetExConstrName sc = lcConstrName sc >>= \n -> return $ n ++ "_ex" 380 | 381 | 382 | {- ----------------------------------------------------------------------- -} 383 | {- * Constructing names: Swapping -} 384 | 385 | {- | The name of the @swap@ function on @atom@s. -} 386 | 387 | swapAtomName :: Name 388 | swapAtomName = "swap_atom" 389 | 390 | {- | Name of the \"swap" type class. -} 391 | 392 | swapClass :: Name 393 | swapClass = "Swap" 394 | 395 | {- | The name of the \"swap_distrib\" type class field. -} 396 | 397 | swapDistrib :: Name 398 | swapDistrib = "swap_distrib" 399 | 400 | {- | The name of the swapping function for the given nonterminal. -} 401 | 402 | swapImplName :: MonadFail m => ASTAnalysis -> NtRoot -> m Name 403 | swapImplName aa nt = ntType aa nt >>= \n -> return $ "swap_" ++ n 404 | 405 | {- | The name of the \"swap_invol\" type class field. -} 406 | 407 | swapInvol :: Name 408 | swapInvol = "swap_invol" 409 | 410 | {- | The name of the swapping function from the class definition. -} 411 | 412 | swapName :: Name 413 | swapName = "swap" 414 | 415 | {- | The name of the \"swap_same\" type class field. -} 416 | 417 | swapSame :: Name 418 | swapSame = "swap_same" 419 | 420 | 421 | {- ----------------------------------------------------------------------- -} 422 | {- * Constructing names: Tactics -} 423 | 424 | {- | The name of the tactic for applying a mutual induction principle. -} 425 | 426 | applyMutInd :: String 427 | applyMutInd = "apply_mutual_ind" 428 | 429 | {- | The name of the default @auto@ tactic. -} 430 | 431 | defaultAuto :: String 432 | defaultAuto = "default_auto" 433 | 434 | {- | The name of the default @autorewrite@ tactic. -} 435 | 436 | defaultAutoRewr :: String 437 | defaultAutoRewr = "default_autorewrite" 438 | 439 | {- | The name of the default simplification tactic. -} 440 | 441 | defaultSimp :: String 442 | defaultSimp = "default_simp" 443 | 444 | {- | The name of the default simplification tactic that doesn't do 445 | case analysis. -} 446 | 447 | defaultSteps :: String 448 | defaultSteps = "default_steps" 449 | 450 | {- | The name of the tactic that decomposes hypotheses about set 451 | non-membership. -} 452 | 453 | destructNotin :: String 454 | destructNotin = "destruct_notin" 455 | 456 | {- | The name of the tactic for using @eapply@ to apply the first 457 | applicable hypothesis. -} 458 | 459 | eapplyFirst :: String 460 | eapplyFirst = "eapply_first_lt_hyp" 461 | 462 | {- | The general purpose tactic for solving goals about finite sets. -} 463 | 464 | fsetdecTac :: String 465 | fsetdecTac = "fsetdec" 466 | 467 | {- | The name of the tactic that \"gathers\" all atoms in the context. -} 468 | 469 | gatherTac :: String 470 | gatherTac = "gather_atoms" 471 | 472 | {- | The name of the tactic that picks a fresh atom. -} 473 | 474 | pickFreshTac :: String 475 | pickFreshTac = "pick_fresh" 476 | 477 | {- | The name of the tactic for renaming the last hypothesis. -} 478 | 479 | renameLastTac :: String 480 | renameLastTac = "rename_last_into" 481 | 482 | {- | The name of the tactic for specializing all hypotheses. -} 483 | 484 | specializeAllTac :: String 485 | specializeAllTac = "specialize_all" 486 | 487 | {- | The name of the tactic for proving the uniqueness of objects. -} 488 | 489 | uniquenessTac :: String 490 | uniquenessTac = "uniqueness" 491 | -------------------------------------------------------------------------------- /examples/SimpleTypes/.SimpleTypes_inf.aux: -------------------------------------------------------------------------------- 1 | COQAUX1 f496e116876c418d390f6d0c29fc3bca /Users/sweirich/github/lngen/examples/SimpleTypes/SimpleTypes_inf.v 2 | 0 0 VernacProof "tac:no using:no" 3 | 4066 4070 proof_build_time "0.007" 4 | 0 0 size_typ_min_mutual "0.007" 5 | 4023 4065 context_used "" 6 | 4066 4070 proof_check_time "0.000" 7 | 0 0 VernacProof "tac:no using:no" 8 | 4199 4203 proof_build_time "0.000" 9 | 0 0 size_typ_min "0.000" 10 | 4145 4198 context_used "" 11 | 4199 4203 proof_check_time "0.000" 12 | 0 0 VernacProof "tac:no using:no" 13 | 4378 4382 proof_build_time "0.016" 14 | 0 0 size_exp_min_mutual "0.016" 15 | 4335 4377 context_used "" 16 | 4378 4382 proof_check_time "0.001" 17 | 0 0 VernacProof "tac:no using:no" 18 | 4511 4515 proof_build_time "0.000" 19 | 0 0 size_exp_min "0.000" 20 | 4457 4510 context_used "" 21 | 4511 4515 proof_check_time "0.000" 22 | 0 0 VernacProof "tac:no using:no" 23 | 4755 4759 proof_build_time "0.080" 24 | 0 0 size_exp_close_exp_wrt_exp_rec_mutual "0.080" 25 | 4712 4754 context_used "" 26 | 4755 4759 proof_check_time "0.001" 27 | 0 0 VernacProof "tac:no using:no" 28 | 4989 4993 proof_build_time "0.000" 29 | 0 0 size_exp_close_exp_wrt_exp_rec "0.000" 30 | 4917 4988 context_used "" 31 | 4989 4993 proof_check_time "0.000" 32 | 0 0 VernacProof "tac:no using:no" 33 | 5305 5309 proof_build_time "0.001" 34 | 0 0 size_exp_close_exp_wrt_exp "0.001" 35 | 5265 5304 context_used "" 36 | 5305 5309 proof_check_time "0.000" 37 | 0 0 VernacProof "tac:no using:no" 38 | 5640 5644 proof_build_time "0.022" 39 | 0 0 size_exp_open_exp_wrt_exp_rec_mutual "0.022" 40 | 5597 5639 context_used "" 41 | 5640 5644 proof_check_time "0.000" 42 | 0 0 VernacProof "tac:no using:no" 43 | 5872 5876 proof_build_time "0.000" 44 | 0 0 size_exp_open_exp_wrt_exp_rec "0.000" 45 | 5801 5871 context_used "" 46 | 5872 5876 proof_check_time "0.000" 47 | 0 0 VernacProof "tac:no using:no" 48 | 6103 6107 proof_build_time "0.001" 49 | 0 0 size_exp_open_exp_wrt_exp "0.001" 50 | 6064 6102 context_used "" 51 | 6103 6107 proof_check_time "0.000" 52 | 0 0 VernacProof "tac:no using:no" 53 | 6370 6374 proof_build_time "0.015" 54 | 0 0 size_exp_open_exp_wrt_exp_rec_var_mutual "0.015" 55 | 6327 6369 context_used "" 56 | 6370 6374 proof_check_time "0.001" 57 | 0 0 VernacProof "tac:no using:no" 58 | 6617 6621 proof_build_time "0.000" 59 | 0 0 size_exp_open_exp_wrt_exp_rec_var "0.000" 60 | 6542 6616 context_used "" 61 | 6617 6621 proof_check_time "0.000" 62 | 0 0 VernacProof "tac:no using:no" 63 | 6948 6952 proof_build_time "0.001" 64 | 0 0 size_exp_open_exp_wrt_exp_var "0.001" 65 | 6909 6947 context_used "" 66 | 6948 6952 proof_check_time "0.000" 67 | 0 0 VernacProof "tac:no using:no" 68 | 7490 7494 proof_build_time "0.001" 69 | 0 0 degree_exp_wrt_exp_S_mutual "0.001" 70 | 7432 7489 context_used "" 71 | 7490 7494 proof_check_time "0.000" 72 | 0 0 VernacProof "tac:no using:no" 73 | 7686 7690 proof_build_time "0.000" 74 | 0 0 degree_exp_wrt_exp_S "0.000" 75 | 7624 7685 context_used "" 76 | 7686 7690 proof_check_time "0.000" 77 | 0 0 VernacProof "tac:no using:no" 78 | 7881 7885 proof_build_time "0.000" 79 | 0 0 degree_exp_wrt_exp_O "0.000" 80 | 7853 7880 context_used "" 81 | 7881 7885 proof_check_time "0.000" 82 | 0 0 VernacProof "tac:no using:no" 83 | 8176 8180 proof_build_time "0.041" 84 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp_rec_mutual "0.041" 85 | 8133 8175 context_used "" 86 | 8176 8180 proof_check_time "0.003" 87 | 0 0 VernacProof "tac:no using:no" 88 | 8463 8467 proof_build_time "0.000" 89 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp_rec "0.000" 90 | 8381 8462 context_used "" 91 | 8463 8467 proof_check_time "0.000" 92 | 0 0 VernacProof "tac:no using:no" 93 | 8744 8748 proof_build_time "0.000" 94 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp "0.000" 95 | 8704 8743 context_used "" 96 | 8744 8748 proof_check_time "0.000" 97 | 0 0 VernacProof "tac:no using:no" 98 | 9077 9081 proof_build_time "0.062" 99 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv_mutual "0.062" 100 | 9016 9076 context_used "" 101 | 9077 9081 proof_check_time "0.003" 102 | 0 0 VernacProof "tac:no using:no" 103 | 9372 9376 proof_build_time "0.000" 104 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv "0.000" 105 | 9286 9371 context_used "" 106 | 9372 9376 proof_check_time "0.000" 107 | 0 0 VernacProof "tac:no using:no" 108 | 9667 9671 proof_build_time "0.000" 109 | 0 0 degree_exp_wrt_exp_close_exp_wrt_exp_inv "0.000" 110 | 9623 9666 context_used "" 111 | 9667 9671 proof_check_time "0.000" 112 | 0 0 VernacProof "tac:no using:no" 113 | 10012 10016 proof_build_time "0.064" 114 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp_rec_mutual "0.064" 115 | 9969 10011 context_used "" 116 | 10012 10016 proof_check_time "0.003" 117 | 0 0 VernacProof "tac:no using:no" 118 | 10326 10330 proof_build_time "0.000" 119 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp_rec "0.000" 120 | 10245 10325 context_used "" 121 | 10326 10330 proof_check_time "0.000" 122 | 0 0 VernacProof "tac:no using:no" 123 | 10632 10636 proof_build_time "0.001" 124 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp "0.001" 125 | 10593 10631 context_used "" 126 | 10632 10636 proof_check_time "0.000" 127 | 0 0 VernacProof "tac:no using:no" 128 | 10962 10966 proof_build_time "0.148" 129 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv_mutual "0.148" 130 | 10901 10961 context_used "" 131 | 10962 10966 proof_check_time "0.004" 132 | 0 0 VernacProof "tac:no using:no" 133 | 11254 11258 proof_build_time "0.000" 134 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv "0.000" 135 | 11169 11253 context_used "" 136 | 11254 11258 proof_check_time "0.000" 137 | 0 0 VernacProof "tac:no using:no" 138 | 11545 11549 proof_build_time "0.000" 139 | 0 0 degree_exp_wrt_exp_open_exp_wrt_exp_inv "0.000" 140 | 11502 11544 context_used "" 141 | 11545 11549 proof_check_time "0.000" 142 | 0 0 VernacProof "tac:no using:no" 143 | 12151 12155 proof_build_time "0.257" 144 | 0 0 close_exp_wrt_exp_rec_inj_mutual "0.257" 145 | 12011 12150 context_used "" 146 | 12151 12155 proof_check_time "0.012" 147 | 0 0 VernacProof "tac:no using:no" 148 | 12399 12403 proof_build_time "0.000" 149 | 0 0 close_exp_wrt_exp_rec_inj "0.000" 150 | 12332 12398 context_used "" 151 | 12399 12403 proof_check_time "0.000" 152 | 0 0 VernacProof "tac:no using:no" 153 | 12646 12650 proof_build_time "0.000" 154 | 0 0 close_exp_wrt_exp_inj "0.000" 155 | 12602 12645 context_used "" 156 | 12646 12650 proof_check_time "0.000" 157 | 0 0 VernacProof "tac:no using:no" 158 | 12956 12960 proof_build_time "0.072" 159 | 0 0 close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual "0.072" 160 | 12913 12955 context_used "" 161 | 12956 12960 proof_check_time "0.005" 162 | 0 0 VernacProof "tac:no using:no" 163 | 13257 13261 proof_build_time "0.000" 164 | 0 0 close_exp_wrt_exp_rec_open_exp_wrt_exp_rec "0.000" 165 | 13173 13256 context_used "" 166 | 13257 13261 proof_check_time "0.000" 167 | 0 0 VernacProof "tac:no using:no" 168 | 13666 13670 proof_build_time "0.000" 169 | 0 0 close_exp_wrt_exp_open_exp_wrt_exp "0.000" 170 | 13601 13665 context_used "" 171 | 13666 13670 proof_check_time "0.000" 172 | 0 0 VernacProof "tac:no using:no" 173 | 14047 14051 proof_build_time "0.077" 174 | 0 0 open_exp_wrt_exp_rec_close_exp_wrt_exp_rec_mutual "0.077" 175 | 14004 14046 context_used "" 176 | 14047 14051 proof_check_time "0.005" 177 | 0 0 VernacProof "tac:no using:no" 178 | 14322 14326 proof_build_time "0.000" 179 | 0 0 open_exp_wrt_exp_rec_close_exp_wrt_exp_rec "0.000" 180 | 14238 14321 context_used "" 181 | 14322 14326 proof_check_time "0.000" 182 | 0 0 VernacProof "tac:no using:no" 183 | 14705 14709 proof_build_time "0.000" 184 | 0 0 open_exp_wrt_exp_close_exp_wrt_exp "0.000" 185 | 14640 14704 context_used "" 186 | 14705 14709 proof_check_time "0.000" 187 | 0 0 VernacProof "tac:no using:no" 188 | 15238 15242 proof_build_time "0.312" 189 | 0 0 open_exp_wrt_exp_rec_inj_mutual "0.312" 190 | 15098 15237 context_used "" 191 | 15238 15242 proof_check_time "0.012" 192 | 0 0 VernacProof "tac:no using:no" 193 | 15550 15554 proof_build_time "0.000" 194 | 0 0 open_exp_wrt_exp_rec_inj "0.000" 195 | 15484 15549 context_used "" 196 | 15550 15554 proof_check_time "0.000" 197 | 0 0 VernacProof "tac:no using:no" 198 | 15860 15864 proof_build_time "0.001" 199 | 0 0 open_exp_wrt_exp_inj "0.001" 200 | 15817 15859 context_used "" 201 | 15860 15864 proof_check_time "0.000" 202 | 0 0 VernacProof "tac:no using:no" 203 | 16473 16477 proof_build_time "0.021" 204 | 0 0 degree_exp_wrt_exp_of_lc_exp_mutual "0.021" 205 | 16267 16472 context_used "" 206 | 16473 16477 proof_check_time "0.000" 207 | 0 0 VernacProof "tac:no using:no" 208 | 16662 16666 proof_build_time "0.000" 209 | 0 0 degree_exp_wrt_exp_of_lc_exp "0.000" 210 | 16592 16661 context_used "" 211 | 16662 16666 proof_check_time "0.000" 212 | 0 0 VernacProof "tac:no using:no" 213 | 17213 17217 proof_build_time "0.091" 214 | 0 0 lc_exp_of_degree_size_mutual "0.091" 215 | 16880 17212 context_used "" 216 | 17213 17217 proof_check_time "0.005" 217 | 0 0 VernacProof "tac:no using:no" 218 | 17413 17417 proof_build_time "0.001" 219 | 0 0 lc_exp_of_degree "0.001" 220 | 17320 17412 context_used "" 221 | 17413 17417 proof_check_time "0.000" 222 | 0 0 VernacProof "tac:no using:no" 223 | 17947 17951 proof_build_time "0.002" 224 | 0 0 lc_abs_exists "0.002" 225 | 17900 17946 context_used "" 226 | 17947 17951 proof_check_time "0.000" 227 | 0 0 VernacProof "tac:no using:no" 228 | 18332 18336 proof_build_time "0.010" 229 | 0 0 lc_body_exp_wrt_exp "0.010" 230 | 18197 18331 context_used "" 231 | 18332 18336 proof_check_time "0.000" 232 | 0 0 VernacProof "tac:no using:no" 233 | 18495 18499 proof_build_time "0.007" 234 | 0 0 lc_body_abs_2 "0.007" 235 | 18481 18494 context_used "" 236 | 18495 18499 proof_check_time "0.000" 237 | 0 0 VernacProof "tac:no using:no" 238 | 18864 18868 proof_build_time "0.011" 239 | 0 0 lc_exp_unique_mutual "0.011" 240 | 18660 18863 context_used "" 241 | 18864 18868 proof_check_time "0.002" 242 | 0 0 VernacProof "tac:no using:no" 243 | 19026 19030 proof_build_time "0.000" 244 | 0 0 lc_exp_unique "0.000" 245 | 18971 19025 context_used "" 246 | 19026 19030 proof_check_time "0.000" 247 | 0 0 VernacProof "tac:no using:no" 248 | 19231 19235 proof_build_time "0.001" 249 | 0 0 lc_exp_of_lc_set_exp_mutual "0.001" 250 | 19181 19230 context_used "" 251 | 19231 19235 proof_check_time "0.000" 252 | 0 0 VernacProof "tac:no using:no" 253 | 19390 19394 proof_build_time "0.000" 254 | 0 0 lc_exp_of_lc_set_exp "0.000" 255 | 19328 19389 context_used "" 256 | 19390 19394 proof_check_time "0.000" 257 | 0 0 VernacProof "tac:no using:no" 258 | 20060 20064 proof_build_time "0.088" 259 | 0 0 lc_set_exp_of_lc_exp_size_mutual "0.088" 260 | 19594 20059 context_used "" 261 | 20060 20064 proof_check_time "0.003" 262 | 0 0 VernacProof "tac:no using:no" 263 | 20258 20262 proof_build_time "0.001" 264 | 0 0 lc_set_exp_of_lc_exp "0.001" 265 | 20161 20257 context_used "" 266 | 20258 20262 proof_check_time "0.000" 267 | 0 0 VernacProof "tac:no using:no" 268 | 20766 20770 proof_build_time "0.054" 269 | 0 0 close_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual "0.054" 270 | 20723 20765 context_used "" 271 | 20766 20770 proof_check_time "0.004" 272 | 0 0 VernacProof "tac:no using:no" 273 | 21056 21060 proof_build_time "0.000" 274 | 0 0 close_exp_wrt_exp_rec_degree_exp_wrt_exp "0.000" 275 | 20974 21055 context_used "" 276 | 21056 21060 proof_check_time "0.000" 277 | 0 0 VernacProof "tac:no using:no" 278 | 21411 21415 proof_build_time "0.000" 279 | 0 0 close_exp_wrt_exp_lc_exp "0.000" 280 | 21371 21410 context_used "" 281 | 21411 21415 proof_check_time "0.000" 282 | 0 0 VernacProof "tac:no using:no" 283 | 21761 21765 proof_build_time "0.045" 284 | 0 0 open_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual "0.045" 285 | 21718 21760 context_used "" 286 | 21761 21765 proof_check_time "0.003" 287 | 0 0 VernacProof "tac:no using:no" 288 | 22022 22026 proof_build_time "0.000" 289 | 0 0 open_exp_wrt_exp_rec_degree_exp_wrt_exp "0.000" 290 | 21941 22021 context_used "" 291 | 22022 22026 proof_check_time "0.000" 292 | 0 0 VernacProof "tac:no using:no" 293 | 22346 22350 proof_build_time "0.000" 294 | 0 0 open_exp_wrt_exp_lc_exp "0.000" 295 | 22307 22345 context_used "" 296 | 22346 22350 proof_check_time "0.000" 297 | 0 0 VernacProof "tac:no using:no" 298 | 22906 22910 proof_build_time "0.518" 299 | 0 0 fv_exp_close_exp_wrt_exp_rec_mutual "0.518" 300 | 22854 22905 context_used "" 301 | 22906 22910 proof_check_time "0.003" 302 | 0 0 VernacProof "tac:no using:no" 303 | 23146 23150 proof_build_time "0.000" 304 | 0 0 fv_exp_close_exp_wrt_exp_rec "0.000" 305 | 23076 23145 context_used "" 306 | 23146 23150 proof_check_time "0.000" 307 | 0 0 VernacProof "tac:no using:no" 308 | 23466 23470 proof_build_time "0.006" 309 | 0 0 fv_exp_close_exp_wrt_exp "0.006" 310 | 23426 23465 context_used "" 311 | 23466 23470 proof_check_time "0.000" 312 | 0 0 VernacProof "tac:no using:no" 313 | 23808 23812 proof_build_time "0.209" 314 | 0 0 fv_exp_open_exp_wrt_exp_rec_lower_mutual "0.209" 315 | 23756 23807 context_used "" 316 | 23808 23812 proof_check_time "0.000" 317 | 0 0 VernacProof "tac:no using:no" 318 | 24046 24050 proof_build_time "0.000" 319 | 0 0 fv_exp_open_exp_wrt_exp_rec_lower "0.000" 320 | 23971 24045 context_used "" 321 | 24046 24050 proof_check_time "0.000" 322 | 0 0 VernacProof "tac:no using:no" 323 | 24283 24287 proof_build_time "0.024" 324 | 0 0 fv_exp_open_exp_wrt_exp_lower "0.024" 325 | 24244 24282 context_used "" 326 | 24283 24287 proof_check_time "0.000" 327 | 0 0 VernacProof "tac:no using:no" 328 | 24572 24576 proof_build_time "0.662" 329 | 0 0 fv_exp_open_exp_wrt_exp_rec_upper_mutual "0.662" 330 | 24520 24571 context_used "" 331 | 24572 24576 proof_check_time "0.001" 332 | 0 0 VernacProof "tac:no using:no" 333 | 24828 24832 proof_build_time "0.000" 334 | 0 0 fv_exp_open_exp_wrt_exp_rec_upper "0.000" 335 | 24753 24827 context_used "" 336 | 24828 24832 proof_check_time "0.000" 337 | 0 0 VernacProof "tac:no using:no" 338 | 25083 25087 proof_build_time "0.049" 339 | 0 0 fv_exp_open_exp_wrt_exp_upper "0.049" 340 | 25044 25082 context_used "" 341 | 25083 25087 proof_check_time "0.000" 342 | 0 0 VernacProof "tac:no using:no" 343 | 25357 25361 proof_build_time "0.289" 344 | 0 0 fv_exp_subst_exp_fresh_mutual "0.289" 345 | 25305 25356 context_used "" 346 | 25357 25361 proof_check_time "0.001" 347 | 0 0 VernacProof "tac:no using:no" 348 | 25569 25573 proof_build_time "0.000" 349 | 0 0 fv_exp_subst_exp_fresh "0.000" 350 | 25505 25568 context_used "" 351 | 25569 25573 proof_check_time "0.000" 352 | 0 0 VernacProof "tac:no using:no" 353 | 25897 25901 proof_build_time "0.822" 354 | 0 0 fv_exp_subst_exp_lower_mutual "0.822" 355 | 25845 25896 context_used "" 356 | 25897 25901 proof_check_time "0.001" 357 | 0 0 VernacProof "tac:no using:no" 358 | 26096 26100 proof_build_time "0.000" 359 | 0 0 fv_exp_subst_exp_lower "0.000" 360 | 26032 26095 context_used "" 361 | 26096 26100 proof_check_time "0.000" 362 | 0 0 VernacProof "tac:no using:no" 363 | 26389 26393 proof_build_time "0.194" 364 | 0 0 fv_exp_subst_exp_notin_mutual "0.194" 365 | 26337 26388 context_used "" 366 | 26389 26393 proof_check_time "0.001" 367 | 0 0 VernacProof "tac:no using:no" 368 | 26627 26631 proof_build_time "0.000" 369 | 0 0 fv_exp_subst_exp_notin "0.000" 370 | 26563 26626 context_used "" 371 | 26627 26631 proof_check_time "0.000" 372 | 0 0 VernacProof "tac:no using:no" 373 | 26899 26903 proof_build_time "0.910" 374 | 0 0 fv_exp_subst_exp_upper_mutual "0.910" 375 | 26847 26898 context_used "" 376 | 26899 26903 proof_check_time "0.002" 377 | 0 0 VernacProof "tac:no using:no" 378 | 27116 27120 proof_build_time "0.000" 379 | 0 0 fv_exp_subst_exp_upper "0.000" 380 | 27052 27115 context_used "" 381 | 27116 27120 proof_check_time "0.000" 382 | 0 0 VernacProof "tac:no using:no" 383 | 27715 27719 proof_build_time "0.151" 384 | 0 0 subst_exp_close_exp_wrt_exp_rec_mutual "0.151" 385 | 27672 27714 context_used "" 386 | 27715 27719 proof_check_time "0.002" 387 | 0 0 VernacProof "tac:no using:no" 388 | 28053 28057 proof_build_time "0.000" 389 | 0 0 subst_exp_close_exp_wrt_exp_rec "0.000" 390 | 27980 28052 context_used "" 391 | 28053 28057 proof_check_time "0.000" 392 | 0 0 VernacProof "tac:no using:no" 393 | 28370 28374 proof_build_time "0.001" 394 | 0 0 subst_exp_close_exp_wrt_exp "0.001" 395 | 28330 28369 context_used "" 396 | 28370 28374 proof_check_time "0.000" 397 | 0 0 VernacProof "tac:no using:no" 398 | 28677 28681 proof_build_time "0.064" 399 | 0 0 subst_exp_degree_exp_wrt_exp_mutual "0.064" 400 | 28634 28676 context_used "" 401 | 28677 28681 proof_check_time "0.002" 402 | 0 0 VernacProof "tac:no using:no" 403 | 28939 28943 proof_build_time "0.000" 404 | 0 0 subst_exp_degree_exp_wrt_exp "0.000" 405 | 28869 28938 context_used "" 406 | 28939 28943 proof_check_time "0.000" 407 | 0 0 VernacProof "tac:no using:no" 408 | 29181 29185 proof_build_time "0.039" 409 | 0 0 subst_exp_fresh_eq_mutual "0.039" 410 | 29138 29180 context_used "" 411 | 29181 29185 proof_check_time "0.001" 412 | 0 0 VernacProof "tac:no using:no" 413 | 29367 29371 proof_build_time "0.000" 414 | 0 0 subst_exp_fresh_eq "0.000" 415 | 29307 29366 context_used "" 416 | 29367 29371 proof_check_time "0.000" 417 | 0 0 VernacProof "tac:no using:no" 418 | 29686 29690 proof_build_time "0.078" 419 | 0 0 subst_exp_fresh_same_mutual "0.078" 420 | 29643 29685 context_used "" 421 | 29686 29690 proof_check_time "0.001" 422 | 0 0 VernacProof "tac:no using:no" 423 | 29891 29895 proof_build_time "0.000" 424 | 0 0 subst_exp_fresh_same "0.000" 425 | 29829 29890 context_used "" 426 | 29891 29895 proof_check_time "0.000" 427 | 0 0 VernacProof "tac:no using:no" 428 | 30166 30170 proof_build_time "0.075" 429 | 0 0 subst_exp_fresh_mutual "0.075" 430 | 30123 30165 context_used "" 431 | 30166 30170 proof_check_time "0.000" 432 | 0 0 VernacProof "tac:no using:no" 433 | 30390 30394 proof_build_time "0.000" 434 | 0 0 subst_exp_fresh "0.000" 435 | 30333 30389 context_used "" 436 | 30390 30394 proof_check_time "0.000" 437 | 0 0 VernacProof "tac:no using:no" 438 | 30569 30573 proof_build_time "0.002" 439 | 0 0 subst_exp_lc_exp "0.002" 440 | 30555 30568 context_used "" 441 | 30569 30573 proof_check_time "0.000" 442 | 0 0 VernacProof "tac:no using:no" 443 | 30898 30902 proof_build_time "0.113" 444 | 0 0 subst_exp_open_exp_wrt_exp_rec_mutual "0.113" 445 | 30855 30897 context_used "" 446 | 30898 30902 proof_check_time "0.001" 447 | 0 0 VernacProof "tac:no using:no" 448 | 31213 31217 proof_build_time "0.000" 449 | 0 0 subst_exp_open_exp_wrt_exp_rec "0.000" 450 | 31141 31212 context_used "" 451 | 31213 31217 proof_check_time "0.000" 452 | 0 0 VernacProof "tac:no using:no" 453 | 31520 31524 proof_build_time "0.000" 454 | 0 0 subst_exp_open_exp_wrt_exp "0.000" 455 | 31481 31519 context_used "" 456 | 31520 31524 proof_check_time "0.000" 457 | 0 0 VernacProof "tac:no using:no" 458 | 31842 31846 proof_build_time "0.032" 459 | 0 0 subst_exp_open_exp_wrt_exp_var "0.032" 460 | 31784 31841 context_used "" 461 | 31842 31846 proof_check_time "0.000" 462 | 0 0 VernacProof "tac:no using:no" 463 | 32120 32124 proof_build_time "0.154" 464 | 0 0 subst_exp_spec_rec_mutual "0.154" 465 | 32077 32119 context_used "" 466 | 32120 32124 proof_check_time "0.005" 467 | 0 0 VernacProof "tac:no using:no" 468 | 32358 32362 proof_build_time "0.000" 469 | 0 0 subst_exp_spec_rec "0.000" 470 | 32298 32357 context_used "" 471 | 32358 32362 proof_check_time "0.000" 472 | 0 0 VernacProof "tac:no using:no" 473 | 32614 32618 proof_build_time "0.000" 474 | 0 0 subst_exp_spec "0.000" 475 | 32549 32613 context_used "" 476 | 32614 32618 proof_check_time "0.000" 477 | 0 0 VernacProof "tac:no using:no" 478 | 32933 32937 proof_build_time "0.173" 479 | 0 0 subst_exp_subst_exp_mutual "0.173" 480 | 32890 32932 context_used "" 481 | 32933 32937 proof_check_time "0.002" 482 | 0 0 VernacProof "tac:no using:no" 483 | 33211 33215 proof_build_time "0.000" 484 | 0 0 subst_exp_subst_exp "0.000" 485 | 33150 33210 context_used "" 486 | 33211 33215 proof_check_time "0.000" 487 | 0 0 VernacProof "tac:no using:no" 488 | 33637 33641 proof_build_time "0.312" 489 | 0 0 subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual "0.312" 490 | 33594 33636 context_used "" 491 | 33637 33641 proof_check_time "0.004" 492 | 0 0 VernacProof "tac:no using:no" 493 | 34068 34072 proof_build_time "0.000" 494 | 0 0 subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec "0.000" 495 | 33974 34067 context_used "" 496 | 34068 34072 proof_check_time "0.000" 497 | 0 0 VernacProof "tac:no using:no" 498 | 34498 34502 proof_build_time "0.001" 499 | 0 0 subst_exp_close_exp_wrt_exp_open_exp_wrt_exp "0.001" 500 | 34433 34497 context_used "" 501 | 34498 34502 proof_check_time "0.000" 502 | 0 0 VernacProof "tac:no using:no" 503 | 34844 34848 proof_build_time "0.077" 504 | 0 0 subst_exp_abs "0.077" 505 | 34830 34843 context_used "" 506 | 34844 34848 proof_check_time "0.000" 507 | 0 0 VernacProof "tac:no using:no" 508 | 35139 35143 proof_build_time "0.163" 509 | 0 0 subst_exp_intro_rec_mutual "0.163" 510 | 35096 35138 context_used "" 511 | 35139 35143 proof_check_time "0.001" 512 | 0 0 VernacProof "tac:no using:no" 513 | 35394 35398 proof_build_time "0.000" 514 | 0 0 subst_exp_intro_rec "0.000" 515 | 35333 35393 context_used "" 516 | 35394 35398 proof_check_time "0.000" 517 | 0 0 VernacProof "tac:no using:no" 518 | 35714 35718 proof_build_time "0.000" 519 | 0 0 subst_exp_intro "0.000" 520 | 35675 35713 context_used "" 521 | 35714 35718 proof_check_time "0.000" 522 | 0 0 vo_compile_time "7.124" 523 | --------------------------------------------------------------------------------