├── .circleci └── config.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject.classic ├── _CoqProject.dune ├── coq-ceres.opam ├── coq-ceres.opam.template ├── dune-project ├── test ├── Test.v └── dune ├── theories ├── Ceres.v ├── CeresDeserialize.v ├── CeresFormat.v ├── CeresParser.v ├── CeresParserInternal.v ├── CeresParserRoundtrip.v ├── CeresParserRoundtripProof.v ├── CeresParserUtils.v ├── CeresRoundtrip.v ├── CeresS.v ├── CeresSerialize.v ├── CeresString.v ├── CeresUtils.v └── dune └── tutorial ├── Tutorial.v └── dune /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2.1 2 | jobs: 3 | test: 4 | parameters: 5 | runtest: 6 | type: boolean 7 | default: true 8 | coq: 9 | type: string 10 | docker: 11 | - image: coqorg/coq:<> 12 | environment: 13 | OPAMVERBOSE: 1 14 | OPAMWITHTEST: << parameters.runtest >> 15 | OPAMYES: true 16 | TERM: xterm 17 | PACKAGES: > 18 | coq-parsec 19 | steps: 20 | - checkout 21 | - run: 22 | name: Configure environment 23 | command: echo . ~/.profile >> $BASH_ENV 24 | - run: 25 | name: List installed packages 26 | command: opam list 27 | - run: 28 | name: Compile Cérès 29 | command: opam install ./coq-ceres.opam 30 | - run: 31 | name: Test dependants 32 | command: | 33 | for PACKAGE in $PACKAGES 34 | do 35 | DEPS_FAILED=false 36 | (opam depext $PACKAGE && 37 | opam install --deps-only -t $PACKAGE) || DEPS_FAILED=true 38 | ([ $DEPS_FAILED == false ] && opam install $PACKAGE) || 39 | echo Dependencies broken: $PACKAGE 40 | done 41 | 42 | workflows: 43 | version: 2 44 | build: 45 | jobs: 46 | - test: 47 | coq: '8.8' 48 | name: 'Coq 8.8' 49 | runtest: false 50 | - test: 51 | coq: '8.9' 52 | name: 'Coq 8.9' 53 | runtest: false 54 | - test: 55 | coq: '8.10' 56 | name: 'Coq 8.10' 57 | - test: 58 | coq: '8.11' 59 | name: 'Coq 8.11' 60 | - test: 61 | coq: '8.12' 62 | name: 'Coq 8.12' 63 | - test: 64 | coq: '8.13' 65 | name: 'Coq 8.13' 66 | - test: 67 | coq: '8.14' 68 | name: 'Coq 8.14' 69 | - test: 70 | coq: '8.15' 71 | name: 'Coq 8.15' 72 | - test: 73 | coq: '8.16' 74 | name: 'Coq 8.16' 75 | - test: 76 | coq: '8.17' 77 | name: 'Coq 8.17' 78 | - test: 79 | coq: 'dev' 80 | name: 'Coq dev' 81 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _CoqProject 2 | .*.aux 3 | *.a 4 | *.cma 5 | *.cmi 6 | *.cmo 7 | *.cmx 8 | *.cmxa 9 | *.cmxs 10 | *.glob 11 | *.ml.d 12 | *.ml4.d 13 | *.mli.d 14 | *.mllib.d 15 | *.mlpack.d 16 | *.native 17 | *.o 18 | *.v.d 19 | *.vio 20 | *.vo* 21 | .coq-native/ 22 | .csdp.cache 23 | .lia.cache 24 | .nia.cache 25 | .nlia.cache 26 | .nra.cache 27 | csdp.cache 28 | lia.cache 29 | nia.cache 30 | nlia.cache 31 | nra.cache 32 | .coqdeps.d 33 | *Makefile.coq* 34 | doc/ 35 | coqdocjs 36 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.4.1 2 | 3 | - Build with Dune 4 | - Compatibility with 8.14, 8.15, 8.16, 8.17 5 | 6 | # 0.4.0 7 | 8 | - Reexport `CeresParser` and `CeresFormat` in `Ceres` 9 | - Add `CeresParserUtils` and `CeresParserInternal` 10 | - Rename `string_of_sexp` to `string_of_sexp_` 11 | - Rename `string_of_sexpa` to `string_of_sexp` 12 | 13 | # 0.3.0 14 | 15 | - Add `Serialize` and `Deserialize` instances for `ascii` 16 | - Prove roundtrip properties 17 | 18 | + Parser (string -> sexp): parse-then-print roundtrip (soundness; see `CeresParserRoundtrip`) 19 | + Serializers (sexp <-> mytype): both ways (see `CeresRoundtrip`, exported by default) 20 | 21 | - The concrete syntax becomes stricter. Strings must consist of printable characters 22 | (only `\\` and `\n` are currently supported escape sequences), and atoms 23 | (identifiers) have a restricted alphabet: 24 | 25 | ``` 26 | is_alphanum c ||| string_elem c "'=-+*/:!?@#$%^&_<>~|.," 27 | ``` 28 | 29 | # 0.2.0 30 | 31 | - Add decidable equality 32 | 33 | # 0.1.0 34 | 35 | - Create coq-ceres. 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Li-yao Xia (c) 2019 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the “Software”), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 7 | of the Software, and to permit persons to whom the Software is furnished to do 8 | so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: test build install clean html cleanall 2 | 3 | MF_COQ := Makefile.coq 4 | TUTO := tutorial/Tutorial.v 5 | 6 | build: $(MF_COQ) 7 | $(MAKE) -f $(MF_COQ) 8 | 9 | install: build 10 | $(MAKE) -f $(MF_COQ) install 11 | 12 | tuto: build 13 | coqc -Q theories/ Ceres $(TUTO) 14 | 15 | test: build tuto 16 | coqc -Q theories/ Ceres test/Test.v 17 | 18 | _CoqProject: 19 | ln -s _CoqProject.classic _CoqProject 20 | 21 | $(MF_COQ): _CoqProject 22 | coq_makefile -f _CoqProject -o $(MF_COQ) 23 | 24 | clean: 25 | if [ -e $(MF_COQ) ] ; then make -f $(MF_COQ) cleanall ; fi 26 | $(RM) */*.{vo,vos,vok,glob} */.*.aux $(MF_COQ){,.conf} 27 | 28 | cleanall: clean 29 | $(RM) _CoqProject 30 | 31 | COQDOCJS_DIR := coqdocjs 32 | 33 | COQDOCFLAGS = \ 34 | -t "Ceres" \ 35 | --toc --toc-depth 2 --interpolate \ 36 | --index indexpage --no-lib-name --parse-comments \ 37 | --with-header $(COQDOCJS_DIR)/extra/header.html --with-footer $(COQDOCJS_DIR)/extra/footer.html \ 38 | --external "." Ceres $(TUTO) 39 | 40 | export COQDOCFLAGS 41 | 42 | html: Makefile.coq tuto 43 | rm -rf html 44 | $(MAKE) -f Makefile.coq html 45 | cp $(COQDOCJS_DIR)/extra/resources/* html 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Cérès [![CircleCI](https://circleci.com/gh/Lysxia/coq-ceres.svg?style=shield)](https://circleci.com/gh/Lysxia/coq-ceres) 2 | 3 | Cérès is a Coq library for serialization to S-expressions. 4 | 5 | S-expressions 6 | ------------- 7 | 8 | S-expressions are uniform representations of structured data. 9 | 10 | They are an alternative to plain strings as used by `Show` in Haskell and 11 | `Debug` in Rust for example. 12 | S-expressions are more amenable to programmatic consumption, avoiding custom 13 | parsers and enabling flexible formatting strategies. 14 | 15 | ### Example 16 | 17 | This S-expression... 18 | 19 | ``` 20 | (example 21 | (message "I'm a teapot") 22 | (code 418)) 23 | ``` 24 | 25 | ... corresponds to this `sexp` in Coq. 26 | 27 | ```coq 28 | Definition example : sexp := 29 | [ Atom "example" 30 | ; [ Atom "message" ; Atom (Str "I'm a teapot") ] 31 | ; [ Atom "code" ; Atom 418%Z ] 32 | ]. 33 | ``` 34 | 35 | ### Documentation 36 | 37 | The [tutorial module](https://lysxia.github.io/coq-ceres/Tutorial.html) is a good place for a quick start. 38 | 39 | [Link to the rendered documentation.](https://lysxia.github.io/coq-ceres/toc.html) 40 | 41 | Simplified overview 42 | ------------------- 43 | 44 | This library offers a type `sexp` with two constructors: 45 | 46 | ```coq 47 | Inductive sexp := 48 | | Atom (a : atom) 49 | | List (xs : list sexp) 50 | . 51 | ``` 52 | 53 | Atoms are identifiers (`Raw`), numbers (`Num`) or strings (`Str`). 54 | 55 | ```coq 56 | Variant atom : Set := 57 | | Num (n : Z) (* Integers. *) 58 | | Str (s : string) (* Literal strings. *) 59 | | Raw (s : string) (* Simple atoms (e.g., ADT tags). *) 60 | (* Should fit in this alphabet: [A-Za-z0-9'=+*/:!?@#$%^&<>.,|_~-]. *) 61 | . 62 | ``` 63 | 64 | Two classes `Serialize` and `Deserialize` are provided to define canonical 65 | serializers and deserializers between your types and S-expressions. 66 | The following functions are provided for conversions to `sexp` or directly to 67 | `string`: 68 | 69 | ```coq 70 | Definition to_sexp {A} `{Serialize A} : A -> sexp. 71 | Definition from_sexp {A} `{Deserialize A} : sexp -> error + A. 72 | 73 | Definition to_string {A} `{Serialize A} : A -> string. 74 | Definition from_string {A} `{Deserialize A} : string -> error + A. 75 | ``` 76 | 77 | Usage 78 | ----- 79 | 80 | Import the main module of the library. 81 | 82 | ```coq 83 | Require Import Ceres.Ceres. 84 | ``` 85 | 86 | This exports: 87 | 88 | - `CeresS`: the core definitions for S-expressions. 89 | - `CeresSerialize`: the `Serialize` type class (`sexp -> error + mytype`). 90 | - `CeresDeserialize`: the `Deserialize` type class (`mytype -> sexp`). 91 | - `CeresRoundtrip`: roundtrip properties for serializers and deserializers. 92 | - `CeresFormat`: format S-expressions as strings (`sexp -> string`). 93 | - `CeresParser`: S-expression parser (`string -> error + sexp`). 94 | 95 | Other modules in the library: 96 | 97 | - `CeresParserUtils`: low-level primitives for the S-expression parser 98 | - `CeresParserRoundtrip`, `CeresParserRoundtripProof`: 99 | Correctness proof of the parser. Currently, only soundness is proved 100 | (i.e., parse-then-print roundtrip). 101 | 102 | Internals: 103 | 104 | - `CeresUtils`: miscellaneous. 105 | - `CeresParserInternal`: S-expression parser, internals 106 | - `CeresString`: general string utilities. 107 | 108 | Core definitions 109 | ---------------- 110 | 111 | The type of S-expressions is actually parameterized by the type of atoms. 112 | 113 | ```coq 114 | Inductive sexp_ (A : Type) := 115 | | Atom_ (a : A) 116 | | List (xs : list (sexp_ A)) 117 | . 118 | ``` 119 | 120 | By default, it is specialized to the `atom` type, so that the main S-expression type is 121 | `sexp := sexp_ atom`. 122 | 123 | ```coq 124 | Notation sexp := (sexp_ atom). 125 | Notation Atom := (@Atom_ atom). 126 | 127 | Coercion Num : Z >-> atom. 128 | Coercion Raw : string >-> atom. 129 | 130 | (* Destructors *) 131 | Definition get_Num : atom -> option Z. 132 | Definition get_Str : atom -> option string. 133 | Definition get_Raw : atom -> option string. 134 | ``` 135 | 136 | Serialization 137 | ------------- 138 | 139 | Serializers can be defined as instances of the `Serialize` type class. 140 | 141 | ```coq 142 | Class Serialize (A : Type) : Type := 143 | to_sexp : A -> sexp. 144 | ``` 145 | 146 | S-expressions can be serialized to a `string`. Thus, so can serializable types. 147 | 148 | ```coq 149 | Definition to_string {A : Type} `{Serialize A} : A -> string. 150 | ``` 151 | 152 | For numeric types, it is sufficient to define a conversion to `Z` as an 153 | instance of `Integral`. 154 | 155 | ```coq 156 | Class Integral (A : Type) : Type := 157 | to_Z : A -> Z. 158 | 159 | Instance Serialize_Integral (A : Type) : Integral A -> Serialize A. 160 | ``` 161 | 162 | Deserialization 163 | --------------- 164 | 165 | Going the other way requires some additional error handling. 166 | 167 | ```coq 168 | Class Deserialize (A : Type) : Type := ... 169 | 170 | Definition from_sexp {A} `{Deserialize A} : sexp -> error + A. 171 | Definition from_string {A} `{Deserialize A} : string -> error + A. 172 | ``` 173 | 174 | Again, a simplified interface for numeric types is thus provided, 175 | with a `SemiIntegral` class. 176 | 177 | ```coq 178 | Class SemiIntegral (A : Type) : Type := 179 | from_Z : Z -> option A. 180 | 181 | Instance Deserialize_SemiIntegral (A : Type) : SemiIntegral A -> Deserialize A. 182 | ``` 183 | 184 | Roundtrip properties 185 | -------------------- 186 | 187 | The module `CeresRoundtrip` defines some roundtripping properties 188 | and lemmas to help prove them. 189 | 190 | ```coq 191 | Class CompleteClass {A} `{Serialize A} `{Deserialize A} : Prop. 192 | Class SoundClass {A} `{Serialize A} `{Deserialize A} : Prop. 193 | ``` 194 | 195 | Generic encoding 196 | ---------------- 197 | 198 | There are no strong requirements on the encodings implemented by `Serialize` 199 | and `Deserialize` instances, but some utilities are provided for the following 200 | default encoding for inductive types: 201 | 202 | - Nullary constructors are atoms `con`. 203 | - Non-nullary constructors are lists `(con x y z)`. 204 | 205 | Serialization is straightforward by pattern-matching. 206 | 207 | For deserialization, the module `CeresDeserialize.Deser` provides 208 | some utilities. 209 | 210 | ### Standard types 211 | 212 | - `unit`, `bool`, `sum` and `option` follow that standard encoding. 213 | - `(x, y) : prod A B` is encoded as `(X Y)` where `X` and `Y` are the encodings of `x` and `y`. 214 | - `[x; y; z] : list A` is encoded as `(X Y Z)`. 215 | - `"somestring" : string` is encoded as `"somestring"`. 216 | - `"c" : ascii` is encoded as `"c"`. 217 | - `33 : Z` (or `N`, `nat`) is encoded as `33`. 218 | 219 | ### Recursive types 220 | 221 | Recursive serializers and deserializers can be defined using explicit fixpoints. 222 | 223 | For deserializers, that means to bind the expression explicitly, since that's 224 | the decreasing argument, but immediately pass it as the last argument of 225 | `Deser.match_con`: 226 | 227 | ```coq 228 | Definition Deserialize_unary : Deserialize nat := 229 | fix deser_nat (l : loc) (e : sexp) {struct e} := 230 | Deser.match_con "nat" 231 | [ ("Z", 0%nat) ] 232 | [ ("S", Deser.con1 S deser_nat) ] l e. 233 | ``` 234 | 235 | Developer notes 236 | --------------- 237 | 238 | ### Build the documentation 239 | 240 | Extra directories: 241 | 242 | - `coqdocjs`: a clone of [coqdocjs](https://github.com/coq-community/coqdocjs) 243 | - `doc`: a clone of this repo's `gh-pages` branch 244 | 245 | ``` 246 | make html && rm -r doc/docs && mv html doc/docs 247 | cd doc 248 | git add docs && git commit -m "Update" && git push 249 | ``` 250 | 251 | See also 252 | -------- 253 | 254 | - Real World OCaml, [Chapter 17, Data Serialization with 255 | S-expressions](https://v1.realworldocaml.org/v1/en/html/data-serialization-with-s-expressions.html). 256 | - [Down with Show!](https://harry.garrood.me/blog/down-with-show-part-3/), a 257 | blog post by Harry Garrood advocating for using structured representations 258 | instead of strings. 259 | -------------------------------------------------------------------------------- /_CoqProject.classic: -------------------------------------------------------------------------------- 1 | -Q theories/ Ceres 2 | theories/CeresUtils.v 3 | theories/CeresString.v 4 | theories/CeresS.v 5 | theories/CeresFormat.v 6 | theories/CeresSerialize.v 7 | theories/CeresParserUtils.v 8 | theories/CeresParserInternal.v 9 | theories/CeresParser.v 10 | theories/CeresDeserialize.v 11 | theories/CeresParserRoundtrip.v 12 | theories/CeresParserRoundtripProof.v 13 | theories/CeresRoundtrip.v 14 | theories/Ceres.v 15 | -------------------------------------------------------------------------------- /_CoqProject.dune: -------------------------------------------------------------------------------- 1 | -Q _build/default/theories Ceres 2 | -------------------------------------------------------------------------------- /coq-ceres.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: "Library for serialization via S-expressions" 5 | maintainer: ["lysxia@gmail.com"] 6 | authors: ["Li-yao Xia"] 7 | license: "MIT" 8 | homepage: "https://github.com/Lysxia/coq-ceres" 9 | bug-reports: "https://github.com/Lysxia/coq-ceres/issues" 10 | depends: [ 11 | "dune" {>= "2.8"} 12 | "coq" {>= "8.8~"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/Lysxia/coq-ceres.git" 30 | run-test: [ "dune" "build" "-p" name "test" "tutorial" ] 31 | -------------------------------------------------------------------------------- /coq-ceres.opam.template: -------------------------------------------------------------------------------- 1 | run-test: [ "dune" "build" "-p" name "test" "tutorial" ] 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using coq 0.2) 3 | (name coq-ceres) 4 | (version dev) 5 | 6 | (generate_opam_files true) 7 | 8 | (source (github Lysxia/coq-ceres)) 9 | (license MIT) 10 | (authors "Li-yao Xia") 11 | (maintainers "lysxia@gmail.com") 12 | 13 | (package 14 | (name coq-ceres) 15 | (synopsis "Library for serialization via S-expressions") 16 | (depends (coq (>= 8.8~))) 17 | ) 18 | -------------------------------------------------------------------------------- /test/Test.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import List NArith ZArith String. 2 | From Ceres Require Import Ceres CeresParser CeresParserInternal. 3 | 4 | Import ListNotations. 5 | Local Open Scope string. 6 | 7 | Definition s : unit + (nat * bool * unit) := inr (1, false, tt). 8 | Definition test_to_string_s : to_string s = "(inr ((1 false) tt))" 9 | := eq_refl. 10 | 11 | Definition roundtrip {A} `{Serialize A} `{Deserialize A} : A -> Prop := 12 | fun a => from_sexp (to_sexp a) = inr a. 13 | 14 | Lemma roundtrip_bool : Forall roundtrip [true; false]. 15 | Proof. repeat constructor. Qed. 16 | 17 | Lemma roundtrip_nat : Forall roundtrip [0; 1; 2]. 18 | Proof. repeat constructor. Qed. 19 | 20 | Lemma roundtrip_Z : Forall roundtrip [-2; -1; 0; 1; 2]%Z. 21 | Proof. repeat constructor. Qed. 22 | 23 | Lemma roundtrip_N : Forall roundtrip [0; 1; 2]%N. 24 | Proof. repeat constructor. Qed. 25 | 26 | Lemma roundtrip_pair : roundtrip (0, true). 27 | Proof. reflexivity. Qed. 28 | 29 | Lemma roundtrip_sum : Forall roundtrip [inl tt; inr 0]. 30 | Proof. repeat constructor. Qed. 31 | 32 | Lemma roundtrip_list : Forall roundtrip [[]; [0]; [0;1]; [0;1;2]]. 33 | Proof. repeat constructor. Qed. 34 | 35 | Lemma roundtrip_s : roundtrip s. 36 | Proof. reflexivity. Qed. 37 | 38 | Require Import Ascii. 39 | 40 | Lemma parse_1 : parse_sexps "a" = inr [Atom "a"]. 41 | Proof. reflexivity. Qed. 42 | 43 | Lemma parse_2 : parse_sexps """a""" = inr [Atom (Str "a")]. 44 | Proof. reflexivity. Qed. 45 | 46 | Lemma parse_3 : parse_sexps "3" = inr [Atom 3%Z]. 47 | Proof. reflexivity. Qed. 48 | 49 | Lemma parse_4 : parse_sexps "-3" = inr [Atom (-3)%Z]. 50 | Proof. reflexivity. Qed. 51 | 52 | Lemma parse_5 : parse_sexps "(ab)" = inr [List [Atom "ab"]]. 53 | Proof. reflexivity. Qed. 54 | 55 | Lemma parse_6 : parse_sexps "(ab cd)" = inr [List [Atom "ab"; Atom "cd"]]. 56 | Proof. reflexivity. Qed. 57 | 58 | Lemma parse_7 : parse_sexps "(a b c)" = inr [List [Atom "a"; Atom "b"; Atom "c"]]. 59 | Proof. reflexivity. Qed. 60 | 61 | Lemma parse_8 : parse_sexps "ab cd" = inr [Atom "ab"; Atom "cd"]. 62 | Proof. reflexivity. Qed. 63 | 64 | Lemma parse_9 : parse_sexps "ab (cd (ef gh) ij) kl" 65 | = inr [Atom "ab"; List [Atom "cd"; List [Atom "ef"; Atom "gh"]; Atom "ij"]; Atom "kl"]. 66 | Proof. reflexivity. Qed. 67 | 68 | Local Open Scope N_scope. 69 | Local Open Scope sexp_scope. 70 | 71 | Lemma parse_10 : 72 | let '(r1, p1, s0) := parse_sexps_ initial_state 0 "(1)(2)3" in 73 | let (e1, s1) := get_one s0 in 74 | let (e2, s2) := get_one s1 in 75 | let (e3, s3) := get_one s2 in 76 | let '(r2, p2, s4) := parse_sexps_ s2 p1 "4 )" in 77 | let (e4, s5) := get_one s4 in 78 | e1 = Some [Atom 1%Z] /\ 79 | e2 = Some [Atom 2%Z] /\ 80 | e3 = None /\ 81 | e4 = Some (Atom 34%Z). 82 | Proof. split; split; split; reflexivity. Qed. 83 | 84 | Lemma parse_11 85 | : parse_sexps "a.b a-b a? a! || hi' +1 a/b" 86 | = inr [Atom "a.b"; Atom "a-b"; Atom "a?"; Atom "a!"; Atom "||"; Atom "hi'"; Atom "+1"; Atom "a/b"]%list. 87 | Proof. reflexivity. Qed. 88 | 89 | (**) 90 | 91 | (* Test that recursive deserializers are supported. *) 92 | Definition Deserialize_unary : Deserialize nat := 93 | fix deser_nat l (e : sexp) {struct e} := 94 | Deser.match_con (A := nat) "nat" 95 | [ ("Z", 0%nat) ] 96 | [ ("S", Deser.con1 S deser_nat) ] l e. 97 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Ceres.Test) 3 | (theories Ceres)) 4 | -------------------------------------------------------------------------------- /theories/Ceres.v: -------------------------------------------------------------------------------- 1 | (** * Main module *) 2 | 3 | (** Exported by default. *) 4 | From Ceres Require Export 5 | CeresS 6 | CeresSerialize 7 | CeresDeserialize 8 | CeresRoundtrip 9 | CeresParser 10 | CeresFormat. 11 | -------------------------------------------------------------------------------- /theories/CeresDeserialize.v: -------------------------------------------------------------------------------- 1 | (** * Deserialization from S-expressions *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | List 6 | ZArith 7 | Ascii 8 | String. 9 | 10 | From Ceres Require Import 11 | CeresUtils 12 | CeresS 13 | CeresParser 14 | CeresString. 15 | 16 | Generalizable Variables A. 17 | 18 | Set Implicit Arguments. 19 | (* end hide *) 20 | 21 | (** * Deserialization *) 22 | 23 | (** ** Errors *) 24 | 25 | (** Location inside an S-expression. *) 26 | Definition loc : Set := list nat. 27 | 28 | (** Error messages. *) 29 | Inductive message : Set := 30 | | MsgApp : message -> message -> message 31 | | MsgStr : string -> message 32 | | MsgSexp : sexp -> message 33 | . 34 | 35 | (* Declare Scope s_msg_scope. *) 36 | Bind Scope s_msg_scope with message. 37 | Delimit Scope s_msg_scope with s_message. 38 | Infix "++" := MsgApp : s_msg_scope. 39 | Coercion MsgStr : string >-> message. 40 | 41 | (** Prefix an error with some type information. *) 42 | Definition type_error (tyname : string) (msg : message) : message := 43 | "could not read type '"%string ++ tyname ++ "', "%string ++ msg. 44 | 45 | (** Errors which may occur when deserializing S-expressions. *) 46 | Variant error := 47 | | ParseError : CeresParserUtils.error -> error (* Errors from parsing [string -> sexp] *) 48 | | DeserError : loc -> message -> error (* Errors from deserializing [sexp -> A] *) 49 | . 50 | 51 | (** ** Deserialization context *) 52 | 53 | (** Context for deserializing values of type [A], with implicit handling of error locations. *) 54 | Definition FromSexp (A : Type) := loc -> sexp -> error + A. 55 | 56 | (** ** The [Deserialize] class *) 57 | 58 | (** Class of types which can be deserialized from S-expressions. *) 59 | Class Deserialize (A : Type) := 60 | _from_sexp : FromSexp A. 61 | 62 | (** Deserialize from an S-expression. *) 63 | Definition from_sexp `{Deserialize A} : sexp -> error + A := 64 | _from_sexp nil. 65 | 66 | (** Deserialize from a string containing an S-expression. *) 67 | Definition from_string `{Deserialize A} : string -> error + A := 68 | fun s => 69 | match parse_sexp s with 70 | | inl e => inl (ParseError e) 71 | | inr x => from_sexp x 72 | end. 73 | 74 | 75 | (** * Combinators for generic [Deserialize] instances *) 76 | 77 | (** The generic format implemented here encodes a constructor [C x y z] 78 | as the expression [(C x y z)]. *) 79 | 80 | (** Context for consuming lists of S-expressions. *) 81 | Definition FromSexpList (A : Type) := loc -> (message -> message) -> list sexp -> error + A. 82 | 83 | (** Context for consuming lists with a statically-known expected length. *) 84 | Record FromSexpListN (m n : nat) (A : Type) := { 85 | _fields : FromSexpList A 86 | }. 87 | 88 | (* Declare Scope deser_scope. *) 89 | Delimit Scope deser_scope with deser. 90 | 91 | (** These combinators are meant to be used qualified. *) 92 | Module Deser. 93 | 94 | Definition _con {A : Type} (tyname : string) 95 | (g : string -> loc -> error + A) (f : string -> FromSexpList A) 96 | : FromSexp A := 97 | fun l e => 98 | match e with 99 | | List (Atom_ (Raw c) :: es) => f c l (type_error tyname) es 100 | | List (_ :: _) => inl (DeserError (0 :: l) (type_error tyname "unexpected atom (expected constructor name)"%string)) 101 | | List nil => inl (DeserError l (type_error tyname "unexpected empty list"%string)) 102 | | Atom_ (Raw c) => g c l 103 | | Atom_ _ => inl (DeserError l (type_error tyname "unexpected atom (expected list or nullary constructor name)"%string)) 104 | end. 105 | 106 | (** Deserialize with a custom function. *) 107 | Definition as_fun {A} (f : loc -> sexp -> error + A) : FromSexp A := f. 108 | 109 | (** Deserialize an ADT based on the name of its constructor. 110 | - The first argument [tyname : string] is the name of the type being parsed, for error messages. 111 | - The second argument [c0 : list (string * A)] is a mapping of nullary constructors, 112 | which are encoded as a plain atom, associating a name to its value. 113 | - The third argument [c1 : list (string * FromSexpList A)] is a mapping of 114 | non-nullary constructors, associating a name to a deserializer for the fields of 115 | the corresponding constructor. 116 | [[ 117 | (* Example type *) 118 | Inductive example A : Type := 119 | | Ex0 : example A 120 | | Ex1 : A -> example A 121 | | Ex2 : A -> A -> example A 122 | . 123 | 124 | Instance Deserialize_example {A} `{Deserialize A} : Deserialize (example A) := 125 | Deser.match_con "example" (* Name of the type. *) 126 | [ ("Ex0", Ex0) (* Nullary constructors in the first list: [("name", constructor)]. *) 127 | ]%string 128 | [ ("Ex1", Deser.con1_ Ex1) (* In the second list, [("name", conN_ constructor)] *) 129 | , ("Ex2", Deser.con2_ Ex2) (* where [N] is the arity of [constructor]. *) 130 | ]%string. 131 | ]] 132 | *) 133 | Definition match_con {A} (tyname : string) 134 | (c0 : list (string * A)) (c1 : list (string * FromSexpList A)) 135 | : FromSexp A := 136 | _con tyname 137 | (fun c l => 138 | let all_con := List.map fst c0 in 139 | _find_or CeresString.eqb_string c c0 inr 140 | (let msg := 141 | match all_con with 142 | | nil => MsgStr "unexpected atom (expected list)"%string 143 | | _ => 144 | ("expected nullary constructor name, one of "%string ++ comma_sep all_con 145 | ++ ", found "%string ++ c)%s_message 146 | end 147 | in inl (DeserError l (type_error tyname msg)))) 148 | (fun c l err es => 149 | let all_con := List.map fst c1 in 150 | _find_or CeresString.eqb_string c c1 (fun x (_ : unit) => x l err es) 151 | (fun (_ : unit) => 152 | let msg := 153 | match all_con with 154 | | nil => MsgStr "unexpected atom"%string 155 | | _ => 156 | ("expected constructor name, one of "%string ++ comma_sep all_con 157 | ++ ", found "%string ++ c)%s_message 158 | end 159 | in inl (DeserError l (type_error tyname msg))) tt). 160 | 161 | (** Deserialize the fields of a constructor. *) 162 | Definition fields {A} {n} : FromSexpListN 0 n A -> FromSexpList A := fun p => _fields p. 163 | 164 | Definition ret {R} (r : R) {n : nat} : FromSexpListN n n R := 165 | {| _fields := fun l mk_error es => 166 | match es with 167 | | nil => inr r 168 | | _ => 169 | let msg := 170 | ("too many fields, expected "%string ++ string_of_nat n 171 | ++ ", got "%string ++ string_of_nat (n + List.length es))%s_message 172 | in inl (DeserError l (mk_error msg)) 173 | end |}. 174 | 175 | Definition bind_field {A B} (pa : FromSexp A) 176 | {n m : nat} (f : A -> FromSexpListN (S n) m B) 177 | : FromSexpListN n m B := 178 | {| _fields := fun l mk_error es => 179 | match es with 180 | | e :: es => _bind_sum (pa (n :: l) e) (fun a => _fields (f a) l mk_error es) 181 | | nil => 182 | let msg := 183 | ("not enough fields, expected "%string ++ string_of_nat m 184 | ++ ", got only "%string ++ string_of_nat n)%s_message 185 | in inl (DeserError l (mk_error msg)) 186 | end |}. 187 | 188 | Module Import Notations. 189 | Notation "p >>= f" := (bind_field p f) (at level 50, left associativity) : deser_scope. 190 | End Notations. 191 | 192 | Local Open Scope deser_scope. 193 | 194 | (** Note: prefer using the first list in [match_con] for nullary constructors. *) 195 | Definition con0 {R} (r : R) : FromSexpList R := fields (ret r). 196 | 197 | Definition con1 {A R} (f : A -> R) : FromSexp A -> FromSexpList R := fun pa => 198 | fields (pa >>= fun a => ret (f a)). 199 | 200 | Definition con2 {A B R} (f : A -> B -> R) : FromSexp A -> FromSexp B -> FromSexpList R := 201 | fun pa pb => fields (pa >>= fun a => pb >>= fun b => ret (f a b)). 202 | 203 | Definition con3 {A B C R} (f : A -> B -> C -> R) 204 | : FromSexp A -> FromSexp B -> FromSexp C -> FromSexpList R := 205 | fun pa pb pc => fields (pa >>= fun a => pb >>= fun b => pc >>= fun c => ret (f a b c)). 206 | 207 | Definition con4 {A B C D R} (f : A -> B -> C -> D -> R) 208 | : FromSexp A -> FromSexp B -> FromSexp C -> FromSexp D -> FromSexpList R := 209 | fun pa pb pc pd => 210 | fields (pa >>= fun a => pb >>= fun b => pc >>= fun c => pd >>= fun d => 211 | ret (f a b c d)). 212 | 213 | Definition con5 {A B C D E R} (f : A -> B -> C -> D -> E -> R) 214 | : FromSexp A -> FromSexp B -> FromSexp C -> FromSexp D -> FromSexp E -> FromSexpList R := 215 | fun pa pb pc pd pe => 216 | fields (pa >>= fun a => pb >>= fun b => pc >>= fun c => pd >>= fun d => pe >>= fun e => 217 | ret (f a b c d e)). 218 | 219 | Definition con1_ {A R} (f : A -> R) `{Deserialize A} : FromSexpList R := 220 | con1 f _from_sexp. 221 | Definition con2_ {A B R} (f : A -> B -> R) `{Deserialize A} `{Deserialize B} : FromSexpList R := 222 | con2 f _from_sexp _from_sexp. 223 | Definition con3_ {A B C R} (f : A -> B -> C -> R) 224 | `{Deserialize A} `{Deserialize B} `{Deserialize C} : FromSexpList R := 225 | con3 f _from_sexp _from_sexp _from_sexp. 226 | Definition con4_ {A B C D R} (f : A -> B -> C -> D -> R) 227 | `{Deserialize A} `{Deserialize B} `{Deserialize C} `{Deserialize D} : FromSexpList R := 228 | con4 f _from_sexp _from_sexp _from_sexp _from_sexp. 229 | Definition con5_ {A B C D E R} (f : A -> B -> C -> D -> E -> R) 230 | `{Deserialize A} `{Deserialize B} `{Deserialize C} `{Deserialize D} `{Deserialize E} 231 | : FromSexpList R := 232 | con5 f _from_sexp _from_sexp _from_sexp _from_sexp _from_sexp. 233 | 234 | Class DeserFromSexpList (A R : Type) (n m : nat) := 235 | _from_sexp_list : A -> FromSexpListN n m R. 236 | 237 | Global 238 | Instance DeserFromSexpList_0 R m : DeserFromSexpList R R m m := fun r => ret r. 239 | Global 240 | Instance DeserFromSexpList_S A B R n m `{Deserialize A} `{DeserFromSexpList B R (S n) m} 241 | : DeserFromSexpList (A -> B) R n m := 242 | fun f => _from_sexp >>= fun a => _from_sexp_list (f a). 243 | 244 | Definition con_ (A R : Type) (m : nat) `{DeserFromSexpList A R 0 m} (a : A) : FromSexpList R := 245 | fields (_from_sexp_list a). 246 | 247 | End Deser. 248 | 249 | Class SemiIntegral (A : Type) := 250 | from_Z : Z -> option A. 251 | 252 | Global 253 | Instance Deserialize_SemiIntegral `{SemiIntegral A} : Deserialize A := 254 | fun l e => 255 | match e with 256 | | Atom_ (Num n) => 257 | match from_Z n with 258 | | Some a => inr a 259 | | None => inl (DeserError l ("could not read integral type, invalid value "%string ++ MsgSexp e)) 260 | end 261 | | Atom_ _ => inl (DeserError l ("could not read integral type, got a non-Num atom "%string ++ MsgSexp e)) 262 | | List _ => inl (DeserError l "could not read integral type, got a list"%string) 263 | end. 264 | 265 | Global 266 | Instance SemiIntegral_Z : SemiIntegral Z := Some. 267 | Global 268 | Instance SemiIntegral_N : SemiIntegral N := 269 | fun n => if (n if (n 301 | match e with 302 | | List (e1 :: e2 :: nil) => 303 | _bind_sum (_from_sexp (0 :: l) e1) (fun a => 304 | _bind_sum (_from_sexp (1 :: l) e2) (fun b => 305 | inr (a, b))) 306 | | List _ => inl (DeserError l "could not read 'prod', expected list of length 2, got list of a different length"%string) 307 | | Atom_ _ => inl (DeserError l "could not read 'prod', expected list of length 2, got atom"%string) 308 | end. 309 | 310 | Global 311 | Instance Deserialize_Empty_set : Deserialize Empty_set := 312 | fun l _ => inl (DeserError l "Tried to deserialize Empty_set"%string). 313 | 314 | Global 315 | Instance Deserialize_unit : Deserialize unit := 316 | fun l e => 317 | match e with 318 | | Atom_ (Raw "tt") => inr tt 319 | | Atom_ _ => inl (DeserError l "could not read 'unit', expected atom ""tt"", got a different atom"%string) 320 | | List _ => inl (DeserError l "could not read 'unit', expected atom ""tt"", got a list"%string) 321 | end. 322 | 323 | Global 324 | Instance Deserialize_string : Deserialize string := 325 | fun l e => 326 | match e with 327 | | Atom_ (Str s) => inr s 328 | | Atom_ _ => inl (DeserError l "could not read 'string', got non-string atom"%string) 329 | | List _ => inl (DeserError l "could not read 'string', got list"%string) 330 | end. 331 | 332 | Global 333 | Instance Deserialize_ascii : Deserialize ascii := 334 | fun l e => 335 | match e with 336 | | Atom_ (Str (c :: "")) => inr c 337 | | Atom_ (Str "") => inl (DeserError l "could not read 'ascii', got empty string") 338 | | Atom_ (Str (_ :: _ :: _)) => 339 | inl (DeserError l "could not read 'ascii', got string of length greater than 1") 340 | | Atom_ _ => inl (DeserError l "could not read 'ascii', got non-string atom") 341 | | List _ => inl (DeserError l "could not read 'ascii', got lost") 342 | end%string. 343 | 344 | Fixpoint _sexp_to_list {A} (pa : FromSexp A) (xs : list A) 345 | (n : nat) (l : loc) (ys : list sexp) : error + list A := 346 | match ys with 347 | | nil => inr (rev' xs) 348 | | y :: ys => 349 | match pa (n :: l) y with 350 | | inl e => inl e 351 | | inr x => _sexp_to_list pa (x :: xs) (S n) l ys 352 | end 353 | end. 354 | 355 | Global 356 | Instance Deserialize_list {A} `{Deserialize A} : Deserialize (list A) := 357 | fun l e => 358 | match e with 359 | | Atom_ _ => inl (DeserError l "could not read 'list', got atom"%string) 360 | | List es => _sexp_to_list _from_sexp nil 0 l es 361 | end. 362 | 363 | Global 364 | Instance Deserialize_sexp : Deserialize sexp := fun _ => inr. 365 | -------------------------------------------------------------------------------- /theories/CeresFormat.v: -------------------------------------------------------------------------------- 1 | 2 | (* begin hide *) 3 | From Coq Require Import 4 | List ZArith Ascii String. 5 | 6 | From Ceres Require Import 7 | CeresString 8 | CeresS. 9 | (* end hide *) 10 | 11 | (** Helper for [string_of_sexp]. *) 12 | Local Definition dstring_of_sexp {A} (dstring_A : A -> DString.t) 13 | : sexp_ A -> DString.t 14 | := fix _to_dstring (x : sexp_ A) : DString.t := 15 | match x with 16 | | Atom_ a => dstring_A a 17 | | List nil => "()"%string 18 | | List (x :: xs) => fun s0 => 19 | ( "(" 20 | :: _to_dstring x 21 | (fold_right (fun x => " "%char ++ _to_dstring x)%dstring 22 | (")" :: s0) 23 | xs))%string 24 | end%dstring. 25 | 26 | (** Convert a [sexp] to a [string]. *) 27 | Definition string_of_sexp_ {A} (string_A : A -> string) (x : sexp_ A) : string := 28 | dstring_of_sexp string_A x ""%string. 29 | 30 | (** Convert an [atom] to a [string]. *) 31 | Definition string_of_atom (a : atom) : string := 32 | match a with 33 | | Num n => string_of_Z n 34 | | Str s => escape_string s 35 | | Raw s => s 36 | end. 37 | 38 | (** Convert a [sexp] to a [string]. *) 39 | Definition string_of_sexp : sexp -> string := 40 | string_of_sexp_ string_of_atom. 41 | -------------------------------------------------------------------------------- /theories/CeresParser.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import NArith String. 2 | 3 | From Ceres Require Import 4 | CeresS 5 | CeresParserUtils 6 | CeresParserInternal. 7 | 8 | (** Parse a string into a list of S-expressions. *) 9 | Definition parse_sexps (s : string) : error + list sexp := 10 | match parse_sexps_ initial_state 0%N s with 11 | | (None, p, i) => eof i p 12 | | (Some e, _, _) => inl e 13 | end. 14 | 15 | (** Parse a string into one S-expression. Subsequent expressions, if any, are ignored. *) 16 | Definition parse_sexp (s : string) : error + sexp := 17 | let '(e, p, i) := parse_sexps_ initial_state 0%N s in 18 | match List.rev' (parser_done i), e with 19 | | (r :: _)%list, _ => inr r 20 | | nil, Some e => inl e 21 | | nil, None => 22 | match eof i p with 23 | | inl e => inl e 24 | | inr (r :: _)%list => inr r 25 | | inr nil => inl EmptyInput 26 | end 27 | end. 28 | -------------------------------------------------------------------------------- /theories/CeresParserInternal.v: -------------------------------------------------------------------------------- 1 | (** * S-expression parser *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import Bool List ZArith NArith Ascii String Decimal DecimalString. 5 | 6 | From Ceres Require Import 7 | CeresS 8 | CeresString 9 | CeresParserUtils. 10 | 11 | Import ListNotations. 12 | Local Open Scope lazy_bool_scope. 13 | (* end hide *) 14 | 15 | (** Symbols on the stack *) 16 | Variant symbol : Set := 17 | | Open : loc -> symbol 18 | | Exp : sexp -> symbol 19 | . 20 | 21 | (** When parsing strings, whether we are parsing an escape character. *) 22 | Variant escape : Set := 23 | | EscBackslash 24 | | EscNone 25 | . 26 | 27 | (** Tokenizer state. *) 28 | Variant partial_token : Set := 29 | | NoToken : partial_token 30 | | SimpleToken : loc -> string -> partial_token 31 | | StrToken : loc -> string -> escape -> partial_token 32 | | Comment : partial_token 33 | . 34 | 35 | Record parser_state_ {T : Type} : Type := 36 | { parser_done : list sexp 37 | ; parser_stack : list symbol 38 | ; parser_cur_token : T 39 | }. 40 | Arguments parser_state_ : clear implicits. 41 | 42 | Definition set_cur_token {T U} (i : parser_state_ T) (u : U) : parser_state_ U := 43 | {| parser_done := parser_done i 44 | ; parser_stack := parser_stack i 45 | ; parser_cur_token := u 46 | |}. 47 | 48 | Definition parser_state := parser_state_ partial_token. 49 | 50 | Definition initial_state : parser_state := 51 | {| parser_done := nil 52 | ; parser_stack := nil 53 | ; parser_cur_token := NoToken 54 | |}. 55 | 56 | Definition new_sexp {T : Set} (d : list sexp) (s : list symbol) (e : sexp) (t : T) 57 | : parser_state_ T := 58 | match s with 59 | | nil => 60 | {| parser_done := e :: d 61 | ; parser_stack := nil 62 | ; parser_cur_token := t 63 | |} 64 | | (_ :: _)%list => 65 | {| parser_done := d 66 | ; parser_stack := Exp e :: s 67 | ; parser_cur_token := t 68 | |} 69 | end. 70 | 71 | (** Parse next character of a string literal. *) 72 | Definition next_str (i : parser_state) (p0 : loc) (tok : string) (e : escape) (p : loc) (c : ascii) 73 | : error + parser_state := 74 | let '{| parser_done := d; parser_stack := s |} := i in 75 | let ret (tok' : string) e' := inr 76 | {| parser_done := d 77 | ; parser_stack := s 78 | ; parser_cur_token := StrToken p0 tok' e' 79 | |} in 80 | match e with 81 | | EscBackslash => 82 | if "n" =? c then ret ("010" :: tok)%string EscNone 83 | else if "\" =? c then ret ("\" :: tok)%string EscNone 84 | else if """" =? c then ret ("""" :: tok)%string EscNone 85 | else inl (UnknownEscape p c) 86 | | EscNone => 87 | if "\" =? c then ret tok EscBackslash 88 | else if """" =? c then inr (new_sexp d s (Atom (Str (string_reverse tok))) NoToken) 89 | else if is_printable c then ret (c :: tok)%string EscNone 90 | else inl (InvalidStringChar c p) 91 | end%char2. 92 | 93 | (** Close parenthesis: build up a list expression. *) 94 | Fixpoint _fold_stack (d : list sexp) (p : loc) (r : list sexp) (s : list symbol) : error + parser_state := 95 | match s with 96 | | nil => inl (UnmatchedClose p) 97 | | Open _ :: s => inr (new_sexp d s (List r) NoToken) 98 | | Exp e :: s => _fold_stack d p (e :: r) s 99 | end%list. 100 | 101 | (** Parse next character outside of a string literal. *) 102 | Definition next' {T} (i : parser_state_ T) (p : loc) (c : ascii) 103 | : error + parser_state := 104 | (if "(" =? c then inr 105 | {| parser_done := parser_done i 106 | ; parser_stack := Open p :: parser_stack i 107 | ; parser_cur_token := NoToken 108 | |} 109 | else if ")" =? c then 110 | _fold_stack (parser_done i) p nil (parser_stack i) 111 | else if """" =? c then 112 | inr (set_cur_token i (StrToken p "" EscNone)) 113 | else if ";" =? c then 114 | inr (set_cur_token i Comment) 115 | else if is_whitespace c then 116 | inr (set_cur_token i NoToken) 117 | else inl (InvalidChar c p))%char2. 118 | 119 | (** Parse next character in a comment. *) 120 | Definition next_comment (i : parser_state) (c : ascii) : error + parser_state := 121 | if eqb_ascii "010" c then inr 122 | {| parser_done := parser_done i 123 | ; parser_stack := parser_stack i 124 | ; parser_cur_token := NoToken 125 | |} 126 | else inr i. 127 | 128 | (** Construct an atom. Make it a [Num] if it can be parsed as a number, 129 | [Raw] otherwise. *) 130 | Definition raw_or_num (s : string) : atom := 131 | let s := string_reverse s in 132 | match NilZero.int_of_string s with 133 | | None => Raw s 134 | | Some n => Num (Z.of_int n) 135 | end. 136 | 137 | (** Consume one more character. *) 138 | Definition next (i : parser_state) (p : loc) (c : ascii) : error + parser_state := 139 | match parser_cur_token i with 140 | | StrToken p0 tok e => next_str i p0 tok e p c 141 | | NoToken => 142 | if is_atom_char c 143 | then inr (set_cur_token i (SimpleToken p (c :: ""))) 144 | else next' i p c 145 | | SimpleToken _ tok => 146 | if is_atom_char c 147 | then inr (set_cur_token i (SimpleToken p (c :: tok))) 148 | else 149 | let i' := new_sexp (parser_done i) (parser_stack i) (Atom (raw_or_num tok)) tt in 150 | next' i' p c 151 | | Comment => next_comment i c 152 | end. 153 | 154 | (** Return all toplevel S-expressions, or fail if there is still an unmatched open parenthesis. *) 155 | Fixpoint _done_or_fail (r : list sexp) (s : list symbol) : error + list sexp := 156 | match s with 157 | | nil => inr (List.rev' r) 158 | | Exp e :: s => _done_or_fail r s (* Here the last symbol in [s] must be an [Open] *) 159 | | Open p :: _ => inl (UnmatchedOpen p) 160 | end%list. 161 | 162 | (** End of the string/file, get the final result. *) 163 | Definition eof (i : parser_state) (p : loc) : error + list sexp := 164 | match parser_cur_token i with 165 | | StrToken p0 _ _ => inl (UnterminatedString p0) 166 | | (NoToken | Comment) => _done_or_fail (parser_done i) (parser_stack i) 167 | | SimpleToken _ tok => 168 | let i := new_sexp (parser_done i) (parser_stack i) (Atom (raw_or_num tok)) tt 169 | in _done_or_fail (parser_done i) (parser_stack i) 170 | end. 171 | 172 | (** Remove successfully parsed toplevel expressions from the parser state. *) 173 | Definition get_done (i : parser_state) : list sexp * parser_state := 174 | ( List.rev' (parser_done i) 175 | , {| parser_done := nil 176 | ; parser_stack := parser_stack i 177 | ; parser_cur_token := parser_cur_token i 178 | |} 179 | ). 180 | 181 | Definition get_one (i : parser_state) : option sexp * parser_state := 182 | match parser_done i with 183 | | nil => (None, i) 184 | | cons e _ as es => 185 | (Some (List.last es e), 186 | {| parser_done := List.removelast es; 187 | parser_stack := parser_stack i; 188 | parser_cur_token := parser_cur_token i |}) 189 | end. 190 | 191 | (** Parse a string and return the location and state at the end if no error occured (to 192 | resume in another string, or finish with [eof]), or the last known good 193 | location and state in case of an error (to read toplevel valid 194 | S-expressions from). *) 195 | Fixpoint parse_sexps_ (i : parser_state) (p : loc) (s : string) : option error * loc * parser_state := 196 | match s with 197 | | "" => (None, p, i) 198 | | c :: s => 199 | match next i p c with 200 | | inl e => (Some e, p, i) 201 | | inr i => parse_sexps_ i (N.succ p) s 202 | end 203 | end%string. 204 | -------------------------------------------------------------------------------- /theories/CeresParserRoundtrip.v: -------------------------------------------------------------------------------- 1 | (** * Parser specification *) 2 | 3 | (** This is the specification of the parser, turning byte strings into S-expressions. *) 4 | 5 | (** Main relations: 6 | - [token_string]: relating strings to streams of tokens; 7 | - [sexp_tokens]: relating tokens to S-expressions. 8 | 9 | The soundness theorem ("parse then print") is stated below, [PARSE_SEXPS_SOUND]. 10 | The completeness theorem ("print then parse") is TODO. 11 | 12 | These are justs the theorem statements, ensuring that they don't 13 | depend on any proof details. The proofs are in [CeresParserRoundtripProof]. 14 | *) 15 | 16 | From Coq Require Import 17 | Ascii 18 | String 19 | List 20 | ZArith 21 | DecimalString. 22 | From Ceres Require Import 23 | CeresS 24 | CeresString 25 | CeresParserUtils 26 | CeresParser. 27 | 28 | Import ListNotations. 29 | 30 | Module Token. 31 | 32 | Inductive t : Type := 33 | | Open : t 34 | | Close : t 35 | | Atom (s : string) : t 36 | | Str (s : string) : t 37 | . 38 | 39 | End Token. 40 | 41 | (* * Lexer *) 42 | 43 | (* Here we specify how to convert strings of bytes to streams of tokens. *) 44 | 45 | (* [whitespaces s] holds when [s] consists of only whitespace, 46 | as defined by [is_whitespace]. *) 47 | Definition whitespaces (s : string) : Prop := 48 | string_forall is_whitespace s = true. 49 | 50 | (* [comment s] holds when [s] is a comment: starts with 51 | a semicolon [';'], ends with a newline ['\n']. *) 52 | Inductive comment : string -> Prop := 53 | | comment_mk s : comment (";" :: s ++ newline) 54 | . 55 | 56 | (* [atom_string s] holds when [s] is an atom. *) 57 | Definition atom_string (s : string) : Prop := 58 | s <> ""%string /\ string_forall is_atom_char s = true. 59 | 60 | (* [after_atom_string false s] if the non-empty string [s] may appear right 61 | after an atom. This predicate is used to avoid ambiguity: two atoms 62 | cannot follow each other immediately, they must at least be separated 63 | by a space, so [ab] is unambiguously one atom, not two separate atoms [a] 64 | and [b]. *) 65 | Inductive after_atom_string : bool -> string -> Prop := 66 | | after_atom_nil : after_atom_string true "" 67 | | after_atom_cons c s more : is_atom_char c = false -> after_atom_string more (c :: s) 68 | . 69 | Global Hint Constructors after_atom_string : ceres. 70 | 71 | Lemma after_atom_string_nil_inv more : after_atom_string more "" -> more = true. 72 | Proof. 73 | inversion 1; reflexivity. 74 | Qed. 75 | 76 | Lemma after_atom_string_cons more c s : is_atom_char c = false -> after_atom_string more (c :: s). 77 | Proof. 78 | destruct more; auto with ceres. 79 | Qed. 80 | 81 | (* [string_string s0 s1] if the string [s1] encodes the raw string [s0] 82 | (i.e., [s1] contains the bytes you would find in a file). 83 | *) 84 | Definition string_string (s0 : string) (s1 : string) : Prop := 85 | s1 = ("""" :: _escape_string "" s0 ++ """")%string. 86 | 87 | (* Lexer relation: [token_string more ts s] if the string [s] can be split into tokens [ts]. 88 | - Handling of spaces and comments. 89 | - Corner cases for spaces around atoms (["ab"] should not be parsed as ["a"] then ["b"]). 90 | - [more] is [true] if the last token is an [Token.Atom] and there are no more 91 | characters after it, in which case we need to be careful when appending something. 92 | *) 93 | Inductive token_string (more : bool) : list Token.t -> string -> Prop := 94 | | token_string_nil : token_string more [] "" 95 | | token_string_open ts s 96 | : token_string more ts s -> token_string more (Token.Open :: ts) ("(" :: s) 97 | | token_string_close ts s 98 | : token_string more ts s -> token_string more (Token.Close :: ts) (")" :: s) 99 | | token_string_atom ts s1 s 100 | : atom_string s1 -> after_atom_string more s -> 101 | token_string more ts s -> token_string more (Token.Atom s1 :: ts) (s1 ++ s) 102 | | token_string_string ts s0 s1 s 103 | : string_string s0 s1 -> token_string more ts s -> token_string more (Token.Str s0 :: ts) (s1 ++ s) 104 | | token_string_spaces ts ws s 105 | : whitespaces ws -> token_string more ts s -> token_string more ts (ws ++ s) 106 | | token_string_comment ts c s 107 | : comment c -> token_string more ts s -> token_string more ts (c ++ s) 108 | . 109 | Global Hint Constructors token_string : ceres. 110 | 111 | Inductive more_ok : bool -> string -> Prop := 112 | | more_ok_false s : more_ok false s 113 | | more_ok_true c s : is_atom_char c = false -> more_ok true (c :: s) 114 | . 115 | Global Hint Constructors more_ok : ceres. 116 | 117 | Lemma more_ok_nil_inv more : more_ok more "" -> more = false. 118 | Proof. 119 | inversion 1; reflexivity. 120 | Qed. 121 | 122 | Lemma more_ok_cons more c s : is_atom_char c = false -> more_ok more (c :: s). 123 | Proof. 124 | destruct more; auto with ceres. 125 | Qed. 126 | 127 | (* * Parser *) 128 | 129 | (* Here we specify how to turn tokens into trees, S-expressions. *) 130 | 131 | (* Lift parser relation on single elements [A] to a parser relation on lists 132 | of elements [list A]. 133 | Remark: This is like the monadic bind on lists, but using relations instead of functions. *) 134 | Inductive list_tokens {A B} (tks : A -> list B -> Prop) : list A -> list B -> Prop := 135 | | list_tokens_nil : list_tokens tks [] [] 136 | | list_tokens_cons x xs y ys 137 | : tks x y -> list_tokens tks xs ys -> list_tokens tks (x :: xs) (y ++ ys) 138 | . 139 | Global Hint Constructors list_tokens : ceres. 140 | 141 | (* Parser relation on atoms. Each atom is a single token. *) 142 | Inductive atom_token : atom -> Token.t -> Prop := 143 | | atom_token_Raw s : atom_token (Raw s) (Token.Atom s) 144 | | atom_token_Num s z 145 | : NilZero.int_of_string s = Some z -> 146 | atom_token (Num (Z.of_int z)) (Token.Atom s) 147 | | atom_token_Str s : atom_token (Str s) (Token.Str s) 148 | . 149 | Global Hint Constructors atom_token : ceres. 150 | 151 | (* Parser relation on S-expressions. This is the main definition of this file. *) 152 | Inductive sexp_tokens : sexp -> list Token.t -> Prop := 153 | | sexp_tokens_Atom a t : atom_token a t -> sexp_tokens (Atom_ a) [t] 154 | | sexp_tokens_List es ts 155 | : list_tokens sexp_tokens es ts -> 156 | sexp_tokens (List es) (Token.Open :: ts ++ [Token.Close]) 157 | . 158 | Global Hint Constructors sexp_tokens : ceres. 159 | 160 | (* Parser relation on lists of S-expressions (without the outer parentheses). *) 161 | Notation list_sexp_tokens := (list_tokens sexp_tokens). 162 | 163 | (** [on_right] is a helper to phrase conditional propositions of the form 164 | "if this parser succeeds, then ...". 165 | 166 | Concretely, this predicate transformer lifts a predicate on the right 167 | component of a sum. It is [True] for [inl] elements. *) 168 | Definition on_right {A B} (x : A + B) (P : B -> Prop) : Prop := 169 | match x with 170 | | inl _ => True 171 | | inr b => P b 172 | end. 173 | 174 | (** Soundness: if the parser succeeds, then the expressions relate to the input string. 175 | ("Parse then print" roundtrip.) I call this "soundness" because it means that the 176 | parser rejects garbage. 177 | *) 178 | Definition PARSE_SEXPS_SOUND : Prop := 179 | forall (s : string) (es : list sexp), 180 | on_right (parse_sexps s) (fun es => 181 | exists ts, list_sexp_tokens es ts /\ token_string false ts (s ++ newline)). 182 | 183 | (* TODO: Completeness *) 184 | -------------------------------------------------------------------------------- /theories/CeresParserRoundtripProof.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | Ascii 3 | String 4 | List 5 | ZArith 6 | DecimalString. 7 | From Ceres Require Import 8 | CeresUtils 9 | CeresS 10 | CeresString 11 | CeresParser 12 | CeresParserUtils 13 | CeresParserInternal 14 | CeresParserRoundtrip. 15 | 16 | Import ListNotations. 17 | 18 | (* * Lemmas *) 19 | 20 | Lemma atom_token_atom s 21 | : atom_string (string_reverse s) -> 22 | atom_token (raw_or_num s) (Token.Atom (string_reverse s)). 23 | Proof. 24 | unfold raw_or_num. remember (string_reverse _) as s' eqn:E; clear E s. 25 | destruct NilZero.int_of_string eqn:Eios; intros H. 26 | - constructor. assumption. 27 | - constructor. 28 | Qed. 29 | 30 | Lemma whitespace_no_atom c 31 | : is_whitespace c = true -> is_atom_char c = false. 32 | Proof. 33 | repeat match goal with 34 | | [ c : _ |- _ ] => destruct c; clear c; try discriminate 35 | end; cbn; reflexivity. 36 | Qed. 37 | Local Hint Resolve whitespace_no_atom : ceres. 38 | 39 | Lemma list_sexp_tokens_singleton e ts 40 | : sexp_tokens e ts -> 41 | list_sexp_tokens [e] ts. 42 | Proof. 43 | rewrite <- (app_nil_r ts) at 2. 44 | constructor; auto with ceres. 45 | Qed. 46 | Local Hint Resolve list_sexp_tokens_singleton : ceres. 47 | 48 | Lemma list_sexp_tokens_app es1 es2 ts1 ts2 49 | : list_sexp_tokens es1 ts1 -> 50 | list_sexp_tokens es2 ts2 -> 51 | list_sexp_tokens (es1 ++ es2) (ts1 ++ ts2). 52 | Proof. 53 | induction 1; cbn. 54 | - auto. 55 | - rewrite <- app_assoc; constructor; auto. 56 | Qed. 57 | 58 | Lemma string_app_assoc (s0 s1 s2 : string) 59 | : ((s0 ++ s1) ++ s2 = s0 ++ (s1 ++ s2))%string. 60 | Proof. 61 | induction s0; cbn; [ auto | rewrite IHs0; auto ]. 62 | Qed. 63 | 64 | Lemma after_atom_string_snoc c s s' more : 65 | is_atom_char c = false -> 66 | after_atom_string more s -> 67 | after_atom_string false (s ++ c :: s'). 68 | Proof. 69 | intros Hc []; constructor; auto. 70 | Qed. 71 | Local Hint Resolve after_atom_string_snoc : ceres. 72 | 73 | Lemma token_string_open_snoc more ts s : 74 | token_string more ts s -> 75 | token_string false (ts ++ [Token.Open]) (s ++ "("). 76 | Proof. 77 | induction 1; cbn; try rewrite (string_app_assoc _ _ "("%string); auto with ceres. 78 | eauto using token_string_atom with ceres. 79 | Qed. 80 | 81 | Lemma token_string_close_snoc more ts s : 82 | token_string more ts s -> 83 | token_string false (ts ++ [Token.Close]) (s ++ ")"). 84 | Proof. 85 | induction 1; cbn; try rewrite (string_app_assoc _ _ ")"%string); auto with ceres. 86 | eauto using token_string_atom with ceres. 87 | Qed. 88 | 89 | Lemma token_string_atom_snoc ts s s1 : 90 | atom_string s1 -> 91 | token_string false ts s -> 92 | token_string true (ts ++ [Token.Atom s1]) (s ++ s1). 93 | Proof. 94 | induction 2; cbn; try rewrite (string_app_assoc _ _ s1); auto with ceres. 95 | - rewrite <- string_app_nil_r at 2. apply token_string_atom; auto with ceres. 96 | - constructor; auto. 97 | inversion H1; cbn. constructor; auto. 98 | Qed. 99 | 100 | Lemma token_string_newline_snoc more s ts 101 | : token_string more ts s -> 102 | token_string false ts (s ++ newline). 103 | Proof. 104 | induction 1; cbn; try rewrite (string_app_assoc _ _ newline); auto with ceres. 105 | - change newline with (newline ++ "")%string. apply token_string_spaces; constructor. 106 | - eauto with ceres. 107 | Qed. 108 | 109 | Lemma token_string_comment_snoc more s s_com ts 110 | : token_string more ts s -> 111 | token_string false ts (s ++ ";" ++ s_com ++ newline). 112 | Proof. 113 | induction 1; cbn; try rewrite string_app_assoc; auto with ceres. 114 | - change newline with (newline ++ "")%string. 115 | change (?x :: ?y ++ ?z)%string with ((x :: y) ++ z)%string; rewrite <- string_app_assoc. 116 | apply token_string_comment; constructor. 117 | - eauto with ceres. 118 | Qed. 119 | 120 | Lemma token_string_string_snoc more s s_str ts 121 | : token_string more ts s -> 122 | token_string false (ts ++ [Token.Str s_str]) (s ++ """" ++ _escape_string "" s_str ++ """"). 123 | Proof. 124 | induction 1; cbn; try rewrite string_app_assoc; auto with ceres. 125 | - rewrite <- (string_app_nil_r (_ :: _)). 126 | do 2 (constructor; eauto with ceres). 127 | - eauto with ceres. 128 | Qed. 129 | 130 | (* * Parser state *) 131 | 132 | Inductive stack_tokens : list symbol -> list Token.t -> Prop := 133 | | stack_tokens_nil : stack_tokens [] [] 134 | | stack_tokens_open p us ts 135 | : stack_tokens us ts -> 136 | stack_tokens (Open p :: us) (ts ++ [Token.Open]) 137 | | stack_tokens_sexp e us ts ts0 138 | : sexp_tokens e ts0 -> 139 | stack_tokens us ts -> 140 | stack_tokens (Exp e :: us) (ts ++ ts0) 141 | . 142 | Local Hint Constructors stack_tokens : ceres. 143 | 144 | Inductive stack_end_last : list symbol -> Prop := 145 | | stack_end_last_last p : stack_end_last [Open p] 146 | | stack_end_last_cons u us : stack_end_last us -> stack_end_last (u :: us) 147 | . 148 | 149 | Inductive stack_end : list symbol -> Prop := 150 | | stack_end_nil : stack_end [] 151 | | stack_end_nonempty us : stack_end_last us -> stack_end us 152 | . 153 | Local Hint Constructors stack_end : ceres. 154 | 155 | Lemma stack_end_cons v u us 156 | : stack_end (u :: us) -> 157 | stack_end (v :: u :: us). 158 | Proof. 159 | inversion 1; do 2 constructor; auto. 160 | Qed. 161 | Local Hint Resolve stack_end_cons : ceres. 162 | 163 | Lemma stack_end_cons_Open p us 164 | : stack_end us -> 165 | stack_end (Open p :: us). 166 | Proof. 167 | inversion 1. 168 | - do 2 constructor. 169 | - inversion H0; do 3 (constructor; auto). 170 | Qed. 171 | Local Hint Resolve stack_end_cons_Open : ceres. 172 | 173 | Lemma stack_end_inv u us 174 | : stack_end (u :: us) -> 175 | stack_end us. 176 | Proof. 177 | inversion 1. inversion H0; auto with ceres. 178 | Qed. 179 | Local Hint Resolve stack_end_inv : ceres. 180 | 181 | Definition escape_to_string (e : escape) : string := 182 | match e with 183 | | EscBackslash => "\" 184 | | EscNone => "" 185 | end. 186 | 187 | Definition no_newline (s : string) : Prop := 188 | string_elem "010" s = false. 189 | 190 | Lemma is_atom_singleton (c : ascii) 191 | : is_atom_char c = true -> atom_string (c :: ""). 192 | Proof. intros E; constructor; cbn; discriminate + rewrite E; reflexivity. Qed. 193 | Local Hint Resolve is_atom_singleton : ceres. 194 | 195 | Lemma is_atom_app (s : string) (c : ascii) 196 | : atom_string s -> is_atom_char c = true -> atom_string (s ++ c :: ""). 197 | Proof. 198 | intros [_ Hs] Hc; constructor. 199 | - destruct s; discriminate. 200 | - revert Hs; unfold atom_string; induction s; cbn; intros. 201 | + rewrite Hc; auto. 202 | + destruct (is_atom_char a); discriminate + rewrite IHs; auto. 203 | Qed. 204 | Local Hint Resolve is_atom_app : ceres. 205 | 206 | Inductive str_token_string (tok : string) : escape -> string -> Prop := 207 | | str_token_string_EscBackslash 208 | : str_token_string tok EscBackslash ("""" :: _escape_string "" (string_reverse tok) ++ "\") 209 | | str_token_string_EscNone 210 | : str_token_string tok EscNone ("""" :: _escape_string "" (string_reverse tok)) 211 | . 212 | 213 | Lemma str_token_string_new : str_token_string "" EscNone """". 214 | Proof. constructor. Qed. 215 | 216 | Lemma more_ok_str_token more tok e s 217 | : str_token_string tok e s -> 218 | more_ok more s. 219 | Proof. 220 | intros []; auto using more_ok_cons. 221 | Qed. 222 | 223 | Ltac match_match := 224 | match goal with 225 | | [ |- context E [ match ?x with _ => _ end ] ] => 226 | let Ex := fresh "H" in 227 | destruct x eqn:Ex 228 | end. 229 | 230 | Lemma escape_string_newline s 231 | : (_escape_string "" s ++ "\n")%string = _escape_string "" (s ++ newline). 232 | Proof. 233 | induction s; auto; cbn. 234 | match_ascii; try match_match; cbn; rewrite IHs; reflexivity. 235 | Qed. 236 | 237 | Lemma escape_string_backslash s 238 | : (_escape_string "" s ++ "\\")%string = _escape_string "" (s ++ "\"). 239 | Proof. 240 | induction s; auto; cbn. 241 | match_ascii; try match_match; cbn; rewrite IHs; reflexivity. 242 | Qed. 243 | 244 | Lemma escape_string_dquote s 245 | : (_escape_string "" s ++ "\""")%string = _escape_string "" (s ++ """"). 246 | Proof. 247 | induction s; auto; cbn. 248 | match_ascii; try match_match; cbn; rewrite IHs; reflexivity. 249 | Qed. 250 | 251 | Lemma escape_string_regular c s 252 | : is_printable c = true -> 253 | """"%char <> c -> 254 | "\"%char <> c -> 255 | (_escape_string "" s ++ c :: "")%string = _escape_string "" (s ++ c :: ""). 256 | Proof. 257 | intros H1 H2 H3. 258 | induction s; cbn. 259 | - match_ascii; try match_match; cbn; try (discriminate + contradiction + auto). 260 | - match_ascii; try match_match; cbn; rewrite IHs; reflexivity. 261 | Qed. 262 | 263 | Lemma _string_reverse_app s0 s1 s2 264 | : _string_reverse (s1 ++ s0) s2 = (_string_reverse s1 s2 ++ s0)%string. 265 | Proof. 266 | revert s1; induction s2 as [ | c s2 IH ]; cbn; intros; auto. 267 | exact (IH (c :: s1)%string). 268 | Qed. 269 | 270 | Lemma string_reverse_cons c s 271 | : string_reverse (c :: s) = (string_reverse s ++ c :: "")%string. 272 | Proof. 273 | apply (_string_reverse_app (c :: "") ""). 274 | Qed. 275 | 276 | Lemma str_token_string_newline tok s 277 | : str_token_string tok EscBackslash s -> 278 | str_token_string ("010" :: tok) EscNone (s ++ "n"). 279 | Proof. 280 | inversion 1; cbn. 281 | rewrite string_app_assoc, escape_string_newline, <- string_reverse_cons. 282 | constructor. 283 | Qed. 284 | 285 | Lemma str_token_string_backslash tok s 286 | : str_token_string tok EscBackslash s -> 287 | str_token_string ("\" :: tok) EscNone (s ++ "\"). 288 | Proof. 289 | inversion 1; cbn. 290 | rewrite string_app_assoc, escape_string_backslash, <- string_reverse_cons. 291 | constructor. 292 | Qed. 293 | 294 | Lemma str_token_string_dquote tok s 295 | : str_token_string tok EscBackslash s -> 296 | str_token_string ("""" :: tok) EscNone (s ++ """"). 297 | Proof. 298 | inversion 1; cbn. 299 | rewrite string_app_assoc, escape_string_dquote, <- string_reverse_cons. 300 | constructor. 301 | Qed. 302 | 303 | Lemma str_token_string_escape tok s 304 | : str_token_string tok EscNone s -> 305 | str_token_string tok EscBackslash (s ++ "\"). 306 | Proof. 307 | inversion 1; cbn; constructor. 308 | Qed. 309 | 310 | Lemma str_token_string_regular c tok s 311 | : is_printable c = true -> 312 | """"%char <> c -> 313 | "\"%char <> c -> 314 | str_token_string tok EscNone s -> 315 | str_token_string (c :: tok) EscNone (s ++ c :: ""). 316 | Proof. 317 | inversion 4; cbn. 318 | rewrite escape_string_regular by auto. 319 | rewrite <- string_reverse_cons. 320 | constructor. 321 | Qed. 322 | 323 | Inductive partial_token_string : partial_token -> string -> Prop := 324 | | partial_token_string_NoToken 325 | : partial_token_string NoToken "" 326 | | partial_token_string_SimpleToken p s s' 327 | : atom_string s' -> 328 | s' = string_reverse s -> 329 | partial_token_string (SimpleToken p s) s' 330 | | partial_token_string_StrToken p tok e s' 331 | : str_token_string tok e s' -> 332 | partial_token_string (StrToken p tok e) s' 333 | | partial_token_string_Comment s 334 | : no_newline s -> 335 | partial_token_string Comment (";" :: s) 336 | . 337 | Local Hint Constructors partial_token_string : ceres. 338 | 339 | Inductive parser_state_string_ 340 | (more : bool) (d : list sexp) (u : list symbol) (s0 : string) : Prop := 341 | | parser_state_string_mk_ ts00 ts01 342 | : token_string more (ts00 ++ ts01) s0 -> 343 | list_sexp_tokens (rev d) ts00 -> 344 | stack_tokens u ts01 -> 345 | stack_end u -> 346 | parser_state_string_ more d u s0 347 | . 348 | Local Hint Constructors parser_state_string_ : ceres. 349 | 350 | Lemma parser_state_string_map d u more more' s0 s0' 351 | : (forall ts, token_string more ts s0 -> token_string more' ts s0') -> 352 | parser_state_string_ more d u s0 -> 353 | parser_state_string_ more' d u s0'. 354 | Proof. 355 | intros f []; eauto with ceres. 356 | Qed. 357 | 358 | (* Invariant on the parsed prefix *) 359 | Inductive parser_state_string (i : parser_state) : string -> Prop := 360 | | parser_state_string_mk more s0 s1 361 | : parser_state_string_ more (parser_done i) (parser_stack i) s0 -> 362 | more_ok more s1 -> 363 | partial_token_string (parser_cur_token i) s1 -> 364 | parser_state_string i (s0 ++ s1) 365 | . 366 | Local Hint Constructors parser_state_string : ceres. 367 | 368 | Lemma more_ok_atom_inv more s 369 | : more_ok more s -> 370 | atom_string s -> 371 | more = false. 372 | Proof. 373 | intros [| c s' Hc]; auto. 374 | intros [_ Hs]. cbn in Hs. rewrite Hc in Hs. discriminate. 375 | Qed. 376 | 377 | Lemma new_sexp_Atom_sound d u s0 more 378 | (Hdu : parser_state_string_ more d u s0) 379 | (s' : string) 380 | (Hmore : more_ok more s') 381 | (s1' : string) 382 | (H : atom_string s') 383 | (H0 : s' = string_reverse s1') 384 | (i' := new_sexp d u (Atom (raw_or_num s1')) tt) 385 | : parser_state_string_ true (parser_done i') (parser_stack i') (s0 ++ s'). 386 | Proof. 387 | unfold new_sexp in i'. 388 | assert (more = false) by eauto using more_ok_atom_inv; subst more. 389 | destruct Hdu as [ ts00 ts01 Hs0 Hts Hstack Hend ]. 390 | destruct u; cbn; clear i'. 391 | - inversion Hstack; subst ts01; clear Hstack. rewrite app_nil_r in Hs0. 392 | apply parser_state_string_mk_ 393 | with (ts00 := ts00 ++ [Token.Atom s']) (ts01 := []); 394 | cbn; auto with ceres. 395 | + rewrite app_nil_r. 396 | auto using token_string_atom_snoc. 397 | + subst s'; auto using list_sexp_tokens_app, atom_token_atom with ceres. 398 | - apply parser_state_string_mk_ 399 | with (ts00 := ts00) (ts01 := ts01 ++ [Token.Atom s']); 400 | cbn; auto with ceres. 401 | + rewrite app_assoc. 402 | auto using token_string_atom_snoc. 403 | + subst s'; auto using atom_token_atom with ceres. 404 | Qed. 405 | 406 | Lemma new_sexp_List_sound d u s0 ts00 ts01 ts02 more 407 | (es : list sexp) 408 | (Hs0 : token_string more (ts00 ++ ts01 ++ [Token.Open] ++ ts02) s0) 409 | (Hdone : list_sexp_tokens (rev d) ts00) 410 | (Hstack : stack_tokens u ts01) 411 | (Hstackend : stack_end u) 412 | (Hes : list_sexp_tokens es ts02) 413 | : parser_state_string (new_sexp d u (List es) NoToken) (s0 ++ ")"). 414 | Proof. 415 | unfold new_sexp. 416 | destruct u. 417 | - inversion Hstack; subst; clear Hstack. cbn in Hs0. 418 | rewrite <- (string_app_nil_r (_ ++ ")")). 419 | apply parser_state_string_mk with (more := false); cbn; auto with ceres. 420 | apply parser_state_string_mk_ 421 | with (ts00 := ts00 ++ [Token.Open] ++ ts02 ++ [Token.Close]) (ts01 := []); 422 | cbn; auto with ceres. 423 | + rewrite app_nil_r. 424 | change (?x :: ?y ++ ?z) with ((x :: y) ++ z). 425 | rewrite !(app_assoc _ _ [Token.Close]). 426 | eauto using token_string_close_snoc. 427 | + apply list_sexp_tokens_app; auto. 428 | rewrite <- (app_nil_r (_ :: _ ++ _)). 429 | auto with ceres. 430 | - rewrite <- (string_app_nil_r (_ ++ ")")). 431 | econstructor; cbn; auto with ceres. 432 | apply parser_state_string_mk_ 433 | with (ts00 := ts00) (ts01 := ts01 ++ [Token.Open] ++ ts02 ++ [Token.Close]); 434 | cbn; auto with ceres. 435 | change (?x :: ?y ++ ?z) with ((x :: y) ++ z). 436 | rewrite !(app_assoc _ _ [Token.Close]). 437 | eauto using token_string_close_snoc. 438 | Qed. 439 | 440 | Lemma new_sexp_Str_sound (d : list sexp) (u : list symbol) (more : bool) 441 | (s0 tok s' : string) 442 | (Hi : parser_state_string_ more d u s0) 443 | (H : str_token_string tok EscNone s') 444 | : parser_state_string 445 | (new_sexp d u (Atom (Str (string_reverse tok))) NoToken) 446 | (s0 ++ s' ++ """"). 447 | Proof. 448 | rewrite <- (string_app_nil_r (_ ++ _ ++ """")). 449 | unfold new_sexp. 450 | destruct Hi. inversion_clear H. 451 | destruct u. 452 | - inversion H2; subst; clear H2. 453 | apply parser_state_string_mk with (more := false); cbn; auto with ceres. 454 | apply parser_state_string_mk_ 455 | with (ts00 := ts00 ++ [Token.Str (string_reverse tok)]) (ts01 := []); 456 | cbn; auto with ceres. 457 | + rewrite app_nil_r in *. 458 | eapply token_string_string_snoc; eauto. 459 | + apply list_sexp_tokens_app; eauto with ceres. 460 | - econstructor; cbn; auto with ceres. 461 | apply parser_state_string_mk_ 462 | with (ts00 := ts00) (ts01 := ts01 ++ [Token.Str (string_reverse tok)]); 463 | cbn; auto with ceres. 464 | rewrite app_assoc. 465 | eapply token_string_string_snoc. eauto. 466 | Qed. 467 | 468 | Lemma _fold_stack_sound_ 469 | d 470 | (p : loc) 471 | (s0 : string) 472 | (more : bool) 473 | u 474 | : forall 475 | (es : list sexp) 476 | (ts00 ts01 ts02 : list Token.t) 477 | (Hs0 : token_string more (ts00 ++ ts01 ++ ts02) s0) 478 | (Hdone : list_sexp_tokens (rev d) ts00) 479 | (Hstack : stack_tokens u ts01) 480 | (Hstackend : stack_end u) 481 | (Hes : list_sexp_tokens es ts02) 482 | , on_right (_fold_stack d p es u) 483 | (fun i' : parser_state => parser_state_string i' (s0 ++ ")")). 484 | Proof. 485 | induction u; cbn; auto; intros. 486 | destruct a; cbn. 487 | - inversion Hstack; subst; clear Hstack. 488 | rewrite <- app_assoc in Hs0. 489 | eauto using new_sexp_List_sound with ceres. 490 | - inversion Hstack; subst; clear Hstack. 491 | rewrite <- app_assoc in Hs0. 492 | specialize IHu with (1 := Hs0). 493 | apply IHu; eauto with ceres. 494 | Qed. 495 | 496 | Lemma _fold_stack_sound 497 | d 498 | (p : loc) 499 | (s0 : string) 500 | (more : bool) 501 | u 502 | : parser_state_string_ more d u s0 -> 503 | on_right (_fold_stack d p [] u) 504 | (fun i' : parser_state => parser_state_string i' (s0 ++ ")")). 505 | Proof. 506 | intros [ts00 ts01 ? ?]; apply _fold_stack_sound_ 507 | with (more := more) (ts00 := ts00) (ts01 := ts01) (ts02 := []); auto with ceres. 508 | rewrite app_nil_r; auto with ceres. 509 | Qed. 510 | 511 | Lemma token_string_spaces_app more ts s c 512 | : is_whitespace c = true -> 513 | token_string more ts s -> 514 | token_string false ts (s ++ c :: ""). 515 | Proof. 516 | intros Hc; induction 1; cbn; try rewrite string_app_assoc; auto with ceres. 517 | - apply token_string_spaces with (ws := (c :: "")%string); auto with ceres. 518 | red; cbn; rewrite Hc; auto. 519 | - apply token_string_atom; auto with ceres. 520 | eauto using after_atom_string_snoc with ceres. 521 | Qed. 522 | 523 | Lemma next_sound' {T} (i : parser_state_ T) (more : bool) s0 p c 524 | : parser_state_string_ more (parser_done i) (parser_stack i) s0 -> 525 | is_atom_char c = false -> 526 | on_right (next' i p c) (fun i' => 527 | parser_state_string i' (s0 ++ c :: "")). 528 | Proof. 529 | intros [ts00 ts01 Hs0 Hdone Hstack] IAC_c. 530 | unfold next'; match_ascii; cbn. 531 | + (* "(" *) 532 | rewrite <- (string_app_nil_r (_ ++ "(")). 533 | apply parser_state_string_mk with (more := false); auto with ceres. 534 | apply parser_state_string_mk_ 535 | with (ts00 := ts00) (ts01 := ts01 ++ [Token.Open]); 536 | cbn; eauto with ceres. 537 | rewrite app_assoc; apply token_string_open_snoc with (more := more); eauto with ceres. 538 | + (* ")" *) 539 | eauto using _fold_stack_sound with ceres. 540 | + (* """" *) 541 | eapply parser_state_string_mk; cbn; eauto using str_token_string_new, more_ok_cons with ceres. 542 | + (* ";" *) 543 | eapply parser_state_string_mk; cbn; eauto using more_ok_cons with ceres. 544 | + (* else *) 545 | destruct (is_whitespace y) eqn:Ews; cbn. 546 | * rewrite <- (string_app_nil_r (_ ++ y :: "")). 547 | eauto using token_string_spaces_app with ceres. 548 | * auto. 549 | Qed. 550 | 551 | Lemma more_ok_atom more s c 552 | : more_ok more s -> 553 | atom_string s -> 554 | is_atom_char c = true -> 555 | more_ok more (s ++ c :: ""). 556 | Proof. 557 | intros []; cbn; auto with ceres. 558 | Qed. 559 | Local Hint Resolve more_ok_atom : ceres. 560 | 561 | Lemma string_reverse_cons' c s s' 562 | : s' = string_reverse s -> 563 | (s' ++ c :: "")%string = string_reverse (c :: s)%string. 564 | Proof. 565 | intros; subst; symmetry; apply string_reverse_cons. 566 | Qed. 567 | 568 | Lemma next_str_sound 569 | (i : parser_state) (p p1 : loc) (c : ascii) (e : escape) 570 | (more : bool) (s0 tok s' : string) 571 | (Hi : parser_state_string_ more (parser_done i) (parser_stack i) s0) 572 | (H : str_token_string tok e s') 573 | : on_right (next_str i p1 tok e p c) 574 | (fun i' : parser_state => parser_state_string i' (s0 ++ s' ++ c :: "")). 575 | Proof with (econstructor; cbn; eauto using more_ok_str_token with ceres). 576 | unfold next_str. 577 | destruct e, i as [d u ct]. 578 | - match_ascii; cbn; auto. 579 | + apply str_token_string_newline in H... 580 | + apply str_token_string_backslash in H... 581 | + apply str_token_string_dquote in H... 582 | - match_ascii; try match_match; cbn; auto. 583 | + apply str_token_string_escape in H... 584 | + eauto using new_sexp_Str_sound. 585 | + econstructor; eauto using more_ok_str_token, str_token_string_regular. 586 | constructor. auto using str_token_string_regular. 587 | Qed. 588 | 589 | Lemma next_comment_sound 590 | (i : parser_state) 591 | (c : ascii) 592 | (more : bool) 593 | (s0 : string) 594 | (Hi : parser_state_string_ more (parser_done i) (parser_stack i) s0) 595 | (Ei : parser_cur_token i = Comment) 596 | (s1 : string) 597 | (Hs : no_newline s1) 598 | : on_right (next_comment i c) (fun i' : parser_state => 599 | parser_state_string i' (s0 ++ ";" :: s1 ++ c :: "")). 600 | Proof. 601 | unfold next_comment. 602 | match_ascii; cbn. 603 | - rewrite <- (string_app_nil_r (_ ++ _ :: _)). 604 | econstructor; eauto using more_ok_cons with ceres. 605 | revert Hi. 606 | apply parser_state_string_map, token_string_comment_snoc. 607 | - econstructor; eauto using more_ok_cons with ceres. 608 | rewrite Ei; constructor. 609 | apply not_string_elem_app; auto. 610 | apply not_string_elem_singleton; assumption. 611 | Qed. 612 | 613 | Lemma next_sound i s p c 614 | : parser_state_string i s -> 615 | on_right (next i p c) (fun i' => 616 | parser_state_string i' (s ++ c :: "")). 617 | Proof. 618 | intros [more s0 s1 Hi Hmore Hcur]. 619 | unfold next. 620 | remember (parser_cur_token i) as ct; symmetry in Heqct. 621 | destruct Hcur as [ | p1' s1' | p1 tok e | s1' Hs ]. 622 | - (* NoToken *) 623 | apply more_ok_nil_inv in Hmore; subst more. 624 | rewrite string_app_nil_r. 625 | destruct (is_atom_char c) eqn:IAC_c; cbn. 626 | + econstructor; cbn; eauto with ceres. 627 | + eauto using next_sound'. 628 | - (* SimpleToken *) 629 | destruct (is_atom_char c) eqn:IAC_c; cbn. 630 | + rewrite string_app_assoc. 631 | econstructor; cbn; eauto using string_reverse_cons' with ceres. 632 | + destruct Hi as [ts00 ts01 Hs0 Hdone Hstack]. 633 | eauto using next_sound', new_sexp_Atom_sound with ceres. 634 | - (* StrToken *) 635 | rewrite string_app_assoc; cbn. 636 | eauto using next_str_sound. 637 | - (* Comment *) 638 | rewrite string_app_assoc; cbn. 639 | eauto using next_comment_sound. 640 | Qed. 641 | 642 | Lemma _done_or_fail_sound d u 643 | (more : bool) 644 | (s0 : string) 645 | (H : parser_state_string_ more d u s0) 646 | : on_right (_done_or_fail d u) 647 | (fun es : list sexp => 648 | exists ts : list Token.t, 649 | list_sexp_tokens es ts /\ token_string more ts s0). 650 | Proof. 651 | destruct H. 652 | destruct H2 as [ | ? H2]; cbn. 653 | - inversion H1; subst; clear H1. rewrite app_nil_r in *. 654 | exists ts00. unfold rev'; rewrite <- rev_alt. 655 | eauto. 656 | - clear H1. induction H2; intros; cbn; auto. 657 | destruct u; cbn; auto. 658 | Qed. 659 | 660 | Lemma eof_sound 661 | (i : parser_state) 662 | (p : loc) 663 | (s : string) 664 | (H : parser_state_string i s) 665 | : on_right (eof i p) (fun es : list sexp => 666 | exists (ts : list Token.t), 667 | list_sexp_tokens es ts /\ token_string false ts (s ++ newline)). 668 | Proof. 669 | unfold eof. 670 | destruct H as [ more s0 s1 H Hmore Hpartial ]. 671 | destruct Hpartial; cbn; auto. 672 | - rewrite string_app_nil_r. 673 | eauto using _done_or_fail_sound, parser_state_string_map, token_string_newline_snoc. 674 | - eauto using _done_or_fail_sound, new_sexp_Atom_sound, parser_state_string_map, token_string_newline_snoc. 675 | - rewrite string_app_assoc. eapply _done_or_fail_sound. cbn. 676 | revert H. 677 | apply parser_state_string_map, token_string_comment_snoc. 678 | Qed. 679 | 680 | Lemma _parse_sexps_sound i p (s0 s : string) 681 | : parser_state_string i s0 -> 682 | match parse_sexps_ i p s with 683 | | (None, p', i') => 684 | on_right (eof i' p') (fun es => 685 | exists ts, 686 | list_sexp_tokens es ts /\ token_string false ts (s0 ++ s ++ newline)) 687 | | (Some _, _, _) => True 688 | end. 689 | Proof. 690 | revert i p s0; induction s as [ | c s ]; intros; cbn. 691 | - apply eof_sound; auto. 692 | - pose proof next_sound as SOUND. 693 | specialize (SOUND i s0 p c H). 694 | destruct next as [ | i']; auto; cbn in SOUND. 695 | specialize (IHs i' (N.succ p) _ SOUND). 696 | destruct parse_sexps_ as [ [ [ | ] ] ? ]; auto. 697 | destruct eof; auto; cbn in *. 698 | destruct IHs as (ts & Hts & Hs0). 699 | rewrite string_app_assoc in Hs0. 700 | eauto. 701 | Qed. 702 | 703 | Lemma parser_state_empty : parser_state_string initial_state "". 704 | Proof. 705 | change ""%string with ("" ++ "")%string. 706 | repeat econstructor; cbn; auto with ceres. 707 | Qed. 708 | 709 | (* If the parser succeeds, then the expressions relate to the input string. *) 710 | Theorem parse_sexps_sound : PARSE_SEXPS_SOUND. 711 | Proof. 712 | red; intros. 713 | unfold parse_sexps. 714 | pose proof (_parse_sexps_sound initial_state 0%N "" s parser_state_empty) as SOUND. 715 | destruct parse_sexps_ as [ [ [ | ] ] ? ]; cbn; auto. 716 | Qed. 717 | -------------------------------------------------------------------------------- /theories/CeresParserUtils.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import Bool NArith String Ascii. 2 | 3 | From Ceres Require Import CeresString. 4 | 5 | Local Open Scope lazy_bool_scope. 6 | 7 | (** Location in a string *) 8 | Definition loc : Set := N. 9 | 10 | Definition pretty_loc (p : loc) : string := string_of_N p. 11 | 12 | (** Errors which may be raised by the parser. *) 13 | Variant error := 14 | | UnmatchedClose : loc -> error 15 | | UnmatchedOpen : loc -> error 16 | | UnknownEscape : loc -> ascii -> error 17 | | UnterminatedString : loc -> error 18 | | EmptyInput : error 19 | | InvalidChar : ascii -> loc -> error 20 | | InvalidStringChar : ascii -> loc -> error 21 | . 22 | 23 | Definition pretty_error (e : error) := 24 | match e with 25 | | UnmatchedClose p => "Unmatched close parenthesis at location " ++ pretty_loc p 26 | | UnmatchedOpen p => "Unmatched open parenthesis at location " ++ pretty_loc p 27 | | UnknownEscape p c => "Unknown escape code '\" ++ c :: "' at location " ++ pretty_loc p 28 | | UnterminatedString p => "Unterminated string starting at location " ++ pretty_loc p 29 | | EmptyInput => "Input is empty" 30 | | InvalidChar c p => 31 | "Invalid character " ++ escape_string (c :: "") ++ " at location " ++ pretty_loc p 32 | | InvalidStringChar c p => 33 | "Invalid character inside string " ++ escape_string (c :: "") ++ " at location " ++ pretty_loc p 34 | end%string. 35 | 36 | Definition is_atom_char (c : ascii) : bool := 37 | (is_alphanum c ||| string_elem c "'=-+*/:!?@#$%^&_<>.,|~"). 38 | -------------------------------------------------------------------------------- /theories/CeresRoundtrip.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | ZArith 3 | List 4 | Ascii 5 | String. 6 | From Ceres Require Import 7 | CeresUtils 8 | CeresS 9 | CeresSerialize 10 | CeresDeserialize. 11 | 12 | Import ListNotations. 13 | 14 | (** Completeness: all values can be serialized without loss of information. *) 15 | Definition Complete {A : Type} (ser : A -> sexp) (de : sexp -> error + A) : Prop := 16 | forall (a : A), de (ser a) = inr a. 17 | 18 | (** Soundness: deserialization succeeds only for well-formed expressions. *) 19 | Definition Sound {A : Type} (ser : A -> sexp) (de : sexp -> error + A) : Prop := 20 | forall (e : sexp) (a : A), 21 | de e = inr a -> 22 | ser a = e. 23 | 24 | Class CompleteClass (A : Type) `{Serialize A} `{Deserialize A} : Prop := 25 | complete_class : forall l, @Complete A to_sexp (_from_sexp l). 26 | 27 | Class SoundClass (A : Type) `{Serialize A} `{Deserialize A} : Prop := 28 | sound_class : forall l, @Sound A to_sexp (_from_sexp l). 29 | 30 | (**) 31 | 32 | Class CompleteIntegral (A : Type) `{Integral A} `{SemiIntegral A} : Prop := 33 | complete_integral : forall (a : A), from_Z (to_Z a) = Some a. 34 | 35 | Class SoundIntegral (A : Type) `{Integral A} `{SemiIntegral A} : Prop := 36 | sound_integral : forall z a, from_Z z = Some a -> to_Z a = z. 37 | 38 | Global 39 | Instance CompleteClass_Integral {A} `{CompleteIntegral A} : CompleteClass A. 40 | Proof. 41 | intros l a; cbn; rewrite complete_integral; reflexivity. 42 | Qed. 43 | 44 | Global 45 | Instance SoundClass_Integral {A} `{SoundIntegral A} : SoundClass A. 46 | Proof. 47 | intros l [ [] | ] a; cbn; try discriminate. 48 | destruct from_Z eqn:Ez; try discriminate. 49 | intros E; injection E; intros []. 50 | apply (f_equal Atom), (f_equal Num). apply sound_integral; assumption. 51 | Qed. 52 | 53 | Global 54 | Instance Complete_Z : CompleteIntegral Z. 55 | Proof. 56 | intros a. reflexivity. 57 | Qed. 58 | 59 | Global 60 | Instance Complete_N : CompleteIntegral N. 61 | Proof. 62 | intros a. unfold from_Z, SemiIntegral_N. 63 | replace (Z.ltb _ _) with false. 64 | - rewrite N2Z.id; reflexivity. 65 | - symmetry; apply Z.ltb_ge. 66 | apply N2Z.is_nonneg. 67 | Qed. 68 | 69 | Global 70 | Instance Complete_nat : CompleteIntegral nat. 71 | Proof. 72 | intros a. unfold from_Z, SemiIntegral_nat. 73 | replace (Z.ltb _ _) with false. 74 | - rewrite Nat2Z.id; reflexivity. 75 | - symmetry; apply Z.ltb_ge. 76 | apply Nat2Z.is_nonneg. 77 | Qed. 78 | 79 | Global 80 | Instance Sound_Z : SoundIntegral Z. 81 | Proof. 82 | intros a b H; injection H; intros []; reflexivity. 83 | Qed. 84 | 85 | Global 86 | Instance Sound_N : SoundIntegral N. 87 | Proof. 88 | intros z n. unfold from_Z, SemiIntegral_N. 89 | destruct (Z.ltb_spec z 0); try discriminate. 90 | intros E; injection E; clear E. 91 | intros []; rewrite Z2N.id; auto. 92 | Qed. 93 | 94 | Global 95 | Instance Sound_nat : SoundIntegral nat. 96 | Proof. 97 | intros z n. unfold from_Z, SemiIntegral_nat. 98 | destruct (Z.ltb_spec z 0); try discriminate. 99 | intros E; injection E; clear E. 100 | intros []; rewrite Z2Nat.id; auto. 101 | Qed. 102 | 103 | (**) 104 | 105 | Lemma sound__con {A} (tyname : string) 106 | (g : string -> loc -> error + A) (f : string -> FromSexpList A) 107 | l (e : sexp) (a : A) 108 | : Deser._con tyname g f l e = inr a -> 109 | (exists c, e = Atom (Raw c) /\ g c l = inr a) \/ 110 | (exists c es, e = List (Atom (Raw c) :: es) /\ f c l (type_error tyname) es = inr a). 111 | Proof. 112 | destruct e as [ [] | [ | [ [] | ] ] ]; cbn; try discriminate; eauto. 113 | Qed. 114 | 115 | Lemma _find_or_spec {A B C} 116 | (eqb : A -> A -> bool) (a : A) (xs : list (A * B)) (f : B -> C) (b : C) 117 | (P : C -> Prop) 118 | : P (_find_or eqb a xs f b) -> 119 | (List.Exists (fun p => eqb a (fst p) = true /\ P (f (snd p))) xs) \/ 120 | (List.Forall (fun p => eqb a (fst p) = false) xs /\ P b). 121 | Proof. 122 | induction xs as [ | xy xs IH ]. 123 | - auto. 124 | - cbn. destruct xy as [x y]. 125 | destruct (eqb a x) eqn:Eeqb. 126 | + left; left; auto. 127 | + intros H; specialize (IH H). 128 | destruct IH as [ | [] ]. 129 | * left; right; assumption. 130 | * right; constructor; [ constructor; auto | auto ]. 131 | Qed. 132 | 133 | (* For backwards compatibility. [List.Exists_impl] which was added on 8.10. *) 134 | Lemma List_Exists_impl {A} (P Q : A -> Prop) (xs : list A) 135 | : (forall x, P x -> Q x) -> List.Exists P xs -> List.Exists Q xs. 136 | Proof. 137 | induction 2; intros; auto. 138 | Qed. 139 | 140 | Theorem sound_match_con {A} (tyname : string) 141 | (c0 : list (string * A)) (c1 : list (string * FromSexpList A)) 142 | l (e : sexp) (a : A) 143 | : Deser.match_con tyname c0 c1 l e = inr a -> 144 | List.Exists (fun p => e = Atom (Raw (fst p)) /\ a = snd p) c0 145 | \/ List.Exists (fun p => exists es, 146 | List (Atom (Raw (fst p)) :: es) = e /\ 147 | inr a = snd p l (type_error tyname) es) c1. 148 | Proof. 149 | unfold Deser.match_con. 150 | intros DESER. apply sound__con in DESER. destruct DESER as [ (c & Ee & Ea ) | (c & es & Ee & Ea) ]. 151 | - apply _find_or_spec in Ea. destruct Ea as [ Ea | [] ]; [ | discriminate ]. 152 | left. revert Ea; apply List_Exists_impl. 153 | intros [] [Es Ea]; cbn in *. 154 | apply CeresString.eqb_eq_string in Es. 155 | injection Ea; intros. 156 | subst. auto. 157 | - apply _find_or_spec in Ea. destruct Ea as [ Ea | [] ]; [ | discriminate ]. 158 | right. revert Ea; apply List_Exists_impl. 159 | intros [] [Es Ea]; cbn in *. 160 | apply CeresString.eqb_eq_string in Es. 161 | exists es. 162 | subst; auto. 163 | Qed. 164 | 165 | Ltac elim_Exists H := 166 | match type of H with 167 | | (List.Exists _ nil) => apply List.Exists_nil in H; destruct H 168 | | (List.Exists _ (cons _ _)) => apply List.Exists_cons in H; 169 | destruct H as [ H | H ]; [ | elim_Exists H ] 170 | end. 171 | 172 | Global 173 | Instance CompleteClass_bool : CompleteClass bool. 174 | Proof. 175 | unfold CompleteClass, Complete. 176 | intros l []; reflexivity. 177 | Qed. 178 | 179 | Global 180 | Instance SoundClass_bool : SoundClass bool. 181 | Proof. 182 | intros l e a Ee; apply sound_match_con in Ee. 183 | destruct Ee as [ Ee | Ee ]; elim_Exists Ee; 184 | destruct Ee as [Eatom Ea]; subst; try reflexivity. 185 | Qed. 186 | 187 | Global 188 | Instance CompleteClass_option {A} `{CompleteClass A} : CompleteClass (option A). 189 | Proof. 190 | unfold CompleteClass, Complete. 191 | intros l []; cbn; [ rewrite H1 | ]; reflexivity. 192 | Qed. 193 | 194 | Global 195 | Instance CompleteClass_sum {A B} `{CompleteClass A} `{CompleteClass B} : CompleteClass (A + B). 196 | Proof. 197 | intros l []; cbn; rewrite complete_class; reflexivity. 198 | Qed. 199 | 200 | Global 201 | Instance CompleteClass_prod {A B} `{CompleteClass A} `{CompleteClass B} : CompleteClass (A * B). 202 | Proof. 203 | intros l []; cbn; rewrite 2 complete_class; reflexivity. 204 | Qed. 205 | 206 | Section DeRetField. 207 | 208 | Context {R} (r : R) {n : nat}. 209 | 210 | Inductive UnnilFields : R -> list sexp -> Prop := 211 | | MkUnnilFields : UnnilFields r nil 212 | . 213 | 214 | Lemma sound_ret_field {a} l err es 215 | : inr a = _fields (@Deser.ret R r n) l err es -> 216 | UnnilFields a es. 217 | Proof. 218 | destruct es; cbn. 219 | - intros H; injection H; intros J; rewrite J; constructor. 220 | - discriminate. 221 | Qed. 222 | 223 | End DeRetField. 224 | 225 | Section DeBindField. 226 | 227 | Context {A B} (pa : FromSexp A) 228 | {n m : nat} (f : A -> FromSexpListN (S n) m B). 229 | 230 | Context (a : B) (es : list sexp) {l : loc} {err : message -> message}. 231 | 232 | Inductive UnconsFields : list sexp -> Prop := 233 | | MkUnconsFields a' e' es' 234 | : pa (n :: l) e' = inr a' -> 235 | inr a = _fields (f a') l err es' -> 236 | UnconsFields (e' :: es') 237 | . 238 | 239 | Lemma sound_bind_field 240 | : inr a = _fields (Deser.bind_field pa f) l err es -> 241 | UnconsFields es. 242 | Proof. 243 | destruct es; cbn; try discriminate. 244 | destruct pa eqn:E1; cbn; try discriminate. 245 | apply MkUnconsFields. assumption. 246 | Qed. 247 | 248 | End DeBindField. 249 | 250 | Ltac sound_field Ea := 251 | (apply sound_ret_field in Ea; destruct Ea) + 252 | (let a1 := fresh "a" in 253 | let e1 := fresh "e" in 254 | let es := fresh "es" in 255 | let Ea1 := fresh "Ea1" in 256 | apply sound_bind_field in Ea; 257 | destruct Ea as [a1 e1 es Ea1 Ea]; 258 | sound_field Ea). 259 | 260 | Global 261 | Instance SoundClass_option {A} `{SoundClass A} : SoundClass (option A). 262 | Proof. 263 | intros l e a Ee; apply sound_match_con in Ee. 264 | destruct Ee as [ Ee | Ee ]; elim_Exists Ee; cbn [fst snd] in *. 265 | - destruct Ee as [E1 E2]; subst; reflexivity. 266 | - destruct Ee as [es [Ee Ea]]. 267 | sound_field Ea. cbn. 268 | apply H1 in Ea1. 269 | rewrite Ea1; assumption. 270 | Qed. 271 | 272 | Global 273 | Instance SoundClass_sum {A B} `{SoundClass A} `{SoundClass B} : SoundClass (A + B). 274 | Proof. 275 | intros l e a Ee; apply sound_match_con in Ee. 276 | destruct Ee as [ Ee | Ee ]; elim_Exists Ee; cbn [fst snd] in *. 277 | - destruct Ee as [es [Ee Ea]]. 278 | sound_field Ea. cbn. 279 | apply sound_class in Ea1. 280 | rewrite Ea1; assumption. 281 | - destruct Ee as [es [Ee Ea]]. 282 | sound_field Ea. cbn. 283 | apply sound_class in Ea1. 284 | rewrite Ea1; assumption. 285 | Qed. 286 | 287 | Global 288 | Instance SoundClass_prod {A B} `{SoundClass A} `{SoundClass B} : SoundClass (A * B). 289 | Proof. 290 | intros l [ ea | [ | ea [ | eb [ | ] ] ] ] a; cbn; try discriminate. 291 | destruct (_from_sexp _ ea) eqn:Ea; cbn; try discriminate. 292 | destruct (_from_sexp _ eb) eqn:Eb; cbn; try discriminate. 293 | intros Eab; injection Eab; intros []. 294 | unfold to_sexp, Serialize_product; cbn. 295 | repeat f_equal; [ revert Ea | revert Eb ]; eapply sound_class. 296 | Qed. 297 | 298 | Lemma sound_class_list {A} `{SoundClass A} (es : list sexp) 299 | : forall fs xs n l a, 300 | map to_sexp (rev xs) = fs -> 301 | _sexp_to_list _from_sexp xs n l es = inr a -> to_sexp a = List (fs ++ es). 302 | Proof. 303 | induction es as [ | e es ]; cbn; intros fs xs n l a E1 E2. 304 | - apply (f_equal List). 305 | injection E2; intros []. 306 | rewrite rev_alt in E1. rewrite app_nil_r. assumption. 307 | - destruct _from_sexp as [ | a'] eqn:E3 in E2; try discriminate. 308 | apply IHes with (fs := fs ++ [e]) in E2; cbn. 309 | + rewrite app_cons_assoc; assumption. 310 | + rewrite map_app; cbn. 311 | f_equal; [ assumption | f_equal ]. 312 | eapply sound_class. eassumption. 313 | Qed. 314 | 315 | Global 316 | Instance SoundClass_list {A} `{SoundClass A} : SoundClass (list A). 317 | Proof. 318 | intros l [e | es] a; cbn; try discriminate. 319 | apply sound_class_list with (fs := []). 320 | reflexivity. 321 | Qed. 322 | 323 | Lemma complete_class_list {A} `{CompleteClass A} (a : list A) 324 | : forall (xs : list A) (n : nat) (l : loc), 325 | _sexp_to_list _from_sexp xs n l (map to_sexp a) = inr (rev xs ++ a). 326 | Proof. 327 | induction a as [ | y ys ]; intros; cbn. 328 | - rewrite rev_alt, app_nil_r; reflexivity. 329 | - rewrite complete_class. rewrite app_cons_assoc. 330 | apply IHys. 331 | Qed. 332 | 333 | Global 334 | Instance CompleteClass_list {A} `{CompleteClass A} : CompleteClass (list A). 335 | Proof. 336 | intros l a. apply complete_class_list. 337 | Qed. 338 | 339 | Global 340 | Instance CompleteClass_string : CompleteClass string. 341 | Proof. 342 | intros l a. reflexivity. 343 | Qed. 344 | 345 | Global 346 | Instance SoundClass_string : SoundClass string. 347 | Proof. 348 | intros l [ [] | ]; cbn; try discriminate. 349 | intros ? E; injection E; intros []; reflexivity. 350 | Qed. 351 | 352 | Global 353 | Instance CompleteClass_ascii : CompleteClass ascii. 354 | Proof. 355 | intros l a. reflexivity. 356 | Qed. 357 | 358 | Global 359 | Instance SoundClass_ascii : SoundClass ascii. 360 | Proof. 361 | intros l [ [ | s | ] | ]; cbn; try discriminate. 362 | destruct s as [ | ? [] ]; cbn; try discriminate. 363 | intros ? E; injection E; intros []; reflexivity. 364 | Qed. 365 | -------------------------------------------------------------------------------- /theories/CeresS.v: -------------------------------------------------------------------------------- 1 | (** * S-expressions *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | DecidableClass List ZArith Ascii String. 6 | 7 | From Ceres Require Import 8 | CeresString. 9 | 10 | Unset Elimination Schemes. 11 | (* end hide *) 12 | 13 | (** S-expressions, parameterized by the type of atoms. *) 14 | Inductive sexp_ (A : Type) := 15 | | Atom_ (a : A) 16 | | List (xs : list (sexp_ A)) 17 | . 18 | 19 | Arguments Atom_ {A} a. 20 | Arguments List {A} xs. 21 | 22 | (* Declare Scope sexp_scope. *) 23 | Delimit Scope sexp_scope with sexp. 24 | Bind Scope sexp_scope with sexp_. 25 | 26 | Notation "[ ]" := (List nil) : sexp_scope. 27 | Notation "[ x ]" := (List (@cons (sexp_ _) x nil)) : sexp_scope. 28 | Notation "[ x ; y ; .. ; z ]" 29 | := (List (@cons (sexp_ _) x (@cons (sexp_ _) y .. (@cons (sexp_ _) z nil) .. ))) 30 | : sexp_scope. 31 | 32 | (** Apply a function to every atom. *) 33 | Fixpoint map_sexp_ {A B : Type} (f : A -> B) (x : sexp_ A) : sexp_ B := 34 | match x with 35 | | Atom_ a => Atom_ (f a) 36 | | List xs => List (map (map_sexp_ f) xs) 37 | end. 38 | 39 | (** Replace every atom with an S-expression. *) 40 | Fixpoint subst_sexp_ {A B : Type} (f : A -> sexp_ B) (x : sexp_ A) : sexp_ B := 41 | match x with 42 | | Atom_ a => f a 43 | | List xs => List (map (subst_sexp_ f) xs) 44 | end. 45 | 46 | (** Construct an S-expression from a list of atoms. *) 47 | Definition sexp_of_atoms {A} (xs : list A) : sexp_ A := 48 | List (map Atom_ xs). 49 | 50 | (** * Default atoms *) 51 | 52 | (** Default type of atoms. [sexp_ atom] thus provides a uniform format to 53 | store and exchange semi-structured data. *) 54 | Variant atom : Set := 55 | | Num (n : Z) (* Integers. *) 56 | | Str (s : string) (* Literal strings. *) 57 | | Raw (s : string) (* Simple atoms (e.g., ADT tags). *) 58 | (* Should fit in this alphabet: [A-Za-z0-9-_.']. *) 59 | . 60 | 61 | Notation sexp := (sexp_ atom). 62 | Notation Atom := (@Atom_ atom). (* This notation helps make coercions work. *) 63 | 64 | (** Potential future extensions: binary strings, floating-point *) 65 | 66 | (** *** Coercions and notations *) 67 | 68 | Coercion Num : Z >-> atom. 69 | Coercion Raw : string >-> atom. 70 | 71 | (** ** Destructors *) 72 | 73 | (** This interface deliberately lacks a way to exhaustively eliminate an 74 | [atom] to enable backward compatible extensions. *) 75 | 76 | Definition get_Num (a : atom) : option Z := 77 | match a with 78 | | Num n => Some n 79 | | _ => None 80 | end. 81 | 82 | Definition get_Str (a : atom) : option string := 83 | match a with 84 | | Str s => Some s 85 | | _ => None 86 | end. 87 | 88 | Definition get_Raw (a : atom) : option string := 89 | match a with 90 | | Raw s => Some s 91 | | _ => None 92 | end. 93 | 94 | (** ** Equality *) 95 | 96 | (* The inductive type [sexp] has recursive occurences 97 | nested in [list : Type -> Type]. 98 | 99 | A common formula to define a recursive function [f_sexp] on [sexp] 100 | (here, [eqb_sexp]) is to first define a recursive function 101 | [f_list] on [list A] parameterized by a function [f] on [A], 102 | which is going to be [f_sexp] in the definition of [f_sexp]. 103 | 104 | There are some more details to be careful about in order to make 105 | the definition of [f_sexp] well-founded. In [f_list], the 106 | parameter [f] should be bound _outside_ of the [fix] 107 | expression, which only binds lists, ensuring that when the 108 | definition of [f_list] is unfolded in [f_sexp], [f] gets 109 | substituted with recursive occurences of [f_sexp]. 110 | *) 111 | 112 | Definition eqb_list {A B} (f : A -> B -> bool) 113 | : list A -> list B -> bool := 114 | fix eqb_list_ (xs : list A) (ys : list B) := 115 | match xs, ys with 116 | | nil, nil => true 117 | | x :: xs, y :: ys => (f x y && eqb_list_ xs ys)%bool 118 | | _, _ => false 119 | end. 120 | 121 | Definition eqb_sexp_ {A B} (a_eqb : A -> B -> bool) 122 | : sexp_ A -> sexp_ B -> bool := 123 | fix eqb_sexp__ (s1 : sexp_ A) (s2 : sexp_ B) : bool := 124 | match s1, s2 with 125 | | Atom_ a1, Atom_ a2 => a_eqb a1 a2 126 | | List xs1, List xs2 => eqb_list eqb_sexp__ xs1 xs2 127 | | _, _ => false 128 | end. 129 | 130 | Definition eqb_atom (x1 x2 : atom) : bool := 131 | match x1, x2 with 132 | | Raw s1, Raw s2 => eqb_string s1 s2 133 | | Str s1, Str s2 => eqb_string s1 s2 134 | | Num z1, Num z2 => Z.eqb z1 z2 135 | | _, _ => false 136 | end. 137 | 138 | Definition eqb_sexp : sexp -> sexp -> bool := 139 | eqb_sexp_ eqb_atom. 140 | 141 | Ltac magic := 142 | simpl in *; 143 | repeat 144 | match goal with 145 | | [ H : Forall _ (_ :: _) |- _ ] => inversion_clear H 146 | | [ |- andb _ _ = true ] => apply andb_true_intro 147 | | [ H : ?x :: ?xs = ?y :: ?ys |- _ ] => inversion H; clear H; subst 148 | | [ H : ?t = true |- _ ] => 149 | match t with 150 | | andb _ _ => apply andb_prop in H; destruct H 151 | | Z.eqb _ _ => apply Z.eqb_eq in H; subst 152 | | eqb_string _ _ => apply eqb_eq_string in H; subst 153 | end 154 | | [ H : _ |- _ ] => solve [ apply H; auto ] 155 | end; auto. 156 | 157 | Lemma eqb_eq_list {A} (eqb : A -> A -> bool) (xs : list A) 158 | (Heqb : Forall (fun a : A => forall b : A, eqb a b = true <-> a = b) xs) 159 | : forall (xs' : list A), eqb_list eqb xs xs' = true <-> xs = xs'. 160 | Proof with auto. 161 | induction xs; intros []; split; intros; try discriminate; 162 | magic; [ f_equal | split ]; magic. 163 | Defined. 164 | 165 | Lemma eqb_eq_atom : eqb_eq eqb_atom. 166 | Proof with auto. 167 | split; intros. 168 | - destruct a, b; try discriminate; magic. 169 | - subst; destruct b; simpl; try apply Z.eqb_refl; try apply eqb_eq_string... 170 | Defined. 171 | 172 | Global 173 | Instance Decidable_eq_atom : forall (x1 x2 : atom), Decidable (x1 = x2). 174 | Proof. 175 | exact (fun x1 x2 => 176 | {| Decidable_witness := eqb_atom x1 x2; 177 | Decidable_spec := eqb_eq_atom x1 x2 |}). 178 | Defined. 179 | 180 | Lemma forall_Forall : forall {X} (P : X -> Prop), 181 | (forall x, P x) -> forall (xs : list X), Forall P xs. 182 | Proof. intros; induction xs; auto. Defined. 183 | 184 | Lemma sexp__ind : forall (A : Type) (P : sexp_ A -> Prop), 185 | (forall a : A, P (Atom_ a)) -> 186 | (forall xs : list (sexp_ A), Forall P xs -> P (List xs)) -> 187 | forall s : sexp_ A, P s. 188 | Proof. 189 | intros A P Ha Hxs. 190 | fix self 1. 191 | intros []. 192 | - auto. 193 | - apply Hxs. 194 | apply forall_Forall. 195 | assumption. 196 | Defined. 197 | 198 | Lemma eqb_eq_sexp_ {A} {eqb_A : A -> A -> bool} 199 | (Heqb_eq : eqb_eq eqb_A) : eqb_eq (eqb_sexp_ eqb_A). 200 | Proof with auto. 201 | intro s1. 202 | induction s1; intros []; split; intro HH; try discriminate; try injection HH; intros. 203 | 1,2: try f_equal; apply Heqb_eq; auto. 204 | - f_equal; simpl in *; apply eqb_eq_list in HH... 205 | - simpl; eapply eqb_eq_list; auto. 206 | Defined. 207 | 208 | Definition eqb_eq_sexp : eqb_eq eqb_sexp := eqb_eq_sexp_ eqb_eq_atom. 209 | 210 | Global 211 | Instance Decidable_eq_sexp : forall (s1 s2 : sexp), Decidable (s1 = s2). 212 | Proof. 213 | exact (fun s1 s2 => 214 | {| Decidable_witness := eqb_sexp s1 s2; 215 | Decidable_spec := eqb_eq_sexp s1 s2 |}). 216 | Defined. 217 | 218 | (** ** Example *) 219 | Section Example. 220 | Import ListNotations. 221 | 222 | Local Open Scope string. 223 | 224 | (** This S-expression: 225 | 226 | << 227 | (example 228 | (message "I'm a teapot") 229 | (code 418)) 230 | >> 231 | 232 | corresponds to this [sexp] in Gallina: 233 | *) 234 | 235 | Let example_1 : sexp := 236 | List [ Atom "example" 237 | ; List [ Atom "message" ; Atom (Str "I'm a teapot") ] 238 | ; List [ Atom "code" ; Atom 418%Z ] 239 | ]. 240 | 241 | Local Open Scope sexp. 242 | 243 | (** Or, overloading the list notation... *) 244 | 245 | Let example_2 : sexp := 246 | [ Atom "example" 247 | ; [ Atom "message" ; Atom (Str "I'm a teapot") ] 248 | ; [ Atom "code" ; Atom 418%Z ] 249 | ]. 250 | 251 | End Example. 252 | -------------------------------------------------------------------------------- /theories/CeresSerialize.v: -------------------------------------------------------------------------------- 1 | (** * Serialization to S-expressions *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | List 6 | ZArith 7 | Ascii 8 | String. 9 | 10 | From Ceres Require Import 11 | CeresS 12 | CeresFormat 13 | CeresString. 14 | (* end hide *) 15 | 16 | (** Serialization to S-expressions. *) 17 | Class Serialize (A : Type) := 18 | to_sexp : A -> sexp. 19 | 20 | (** Serialize a value to a string. *) 21 | Definition to_string {A} `{Serialize A} : A -> string := 22 | fun a => string_of_sexp (to_sexp a). 23 | 24 | (** ** Serialize integers *) 25 | 26 | (** Integer representations. *) 27 | Class Integral (A : Type) := 28 | to_Z : A -> Z. 29 | 30 | (** Integers are serializable. *) 31 | Global 32 | Instance Serialize_Integral {A : Type} `(Integral A) : Serialize A := 33 | fun z => Atom (to_Z z). 34 | 35 | Global 36 | Instance Integral_nat : Integral nat := Z.of_nat. 37 | Global 38 | Instance Integral_N : Integral N := Z.of_N. 39 | Global 40 | Instance Integral_Z : Integral Z := id. 41 | 42 | (** ** Serialize common types *) 43 | 44 | Global 45 | Instance Serialize_bool : Serialize bool 46 | := fun b => Atom (string_of_bool b). 47 | 48 | Global 49 | Instance Serialize_option {A} `(Serialize A) : Serialize (option A) 50 | := fun oa => 51 | match oa with 52 | | None => Atom "None"%string 53 | | Some a => [ Atom "Some"%string ; to_sexp a ]%sexp 54 | end. 55 | 56 | Global 57 | Instance Serialize_sum {A B} `(Serialize A) `(Serialize B) 58 | : Serialize (A + B) 59 | := fun ab => 60 | match ab with 61 | | inl a => [ Atom "inl"%string ; to_sexp a ]%sexp 62 | | inr b => [ Atom "inr"%string ; to_sexp b ]%sexp 63 | end. 64 | 65 | Global 66 | Instance Serialize_product {A B} `(Serialize A) `(Serialize B) 67 | : Serialize (A * B) 68 | := fun ab => [ to_sexp (fst ab) ; to_sexp (snd ab) ]%sexp. 69 | 70 | Global 71 | Instance Serialize_Empty_set : Serialize Empty_set 72 | := fun v => match v with end. 73 | 74 | Global 75 | Instance Serialize_unit : Serialize unit 76 | := fun _ => Atom "tt"%string. 77 | 78 | Global 79 | Instance Serialize_ascii : Serialize ascii 80 | := fun a => Atom (Str (String a "")). 81 | 82 | Global 83 | Instance Serialize_string : Serialize string 84 | := fun s => Atom (Str s). 85 | 86 | Global 87 | Instance Serialize_list {A} `{Serialize A} : Serialize (list A) 88 | := fun xs => List (List.map to_sexp xs). 89 | 90 | Global 91 | Instance Serialize_sexp : Serialize sexp := id. 92 | -------------------------------------------------------------------------------- /theories/CeresString.v: -------------------------------------------------------------------------------- 1 | (** * String utilities *) 2 | 3 | (* begin hide *) 4 | From Coq Require Import 5 | Setoid 6 | Bool DecidableClass List Arith ZArith NArith Ascii String Decimal DecimalString. 7 | (* end hide *) 8 | 9 | (* Booleans *) 10 | 11 | Inductive reflect_eq {A} (x : A) : A -> bool -> Prop := 12 | | reflect_eq_true : reflect_eq x x true 13 | | reflect_eq_false y : x <> y -> reflect_eq x y false 14 | . 15 | 16 | (* [Bool.eqb_spec], which doesn't exist on Coq 8.8 *) 17 | Lemma eqb_eq_bool x y : reflect (x = y) (Bool.eqb x y). 18 | Proof. 19 | destruct (Bool.eqb _ _) eqn:H; 20 | constructor; [ apply eqb_prop | apply eqb_false_iff ]; auto. 21 | Defined. 22 | 23 | Lemma eqb_eq_bool' x y : reflect_eq x y (Bool.eqb x y). 24 | Proof. 25 | destruct x, y; constructor; discriminate. 26 | Qed. 27 | 28 | Definition compcomp (x y : comparison) : comparison := 29 | match x with 30 | | Eq => y 31 | | Lt => Lt 32 | | Gt => Gt 33 | end. 34 | 35 | Delimit Scope compare_scope with compare. 36 | Infix "::" := compcomp : compare_scope. 37 | 38 | Definition compb (x y : bool) : comparison := 39 | match x, y with 40 | | false, false => Eq 41 | | false, true => Lt 42 | | true, false => Gt 43 | | true, true => Eq 44 | end. 45 | 46 | (* Strings and characters *) 47 | 48 | Infix "::" := String : string_scope. 49 | 50 | Local Open Scope lazy_bool_scope. 51 | 52 | (* Backport #8063 to Coq 8.8 *) 53 | Definition eqb_ascii (a b : ascii) : bool := 54 | match a, b with 55 | | Ascii a0 a1 a2 a3 a4 a5 a6 a7, 56 | Ascii b0 b1 b2 b3 b4 b5 b6 b7 => 57 | Bool.eqb a0 b0 &&& Bool.eqb a1 b1 &&& Bool.eqb a2 b2 &&& Bool.eqb a3 b3 58 | &&& Bool.eqb a4 b4 &&& Bool.eqb a5 b5 &&& Bool.eqb a6 b6 &&& Bool.eqb a7 b7 59 | end. 60 | Arguments eqb_ascii : simpl never. 61 | 62 | (* Note: the most significant bit is on the right. *) 63 | Definition ascii_compare (a b : ascii) : comparison := 64 | match a, b with 65 | | Ascii a0 a1 a2 a3 a4 a5 a6 a7, 66 | Ascii b0 b1 b2 b3 b4 b5 b6 b7 => 67 | ( compb a7 b7 :: compb a6 b6 :: compb a5 b5 :: compb a4 b4 68 | :: compb a3 b3 :: compb a2 b2 :: compb a1 b1 :: compb a0 b0)%compare 69 | end. 70 | 71 | Definition leb_ascii (a b : ascii) : bool := 72 | match ascii_compare a b with 73 | | Gt => false 74 | | _ => true 75 | end. 76 | 77 | Delimit Scope char2_scope with char2. 78 | Infix "=?" := eqb_ascii : char2_scope. 79 | Infix "<=?" := leb_ascii : char2_scope. 80 | 81 | Definition eqb_eq {A} (eqb : A -> A -> bool) := 82 | forall a b, eqb a b = true <-> a = b. 83 | 84 | Lemma eqb_eq_ascii : eqb_eq eqb_ascii. 85 | Proof with auto. 86 | split; intros H. 87 | - destruct a, b; unfold eqb_ascii in H. 88 | do 8 ( 89 | match type of H with 90 | | context [ Bool.eqb ?x ?y ] => destruct (eqb_eq_bool x y); try discriminate; subst 91 | end)... 92 | - subst; destruct b; unfold eqb_ascii. 93 | repeat rewrite eqb_reflx... 94 | Defined. 95 | 96 | Lemma eqb_eq_ascii' c0 c1 : 97 | reflect_eq c0 c1 (c0 =? c1)%char2. 98 | Proof. 99 | destruct c0, c1; unfold eqb_ascii. 100 | repeat 101 | match goal with 102 | | [ |- context E [ Bool.eqb ?x ?y ] ] => 103 | destruct (eqb_eq_bool' x y); try (constructor; congruence) 104 | end. 105 | Qed. 106 | 107 | Lemma neqb_neq_ascii a b : eqb_ascii a b = false <-> a <> b. 108 | Proof. 109 | etransitivity. 110 | - symmetry; apply not_true_iff_false. 111 | - apply not_iff_compat, eqb_eq_ascii. 112 | Qed. 113 | 114 | Global 115 | Instance Decidable_eq_ascii : forall (a b : ascii), Decidable (a = b). 116 | Proof. 117 | exact (fun a b : ascii => 118 | {| Decidable_witness := eqb_ascii a b; 119 | Decidable_spec := eqb_eq_ascii a b |}). 120 | Defined. 121 | 122 | Ltac match_ascii := 123 | repeat 124 | match goal with 125 | | [ |- context E [ eqb_ascii ?x ?y ] ] => 126 | destruct (eqb_eq_ascii' x y) 127 | end. 128 | 129 | Fixpoint eqb_string s1 s2 : bool := 130 | match s1, s2 with 131 | | EmptyString, EmptyString => true 132 | | String c1 s1', String c2 s2' => eqb_ascii c1 c2 &&& eqb_string s1' s2' 133 | | _,_ => false 134 | end. 135 | 136 | Lemma eqb_eq_string : eqb_eq eqb_string. 137 | Proof with auto. 138 | intro s1. 139 | induction s1; intros []; split; intro H; try discriminate... 140 | - simpl in H. 141 | apply andb_prop in H. 142 | destruct H. 143 | apply eqb_eq_ascii in H. 144 | apply IHs1 in H0. 145 | f_equal... 146 | - inversion H; subst. 147 | simpl. 148 | apply andb_true_intro. 149 | split. 150 | + apply eqb_eq_ascii... 151 | + apply IHs1... 152 | Defined. 153 | 154 | Global 155 | Instance Decidable_eq_string : forall (s1 s2 : string), Decidable (s1 = s2). 156 | Proof. 157 | exact (fun s1 s2 : string => 158 | {| Decidable_witness := eqb_string s1 s2; 159 | Decidable_spec := eqb_eq_string s1 s2 |}). 160 | Defined. 161 | 162 | Fixpoint string_elem (c : ascii) (s : string) : bool := 163 | match s with 164 | | "" => false 165 | | c' :: s => eqb_ascii c c' ||| string_elem c s 166 | end%string. 167 | 168 | Fixpoint string_forall (f : ascii -> bool) (s : string) : bool := 169 | match s with 170 | | "" => true 171 | | c :: s => f c &&& string_forall f s 172 | end%string. 173 | 174 | Fixpoint _string_reverse (r s : string) : string := 175 | match s with 176 | | "" => r 177 | | c :: s => _string_reverse (c :: r) s 178 | end%string. 179 | 180 | Definition string_reverse : string -> string := _string_reverse "". 181 | 182 | Lemma string_app_nil_r (s : string) : (s ++ "")%string = s. 183 | Proof. 184 | induction s; [ auto | cbn; rewrite IHs; auto ]. 185 | Qed. 186 | 187 | Lemma not_string_elem_app c s1 s2 188 | : string_elem c s1 = false -> 189 | string_elem c s2 = false -> 190 | string_elem c (s1 ++ s2) = false. 191 | Proof. 192 | induction s1; cbn; auto. 193 | destruct (c =? a)%char2; try discriminate; auto. 194 | Qed. 195 | 196 | Lemma not_string_elem_head c c' s 197 | : string_elem c (c' :: s) = false -> c <> c'. 198 | Proof. 199 | cbn; destruct (eqb_eq_ascii' c c'); discriminate + auto. 200 | Qed. 201 | 202 | Lemma not_string_elem_singleton c c' 203 | : c <> c' -> string_elem c (c' :: "") = false. 204 | Proof. 205 | rewrite <- neqb_neq_ascii. 206 | intros H; cbn; rewrite H. 207 | reflexivity. 208 | Qed. 209 | 210 | (** Separate elements with commas. *) 211 | Fixpoint comma_sep (xs : list string) : string := 212 | match xs with 213 | | nil => "" 214 | | x :: nil => x 215 | | x :: xs => x ++ ", " ++ comma_sep xs 216 | end. 217 | 218 | Notation newline := ("010" :: "")%string. 219 | 220 | Section AsciiTest. 221 | 222 | Local Open Scope char2_scope. 223 | 224 | (** Is a character printable? The character is given by its ASCII code. *) 225 | Definition is_printable (c : ascii) : bool := 226 | ( (" " <=? c)%char2 (* 32 = SPACE *) 227 | && (c <=? "~")%char2 (* 126 = ~ *) 228 | ). 229 | 230 | Definition is_whitespace (c : ascii) : bool := 231 | match c with 232 | | " " | "010" | "013" => true 233 | | _ => false 234 | end%char. 235 | 236 | Definition is_digit (c : ascii) : bool := 237 | ("0" <=? c) &&& (c <=? "9"). 238 | 239 | Definition is_upper (c : ascii) : bool := 240 | ("A" <=? c) &&& (c <=? "Z"). 241 | 242 | Definition is_lower (c : ascii) : bool := 243 | ("a" <=? c) &&& (c <=? "z"). 244 | 245 | Definition is_alphanum (c : ascii) : bool := 246 | is_upper c ||| 247 | is_lower c ||| 248 | is_digit c. 249 | 250 | End AsciiTest. 251 | 252 | (** ** Escape string *) 253 | 254 | (** The [ascii] units digit of a [nat]. *) 255 | Local Definition _units_digit (n : nat) : ascii := 256 | ascii_of_nat ((n mod 10) + 48 (* 0 *)). 257 | 258 | (** The hundreds, tens, and units digits of a [nat]. *) 259 | Local Definition _three_digit (n : nat) : string := 260 | let n0 := _units_digit n in 261 | let n1 := _units_digit (n / 10) in 262 | let n2 := _units_digit (n / 100) in 263 | (n2 :: n1 :: n0 :: EmptyString). 264 | 265 | (** Helper for [escape_string] *) 266 | Fixpoint _escape_string (_end s : string) : string := 267 | match s with 268 | | EmptyString => _end 269 | | (c :: s')%string => 270 | let escaped_s' := _escape_string _end s' in 271 | if ("009" =? c)%char2 (* 9 = TAB *) then 272 | "\" :: "t" :: escaped_s' 273 | else if ("010" =? c)%char2 (* 10 = NEWLINE *) then 274 | "\" :: "n" :: escaped_s' 275 | else if ("013" =? c)%char2 (* 13 = CARRIAGE RETURN *) then 276 | "\" :: "r" :: escaped_s' 277 | else if ("""" =? c)%char2 (* DOUBLEQUOTE *) then 278 | "\" :: """" :: escaped_s' 279 | else if ("\" =? c)%char2 (* BACKSLASH *) then 280 | "\" :: "\" :: escaped_s' 281 | else 282 | if is_printable c then 283 | c :: escaped_s' 284 | else 285 | let n := nat_of_ascii c in 286 | "\" :: _three_digit n ++ escaped_s' 287 | end. 288 | 289 | (** Escape a string so it can be shown in a terminal. *) 290 | Definition escape_string (s : string) : string := 291 | String """" (_escape_string """" s). 292 | 293 | (** ** Unescape string *) 294 | 295 | (** Read an [ascii] digit into a [nat]. *) 296 | Definition digit_of_ascii (c : ascii) : option nat := 297 | let n := nat_of_ascii c in 298 | if ((48 <=? n)%nat && (n <=? 57)%nat)%bool then 299 | Some (n - 48) 300 | else 301 | None. 302 | 303 | (** The inverse of [three digit]. *) 304 | Local Definition _unthree_digit (c2 c1 c0 : ascii) : option ascii := 305 | let doa := digit_of_ascii in 306 | match doa c2, doa c1, doa c0 with 307 | | Some n2, Some n1, Some n0 => 308 | Some (ascii_of_nat (n2 * 100 + n1 * 10 + n0)) 309 | | _, _, _ => None 310 | end. 311 | 312 | (** Helper for [unescape_string]. *) 313 | Local Fixpoint _unescape_string (s : string) : option string := 314 | match s with 315 | | String c s' => 316 | if ascii_dec c """" then 317 | match s' with 318 | | EmptyString => Some EmptyString 319 | | _ => None 320 | end 321 | else if ascii_dec c "\" then 322 | match s' with 323 | | String c2 s'' => 324 | if ascii_dec c2 "n" then 325 | option_map (String "010") (_unescape_string s'') 326 | else if ascii_dec c2 "r" then 327 | option_map (String "013") (_unescape_string s'') 328 | else if ascii_dec c2 "t" then 329 | option_map (String "009") (_unescape_string s'') 330 | else if ascii_dec c2 "\" then 331 | option_map (String "\") (_unescape_string s'') 332 | else if ascii_dec c2 """" then 333 | option_map (String """") (_unescape_string s'') 334 | else 335 | match s'' with 336 | | String c1 (String c0 s''') => 337 | match _unthree_digit c2 c1 c0 with 338 | | Some c' => option_map (String c') 339 | (_unescape_string s''') 340 | | None => None 341 | end 342 | | _ => None 343 | end 344 | | _ => None 345 | end 346 | else 347 | option_map (String c) (_unescape_string s') 348 | | _ => None 349 | end. 350 | 351 | (** The inverse of [escape_string]. *) 352 | Definition unescape_string (s : string) : option string := 353 | match s with 354 | | ("""" :: s')%string => _unescape_string s' 355 | | (_ :: _)%string => None 356 | | EmptyString => None 357 | end. 358 | 359 | (** ** Convert numbers to string *) 360 | 361 | Import NilEmpty. 362 | 363 | Definition string_of_nat (n : nat) : string := 364 | string_of_uint (Nat.to_uint n). 365 | 366 | Definition string_of_Z (n : Z) : string := 367 | string_of_int (Z.to_int n). 368 | 369 | Definition string_of_N (n : N) : string := 370 | string_of_Z (Z.of_N n). 371 | 372 | Definition string_of_bool (b : bool) : string := 373 | match b with 374 | | true => "true" 375 | | false => "false" 376 | end. 377 | 378 | Module DString. 379 | 380 | (** Difference lists for fast append. *) 381 | Definition t : Type := string -> string. 382 | 383 | Definition of_string (s : string) : t := fun s' => (s ++ s')%string. 384 | Definition of_ascii (c : ascii) : t := fun s => (c :: s)%string. 385 | Definition app_string : t -> string -> string := id. 386 | 387 | End DString. 388 | 389 | Coercion DString.of_string : string >-> DString.t. 390 | Coercion DString.of_ascii : ascii >-> DString.t. 391 | 392 | (* Declare Scope dstring_scope. *) 393 | Delimit Scope dstring_scope with dstring. 394 | Bind Scope dstring_scope with DString.t. 395 | Notation "a ++ b" := (fun s => DString.app_string a (DString.app_string b s)) 396 | : dstring_scope. 397 | 398 | -------------------------------------------------------------------------------- /theories/CeresUtils.v: -------------------------------------------------------------------------------- 1 | (* begin hide *) 2 | From Coq Require Import 3 | List. 4 | Import ListNotations. 5 | (* end hide *) 6 | 7 | (** * Functions *) 8 | 9 | Definition map_sum {A B B' : Type} (f : B -> B') (x : A + B) : A + B' := 10 | match x with 11 | | inl a => inl a 12 | | inr b => inr (f b) 13 | end. 14 | 15 | (** Find an element by key in an association list. *) 16 | Fixpoint _find_or {A B C} (eqb : A -> A -> bool) (a : A) (xs : list (A * B)) (f : B -> C) (b : C) : C := 17 | match xs with 18 | | nil => b 19 | | (x, y) :: xs => if eqb a x then f y else _find_or eqb a xs f b 20 | end. 21 | 22 | (** The bind of the [sum A] monad. *) 23 | Definition _bind_sum {A B C} (x : A + B) (f : B -> A + C) : A + C := 24 | match x with 25 | | inl a => inl a 26 | | inr b => f b 27 | end. 28 | 29 | (** * Lemmas *) 30 | 31 | Lemma app_cons_assoc {A} (xs : list A) (x : A) (ys : list A) 32 | : xs ++ x :: ys = (xs ++ [x]) ++ ys. 33 | Proof. 34 | rewrite <- app_assoc; reflexivity. 35 | Qed. 36 | -------------------------------------------------------------------------------- /theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Ceres) 3 | (package coq-ceres) 4 | (synopsis "Library for serialization to S-expressions")) 5 | -------------------------------------------------------------------------------- /tutorial/Tutorial.v: -------------------------------------------------------------------------------- 1 | (** * Ceres library tutorial *) 2 | 3 | (** {{https://github.com/Lysxia/coq-ceres/tree/master/tutorial/Tutorial.v} Source of this file} *) 4 | 5 | From Coq Require Import List ZArith String. 6 | From Ceres Require Import Ceres. 7 | 8 | Import ListNotations. 9 | Local Open Scope string_scope. 10 | 11 | (** ** Introduction *) 12 | 13 | (** Ceres is a library for serializing Coq data types, 14 | so they can be stored or displayed outside of Coq's interactive 15 | environment (for example, in an extracted program). 16 | 17 | Ceres manipulates S-expressions ("LISP notation"), a generic format with: 18 | 19 | - a common human-readable string representation, 20 | - a tree structure which makes it easy to map to user-defined Coq types. 21 | 22 | Thus the library consists of two components mediating between these 23 | data representations: 24 | 25 | << 26 | Strings 27 | ↕ (1) Parser/printer 28 | S-expressions 29 | ↕ (2) Serialization 30 | Your data types 31 | >> 32 | *) 33 | 34 | (** ** S-expressions *) 35 | 36 | (** *** Types and constructors *) 37 | 38 | (** S-expressions have type [sexp], with two constructors, [Atom] and [List]. 39 | So S-expressions are trees of atoms. 40 | *) 41 | 42 | Check (sexp : Set). 43 | 44 | Check (Atom : atom -> sexp). 45 | Check (List : list sexp -> sexp). 46 | 47 | (** Note: The actual definition of [sexp] is a little fancier than a plain 48 | inductive type, but don't pay too much attention to that. *) 49 | 50 | (** Here is an example of an S-expression in its concrete syntax: 51 | 52 | << 53 | (example 54 | (message "I'm a teapot") 55 | (code 418)) 56 | >> 57 | *) 58 | 59 | (** Atoms are numbers ([Num]), strings ([Str]), and "raw identifiers" ([Raw]). *) 60 | 61 | (** Numbers are integers (they may be negative). *) 62 | Check (Num : Z -> atom). 63 | 64 | (** Strings are arbitrary values of type [string]. 65 | Their concrete syntax is between double quotes, possibly containing escape sequences 66 | (e.g., <<"\\">>, <<"\n">>, <<"\010">>). 67 | 68 | Use strings to embed actual strings from your data types, or to embed other 69 | arbitrary syntax (e.g., dates, fractional numbers, hex, binary). *) 70 | Check (Str : string -> atom). 71 | 72 | (** Raw identifiers correspond to unquoted strings in the concrete syntax of S-expressions. 73 | Raw identifiers also have type [string], but they must consist only of 74 | characters in the set <<[A-Za-z0-9'=+*/:!?@#$%^&<>.,|_~-]>>. 75 | 76 | For the purpose of encoding Coq inductive types, their constructor names 77 | can be encoded as [Raw] atoms. *) 78 | Check (Raw : string -> atom). 79 | 80 | (** Note: [Raw] is a coercion, but [Str] is not (that would be ambiguous otherwise). 81 | Thus a [string] can be put anywhere an [atom] is expected. *) 82 | 83 | Check (Raw "example" = "example")%string. 84 | 85 | (** *** Examples *) 86 | 87 | Definition example1 : sexp := 88 | List [ Atom (Raw "example") 89 | ; List [ Atom (Raw "message") ; Atom (Str "I'm a teapot") ] 90 | ; List [ Atom (Raw "code") ; Atom 418%Z ] 91 | ]. 92 | 93 | (** The list notation is also overloaded to implicitly add the [List] constructor: 94 | [[ 95 | Notation "[ ]" := (List nil) : sexp_scope. 96 | Notation "[ x ]" := (List (@cons (sexp_ _) x nil)) : sexp_scope. 97 | Notation "[ x ; y ; .. ; z ]" 98 | := (List (@cons (sexp_ _) x (@cons (sexp_ _) y .. (@cons (sexp_ _) z nil) .. ))) 99 | : sexp_scope. 100 | ]] 101 | 102 | Remember to open [sexp_scope]: 103 | - with the command <> 104 | - or with the key <<%sexp>>. 105 | 106 | Also open [string_scope] to benefit from the [Raw] coercion. 107 | *) 108 | 109 | Definition example2 : sexp := 110 | [ Atom "example" 111 | ; [ Atom "message" ; Atom (Str "I'm a teapot") ] 112 | ; [ Atom "code" ; Atom 418%Z ] 113 | ]%sexp. 114 | 115 | (** ** String conversions *) 116 | 117 | Check (parse_sexp : string -> CeresParserUtils.error + sexp). 118 | Check (parse_sexps : string -> CeresParserUtils.error + list sexp). 119 | Check (string_of_sexp : sexp -> string). 120 | 121 | (** The function [parse_sexp] (resp. [parse_sexps]) reads a [string] intro 122 | a single [sexp] (resp. a list of [sexp]). An error is returned if the string 123 | is not well-formed. *) 124 | 125 | (** The function [string_of_sexp] converts a [sexp] into a [string]. *) 126 | 127 | (** ** Serialization of data types *) 128 | 129 | (** Example inductive type: *) 130 | Inductive t : Set := 131 | | Number : nat -> t 132 | | Bool : bool -> t 133 | | If : t -> t -> t -> t 134 | | Plus : t -> t -> t 135 | . 136 | 137 | (** We define a [Serialize] and [Deserialize] instance to convert it to and 138 | from S-expressions. *) 139 | 140 | (** *** Serialize *) 141 | 142 | (** An instance [Serialize t] is a function [t -> sexp]. *) 143 | Check (eq_refl : Serialize t = (t -> sexp)). 144 | 145 | (** Since [t] is recursive, this function will be defined using [fix]. *) 146 | 147 | Global 148 | Instance Serialize_t : Serialize t := 149 | fix sz (a : t) : sexp := 150 | match a with 151 | | Number n => [ Atom "Number" ; to_sexp n ] 152 | | Bool b => [ Atom "Bool" ; to_sexp b ] 153 | | If x y z => [ Atom "If" ; sz x ; sz y ; sz z ] 154 | | Plus x y => [ Atom "Plus" ; sz x ; sz y ] 155 | end%sexp. 156 | 157 | (** Having defined a [Serialize] instance, the [to_sexp] function becomes available 158 | for that type: *) 159 | Check (to_sexp : t -> sexp). 160 | 161 | (** A [Serialize] instance can be any function [t -> sexp], but for uniformity, 162 | and to benefit from library combinators for deserialization, it is recommended 163 | to stick to the following encoding. 164 | 165 | A constructor [C x y z] as a list <<(C x y z)>>, i.e., 166 | [List [ Atom "C" ; to_sexp x ; to_sexp y ; to_sexp z ]] in Gallina, 167 | such that the first element is the name of the constructor as an atom, and the 168 | subsequent elements are the fields of the constructor. 169 | *) 170 | 171 | 172 | (** *** Deserialize *) 173 | 174 | (** For deserialization, the helper [Deser.match_con] quickly provides 175 | an implementation to decode the encoding described above. *) 176 | 177 | (** An instance [Deserialize t] is a function [loc -> sexp -> error + t]. *) 178 | Check (eq_refl : Deserialize t = (loc -> sexp -> error + t)). 179 | 180 | (** The fact that these are functions is mostly hidden by the helpers, except 181 | for recursive types where you have to build a fixpoint and explicitly pass the 182 | two arguments to [Deser.match_con]. *) 183 | 184 | Global 185 | Instance Deserialize_t : Deserialize t := 186 | fix ds (l : loc) (e : sexp) : error + t := 187 | Deser.match_con "t" [] 188 | [ ("Number", Deser.con1_ Number) 189 | ; ("Bool", Deser.con1_ Bool) 190 | ; ("If", Deser.con3 If ds ds ds) 191 | ; ("Plus", Deser.con2 Plus ds ds) 192 | ] l e. 193 | 194 | (** Having defined a [Deserialize] instance, the [from_sexp] function becomes available 195 | for that type: *) 196 | Check (from_sexp : sexp -> error + t). 197 | 198 | (** To explain [Deser.match_con] in more details, it takes three main arguments: 199 | - the name of the type, as a string, for error messages 200 | - a list of cases for nullary constructors of [t] paired with their names ([list (string * t)]) 201 | - a list of cases for non-nullary constructors, also with their names, 202 | wrapped using one of the following combinators depending on its arity: 203 | [Deser.con1], [Deser.con2], [Deser.con3], etc. 204 | 205 | The functions [Deser.con1], etc., take the constructor plus one more argument 206 | per field, which is a deserializer for that field. 207 | 208 | - Use the [_from_sexp] deserializer for fields whose type is already an instance of [Deserialize]; 209 | the variants [Deser.con1_], [Deser.con2_], etc., suffixed by an underscore, 210 | can be used to supply [_from_sexp] to all fields. 211 | - Use the fixpoint for recursive fields. 212 | *) 213 | -------------------------------------------------------------------------------- /tutorial/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Ceres.Tutorial) 3 | (theories Ceres)) 4 | --------------------------------------------------------------------------------