├── .git-blame-ignore-revs ├── .github └── workflows │ ├── PR.yml │ ├── master.yml │ └── master52.yml ├── .gitignore ├── .ocamlinit ├── .ocamlinit-camlp5 ├── CHANGES ├── COPYING ├── GT-bench.opam ├── GT.opam ├── META.GT-p5.template ├── META.GT.template ├── Makefile ├── README.md ├── bench ├── .ocamlformat ├── bench1.ml ├── bench2.ml └── dune ├── camlp5 ├── Camlp5Helpers.ml ├── core2.ml ├── dune ├── extension.ml ├── pp5gt.ml └── style.css ├── common ├── .ocamlformat ├── GTHELPERS_sig.ml ├── HelpersBase.ml ├── common_stubs.c ├── dune ├── expander.ml ├── expander.mli ├── naming.ml ├── plugin.ml └── plugin_intf.ml ├── config ├── discover.ml ├── dune └── tests.dune.tpl ├── doc ├── Makefile ├── conf.py └── index.rst ├── dune ├── dune-project ├── index.mld ├── mymetaquot ├── lifters.ml ├── my_metaquot.ml ├── mymetaquot.mllib └── pp_mymetaquot.ml ├── note ├── murec.ml ├── polyvar.ml └── regular.ml ├── papers ├── .gitignore ├── EPTCS │ ├── .gitignore │ ├── Makefile │ ├── breakurl.sty │ ├── conclusion.tex │ ├── eptcs.bst │ ├── eptcs.cls │ ├── examples.tex │ ├── exposition.tex │ ├── impl.tex │ ├── intro.tex │ ├── main.bib │ ├── main.tex │ ├── related.tex │ ├── sybdemo │ │ ├── .gitignore │ │ ├── Setup.hs │ │ ├── app │ │ │ ├── Length.hs │ │ │ └── Main.hs │ │ ├── package.yaml │ │ ├── stack.yaml │ │ └── sybdemo.cabal │ └── visitors-demo │ │ ├── Makefile │ │ └── test005.ml ├── FLOPS2020 │ ├── .gitignore │ ├── GT-main.bib │ ├── GT.tex │ ├── Makefile │ ├── breakurl.sty │ ├── conclusion.tex │ ├── examples.tex │ ├── exposition.tex │ ├── impl.tex │ ├── intro.tex │ ├── llncs.cls │ ├── related.tex │ └── splncs04.bst └── OCAML-2018 │ ├── .gitignore │ ├── Makefile │ ├── arith.ml │ ├── decoration.ml │ ├── eval.ml │ ├── main.tex │ └── names.ml ├── plugins ├── .ocamlformat ├── compare.ml ├── dune ├── eq.ml ├── eval.ml ├── foldl.ml ├── foldr.ml ├── genum.ml ├── gfmt.ml ├── ghash.ml ├── gmap.ml ├── html.ml ├── htmlTy.ml ├── show.ml ├── show_typed.ml └── stateful.ml ├── ppx ├── .ocamlformat ├── PpxHelpers.ml ├── dune ├── pp_gt.ml ├── pp_gt_all.ml ├── ppx_all.ml └── ppx_deriving_gt.ml ├── regression ├── .gitignore ├── .ocamlformat ├── README.md ├── dune ├── dune.tests ├── html_tyxml_api.ml ├── orig │ └── test036.log ├── show_typed_api.ml ├── test000.ml ├── test000.mli ├── test000.t ├── test001.ml ├── test001.mli ├── test001.t ├── test002.ml ├── test002.mli ├── test002.t ├── test003.ml ├── test003.mli ├── test003.t ├── test004.ml ├── test004.mli ├── test004.t ├── test005.ml ├── test005.mli ├── test005.t ├── test006.ml ├── test006.mli ├── test006.t ├── test007.ml ├── test007.mli ├── test007.t ├── test008.ml ├── test008.mli ├── test008.t ├── test009.ml ├── test009.mli ├── test009.t ├── test010.ml ├── test010.mli ├── test010.t ├── test011.ml ├── test011.t ├── test012.ml ├── test012.mli ├── test012.t ├── test013.ml ├── test013.mli ├── test013.t ├── test014.ml ├── test014.mli ├── test014.t ├── test015.ml ├── test015.mli ├── test015.t ├── test016.ml ├── test016.mli ├── test016.t ├── test017.ml ├── test017.mli ├── test017.t ├── test018.ml ├── test018.mli ├── test018.t ├── test019.ml ├── test019.mli ├── test019.t ├── test020.ml ├── test020.mli ├── test020.t ├── test021.ml ├── test021.mli ├── test021.t ├── test022.ml ├── test022.mli ├── test022.t ├── test023.ml ├── test023.mli ├── test023.t ├── test024.ml ├── test024.mli ├── test024.t ├── test025.ml ├── test025.mli ├── test025.t ├── test026.ml ├── test026.mli ├── test026.t ├── test027.ml ├── test027.mli ├── test027.t ├── test028.ml ├── test028.mli ├── test028.t ├── test029.ml ├── test029.mli ├── test029.t ├── test030.ml ├── test030.mli ├── test030.t ├── test031.ml ├── test031.mli ├── test031.t ├── test032.ml ├── test032.mli ├── test032.t ├── test036.ml ├── test036.mli ├── test036.t ├── test037.ml ├── test037.mli ├── test037.t ├── test040.ml ├── test040.t ├── test041.ml ├── test041.t ├── test042.ml ├── test042.t ├── test081.t ├── test081llist.ml ├── test082.t ├── test082mutal.ml ├── test083.t ├── test083polyvar.ml ├── test084.ml ├── test084.t ├── test086.t ├── test086std.ml ├── test087.t ├── test087stateful.ml ├── test089.t ├── test089struct.ml ├── test090.t ├── test090eval.ml ├── test091.t ├── test091eval.ml ├── test705.ml ├── test705.t ├── test791showT.ml ├── test795intoption.ml ├── test798.t ├── test798gen.ml ├── test799.ml ├── test800.ml ├── test800.t ├── test801mutal.ml ├── test802.t ├── test802mutal.ml ├── test803.t ├── test803polyvar.ml ├── test804.t ├── test804polyvar.ml ├── test805.t ├── test805std.ml ├── test806.t ├── test806fmt.ml ├── test807.t ├── test807showT.ml ├── test808ext.ml ├── test809cool.ml ├── test810cool.ml ├── test811.t ├── test811compare.ml ├── test812.t ├── test812html.ml ├── test813.t ├── test813htmlTy.ml ├── test814nonreg.ml ├── test815.t ├── test815abstr.ml ├── test816.t ├── test816hash.ml ├── test817.t ├── test817logic.ml ├── test818.t ├── test818complex.ml ├── test820.t ├── test820spec.ml ├── test821.t ├── test821clab.ml ├── test822.ml ├── test822.t ├── test823.t ├── test823list.ml ├── test824.t ├── test824mut.ml ├── test825.t ├── test825tuples.ml ├── test826.t ├── test826antiph.ml ├── test827.ml ├── test827.t ├── test827_2.t ├── test827mut.ml ├── test828.t ├── test828combi.ml ├── test828mut.ml ├── test829.t ├── test829enum.ml ├── test830.t ├── test830mut.ml ├── test830pp.t ├── test840.t └── test840garrique.ml ├── regression_ppx ├── .gitignore ├── test001.ml ├── test029.ml ├── test037.ml ├── test089struct.ml ├── test801.ml ├── test802.log ├── test805nonrec.ml ├── test807showT.ml ├── test809struct.ml └── test810lists.ml ├── sample ├── .gitignore ├── a.ml ├── bullet.gif ├── camlast.ml ├── camlastrun.ml ├── decoration.ml ├── dune ├── expr.ml ├── lambdas.ml ├── lists.ml ├── minus.gif ├── mktree.css ├── mktree.js ├── nameless.ml ├── old │ ├── murec.ml │ ├── sample.ml │ └── show.ml ├── plus.gif ├── pres.tex ├── tast.ml └── tastrun.ml ├── src ├── GT.ml ├── HTML.ml ├── HTML.mli ├── View.ml ├── View.mli ├── dune └── macro.m4 └── work ├── .ocamlformat ├── demo1.ml ├── demo2.ml ├── demo_mutual.ml └── dune /.git-blame-ignore-revs: -------------------------------------------------------------------------------- 1 | # Run this command to always ignore formatting commits in `git blame` 2 | # git config blame.ignoreRevsFile .git-blame-ignore-revs 3 | 4 | # reformat with ocamformat.0.24.1 5 | c8b30c836f241b02c2ad002585521659cea8bf3f 6 | -------------------------------------------------------------------------------- /.github/workflows/PR.yml: -------------------------------------------------------------------------------- 1 | name: Build PR 2 | 3 | on: 4 | pull_request: 5 | paths-ignore: 6 | - 'README.md' 7 | branches: 8 | - 'master' 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - ubuntu-20.04 17 | ocaml-version: 18 | - 4.10.1 19 | 20 | runs-on: ${{ matrix.os }} 21 | 22 | steps: 23 | - name: Checkout code 24 | uses: actions/checkout@v2 25 | 26 | - name: Retrieve date for cache key 27 | id: cache-key 28 | run: echo "::set-output name=date::$(/bin/date -u "+%Y%m%d")" 29 | shell: bash 30 | 31 | - name: Restore opam cache 32 | id: opam-cache 33 | uses: actions/cache@v2 34 | with: 35 | path: "~/.opam" 36 | # invalidate cache daily, gets built daily using a scheduled job 37 | key: ${{ steps.cache-key.outputs.date }} 38 | 39 | - name: Use OCaml ${{ matrix.ocaml-version }} 40 | uses: avsm/setup-ocaml@v1 41 | with: 42 | ocaml-version: ${{ matrix.ocaml-version }} 43 | 44 | - run: opam pin add GT.dev . --no-action 45 | - run: opam depext GT.dev --yes --with-test 46 | - run: opam install . --deps-only --with-test 47 | - run: opam exec -- make #dune build 48 | - run: opam exec -- make test # dune runtest 49 | -------------------------------------------------------------------------------- /.github/workflows/master.yml: -------------------------------------------------------------------------------- 1 | name: Build master in docker 2 | 3 | on: 4 | # pull_request: 5 | # branches: 6 | # - 'master' 7 | push: 8 | branches: 9 | - 'master' 10 | paths-ignore: 11 | - 'README.md' 12 | 13 | env: 14 | OPAMROOT: /home/opam/.opam 15 | OPAMCONFIRMLEVEL: unsafe-yes 16 | GT_WITH_DOCS: yes 17 | 18 | jobs: 19 | build: 20 | strategy: 21 | fail-fast: false 22 | matrix: 23 | os: 24 | - ubuntu-latest 25 | concurrency: 26 | group: ${{ github.workflow }}-${{ github.ref }} 27 | cancel-in-progress: true 28 | runs-on: ${{ matrix.os }} 29 | container: 30 | image: ocaml/opam:ubuntu-lts-ocaml-4.14 31 | options: --user root # Kind of important dirty hack 32 | #options: --user opam # dirty hack 33 | 34 | steps: 35 | - name: Checkout code 36 | uses: actions/checkout@v4 37 | with: 38 | fetch-depth: 1 39 | 40 | - run: | 41 | sudo apt-get update 42 | sudo apt-get install pkg-config libpcre2-dev m4 -y 43 | - run: opam --version 44 | 45 | - name: bisect many not work without it 46 | run: | 47 | git config --global --add safe.directory /__w/GT/GT 48 | #git submodule update --init 49 | 50 | 51 | - name: Install dependecies for documentation 52 | run: | 53 | sudo apt-get install pkg-config libpcre2-dev -y 54 | 55 | - run: opam install . --deps-only --with-test --with-doc 56 | - run: opam exec -- dune build @check --profile=release 57 | - run: opam exec -- dune test --profile=release 58 | 59 | - name: Send coverage report to Coveralls 60 | run: | 61 | opam exec -- make coverage 62 | opam exec -- bisect-ppx-report send-to Coveralls --coverage-path $BISECT_DIR 63 | env: 64 | BISECT_DIR: /tmp/GTcov 65 | COVERALLS_REPO_TOKEN: ${{ secrets.GITHUB_TOKEN }} 66 | PULL_REQUEST_NUMBER: ${{ github.event.number }} 67 | 68 | - name: Installing using Opam 69 | run: | 70 | opam exec -- dune build @install 71 | opam exec -- dune install 72 | 73 | - name: Deploy documentation 74 | #if: ${{ github.event.pull_request.head.repo.full_name == 'PLTools/OCanren' }} 75 | if: false 76 | uses: peaceiris/actions-gh-pages@v3 77 | with: 78 | github_token: ${{ secrets.GITHUB_TOKEN }} 79 | publish_dir: ./_build/default/_doc/_html 80 | 81 | - name: Build API documentation 82 | if: github.event_name != 'pull_request' 83 | run: | 84 | opam exec -- make install odig 85 | echo "ODIG_DOC_LOC=$(opam exec -- odig cache path)/html" >> $GITHUB_ENV 86 | 87 | - name: Deploy documentation 88 | #if: ${{ github.event.pull_request.head.repo.full_name == 'PLTools/GT' }} 89 | #if: false 90 | uses: peaceiris/actions-gh-pages@v3 91 | with: 92 | github_token: ${{ secrets.GITHUB_TOKEN }} 93 | publish_dir: ${{ env.ODIG_DOC_LOC }} 94 | 95 | - name: List files 96 | run: opam show --list-files GT 97 | -------------------------------------------------------------------------------- /.github/workflows/master52.yml: -------------------------------------------------------------------------------- 1 | name: Build master in docker (OCaml 5.2) 2 | 3 | on: 4 | push: 5 | branches: 6 | - 'master' 7 | paths-ignore: 8 | - 'README.md' 9 | 10 | env: 11 | OPAMROOT: /home/opam/.opam 12 | OPAMCONFIRMLEVEL: unsafe-yes 13 | GT_WITH_DOCS: yes 14 | 15 | jobs: 16 | build: 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | os: 21 | - ubuntu-latest 22 | concurrency: 23 | group: ${{ github.workflow }}-${{ github.ref }} 24 | cancel-in-progress: true 25 | 26 | runs-on: ${{ matrix.os }} 27 | container: 28 | image: ocaml/opam:ubuntu-lts-ocaml-5.2 29 | options: --user root # Kind of important dirty hack 30 | #options: --user opam # dirty hack 31 | 32 | steps: 33 | - name: Checkout code 34 | uses: actions/checkout@v4 35 | with: 36 | fetch-depth: 1 37 | 38 | - run: | 39 | sudo apt-get update 40 | sudo apt-get install pkg-config libpcre2-dev m4 -y 41 | - run: opam --version 42 | 43 | - name: bisect many not work without it 44 | if: false #we will not run coverage in 5.2 45 | run: | 46 | git config --global --add safe.directory /__w/GT/GT 47 | #git submodule update --init 48 | 49 | 50 | - name: Install dependecies for documentation 51 | run: | 52 | sudo apt-get install pkg-config libpcre2-dev -y 53 | 54 | - run: opam install . --deps-only --with-test --with-doc 55 | - run: opam exec -- dune build @check --profile=release 56 | - run: opam exec -- dune test --profile=release 57 | 58 | - name: Installing using Opam 59 | run: | 60 | opam exec -- dune build @install 61 | opam exec -- dune install 62 | 63 | - name: List files 64 | run: opam show --list-files GT 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | \ *undo-tree* 2 | /node_modules 3 | _build 4 | *.native 5 | *.byte 6 | Makefile 7 | # documentation directory 8 | /GT.docdir 9 | /_esy 10 | /.vscode 11 | .merlin 12 | 13 | /qtc-gt.* 14 | /qtc-GT.* 15 | 16 | *.install 17 | _coverage 18 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #rectypes;; 3 | #require "GT";; 4 | (* 5 | #require "GT.ppx";; 6 | *) 7 | #require "GT.ppx_all";; 8 | #require "GT.syntax.show";; 9 | -------------------------------------------------------------------------------- /.ocamlinit-camlp5: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #rectypes;; 3 | #require "GT";; 4 | 5 | #use "topfind.camlp5" 6 | #camlp5o;; 7 | #require "GT-p5,GT.syntax.all";; 8 | #load "pa_gt.cma";; 9 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | ## Ureleased 2 | 3 | ## Changed 4 | 5 | * Fix issue 32: using polyvariants as type arguments crashed for Camlp5 6 | * Allow both 'options' and 'plugins' in the signatures 7 | 8 | ## 0.5.3 (2024-07-30) 9 | 10 | ## Changed 11 | 12 | * It compiles for OCaml 4.14 or 5.2 13 | * Upper bound for ppxlib is <= 0.32.1 14 | * Minor fixes 15 | 16 | 17 | ## 0.5.2 (2023-06-16) 18 | 19 | ## Changed 20 | 21 | - Upgrade support of mutually recursive abbreviations (in presence of -rectypes). Previously some code would not compile (breaking) 22 | - Mutually recursive fixpoint on N typs is now called 'fix_typ1_typ2_..._typN' instead of 'fix_typ1' (breaking) 23 | - Add forgotten `html` plugin to `GT.ppx_all` findlib package 24 | - Replace dependecy on base by a dependecy on Ppxlib.stdppx 25 | - Support both `[@@deriving gt ~options:{...}]` and `[@@deriving gt ~plugins:{...}]` 26 | - Better pretty-printing of zero-argument constructors 27 | - Relax upper constraint on PPXlib to be <= 0.28 28 | 29 | 30 | ## 0.5.1 (2022-04-27) 31 | 32 | ## Changed 33 | 34 | - Upgrade to ppxlib <= 0.26 and OCaml 4.14 35 | 36 | ## 0.5.0 (2022-02-11) 37 | 38 | ## 0.4.2 (2021-08-09) 39 | 40 | ### Changed 41 | 42 | - Add PPX rewriter GT.ppx_all that incapsulated all available plugins 43 | - Generated code has less warnings 44 | 45 | ## 0.4.1 (2021-02-19) 46 | -------------------------------------------------------------------------------- /GT-bench.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Some benchmarks. Should not be installed" 5 | maintainer: ["Kakadu@pm.me"] 6 | authors: ["Dmitrii Kosarev a.k.a. Kakadu"] 7 | license: "LGPL-2.1-or-later" 8 | homepage: "https://github.com/PLTools/GT" 9 | bug-reports: "https://github.com/PLTools/GT/issues" 10 | depends: [ 11 | "dune" {>= "3.16"} 12 | "benchmark" {< "1.7"} 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/PLTools/GT.git" 30 | -------------------------------------------------------------------------------- /GT.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.5.3" 4 | synopsis: "Generic programming with extensible transformations" 5 | description: """ 6 | Yet another library for generic programming. Provides syntax extensions 7 | both for camlp5 and PPX which allow decoration of type declarations with 8 | following compile-time code generation. Provides the way for creating 9 | plugins (compiled separately from the library) for enchancing supported 10 | type transformations. 11 | 12 | Strongly reminds the `visitors` library from François Pottier. 13 | During desing of a library of these kind there many possible 14 | design decision and in many cases we decided to implement 15 | the decision opposite to the one used in `visitors`. 16 | 17 | 18 | P.S. Since 2023 development team is no longer associated with JetBrains Research""" 19 | maintainer: ["Kakadu@pm.me"] 20 | authors: ["https://github.com/dboulytchev" "https://github.com/Kakadu"] 21 | license: "LGPL-2.1-or-later" 22 | homepage: "https://github.com/PLTools/GT" 23 | bug-reports: "https://github.com/PLTools/GT/issues" 24 | depends: [ 25 | "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & < "5.3.0"} 26 | "dune" {>= "3.16" & >= "3.16"} 27 | "ppxlib" {<= "0.34.0"} 28 | "camlp5" {>= "8.00.05"} 29 | "ocamlgraph" 30 | "ppx_inline_test_nobase" 31 | "ocamlfind" {build} 32 | "logger-p5" {build} 33 | "bisect_ppx" {build} 34 | "conf-m4" {build} 35 | "odoc" {with-doc} 36 | "odig" {with-doc} 37 | "pa_ppx" {with-doc} 38 | "mdx" {with-test} 39 | ] 40 | build: [ 41 | ["dune" "subst"] {dev} 42 | [ 43 | "dune" 44 | "build" 45 | "-p" 46 | name 47 | "-j" 48 | jobs 49 | "@install" 50 | "@runtest" {with-test} 51 | "@doc" {with-doc} 52 | ] 53 | ] 54 | dev-repo: "git+https://github.com/PLTools/GT.git" 55 | -------------------------------------------------------------------------------- /META.GT-p5.template: -------------------------------------------------------------------------------- 1 | # DISABLED DUNE_GEN 2 | version = "0.4.2" 3 | requires = "camlp5 GT.syntax" 4 | #archive(syntax,preprocessor) = "../GT/pa_gt.cma" 5 | #archive(syntax,preprocessor,toplevel) = "pa_gt.cma" 6 | 7 | #archive(syntax,preprocessor,camlp5) = "pa_gt.cma" 8 | #archive(syntax,preprocessor,byte) = "pa_gt.cma" 9 | #archive(syntax,preprocessor,native) = "../GT/pa_gt.cmxa" 10 | #plugin(syntax,preprocessor,byte) = "pa_gt.cma" 11 | #plugin(syntax,preprocessor,native) = "pa_gt.cmxs" 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: release discover-tests test promote clean celan doc 2 | 3 | # compiler packages without tests 4 | all: 5 | dune build $(DFLAGS) 6 | 7 | release: DFLAGS += --profile=release 8 | release: all 9 | 10 | discover-tests: 11 | echo "" > regression/dune.tests 12 | $(RM) -fr _build/default/config 13 | dune build @discover-tests 14 | cp _build/default/config/*.t regression/ 15 | 16 | doc: 17 | dune build @doc $(DFLAGS) 18 | 19 | doc-sphinx: 20 | echo TODO 21 | 22 | test: 23 | dune runtest $(DFLAGS) 24 | 25 | promote: 26 | dune promote $(DFLAGS) 27 | 28 | celan: clean 29 | clean: 30 | $(RM) -r _build _coverage 31 | 32 | rebuild: clean 33 | $(MAKE) all tests 34 | 35 | watch: 36 | $(MAKE) all DFLAGS=-w 37 | 38 | install: 39 | dune build @install $(DFLAGS) 40 | dune install $(DFLAGS) 41 | 42 | uninstall: 43 | dune build @install $(DFLAGS) 44 | dune uninstall $(DFLAGS) 45 | 46 | .PHONY: odig 47 | ODIG_SWITCHES = --odoc-theme=odig.gruvbox.light 48 | ODIG_SWITCHES += --no-tag-index 49 | ODIG_SWITCHES += --no-pkg-deps 50 | odig: 51 | dune install $(DFLAGS) GT 52 | odig odoc $(ODIG_SWITCHES) GT 53 | 54 | .PHONY: coverage 55 | TEST_COV_D ?= /tmp/GTcov 56 | coverage: 57 | if [ -d $(TEST_COV_D) ]; then $(RM) -r $(TEST_COV_D); fi 58 | mkdir -p $(TEST_COV_D) 59 | BISECT_FILE=$(TEST_COV_D)/GT dune runtest regression \ 60 | --no-print-directory \ 61 | --instrument-with bisect_ppx --force 62 | bisect-ppx-report html --coverage-path $(TEST_COV_D) #--expect src/ 63 | bisect-ppx-report summary --coverage-path $(TEST_COV_D) #--expect src/ 64 | -------------------------------------------------------------------------------- /bench/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | max-indent=2 3 | 4 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (ocamlopt_flags -S) 4 | (flags 5 | (:standard -w -9-32-33-37)))) 6 | 7 | (executable 8 | (name bench1) 9 | (modules bench1) 10 | (public_name GT-bench.bench1) 11 | (package GT-bench) 12 | (optional) 13 | (libraries benchmark)) 14 | 15 | (executable 16 | (name bench2) 17 | (modules bench2) 18 | (public_name GT-bench.bench2) 19 | (package GT-bench) 20 | (preprocess 21 | (pps GT.ppx_all)) 22 | (optional) 23 | (libraries GT benchmark)) 24 | -------------------------------------------------------------------------------- /camlp5/core2.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Generic Transformers: Camlp5 syntax extension. 3 | * Copyright (C) 2016-2021 4 | * Dmitry Boulytchev, Dmitrii Kosarev aka Kakadu 5 | * St.Petersburg State University, JetBrains Research 6 | *) 7 | 8 | open Ploc 9 | 10 | let oops loc str = Ploc.raise loc (Failure str) 11 | let get_val _loc = function 12 | | VaVal x -> x 13 | | _ -> failwith "could not get VaVal _ (should not happen)" 14 | 15 | 16 | module Migr = Ppxlib_ast.Selected_ast.Of_ocaml 17 | 18 | open GTCommon 19 | 20 | 21 | let generate_str is_nonrec tdecls loc = 22 | let info = snd @@ List.hd @@ List.rev tdecls in 23 | let module H = Expander.Make(Camlp5Helpers) in 24 | (* Expander.notify "with annotations %s" (String.concat "," info); *) 25 | let generator_f si = 26 | H.str_type_decl_many_plugins ~loc si 27 | (List.map (fun s -> (s,Expander.Use []) ) info) 28 | in 29 | let out = 30 | let sis = <:str_item< type $list:(List.map fst tdecls)$ >> in 31 | let caml_ast = Ast2pt.implem "harcoded_filename.ml" [sis] in 32 | let () = assert (List.length caml_ast = 1) in 33 | match (List.hd caml_ast).pstr_desc with 34 | | Pstr_type (_flg, tds) -> 35 | let tds = List.map Migr.copy_type_declaration tds in 36 | generator_f [sis] ((if is_nonrec then Ppxlib.Nonrecursive else Recursive), tds) 37 | | _ -> failwith "type declaration expected" 38 | in 39 | 40 | <:str_item< declare $list:out$ end >> 41 | 42 | let generate_sig is_nonrec tdecls loc = 43 | let info = snd @@ List.hd @@ List.rev tdecls in 44 | (* Expander.notify "with annotations %s" (String.concat "," info); *) 45 | let module H = Expander.Make(Camlp5Helpers) in 46 | let generator_f si = 47 | H.sig_type_decl_many_plugins ~loc si 48 | (List.map (fun s -> (s,Expander.Use []) ) info) 49 | in 50 | 51 | let out = 52 | let ts = List.map fst tdecls in 53 | let sis = <:sig_item< type $list:ts$ >> in 54 | let caml_ast = Ast2pt.interf "harcoded_filename.mli" [sis] in 55 | assert (List.length caml_ast = 1); 56 | match (List.hd caml_ast).psig_desc with 57 | | Psig_type (_flg, tds) -> 58 | let tds = List.map Migr.copy_type_declaration tds in 59 | generator_f [sis] ((if is_nonrec then Ppxlib.Nonrecursive else Recursive), tds) 60 | | _ -> assert false 61 | in 62 | 63 | <:sig_item< declare $list:out$ end >> 64 | -------------------------------------------------------------------------------- /camlp5/pp5gt.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PLTools/GT/7eda298fa0bc4e4bb96f3dcfbb20efebc38ae4af/camlp5/pp5gt.ml -------------------------------------------------------------------------------- /camlp5/style.css: -------------------------------------------------------------------------------- 1 | body { padding: 0px 20px 0px 26px; background: #ffffff; color: #000000; font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 90%; } 2 | h1 { padding : 5px 0px 5px 0px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF } 3 | h6 { padding : 5px 0px 5px 20px; font-size : 16pt; font-weight : normal; background-color : #E0E0FF } 4 | a:link, a:visited, a:active { text-decoration: none; } 5 | a:link { color: #000077; } 6 | a:visited { color: #000077; } 7 | a:hover { color: #cc9900; } 8 | .keyword { font-weight : bold ; color : Blue } 9 | .keywordsign { color : #606060 } 10 | .superscript { font-size : 4 } 11 | .subscript { font-size : 4 } 12 | .comment { color : #606060 } 13 | .constructor { color : #808080; } 14 | .type { color : #606060 } 15 | .string { color : Red } 16 | .warning { color : Red ; font-weight : bold } 17 | .info { margin-left : 3em; margin-right : 3em } 18 | .code { color : #606060 ; } 19 | .title1 { font-size : 16pt ; background-color : #E0E0E0 } 20 | .title2 { font-size : 16pt ; background-color : #E0E0E0 } 21 | .title3 { font-size : 16pt ; background-color : #E0E0E0 } 22 | .title4 { font-size : 16pt ; background-color : #E0E0E0 } 23 | .title5 { font-size : 16pt ; background-color : #E0E0E0 } 24 | .title6 { font-size : 16pt ; background-color : #E0E0E0; } -------------------------------------------------------------------------------- /common/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | max-indent=2 3 | sequence-style = terminator 4 | field-space=loose 5 | -------------------------------------------------------------------------------- /common/common_stubs.c: -------------------------------------------------------------------------------- 1 | #include "caml/mlvalues.h" 2 | #include "caml/memory.h" 3 | 4 | value caml_gt_hash_variant(value _str) { 5 | CAMLparam1(_str); 6 | CAMLlocal1(_ans); 7 | _ans = caml_hash_variant(String_val(_str)); 8 | CAMLreturn(_ans); 9 | } 10 | -------------------------------------------------------------------------------- /common/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | (:standard -w -27-32+9 -warn-error -A)))) 5 | 6 | (library 7 | (name GTCommon) 8 | (public_name GT.common) 9 | (libraries ppxlib ppxlib.stdppx ocamlgraph) 10 | (modules HelpersBase Naming Expander GTHELPERS_sig Plugin_intf Plugin) 11 | (synopsis 12 | "Actual code that perform codegeneration. Will used for creating new plugins") 13 | (flags 14 | (:standard -w -32-9 -warn-error -A)) 15 | ;(inline_tests) 16 | (instrumentation 17 | (backend bisect_ppx)) 18 | (preprocess 19 | (pps 20 | ppx_inline_test_nobase 21 | ;ppx_expect 22 | ppxlib.metaquot)) 23 | (foreign_stubs 24 | (language c) 25 | (names common_stubs))) 26 | -------------------------------------------------------------------------------- /common/expander.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Generic Transformers PPX syntax extension. 3 | * Copyright (C) 2016-2021 4 | * Dmitrii Kosarev aka Kakadu 5 | * St.Petersburg State University, JetBrains Research 6 | *) 7 | 8 | (** Expander: base module for Generic Tranformers that utilize plugins. *) 9 | 10 | open Ppxlib 11 | 12 | (** Arguments of plugin are empty *) 13 | type config_plugin = 14 | | Skip 15 | | Use of (longident * expression) list 16 | 17 | module Make : functor (Helpers : GTHELPERS_sig.S) -> sig 18 | open Helpers 19 | 20 | val str_type_decl_many_plugins 21 | : loc:loc 22 | -> Str.t list 23 | -> (string * config_plugin) list 24 | -> Ppxlib.rec_flag * Ppxlib.type_declaration list 25 | -> Str.t HelpersBase.List.t 26 | 27 | val sig_type_decl_many_plugins 28 | : loc:loc 29 | -> Sig.t list 30 | -> (string * config_plugin) list 31 | -> Ppxlib.rec_flag * Ppxlib.type_declaration list 32 | -> Sig.t HelpersBase.List.t 33 | end 34 | 35 | (** Registers a plugin. See {! Plugin_intf.PluginRes } for plugin interface. *) 36 | val register_plugin : string -> (module Plugin_intf.MAKE) -> unit 37 | 38 | val get_registered_plugins : unit -> string list 39 | val set_inline_registration : (string -> (module Plugin_intf.MAKE) -> unit) -> unit 40 | 41 | val register_ppx_inline_plugin 42 | : string 43 | -> (loc:Ppxlib.Location.t -> Ppxlib.core_type -> Ppxlib.expression) 44 | -> unit 45 | -------------------------------------------------------------------------------- /config/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | (:standard -warn-error -26)))) 5 | 6 | (executable 7 | (name discover) 8 | (modules Discover) 9 | (libraries str dune-configurator)) 10 | 11 | (rule 12 | (targets camlp5-flags.cfg) 13 | (action 14 | (run ./discover.exe -all-flags))) 15 | 16 | (rule 17 | (targets package-doc.cfg) 18 | (action 19 | (run ./discover.exe -doc-flags))) 20 | 21 | (rule 22 | (targets dune.tests) 23 | (alias discover-tests) 24 | (deps 25 | (source_tree ../regression)) 26 | (mode 27 | (promote 28 | (into ../regression))) 29 | (action 30 | (run ./discover.exe -tests -tests-dir %{project_root}/regression))) 31 | -------------------------------------------------------------------------------- /config/tests.dune.tpl: -------------------------------------------------------------------------------- 1 | (executables 2 | (names 3 | %{tests} 4 | ) 5 | (libraries GT OCanren OCanren.syntax) 6 | (preprocess 7 | (action 8 | (run camlp5 9 | %{read-lines:../config/camlp5-flags.cfg} 10 | %{read-lines:../config/gt-flags.cfg} 11 | %{read-lines:../config/logger-flags.cfg} 12 | %{workspace_root}/camlp5/pa_ocanren.cma 13 | %{input-file}) 14 | ) 15 | ) 16 | (preprocessor_deps (file %{workspace_root}/camlp5/pa_ocanren.cma)) 17 | ) 18 | 19 | 20 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all debs 2 | 3 | all: 4 | sphinx-build . _build 5 | 6 | debs: 7 | sudo apt install python3-sphinx-rtd-theme 8 | 9 | clean: 10 | $(RM) -r _build 11 | 12 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (dirs :standard \ regression_ppx work) 2 | 3 | (documentation 4 | (package GT)) 5 | 6 | (mdx 7 | (files index.mld README.md) 8 | (package GT) 9 | (libraries GT)) 10 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.16) 2 | 3 | (generate_opam_files true) 4 | 5 | (using mdx 0.3) 6 | 7 | (cram enable) 8 | 9 | (name GT) 10 | 11 | (license LGPL-2.1-or-later) 12 | 13 | (bug_reports "https://github.com/PLTools/GT/issues") 14 | 15 | (homepage "https://github.com/PLTools/GT") 16 | 17 | (source 18 | (github PLTools/GT)) 19 | 20 | (package 21 | (name GT) 22 | (synopsis "Generic programming with extensible transformations") 23 | (description 24 | "Yet another library for generic programming. Provides syntax extensions\nboth for camlp5 and PPX which allow decoration of type declarations with\nfollowing compile-time code generation. Provides the way for creating\nplugins (compiled separately from the library) for enchancing supported\ntype transformations.\n\nStrongly reminds the `visitors` library from François Pottier.\nDuring desing of a library of these kind there many possible\ndesign decision and in many cases we decided to implement\nthe decision opposite to the one used in `visitors`.\n\n\nP.S. Since 2023 development team is no longer associated with JetBrains Research") 25 | (authors "https://github.com/dboulytchev" "https://github.com/Kakadu") 26 | (maintainers "Kakadu@pm.me") 27 | (version 0.5.3) 28 | (depends 29 | (ocaml 30 | (or 31 | (and 32 | (>= "4.14") 33 | (< "5.0.0")) 34 | (and 35 | (>= "5.2.0") 36 | (< "5.3.0")))) 37 | (dune 38 | (>= "3.16")) 39 | (ppxlib 40 | (<= "0.34.0")) 41 | (camlp5 42 | (>= "8.00.05")) 43 | ocamlgraph 44 | ppx_inline_test_nobase 45 | (ocamlfind :build) 46 | (logger-p5 :build) 47 | (bisect_ppx :build) 48 | (conf-m4 :build) 49 | (odoc :with-doc) 50 | (odig :with-doc) 51 | (pa_ppx :with-doc) 52 | (mdx :with-test) 53 | ; 54 | )) 55 | 56 | (package 57 | (name GT-bench) 58 | (synopsis "Some benchmarks. Should not be installed") 59 | (version 0.1) 60 | (authors "Dmitrii Kosarev a.k.a. Kakadu") 61 | (maintainers "Kakadu@pm.me") 62 | (depends 63 | dune 64 | (benchmark 65 | (< "1.7")))) 66 | -------------------------------------------------------------------------------- /mymetaquot/lifters.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | open Ast_builder.Default 4 | 5 | let meint ~loc n = 6 | pexp_apply ~loc 7 | (Ast_builder.Default.pexp_ident ~loc 8 | (Located.mk ~loc (Ldot (Lident "Exp", "int")) ) ) 9 | 10 | [ Labelled "loc", pexp_ident ~loc (Located.mk ~loc (Lident "loc")) 11 | ; Nolabel, eint ~loc n] 12 | 13 | let meident ~loc longident = 14 | pexp_apply ~loc 15 | (Ast_builder.Default.pexp_ident ~loc 16 | (Located.mk ~loc (Ldot (Lident "Exp", "ident")) ) ) 17 | 18 | [ Labelled "loc", pexp_ident ~loc (Located.mk ~loc (Lident "loc")) 19 | ; Nolabel, pexp_ident ~loc (Located.mk ~loc longident) ] 20 | 21 | let meapply ~loc (e0) args : expression = 22 | List.fold_left args ~init:e0 23 | ~f:(fun (acc: expression) e -> 24 | pexp_apply ~loc 25 | (Ast_builder.Default.pexp_ident ~loc 26 | (Located.mk ~loc (Ldot (Lident "Exp", "apply1")) ) ) 27 | 28 | [ Labelled "loc", pexp_ident ~loc (Located.mk ~loc (Lident "loc")) 29 | ; Nolabel, (acc:expression) 30 | ; e ] 31 | 32 | ) 33 | 34 | let mpint ~loc n = 35 | pexp_apply ~loc 36 | (Ast_builder.Default.pexp_ident ~loc (Located.mk ~loc (Lident "int"))) 37 | [ Nolabel, eint ~loc n] 38 | 39 | class expression_lifters loc = object 40 | inherit [expression] Ppxlib_traverse_builtins.lift 41 | method record flds = 42 | pexp_record ~loc 43 | (List.map flds ~f:(fun (lab, e) -> 44 | ({ loc; txt = Lident lab }, e))) 45 | None 46 | method constr id args = 47 | pexp_construct ~loc { loc; txt = Lident id } 48 | (match args with 49 | | [] -> None 50 | | l -> Some (pexp_tuple ~loc l)) 51 | method tuple l = pexp_tuple ~loc l 52 | method int i = eint ~loc i 53 | method int32 i = eint32 ~loc i 54 | method int64 i = eint64 ~loc i 55 | method nativeint i = enativeint ~loc i 56 | method float f = efloat ~loc (Float.to_string f) 57 | method string s = estring ~loc s 58 | method char c = echar ~loc c 59 | method bool b = ebool ~loc b 60 | method array : 'a. ('a -> expression) -> 'a array -> expression = 61 | fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f) 62 | method unit () = eunit ~loc 63 | method other : 'a. 'a -> expression = fun _ -> failwith "not supported" 64 | end 65 | 66 | class pattern_lifters loc = object 67 | inherit [pattern] Ppxlib_traverse_builtins.lift 68 | method record flds = 69 | ppat_record ~loc 70 | (List.map flds ~f:(fun (lab, e) -> 71 | ({ loc; txt = Lident lab }, e))) 72 | Closed 73 | method constr id args = 74 | ppat_construct ~loc { loc; txt = Lident id } 75 | (match args with 76 | | [] -> None 77 | | l -> Some (ppat_tuple ~loc l)) 78 | method tuple l = ppat_tuple ~loc l 79 | method int i = pint ~loc i 80 | method int32 i = pint32 ~loc i 81 | method int64 i = pint64 ~loc i 82 | method nativeint i = pnativeint ~loc i 83 | method float f = pfloat ~loc (Float.to_string f) 84 | method string s = pstring ~loc s 85 | method char c = pchar ~loc c 86 | method bool b = pbool ~loc b 87 | method array : 'a. ('a -> pattern) -> 'a array -> pattern = 88 | fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f) 89 | method unit () = punit ~loc 90 | method other : 'a. 'a -> pattern = fun _ -> failwith "not supported" 91 | end 92 | -------------------------------------------------------------------------------- /mymetaquot/mymetaquot.mllib: -------------------------------------------------------------------------------- 1 | Lifters 2 | My_metaquot -------------------------------------------------------------------------------- /mymetaquot/pp_mymetaquot.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /note/murec.ml: -------------------------------------------------------------------------------- 1 | type m = M of int | N of n 2 | and n = K of m | L of string 3 | 4 | let xm = N (K (N (L "1"))) 5 | let xn = K xm 6 | 7 | class virtual ['i, 's] m_t = 8 | object (self) 9 | method virtual m_M : 'i -> (('i -> m -> 's) * m) -> (('i -> int -> 's) * int) -> 's 10 | method virtual m_N : 'i -> (('i -> m -> 's) * m) -> (('i -> n -> 's) * n) -> 's 11 | method virtual t_n : 'i -> n -> 's 12 | method virtual t_int : 'i -> int -> 's 13 | method virtual t_m : 'i -> m -> 's 14 | end 15 | 16 | let rec transform_m t acc x = 17 | let self = transform_m t in 18 | match x with 19 | | M y -> t#m_M acc (self, x) (t#t_int, y) 20 | | N y -> t#m_N acc (self, x) (t#t_n, y) 21 | 22 | class virtual ['i, 's] n_t = 23 | object (self) 24 | method virtual m_K : 'i -> (('i -> n -> 's) * n) -> (('i -> m -> 's) * m) -> 's 25 | method virtual m_L : 'i -> (('i -> n -> 's) * n) -> (('i -> string -> 's) * string) -> 's 26 | method virtual t_m : 'i -> m -> 's 27 | method virtual t_string : 'i -> string -> 's 28 | method virtual t_n : 'i -> n -> 's 29 | end 30 | 31 | let rec transform_n t acc x = 32 | let self = transform_n t in 33 | match x with 34 | | K y -> t#m_K acc (self, x) (t#t_m, y) 35 | | L y -> t#m_L acc (self, x) (t#t_string, y) 36 | 37 | class show_m' env = 38 | object (self) 39 | inherit [unit, string] m_t 40 | method m_M _ (_, _) (fi, i) = Printf.sprintf "M (%s)" (fi () i) 41 | method m_N _ (_, _) (fn, n) = Printf.sprintf "N (%s)" (fn () n) 42 | method t_int _ i = string_of_int i 43 | method t_n = env#t_n 44 | method t_m _ m = transform_m self () m 45 | end 46 | 47 | class show_n' env = 48 | object (self) 49 | inherit [unit, string] n_t 50 | method m_K _ (_, _) (fn, n) = Printf.sprintf "K (%s)" (fn () n) 51 | method m_L _ (_, _) (fs, s) = Printf.sprintf "L (%s)" (fs () s) 52 | method t_m = env#t_m 53 | method t_string acc s = s 54 | method t_n _ n = transform_n self () n 55 | end 56 | 57 | class show_m = 58 | object (this) 59 | val shn = ref (new show_n' (Obj.magic 0)) 60 | val shm = ref (new show_m' (Obj.magic 0)) 61 | 62 | initializer shn := new show_n' this; 63 | shm := new show_m' this 64 | 65 | method m_M = !shm#m_M 66 | method m_N = !shm#m_N 67 | method t_int = !shm#t_int 68 | method t_m = transform_m this 69 | method t_n = transform_n !shn 70 | end 71 | 72 | class show_n = 73 | object (this) 74 | val shn = ref (new show_n' (Obj.magic 0)) 75 | val shm = ref (new show_m' (Obj.magic 0)) 76 | 77 | initializer shn := new show_n' this; 78 | shm := new show_m' this 79 | 80 | method m_K = !shn#m_K 81 | method m_L = !shn#m_L 82 | method t_string = !shn#t_string 83 | method t_m = transform_m !shm 84 | method t_n = transform_n this 85 | end 86 | 87 | class show_m'' = 88 | object (this) 89 | inherit show_m 90 | method m_N _ _ (fn, n) = Printf.sprintf "NNN (%s)" (fn () n) 91 | end 92 | 93 | class show_n'' = 94 | object (this) 95 | inherit show_n 96 | method m_L _ _ (fn, n) = Printf.sprintf "LLL (%s)" (fn () n) 97 | end 98 | 99 | let _ = 100 | Printf.printf "%s\n" (transform_m (new show_m) () xm); 101 | Printf.printf "%s\n" (transform_m (new show_m'') () xm); 102 | Printf.printf "%s\n" (transform_n (new show_n) () xn); 103 | Printf.printf "%s\n" (transform_n (new show_n'') () xn) 104 | 105 | 106 | -------------------------------------------------------------------------------- /papers/.gitignore: -------------------------------------------------------------------------------- 1 | *.synctex.gz 2 | *.aux 3 | *.bbl 4 | *.blg 5 | *.pag 6 | 7 | *.pdf 8 | 9 | -------------------------------------------------------------------------------- /papers/EPTCS/.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | *.log 3 | *.out 4 | 5 | -------------------------------------------------------------------------------- /papers/EPTCS/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: main.pdf clean 2 | 3 | all: main.pdf 4 | 5 | OCANREN_TEX=main.tex intro.tex related.tex 6 | 7 | main.pdf: $(OCANREN_TEX) 8 | pdflatex $< 9 | bibtex main.aux 10 | pdflatex $< 11 | pdflatex $< 12 | 13 | clean: 14 | $(RM) *.bak *.out *.log *.pag 15 | 16 | 17 | -------------------------------------------------------------------------------- /papers/EPTCS/conclusion.tex: -------------------------------------------------------------------------------- 1 | \section{Future Work} 2 | 3 | There are a few possible directions for future work. First, in this paper we did not address the performance issues. As we represent 4 | the transformations in a very generic form with many levels of indirection, obviously, the transformations, implemented with 5 | our framework, are at disadvantage in comparison with hard coded ones in terms of performance. We assume that the performance of transformations 6 | can be essentially improved by applying some techniques like staging~\cite{Staged} or, perhaps, object-specific optimisations. 7 | 8 | Another important direction is supporting more kinds of type declarations, in the first hand, GADTs and non-regular types. Although we have some 9 | implementation ideas for this case, the solution we came up with so far makes the interface of the whole framework too cumbersome to use even for 10 | simple cases. 11 | 12 | Finally, the typeinfo structure we generate can be used to mimic the \emph{ad-hoc} polymorphism as it contains the implementation of 13 | type-indexed functions. This, together with some proposed extensions~\cite{ModularImplicits}, can open interesting perspectives. 14 | 15 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | 3 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/app/Length.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs, ExplicitForAll, DeriveDataTypeable #-} 2 | module Length 3 | (Length(..), to_miles, add) 4 | where 5 | 6 | import Data.Generics (everywhere, mkT, Data, Typeable) 7 | 8 | data Foo = Foo String Int 9 | deriving (Eq, Show, Typeable, Data) 10 | newtype Length = Length Foo 11 | deriving (Eq, Show, Typeable, Data) 12 | 13 | -- data Miles deriving (Data) 14 | -- data Kilometers 15 | 16 | 17 | to_miles :: Int -> Maybe Length 18 | to_miles x | x<0 = Nothing 19 | to_miles x = Just (Length $ Foo (show x) x) 20 | 21 | add :: Length -> Length -> Length 22 | add (Length (Foo _ x)) (Length (Foo _ y)) | (x<0) || (y<0) = undefined 23 | add (Length (Foo _ x)) (Length (Foo _ y)) = Length $ Foo (show $ x+y) (x+y) 24 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs, ExplicitForAll #-} 2 | module Main where 3 | 4 | import Length (add, to_miles) 5 | 6 | import Data.Generics (everywhere, mkT, Data, Typeable) 7 | 8 | main :: IO () 9 | main = do 10 | print l1 11 | print l2 12 | print l3 13 | print l4 14 | where 15 | l1 = to_miles 10 16 | l2 = to_miles 20 17 | l3 = l1 >>= \x -> l2 >>= \y -> Just $ add x y 18 | incrLen :: Int -> Int 19 | incrLen n = n-100 20 | l4 = everywhere (mkT incrLen) l2 21 | 22 | {- 23 | prints: 24 | 25 | Just (Length (Foo "10" 10)) 26 | Just (Length (Foo "20" 20)) 27 | Just (Length (Foo "30" 30)) 28 | Just (Length (Foo "20" (-80))) 29 | -} -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/package.yaml: -------------------------------------------------------------------------------- 1 | name: sybdemo 2 | version: 0.1.0.0 3 | github: "githubuser/sybdemo" 4 | license: BSD3 5 | author: "Author name here" 6 | maintainer: "example@example.com" 7 | copyright: "2019 Author name here" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on GitHub at 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | 25 | executables: 26 | sybdemo-exe: 27 | main: Main.hs 28 | source-dirs: app 29 | ghc-options: 30 | - -threaded 31 | - -rtsopts 32 | - -with-rtsopts=-N 33 | dependencies: 34 | - syb 35 | 36 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-13.18 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # - location: 29 | # git: https://github.com/commercialhaskell/stack.git 30 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 31 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # subdirs: 33 | # - auto-update 34 | # - wai 35 | packages: 36 | - . 37 | # Dependency packages to be pulled from upstream that are not in the resolver 38 | # using the same syntax as the packages field. 39 | # (e.g., acme-missiles-0.3) 40 | # extra-deps: [] 41 | 42 | # Override default flag values for local packages and extra-deps 43 | # flags: {} 44 | 45 | # Extra package databases containing global packages 46 | # extra-package-dbs: [] 47 | 48 | # Control whether we use the GHC we find on the path 49 | # system-ghc: true 50 | # 51 | # Require a specific version of stack, using version ranges 52 | # require-stack-version: -any # Default 53 | # require-stack-version: ">=1.9" 54 | # 55 | # Override the architecture used by stack, especially useful on Windows 56 | # arch: i386 57 | # arch: x86_64 58 | # 59 | # Extra directories used by stack for building 60 | # extra-include-dirs: [/path/to/dir] 61 | # extra-lib-dirs: [/path/to/dir] 62 | # 63 | # Allow a newer minor version of GHC than the snapshot specifies 64 | # compiler-check: newer-minor 65 | -------------------------------------------------------------------------------- /papers/EPTCS/sybdemo/sybdemo.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: fc6aa077584a6cced73c6b3767b20e8d94dba51fc3d0677bc4f26f0a7dbdb2ac 8 | 9 | name: sybdemo 10 | version: 0.1.0.0 11 | description: Please see the README on GitHub at 12 | homepage: https://github.com/githubuser/sybdemo#readme 13 | bug-reports: https://github.com/githubuser/sybdemo/issues 14 | author: Author name here 15 | maintainer: example@example.com 16 | copyright: 2019 Author name here 17 | license: BSD3 18 | build-type: Simple 19 | extra-source-files: 20 | README.md 21 | ChangeLog.md 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/githubuser/sybdemo 26 | 27 | executable sybdemo-exe 28 | main-is: Main.hs 29 | other-modules: 30 | Length 31 | Paths_sybdemo 32 | hs-source-dirs: 33 | app 34 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 35 | build-depends: 36 | base >=4.7 && <5 37 | , syb 38 | default-language: Haskell2010 39 | -------------------------------------------------------------------------------- /papers/EPTCS/visitors-demo/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | #ocamlfind opt -rectypes -package visitors.runtime,visitors.ppx -linkpkg test001.ml 3 | #ocamlfind opt -rectypes -package visitors.runtime,visitors.ppx -linkpkg -dsource test003.ml 4 | #ocamlfind opt -rectypes -package visitors.runtime,visitors.ppx -linkpkg -dsource test003.ml 5 | #ocamlfind opt -rectypes -package visitors.runtime,visitors.ppx -linkpkg -dsource test004.ml 6 | ocamlfind opt -rectypes -package visitors.runtime,visitors.ppx -linkpkg -dsource test005.ml 7 | 8 | -------------------------------------------------------------------------------- /papers/FLOPS2020/.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | *.log 3 | *.out 4 | 5 | -------------------------------------------------------------------------------- /papers/FLOPS2020/Makefile: -------------------------------------------------------------------------------- 1 | R=GT 2 | PDF=$(R).pdf 3 | .SUFFIXES: .pdf .tex 4 | .PHONY: $(PDF) clean 5 | 6 | all: $(PDF) 7 | 8 | FILES_TEX= $(R).tex intro.tex related.tex 9 | 10 | $(R).pdf: $(FILES_TEX) 11 | pdflatex $< 12 | bibtex $(R).aux 13 | pdflatex $< 14 | pdflatex $< 15 | 16 | clean: 17 | $(RM) *.bak *.out $(PDF) 18 | 19 | -------------------------------------------------------------------------------- /papers/FLOPS2020/conclusion.tex: -------------------------------------------------------------------------------- 1 | \section{Future Work} 2 | 3 | There are a few possible directions for future work. First, in this paper we did not address the performance issues. As we represent 4 | the transformations in a very generic form with many levels of indirection, obviously, the transformations, implemented with 5 | our framework, are at disadvantage in comparison with hard coded ones in terms of performance. We assume that the performance of transformations 6 | can be essentially improved by applying some techniques like staging~\cite{Staged} or, perhaps, object-specific optimisations. 7 | 8 | Another important direction is supporting more kinds of type declarations, in the first hand, GADTs and non-regular types. Although we have some 9 | implementation ideas for this case, the solution we came up with so far makes the interface of the whole framework too cumbersome to use even for 10 | simple cases. 11 | 12 | Finally, the typeinfo structure we generate can be used to mimic the \emph{ad-hoc} polymorphism as it contains the implementation of 13 | type-indexed functions. This, together with some proposed extensions~\cite{ModularImplicits}, can open interesting perspectives. 14 | 15 | -------------------------------------------------------------------------------- /papers/OCAML-2018/.gitignore: -------------------------------------------------------------------------------- 1 | /*.aux 2 | /*.bcf 3 | /*.log 4 | /*.xml 5 | /*.bak 6 | 7 | -------------------------------------------------------------------------------- /papers/OCAML-2018/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLC = ocamlfind c 2 | OCAMLOPT = ocamlfind opt 3 | OCAMLDEP = ocamlfind dep 4 | SOURCES = $(TOPFILE).ml 5 | CAMLP5 = -syntax camlp5o -package GT.syntax.all 6 | PXFLAGS = $(CAMLP5) 7 | BFLAGS = -rectypes 8 | OFLAGS = $(BFLAGS) 9 | 10 | all: .depend $(TOPFILE).opt 11 | 12 | .depend: $(SOURCES) 13 | $(OCAMLDEP) $(PXFLAGS) *.ml > .depend 14 | 15 | $(TOPFILE).opt: $(SOURCES:.ml=.cmx) 16 | $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package GT $(SOURCES:.ml=.cmx) 17 | 18 | $(TOPFILE).byte: $(SOURCES:.ml=.cmo) 19 | $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package GT $(SOURCES:.ml=.cmo) 20 | 21 | clean: 22 | rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend 23 | 24 | -include .depend 25 | # generic rules 26 | 27 | ############### 28 | %.cmi: %.mli 29 | $(OCAMLC) -c $(BFLAGS) $(PXFLAGS) $< 30 | 31 | # Note: cmi <- mli should go first 32 | %.cmi: %.ml 33 | $(OCAMLC) -c $(BFLAGS) $(PXFLAGS) $< 34 | 35 | %.cmo: %.ml 36 | $(OCAMLC) -c $(BFLAGS) $(PXFLAGS) $< 37 | 38 | %.o: %.ml 39 | $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< 40 | 41 | %.cmx: %.ml 42 | $(OCAMLOPT) -c $(OFLAGS) $(STATIC) $(PXFLAGS) $< 43 | 44 | -------------------------------------------------------------------------------- /papers/OCAML-2018/eval.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type expr = 4 | | Abs of string * expr 5 | | App of expr * expr 6 | | Var of string 7 | | Binop of string * expr * expr 8 | | Let of string * expr * expr 9 | | Seq of expr * expr 10 | | Assn of string * expr 11 | with eval, show 12 | 13 | @type state = (string * int) list with show 14 | 15 | let lookup st x = List.assoc st x 16 | let update st x z = (x, z) :: st 17 | 18 | class eval fself = 19 | object 20 | inherit [state, state] @expr[eval] fself 21 | 22 | end 23 | -------------------------------------------------------------------------------- /plugins/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | max-indent=2 3 | 4 | -------------------------------------------------------------------------------- /plugins/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | (:standard -warn-error -A -w -7-9-13-27 -linkall)))) 5 | 6 | (library 7 | (name show) 8 | (public_name GT.syntax.show) 9 | (modules show) 10 | (libraries GT.common) 11 | (instrumentation 12 | (backend bisect_ppx)) 13 | (synopsis "Plugin 'show'")) 14 | 15 | (library 16 | (name gfmt) 17 | (public_name GT.syntax.gfmt) 18 | (modules gfmt) 19 | (libraries GTCommon) 20 | (instrumentation 21 | (backend bisect_ppx)) 22 | (synopsis "Plugin 'gfmt'")) 23 | 24 | (library 25 | (name foldl) 26 | (public_name GT.syntax.foldl) 27 | (modules foldl) 28 | (libraries GTCommon) 29 | (instrumentation 30 | (backend bisect_ppx)) 31 | (synopsis "Plugin 'foldl'")) 32 | 33 | (library 34 | (name foldr) 35 | (public_name GT.syntax.foldr) 36 | (modules foldr) 37 | (libraries GTCommon foldl) 38 | (instrumentation 39 | (backend bisect_ppx)) 40 | (synopsis "Plugin 'foldr'")) 41 | 42 | (library 43 | (name eq) 44 | (public_name GT.syntax.eq) 45 | (modules eq) 46 | (libraries GTCommon compare) 47 | (instrumentation 48 | (backend bisect_ppx)) 49 | (synopsis "Plugin 'eq'")) 50 | 51 | (library 52 | (name compare) 53 | (public_name GT.syntax.compare) 54 | (modules compare) 55 | (synopsis "Plugin 'compare'") 56 | (libraries GTCommon) 57 | (instrumentation 58 | (backend bisect_ppx)) 59 | (flags 60 | (:standard -w -7-9))) 61 | 62 | (library 63 | (name gmap) 64 | (public_name GT.syntax.map) 65 | (modules gmap) 66 | (synopsis "Plugin 'map' a.k.a. functor's fmap") 67 | (libraries GTCommon) 68 | (instrumentation 69 | (backend bisect_ppx))) 70 | 71 | (library 72 | (name eval) 73 | (public_name GT.syntax.eval) 74 | (modules eval) 75 | (libraries GTCommon gmap) 76 | (synopsis "Plugin 'eval'") 77 | (flags 78 | (:standard -w -7-9-13-36)) 79 | (instrumentation 80 | (backend bisect_ppx))) 81 | 82 | (library 83 | (name stateful) 84 | (public_name GT.syntax.stateful) 85 | (modules stateful) 86 | (libraries GTCommon gmap) 87 | (synopsis "Plugin 'stateful'") 88 | (instrumentation 89 | (backend bisect_ppx))) 90 | 91 | (library 92 | (name html) 93 | (public_name GT.syntax.html) 94 | (modules html) 95 | (libraries GTCommon) 96 | (synopsis "Plugin 'html'") 97 | (flags 98 | (:standard -w -7-9-13-36)) 99 | (instrumentation 100 | (backend bisect_ppx))) 101 | 102 | (library 103 | (name ghash) 104 | (public_name GT.syntax.hash) 105 | (modules ghash) 106 | (libraries GTCommon) 107 | (synopsis "Plugin 'hash'") 108 | (flags 109 | (:standard -w -7-9-13-36)) 110 | (instrumentation 111 | (backend bisect_ppx))) 112 | 113 | (library 114 | (name enum) 115 | (public_name GT.syntax.enum) 116 | (modules genum) 117 | (libraries GTCommon) 118 | (synopsis "Plugin 'enum'") 119 | (flags 120 | (:standard -w -7-9-13-36)) 121 | (instrumentation 122 | (backend bisect_ppx))) 123 | 124 | (library 125 | (name syntax_all) 126 | (public_name GT.syntax.all) 127 | (wrapped false) 128 | (modules) 129 | (libraries 130 | GT.syntax.show 131 | GT.syntax.gfmt 132 | GT.syntax.foldl 133 | GT.syntax.foldr 134 | GT.syntax.eq 135 | GT.syntax.compare 136 | GT.syntax.map 137 | GT.syntax.eval 138 | GT.syntax.stateful 139 | GT.syntax.html 140 | GT.syntax.hash) 141 | (instrumentation 142 | (backend bisect_ppx))) 143 | -------------------------------------------------------------------------------- /plugins/eq.ml: -------------------------------------------------------------------------------- 1 | (** {i Eq} plugin: receive another value as inherited attribute and test for equality. 2 | 3 | Very similar to {!Compare} plugin. 4 | 5 | For type declaration [type ('a,'b,...) typ = ...] it will create a transformation 6 | function with type 7 | 8 | [('a -> 'a -> bool) -> 9 | ('b -> 'b -> bool) -> ... -> ('a,'b,...) typ -> bool ] 10 | 11 | Inherited attribute' is the same as argument, synthetized attribute is {!GT.comparison}. 12 | *) 13 | 14 | open GTCommon 15 | 16 | let trait_name = "eq" 17 | 18 | module Make (AstHelpers : GTHELPERS_sig.S) = struct 19 | let trait_name = trait_name 20 | 21 | module C = Compare.Make (AstHelpers) 22 | open AstHelpers 23 | 24 | class g initial_args tdecls = 25 | object (self : 'self) 26 | inherit C.g initial_args tdecls 27 | method! trait_name = trait_name 28 | method! syn_of_param ~loc s = Typ.sprintf ~loc "bool" 29 | method! syn_of_main ~loc ?in_class tdecl = self#syn_of_param ~loc "dummy" 30 | 31 | method! on_different_constructors ~loc is_poly other_name cname arg_typs = 32 | Exp.let_ ~loc [ Pat.any ~loc, Exp.ident ~loc other_name ] (Exp.false_ ~loc) 33 | 34 | method! chain_exprs ~loc e1 e2 = Exp.app_list ~loc (Exp.ident ~loc "&&") [ e1; e2 ] 35 | method! chain_init ~loc = Exp.true_ ~loc 36 | end 37 | 38 | let create = (new g :> C.P.plugin_constructor) 39 | end 40 | 41 | let register () = Expander.register_plugin trait_name (module Make : Plugin_intf.MAKE) 42 | let () = register () 43 | -------------------------------------------------------------------------------- /plugins/foldr.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Generic transformers: plugins. 3 | * Copyright (C) 2016-2022 4 | * Dmitrii Kosarev aka Kakadu 5 | * St.Petersburg State University, JetBrains Research 6 | *) 7 | 8 | (** {i Foldr} plugin: fold all values in a type. 9 | 10 | Essentially is a stub that chains inherited attribute thorough all values 11 | in the value 12 | 13 | For type declaration [type ('a,'b,...) typ = ...] it will create a transformation 14 | function with type 15 | 16 | [('s -> 'a -> 's) -> 17 | ('s -> 'b -> 's) -> 18 | ... -> 19 | 's -> ('a,'b,...) typ -> 's ] 20 | *) 21 | 22 | open Ppxlib 23 | open GTCommon 24 | 25 | let trait_name = "foldr" 26 | 27 | module Make (AstHelpers : GTHELPERS_sig.S) = struct 28 | open AstHelpers 29 | module Foldl = Foldl.Make (AstHelpers) 30 | 31 | let trait_name = trait_name 32 | 33 | class g initial_args tdecls = 34 | object (self : 'self) 35 | inherit Foldl.g initial_args tdecls 36 | method trait_name = trait_name 37 | 38 | method join_args ~loc do_typ ~init (xs : (string * core_type) list) = 39 | ListLabels.fold_left 40 | ~f:(fun acc (name, typ) -> 41 | Exp.app_list ~loc (do_typ typ) [ acc; Exp.sprintf ~loc "%s" name ]) 42 | ~init 43 | (List.rev xs) 44 | end 45 | 46 | let create = (new g :> Foldl.P.plugin_constructor) 47 | end 48 | 49 | let register () = Expander.register_plugin trait_name (module Make : Plugin_intf.MAKE) 50 | let () = register () 51 | -------------------------------------------------------------------------------- /ppx/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | max-indent=2 3 | 4 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx) 3 | (public_name GT.ppx) 4 | (kind ppx_rewriter) 5 | (libraries ppxlib.stdppx ppxlib GT.common) 6 | (modules Ppx_deriving_gt PpxHelpers) 7 | (synopsis "PPX syntax extension on top of ppxlib") 8 | (preprocess 9 | (pps ppxlib.metaquot)) 10 | (flags 11 | (:standard -w -27-9 -warn-error -A -linkall)) 12 | (instrumentation 13 | (backend bisect_ppx))) 14 | 15 | (library 16 | (name ppx_all) 17 | (public_name GT.ppx_all) 18 | (kind ppx_rewriter) 19 | (libraries 20 | ppx 21 | show 22 | gfmt 23 | gmap 24 | compare 25 | eq 26 | foldl 27 | foldr 28 | eval 29 | stateful 30 | enum 31 | html 32 | ghash) 33 | (modules ppx_all) 34 | (wrapped false) 35 | (synopsis "PPX syntax extension on top of ppxlib + plugins") 36 | (flags 37 | (:standard -linkall -w -33)) 38 | (instrumentation 39 | (backend bisect_ppx))) 40 | 41 | (executable 42 | (name pp_gt) 43 | (modules pp_gt) 44 | (libraries 45 | ppxlib 46 | ppxlib.stdppx 47 | GT.common 48 | ppx 49 | show 50 | gfmt 51 | gmap 52 | eval 53 | stateful 54 | foldr 55 | foldl 56 | compare 57 | eq 58 | html 59 | ghash 60 | enum) 61 | (flags 62 | (:standard -linkall)) 63 | (instrumentation 64 | (backend bisect_ppx))) 65 | 66 | ;(executable 67 | ; (name pp_all) 68 | ; (modules pp_gt) 69 | ; (flags (:standard -linkall)) 70 | ; (libraries ppx_all ppxlib)) 71 | -------------------------------------------------------------------------------- /ppx/pp_gt.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Generic Transformers PPX syntax extension. 3 | * Copyright (C) 2016-2019 4 | * Dmitrii Kosarev aka Kakadu 5 | * St.Petersburg State University, JetBrains Research 6 | *) 7 | 8 | [@@@coverage off] 9 | 10 | (* TODO: make -pretty option to be a default *) 11 | 12 | let () = Ppxlib.Driver.standalone () 13 | -------------------------------------------------------------------------------- /ppx/pp_gt_all.ml: -------------------------------------------------------------------------------- 1 | (* TODO: make -pretty option to be a default *) 2 | 3 | (* 4 | * Generic Transformers PPX syntax extension. 5 | * Copyright (C) 2016-2019 6 | * Dmitrii Kosarev aka Kakadu 7 | * St.Petersburg State University, JetBrains Research 8 | *) 9 | 10 | let () = Ppxlib.Driver.standalone () 11 | -------------------------------------------------------------------------------- /ppx/ppx_all.ml: -------------------------------------------------------------------------------- 1 | module P : sig end = Ppx 2 | module C : sig end = Compare 3 | -------------------------------------------------------------------------------- /regression/.gitignore: -------------------------------------------------------------------------------- 1 | /*.log 2 | *.diff 3 | 4 | -------------------------------------------------------------------------------- /regression/.ocamlformat: -------------------------------------------------------------------------------- 1 | disable=true -------------------------------------------------------------------------------- /regression/README.md: -------------------------------------------------------------------------------- 1 | This is a test suite for regression testing of a library. The compiled executables 2 | produce some output which is compared to the prepared output from the `orig/` 3 | directory. If the output is the same test is passed. 4 | 5 | Most of the tests are related to camlp5 syntax extension. The tests related to 6 | `ppx` extension engine are starting from `test7*`. 7 | -------------------------------------------------------------------------------- /regression/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -warn-error -A -w +39-32-7-34 -w -unused-constructor)))) 5 | 6 | (include dune.tests) 7 | 8 | (cram 9 | (applies_to test828) 10 | (deps 11 | ../ppx/pp_gt.exe 12 | test828mut.ml 13 | test828mut.exe 14 | ; 15 | )) 16 | 17 | (cram 18 | (deps 19 | ../ppx/pp_gt.exe 20 | test824mut.ml 21 | test827mut.ml 22 | test827mut.exe 23 | test830mut.exe 24 | ; 25 | )) 26 | 27 | ; (executable 28 | ; (name test827mut) 29 | ; (modules test827mut) 30 | ; (libraries GT) 31 | ; (flags 32 | ; (:standard 33 | ; ;-dsource 34 | ; ;-rectypes 35 | ; )) 36 | ; (preprocess 37 | ; (action 38 | ; (run %{project_root}/ppx/pp_gt.exe -pretty --as-pp %{input-file}))) 39 | ; (preprocessor_deps 40 | ; (file %{project_root}/ppx/pp_gt.exe))) 41 | 42 | ; (executables 43 | ; (names test830mut test828mut) 44 | ; (modules test830mut test828mut) 45 | ; (libraries GT) 46 | ; (flags 47 | ; (:standard -rectypes)) 48 | ; (preprocess 49 | ; (action 50 | ; (run %{project_root}/ppx/pp_gt.exe -pretty --as-pp %{input-file}))) 51 | ; (preprocessor_deps 52 | ; (file %{project_root}/ppx/pp_gt.exe))) 53 | -------------------------------------------------------------------------------- /regression/html_tyxml_api.ml: -------------------------------------------------------------------------------- 1 | module H = Tyxml.Html 2 | 3 | let int = 4 | { GT.gcata = GT.gcata_int; 5 | GT.plugins = object 6 | method show = GT.int.GT.plugins#show 7 | method gmap = GT.int.GT.plugins#gmap 8 | method compare = GT.int.GT.plugins#compare 9 | method eq = GT.int.GT.plugins#eq 10 | method foldl = GT.int.GT.plugins#foldr 11 | method foldr = GT.int.GT.plugins#foldl 12 | method stateful = GT.int.GT.plugins#stateful 13 | method eval = GT.int.GT.plugins#eval 14 | method html n = Tyxml_html.pcdata (string_of_int n) 15 | end 16 | } 17 | let float = 18 | { GT.gcata = GT.gcata_float; 19 | GT.plugins = object 20 | method show = GT.float.GT.plugins#show 21 | method gmap = GT.float.GT.plugins#gmap 22 | method compare = GT.float.GT.plugins#compare 23 | method eq = GT.float.GT.plugins#eq 24 | method foldl = GT.float.GT.plugins#foldr 25 | method foldr = GT.float.GT.plugins#foldl 26 | method stateful = GT.float.GT.plugins#stateful 27 | method eval = GT.float.GT.plugins#eval 28 | method html n = Tyxml_html.pcdata (string_of_float n) 29 | end 30 | } 31 | 32 | let string = 33 | { GT.gcata = GT.gcata_string; 34 | GT.plugins = object 35 | method show = GT.string.GT.plugins#show 36 | method gmap = GT.string.GT.plugins#gmap 37 | method compare = GT.string.GT.plugins#compare 38 | method eq = GT.string.GT.plugins#eq 39 | method foldl = GT.string.GT.plugins#foldr 40 | method foldr = GT.string.GT.plugins#foldl 41 | method stateful = GT.string.GT.plugins#stateful 42 | method eval = GT.string.GT.plugins#eval 43 | method show_typed x = GT.string.GT.plugins#show x 44 | method html = Tyxml_html.pcdata 45 | end 46 | } 47 | 48 | class ['a, 'b, 'self, 'html] html_tuple2_t _ fa fb = 49 | object 50 | inherit [ unit, 'a, 'syn 51 | , unit, 'b, 'syn 52 | , unit, 'self, 'syn] GT.pair_t 53 | constraint 'syn = 'html 54 | method c_Pair () x y = Tyxml.Html.div [fa x; fb y] 55 | end 56 | 57 | class ['a, 'self, 'html] html_list_t fself fa = object 58 | inherit ['inh, 'a, 'syn, 'inh, 'self, 'html H.elt] GT.list_t 59 | method c_Nil () = H.div [H.pcdata "[]"] 60 | method c_Cons () x xs = H.div [fa x; H.pcdata "::"; fself xs] 61 | end 62 | 63 | class ['a, 'self, 'html] html_option_t _fself fa = object 64 | inherit [unit, 'a, 'syn, unit, 'self, 'syn] GT.option_t 65 | constraint 'syn = 'html H.elt 66 | method c_None () = H.pcdata "None" 67 | method c_Some () x = H.div [H.pcdata "Some"; fa x] 68 | end 69 | 70 | let tuple2 = 71 | { GT.gcata = GT.gcata_pair; 72 | GT.plugins = object 73 | method show = GT.tuple2.GT.plugins#show 74 | method html fa fb t = 75 | GT.fix0 (fun fself -> GT.tuple2.GT.gcata (new html_tuple2_t fself fa fb)) t 76 | method gmap = GT.tuple2.GT.plugins#gmap 77 | method compare = GT.tuple2.GT.plugins#compare 78 | method eq = GT.tuple2.GT.plugins#eq 79 | method foldl = GT.tuple2.GT.plugins#foldr 80 | method foldr = GT.tuple2.GT.plugins#foldl 81 | method stateful = GT.tuple2.GT.plugins#stateful 82 | method eval = GT.tuple2.GT.plugins#eval 83 | end 84 | } 85 | -------------------------------------------------------------------------------- /regression/orig/test036.log: -------------------------------------------------------------------------------- 1 | 2 | 3 | -------------------------------------------------------------------------------- /regression/test000.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type tree = Node of int * tree list 4 | 5 | 6 | class ['a, 'b] tree_gmap_t f fself = 7 | object 8 | inherit ['a, 'b, _] @tree 9 | method c_Node _ _ n l = Node (f () n, List.map (fself ()) l) 10 | end 11 | 12 | class ['a, 'b, 'extra] tree_fold_t f fself = 13 | object 14 | inherit ['a, 'extra, 'b] @tree 15 | method c_Node acc _ n l = List.fold_left fself (f acc n) l 16 | end 17 | 18 | let num_of_nodes t = 19 | GT.transform(tree) (new tree_fold_t (fun n _ -> n+1)) 0 t 20 | 21 | let increment t = 22 | GT.transform(tree) (new tree_gmap_t (fun () n -> n+1)) () t 23 | 24 | let toString t = 25 | Buffer.contents @@ 26 | GT.transform(tree) 27 | (new tree_fold_t 28 | (fun buf n -> 29 | Buffer.add_string buf (string_of_int n); 30 | buf 31 | )) 32 | (Buffer.create 1024) 33 | t 34 | 35 | let _ = 36 | let t = Node (1, [Node (2, [Node (4, [])]); Node (2, [])]) in 37 | Printf.printf "Tree: %s\n" (toString t); 38 | Printf.printf "Number of nodes: %d\n" (num_of_nodes t); 39 | Printf.printf "Incremented: %s\n" (toString (increment t)) 40 | -------------------------------------------------------------------------------- /regression/test000.mli: -------------------------------------------------------------------------------- 1 | @type tree = Node of int * tree list 2 | -------------------------------------------------------------------------------- /regression/test000.t: -------------------------------------------------------------------------------- 1 | $ ./test000.exe 2 | Tree: 1242 3 | Number of nodes: 4 4 | Incremented: 2353 5 | -------------------------------------------------------------------------------- /regression/test001.mli: -------------------------------------------------------------------------------- 1 | @type 'l t = 2 | R 3 | | W 4 | | L of string 5 | | S of string 6 | | B of (int -> int -> int) * string 7 | | E 8 | | C of int 9 | | J of 'l 10 | | JT of 'l 11 | | JF of 'l 12 | -------------------------------------------------------------------------------- /regression/test001.t: -------------------------------------------------------------------------------- 1 | $ ./test001.exe 2 | sum: 3 | 5 4 | sumN: 5 | 55 6 | sum with debug: 7 | R @ 0 8 | R @ 1 9 | B + @ 2 10 | W @ 3 11 | E @ 4 12 | 5 13 | sumN with debug: 14 | R @ 0 15 | S n @ 1 16 | C 0 @ 2 17 | S s @ 3 18 | L n @ 4 19 | JF 15 @ 5 20 | L n @ 6 21 | C 1 @ 7 22 | B - @ 8 23 | S n @ 9 24 | R @ 10 25 | L s @ 11 26 | B + @ 12 27 | S s @ 13 28 | J 4 @ 14 29 | L n @ 4 30 | JF 15 @ 5 31 | L n @ 6 32 | C 1 @ 7 33 | B - @ 8 34 | S n @ 9 35 | R @ 10 36 | L s @ 11 37 | B + @ 12 38 | S s @ 13 39 | J 4 @ 14 40 | L n @ 4 41 | JF 15 @ 5 42 | L n @ 6 43 | C 1 @ 7 44 | B - @ 8 45 | S n @ 9 46 | R @ 10 47 | L s @ 11 48 | B + @ 12 49 | S s @ 13 50 | J 4 @ 14 51 | L n @ 4 52 | JF 15 @ 5 53 | L n @ 6 54 | C 1 @ 7 55 | B - @ 8 56 | S n @ 9 57 | R @ 10 58 | L s @ 11 59 | B + @ 12 60 | S s @ 13 61 | J 4 @ 14 62 | L n @ 4 63 | JF 15 @ 5 64 | L n @ 6 65 | C 1 @ 7 66 | B - @ 8 67 | S n @ 9 68 | R @ 10 69 | L s @ 11 70 | B + @ 12 71 | S s @ 13 72 | J 4 @ 14 73 | L n @ 4 74 | JF 15 @ 5 75 | L n @ 6 76 | C 1 @ 7 77 | B - @ 8 78 | S n @ 9 79 | R @ 10 80 | L s @ 11 81 | B + @ 12 82 | S s @ 13 83 | J 4 @ 14 84 | L n @ 4 85 | JF 15 @ 5 86 | L n @ 6 87 | C 1 @ 7 88 | B - @ 8 89 | S n @ 9 90 | R @ 10 91 | L s @ 11 92 | B + @ 12 93 | S s @ 13 94 | J 4 @ 14 95 | L n @ 4 96 | JF 15 @ 5 97 | L n @ 6 98 | C 1 @ 7 99 | B - @ 8 100 | S n @ 9 101 | R @ 10 102 | L s @ 11 103 | B + @ 12 104 | S s @ 13 105 | J 4 @ 14 106 | L n @ 4 107 | JF 15 @ 5 108 | L n @ 6 109 | C 1 @ 7 110 | B - @ 8 111 | S n @ 9 112 | R @ 10 113 | L s @ 11 114 | B + @ 12 115 | S s @ 13 116 | J 4 @ 14 117 | L n @ 4 118 | JF 15 @ 5 119 | L n @ 6 120 | C 1 @ 7 121 | B - @ 8 122 | S n @ 9 123 | R @ 10 124 | L s @ 11 125 | B + @ 12 126 | S s @ 13 127 | J 4 @ 14 128 | L n @ 4 129 | JF 15 @ 5 130 | L s @ 15 131 | W @ 16 132 | E @ 17 133 | 55 134 | sum: 135 | 5 136 | sumN: 137 | 55 138 | -------------------------------------------------------------------------------- /regression/test002.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open GT 4 | 5 | module Expr = struct 6 | @type 'self t = 7 | [ `Var of string 8 | | `Const of int 9 | | `Binop of (int -> int -> int) * string * 'self * 'self 10 | ] 11 | 12 | class ['a] toString (fself: unit -> 'a -> string) = 13 | object 14 | inherit [unit, 'a, string, unit, 'a t, string] t_t 15 | method c_Var _ _ s = s 16 | method c_Const _ _ n = string_of_int n 17 | method c_Binop _ _ _ s x y = "(" ^ (fself () x) ^ s ^ (fself () y) ^ ")" 18 | end 19 | 20 | class ['a] eval do_var (fself: _ -> 'a t -> _) = 21 | object 22 | inherit [ unit, 'a, int, unit, 'a t, int] t_t 23 | method c_Var _ _ x = do_var x 24 | method c_Const _ _ n = n 25 | method c_Binop _ _ f _ x y = f (fself () x) (fself () y) 26 | end 27 | 28 | end 29 | 30 | let _ = 31 | let toString () e = GT.transform(Expr.t) (new Expr.toString) () e in 32 | let eval s i e = GT.transform(Expr.t) (new Expr.eval s) i e in 33 | let e = `Binop ((+), "+", `Const 1, `Var "a") in 34 | 35 | let s = toString () e in 36 | let v = eval (fun "a" -> 2) () e in 37 | Printf.printf "%s\n" s; 38 | Printf.printf "%d\n" v 39 | -------------------------------------------------------------------------------- /regression/test002.mli: -------------------------------------------------------------------------------- 1 | module Expr : sig 2 | @type 'self t = 3 | [ | `Var of string 4 | | `Const of int 5 | | `Binop of (int -> int -> int) * string * 'self * 'self 6 | ] 7 | 8 | end 9 | -------------------------------------------------------------------------------- /regression/test002.t: -------------------------------------------------------------------------------- 1 | $ ./test002.exe 2 | (1+a) 3 | 3 4 | -------------------------------------------------------------------------------- /regression/test003.ml: -------------------------------------------------------------------------------- 1 | @type a = A of b | C of GT.int GT.list with show 2 | and b = B of a | D of GT.string with show 3 | 4 | let x = A (B (C [1; 2; 3; 4])) 5 | let y = B (A (D "3")) 6 | 7 | let () = Printf.printf "%s\n" @@ GT.show(a) x 8 | 9 | class show_a2stub prereq = 10 | object 11 | inherit [_] show_a_t_stub prereq as super 12 | method! c_C () a ys = "new " ^ super#c_C () a ys 13 | end 14 | 15 | let show_a_new eta = let (f, _) = fix_a_b (new show_a2stub) show_b_0 in f eta 16 | 17 | let a = { a with plugins = object 18 | method show eta = show_a_new () eta 19 | end} 20 | let _ = 21 | Printf.printf "%s\n" (GT.show(b) y); 22 | Printf.printf "%s\n" (GT.show(a) x); 23 | -------------------------------------------------------------------------------- /regression/test003.mli: -------------------------------------------------------------------------------- 1 | @type a = A of b | C of GT.int GT.list with show 2 | and b = B of a | D of GT.string with show 3 | -------------------------------------------------------------------------------- /regression/test003.t: -------------------------------------------------------------------------------- 1 | $ ./test003.exe 2 | A (B (C ([1; 2; 3; 4]))) 3 | B (A (D ("3"))) 4 | A (B (new C ([1; 2; 3; 4]))) 5 | -------------------------------------------------------------------------------- /regression/test004.ml: -------------------------------------------------------------------------------- 1 | @type a = [`A of b | `C of GT.int] with show 2 | and b = [`B of a GT.list | `D of GT.string] with show 3 | 4 | let x = `A (`B [`C 3; `C 4]) 5 | let y = `B [`A (`D "3"); `C 5] 6 | 7 | let () = 8 | Printf.printf "%s\n" (GT.show(a) x); 9 | Printf.printf "%s\n" (GT.show(b) y) 10 | 11 | class ['e] show_a' (for_a,for_b) = 12 | object 13 | inherit ['e] show_a_t_stub (for_a,for_b) as super 14 | method c_C i x y = "new " ^ super#c_C i x y 15 | method c_A _ _ x = Printf.sprintf "new A %a" for_b x 16 | end 17 | 18 | 19 | let show_a' () s = 20 | (fst @@ fix_a_b (new show_a') (new show_b_t_stub)) () s 21 | 22 | let () = 23 | Printf.printf "%s\n" (show_a' () x) 24 | -------------------------------------------------------------------------------- /regression/test004.mli: -------------------------------------------------------------------------------- 1 | (* @type a = [`A of b | `C of GT.int] with show 2 | * and b = [`B of a GT.list | `D of GT.string] with show *) 3 | -------------------------------------------------------------------------------- /regression/test004.t: -------------------------------------------------------------------------------- 1 | $ ./test004.exe 2 | `A (`B ([`C (3); `C (4)])) 3 | `B ([`A (`D ("3")); `C (5)]) 4 | new A `B ([new `C (3); new `C (4)]) 5 | -------------------------------------------------------------------------------- /regression/test005.ml: -------------------------------------------------------------------------------- 1 | (* Camlp5 version of test802 *) 2 | open Printf 3 | 4 | module PV : sig 5 | @type a = [`A of b | `C of GT.int] with show 6 | and b = [`B of a | `D of GT.string] with show 7 | end = struct 8 | @type a = [`A of b | `C of GT.int] with show 9 | and b = [`B of a | `D of GT.string] with show 10 | end 11 | 12 | module Show2 = struct 13 | open PV 14 | class ['self] show_b_t_stub2 (for_a,for_b) = object 15 | inherit ['self] show_b_t_stub (for_a,for_b) 16 | method c_C () (_ :b) a = Printf.sprintf "new C (%s)" (for_a () a) 17 | method c_D () _ s = Printf.sprintf "new D %s" s 18 | end 19 | 20 | let showa0 a = Printf.printf "new!\n"; new show_a_t_stub a 21 | let showb0 a = Printf.printf "new!\n"; new show_b_t_stub2 a 22 | 23 | let show_a () s = 24 | (fst @@ fix_a_b showa0 showb0) () s 25 | 26 | let show_b () s = 27 | (snd @@ fix_a_b showa0 showb0) () s 28 | 29 | let _ = Printf.printf "%s\n" (show_a () (`A (`B (`A (`D "4"))))) 30 | end 31 | 32 | let () = ();; 33 | 34 | @type c = [ PV.b | `E of GT.int (* GT.list *) ] with show 35 | 36 | (* TODO: collect plugins for mutual type declarations *) 37 | (* 38 | let x = `A (`B (`C 3)) 39 | let y = `B (`A (`D "3")) 40 | let z = `E 1 41 | 42 | let () = 43 | Printf.printf "%s\n" (GT.show(PV.a) x); 44 | Printf.printf "%s\n" (GT.show(PV.b) y); 45 | Printf.printf "%s\n" (GT.show(c) z); 46 | Printf.printf "%s\n" (GT.show(c) y); 47 | *) 48 | module ShowC = struct 49 | open PV 50 | 51 | class ['extra] show_c_stub2 make_clas = 52 | let show_a2,show_b2 = 53 | Show2.(fix_a_b 54 | showa0 55 | (fun _ -> ((make_clas ()) (* :> 'extra show_b_t_stub *)) )) 56 | in 57 | object 58 | inherit [unit, 'extra, string] c_t 59 | 60 | inherit [ 'extra ] show_b_t_stub (show_a2,show_b2) 61 | method! c_B () _ a = sprintf "new `B (%s)" (show_a2 () a) 62 | method! c_D () _ s = sprintf "new `D %s" s 63 | method c_E () _ s = sprintf "new `E %d" s 64 | end 65 | 66 | let rec showc0 () = Printf.printf "new c0!\n"; new show_c_stub2 showc0 67 | 68 | let show_c () (s: c) = 69 | let trait () s = gcata_c (showc0 ()) () (s :> c) in 70 | trait () s 71 | 72 | let _ = 73 | Printf.printf "%s\n" (show_c () (`B (`A (`D "4")))); 74 | Printf.printf "%s\n" (show_c () (`E 18) ) 75 | 76 | end 77 | -------------------------------------------------------------------------------- /regression/test005.mli: -------------------------------------------------------------------------------- 1 | (* @type a = [`A of b | `C of GT.int] with show 2 | * and b = [`B of a | `D of GT.string] with show 3 | * 4 | * @type c = [`E of GT.int GT.list | b] with show *) 5 | -------------------------------------------------------------------------------- /regression/test005.t: -------------------------------------------------------------------------------- 1 | $ ./test005.exe 2 | new! 3 | new! 4 | new! 5 | new! 6 | `A (`B (`A (new D 4))) 7 | new c0! 8 | new! 9 | new c0! 10 | new `B (`A (new `D 4)) 11 | new c0! 12 | new `E 18 13 | -------------------------------------------------------------------------------- /regression/test006.ml: -------------------------------------------------------------------------------- 1 | open GT;; 2 | 3 | @type 'a tree = Leaf | Node of 'a * 'a tree list with show, gmap 4 | 5 | let _ = 6 | let x = Node (1, [ Node (2, [Leaf]) 7 | ; Node (3, [Leaf]) 8 | ; Node (4, [Node (5, []); Leaf]) 9 | ] 10 | ) in 11 | let y = GT.gmap tree string_of_int x in 12 | Printf.printf "%s\n" @@ GT.show tree string_of_int x; 13 | Printf.printf "%s\n" @@ GT.show tree Fun.id y 14 | -------------------------------------------------------------------------------- /regression/test006.mli: -------------------------------------------------------------------------------- 1 | @type 'a tree = Leaf | Node of 'a * 'a tree GT.list with show, gmap 2 | 3 | -------------------------------------------------------------------------------- /regression/test006.t: -------------------------------------------------------------------------------- 1 | $ ./test006.exe 2 | Node (1, [Node (2, [Leaf]); Node (3, [Leaf]); Node (4, [Node (5, []); Leaf])]) 3 | Node (1, [Node (2, [Leaf]); Node (3, [Leaf]); Node (4, [Node (5, []); Leaf])]) 4 | -------------------------------------------------------------------------------- /regression/test007.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = A of 'a GT.list * 'b GT.list with show, gmap 2 | 3 | let _ = 4 | let x = A ([1; 2; 3], ["4"; "5"; "6"]) in 5 | let y = GT.gmap t string_of_int int_of_string x in 6 | Printf.printf "%s\n" @@ GT.show t string_of_int Fun.id x; 7 | Printf.printf "%s\n" @@ GT.show t Fun.id string_of_int y 8 | -------------------------------------------------------------------------------- /regression/test007.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = A of 'a GT.list * 'b GT.list with show, gmap 2 | -------------------------------------------------------------------------------- /regression/test007.t: -------------------------------------------------------------------------------- 1 | $ ./test007.exe 2 | A ([1; 2; 3], [4; 5; 6]) 3 | A ([1; 2; 3], [4; 5; 6]) 4 | -------------------------------------------------------------------------------- /regression/test008.ml: -------------------------------------------------------------------------------- 1 | @type ident = [`Var of string] 2 | 3 | class ['r, 'self] ident_eval = object 4 | inherit [string -> 'r, 'self, 'r] @ident 5 | method c_Var s _ x = s x 6 | end 7 | 8 | @type 'a arith = [ `Add of 'a * 'a | `Sub of 'a * 'a] 9 | 10 | class ['i, 'a, 'self] arith_eval fa = object 11 | inherit ['i, 'a, int, 'i, 'self, int] @arith 12 | method c_Add inh _ x y = (fa inh x) + (fa inh y) 13 | method c_Sub inh _ x y = (fa inh x) - (fa inh y) 14 | end 15 | 16 | @type 'a expr = [ ident | 'a arith ] 17 | 18 | class ['a, 'self] expr_eval fa _fself = object 19 | inherit [string->int, 'a, int, string->int, 'self, int] @expr 20 | inherit [int, 'self] ident_eval 21 | inherit [string -> int, 'a, 'self] arith_eval fa 22 | end 23 | 24 | [@@@warning "-8"] 25 | 26 | let _ = 27 | let rec eval f x = GT.transform(expr) (new expr_eval eval) f x in 28 | Printf.printf "%d\n" @@ 29 | eval (function "x" -> 1 | "y" -> 2 ) (`Add (`Var "x", `Var "y")) 30 | -------------------------------------------------------------------------------- /regression/test008.mli: -------------------------------------------------------------------------------- 1 | @type ident = [`Var of string] 2 | @type 'a arith = [ `Add of 'a * 'a | `Sub of 'a * 'a] 3 | @type 'a expr = [ ident | 'a arith ] 4 | 5 | -------------------------------------------------------------------------------- /regression/test008.t: -------------------------------------------------------------------------------- 1 | $ ./test008.exe 2 | 3 3 | -------------------------------------------------------------------------------- /regression/test009.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) a = A of 'a | B of 'b with show, gmap 2 | 3 | @type ('a, 'b) t = X of ('a, 'b) a * ('a, 'b) t GT.list | 4 | Y of ('b, 'a) a * ('a, 'b) t GT.list 5 | with show, gmap 6 | 7 | let _ = 8 | let x = X (A 1, [Y (A "2", []); X (A 2, []); Y (A "3", [])]) in 9 | let y = GT.gmap t string_of_int int_of_string x in 10 | Printf.printf "%s\n" @@ GT.show t string_of_int Fun.id x; 11 | Printf.printf "%s\n" @@ GT.show t Fun.id string_of_int y 12 | -------------------------------------------------------------------------------- /regression/test009.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) a = A of 'a | B of 'b with show, gmap 2 | @type ('a, 'b) t = X of ('a, 'b) a * ('a, 'b) t GT.list | 3 | Y of ('b, 'a) a * ('a, 'b) t GT.list with show, gmap 4 | -------------------------------------------------------------------------------- /regression/test009.t: -------------------------------------------------------------------------------- 1 | $ ./test009.exe 2 | X (A (1), [Y (A (2), []); X (A (2), []); Y (A (3), [])]) 3 | X (A (1), [Y (A (2), []); X (A (2), []); Y (A (3), [])]) 4 | -------------------------------------------------------------------------------- /regression/test010.ml: -------------------------------------------------------------------------------- 1 | let rec to_string = function 2 | | `Var s -> s 3 | | `Abs (s, x) -> "(\\" ^ s ^ " -> " ^ to_string x ^ ")" 4 | | `App (x, y) -> "(" ^ to_string x ^ " " ^ to_string y ^ ")" 5 | | `Num i -> string_of_int i 6 | | `Add (x, y) -> "(" ^ to_string x ^ " + " ^ to_string y ^ ")" 7 | | `Mult (x, y) -> "(" ^ to_string x ^ " * " ^ to_string y ^ ")" 8 | 9 | let gensym = let n = ref 0 in fun () -> incr n; "_" ^ string_of_int !n;; 10 | 11 | @type var = [`Var of string] 12 | 13 | class ['self, 'v] var_eval = object 14 | inherit [(string * 'v) list, 'self, 'v] @var 15 | constraint 'self = [> var] 16 | method c_Var s _ name = try List.assoc name s with Not_found -> `Var name 17 | end 18 | 19 | @type 'a lambda = [var | `Abs of string * 'a | `App of 'a * 'a] 20 | 21 | class ['self] lambda_eval fa _fself = object 22 | inherit [ (string * 'self) list, 'self, 'self 23 | , (string * 'self) list, 'self, 'self 24 | ] @lambda 25 | inherit ['self, 'self] var_eval 26 | constraint 'self = [> 'self lambda ] 27 | method c_Abs env _ name l1 = 28 | let s' = gensym () in 29 | `Abs (s', fa ((name, `Var s')::env) l1) 30 | 31 | method c_App s _ l1 l2 = 32 | let l2' = fa s l2 in 33 | match fa s l1 with 34 | | `Abs (s, body) -> fa [s, l2'] body (* Why we don't extend old env here *) 35 | | l1' -> `App (l1', l2') 36 | end 37 | 38 | (* let (_: _ -> int) = new lambda_eval *) 39 | 40 | let rec eval1 s e = GT.transform(lambda) (new lambda_eval eval1) s e;; 41 | 42 | @type 'a var_expr = [var | `Num of int | `Add of 'a * 'a | `Mult of 'a * 'a] 43 | 44 | class [ 'self ] var_expr_eval fa _fself = object 45 | inherit [ (string * 'self) list, 'self, 'self 46 | , (string * 'self) list, 'self, 'self 47 | ] @var_expr 48 | inherit ['self, 'self] var_eval 49 | constraint 'self = [> 'self var_expr ] 50 | 51 | method c_Num _ _ i = `Num i 52 | method c_Add env _ x y = 53 | match fa env x, fa env y with 54 | | `Num x, `Num y -> `Num (x+y) 55 | | x, y -> `Add (x, y) 56 | method c_Mult env _ x y = 57 | match fa env x, fa env y with 58 | | `Num x, `Num y -> `Num (x*y) 59 | | x, y -> `Mult (x, y) 60 | end 61 | 62 | let rec eval2 s e = GT.transform(var_expr) (new var_expr_eval eval2) s e;; 63 | 64 | @type 'a expr = ['a lambda | 'a var_expr] 65 | 66 | class ['a, 'self] expr_eval fself = object 67 | inherit [ (string * 'self) list, 'a, 'self 68 | , (string * 'self) list, 'self, 'self 69 | ] @expr 70 | inherit ['self] lambda_eval fself fself 71 | inherit ['self] var_expr_eval fself fself 72 | constraint 'self = [> 'a var_expr | 'a lambda ] 73 | end 74 | 75 | let eval3 s e = GT.transform(expr) (new expr_eval) s e 76 | 77 | let _ = 78 | Printf.printf "%s\n" @@ 79 | to_string (eval3 ["x", `Num 5; "y", `Num 6] (`Add (`Var "x", `Mult (`Num 2, `Var "y")))) 80 | -------------------------------------------------------------------------------- /regression/test010.mli: -------------------------------------------------------------------------------- 1 | @type var = [`Var of string] 2 | @type 'a lambda = [var | `Abs of string * 'a | `App of 'a * 'a] 3 | @type 'a var_expr = [var | `Num of int | `Add of 'a * 'a | `Mult of 'a * 'a] 4 | @type 'a expr = ['a lambda | 'a var_expr] 5 | -------------------------------------------------------------------------------- /regression/test010.t: -------------------------------------------------------------------------------- 1 | $ ./test010.exe 2 | 17 3 | -------------------------------------------------------------------------------- /regression/test011.ml: -------------------------------------------------------------------------------- 1 | (* @type 'a option = Some of 'a | None 2 | * with show,html,gmap,fmt,eval,stateful,foldl,foldr,compare,eq *) 3 | 4 | 5 | (* @type ('a,'b,'c) triple = Triple of 'a*'b*'c 6 | * with foldr,foldl,eq,compare,stateful,eval,gmap,html,fmt,show *) 7 | 8 | 9 | (* @type ('a) t = Lazy of 'a 10 | * with foldr,foldl,eq,compare,stateful,eval,gmap,html,fmt,show *) 11 | 12 | let () = ();; 13 | 14 | module A = struct 15 | @type 'a t = [ `A ] with stateful 16 | end 17 | (* module B = struct 18 | * @type 'b t = [ `B ] with stateful 19 | * end 20 | * 21 | * module Z = struct 22 | * @type 'x t = [ GT.int A.t | GT.string B.t ] with stateful 23 | * 24 | * end *) 25 | -------------------------------------------------------------------------------- /regression/test011.t: -------------------------------------------------------------------------------- 1 | $ ./test011.exe 2 | -------------------------------------------------------------------------------- /regression/test012.ml: -------------------------------------------------------------------------------- 1 | @type a = [`A of GT.int | `B of GT.string] with show, eq, compare 2 | @type b = [`C of GT.int | `D of GT.string] with show, eq, compare 3 | @type c = [a | b] with show, eq, compare 4 | 5 | let _ = 6 | let x = `A 3 in 7 | let y = `D "2" in 8 | Printf.printf "%s\n" @@ GT.show(a) x; 9 | Printf.printf "%s\n" @@ GT.show(b) y; 10 | Printf.printf "%s\n" @@ GT.show(c) x; 11 | Printf.printf "%s\n" @@ GT.show(c) y; 12 | Printf.printf "%b\n" @@ GT.eq(a) x x; 13 | Printf.printf "%b\n" @@ GT.eq(b) y y; 14 | Printf.printf "%b\n" @@ GT.eq(c) x x; 15 | Printf.printf "%b\n" @@ GT.eq(c) y y; 16 | Printf.printf "%b\n" @@ GT.eq(c) x y; 17 | -------------------------------------------------------------------------------- /regression/test012.mli: -------------------------------------------------------------------------------- 1 | @type a = [`A of GT.int | `B of GT.string] with show, eq, compare 2 | @type b = [`C of GT.int | `D of GT.string] with show, eq, compare 3 | @type c = [a | b] with show, eq, compare 4 | -------------------------------------------------------------------------------- /regression/test012.t: -------------------------------------------------------------------------------- 1 | $ ./test012.exe 2 | `A (3) 3 | `D ("2") 4 | `A (3) 5 | `D ("2") 6 | true 7 | true 8 | true 9 | true 10 | false 11 | -------------------------------------------------------------------------------- /regression/test013.ml: -------------------------------------------------------------------------------- 1 | @type a = [`A of GT.int | `B of b] with show 2 | and b = [`C of GT.string | `D of a] with show 3 | 4 | @type c = [a | b] with show 5 | 6 | (* Doesn't work for now *) 7 | class show_c' fself = 8 | object 9 | inherit [c] @c[show] fself 10 | method! c_C () _ s = "new C " ^ s 11 | end 12 | 13 | 14 | class [ 'fself ] show_b' prereq = 15 | object 16 | inherit [ 'fself ] show_b_t_stub prereq 17 | method! c_C () _ s = "new C " ^ s 18 | end 19 | 20 | let show_b_new eta = let (_,f) = fix_a_b (new show_a_t_stub) (new show_b') in f eta 21 | 22 | let _ = 23 | let y = `D (`B (`C "5")) in 24 | Printf.printf "%s\n" (GT.transform(c) (new @c[show]) () y); 25 | Printf.printf "%s\n" (show_b_new () y) 26 | -------------------------------------------------------------------------------- /regression/test013.mli: -------------------------------------------------------------------------------- 1 | @type a = [`A of GT.int | `B of b] with show 2 | and b = [`C of GT.string | `D of a] with show 3 | 4 | @type c = [a | b] with show 5 | -------------------------------------------------------------------------------- /regression/test013.t: -------------------------------------------------------------------------------- 1 | $ ./test013.exe 2 | `D (`B (`C ("5"))) 3 | `D (`B (new C 5)) 4 | -------------------------------------------------------------------------------- /regression/test014.ml: -------------------------------------------------------------------------------- 1 | @type a = A of b | C of GT.int GT.list with show 2 | and b = B of c | D of GT.string with show 3 | and c = E of a with show 4 | 5 | class show_a_new ((_,fb,_) as prereq) = 6 | object 7 | inherit [_] @a[show] prereq as super 8 | method! c_C () x y = "new " ^ super#c_C () x y 9 | method! c_A () _ x = "new A " ^ (fb () x) 10 | end 11 | 12 | let show_a_new eta = 13 | let (f,_,_) = fix_a_b_c (new show_a_new) (new show_b_t_stub) (new show_c_t_stub) in 14 | f eta 15 | 16 | 17 | let _ = 18 | let x = A (B (E (C [1; 2; 3; 4]))) in 19 | let y = B (E (A (D "3"))) in 20 | Printf.printf "%s\n" (GT.transform(a) (new @a[show]) () x); 21 | Printf.printf "%s\n" (GT.transform(b) (new @b[show]) () y); 22 | Printf.printf "%s\n" (show_a_new () x); 23 | -------------------------------------------------------------------------------- /regression/test014.mli: -------------------------------------------------------------------------------- 1 | @type a = A of b | C of GT.int GT.list with show 2 | and b = B of c | D of GT.string with show 3 | and c = E of a with show 4 | -------------------------------------------------------------------------------- /regression/test014.t: -------------------------------------------------------------------------------- 1 | $ ./test014.exe 2 | A (B (E (C ([1; 2; 3; 4])))) 3 | B (E (A (D ("3")))) 4 | new A B (E (new C ([1; 2; 3; 4]))) 5 | -------------------------------------------------------------------------------- /regression/test015.ml: -------------------------------------------------------------------------------- 1 | @type 'a tree = Node of 'a * 'a tree GT.list with show, foldl, foldr 2 | 3 | let _ = 4 | let x = Node (1, [Node (2, [Node (5, [])]); Node (3, []); Node (4, [Node (6, [])])]) in 5 | let n = GT.transform(tree) (new @tree[foldl] (+)) 0 x in 6 | 7 | let fa s x = if s = "" then string_of_int x else s ^ ", " ^ string_of_int x in 8 | let sl = GT.transform(tree) (new @tree[foldl] fa) "" x in 9 | let sr = GT.transform(tree) (new @tree[foldr] fa) "" x in 10 | Printf.printf "%s\n" @@ 11 | GT.transform(tree) (new @tree[show] (GT.lift string_of_int)) () x; 12 | Printf.printf "%d\n" n; 13 | Printf.printf "%s\n" sl; 14 | Printf.printf "%s\n" sr 15 | -------------------------------------------------------------------------------- /regression/test015.mli: -------------------------------------------------------------------------------- 1 | @type 'a tree = Node of 'a * 'a tree GT.list with show, foldl, foldr 2 | -------------------------------------------------------------------------------- /regression/test015.t: -------------------------------------------------------------------------------- 1 | $ ./test015.exe 2 | Node (1, [Node (2, [Node (5, [])]); Node (3, []); Node (4, [Node (6, [])])]) 3 | 21 4 | 1, 2, 5, 3, 4, 6 5 | 6, 4, 3, 5, 2, 1 6 | -------------------------------------------------------------------------------- /regression/test016.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b, 'c) t = A of 'a | B of 'b | C of 'c with eq 2 | 3 | let _ = 4 | let x = A 1 in 5 | let y = B "2" in 6 | let z = C "4" in 7 | let compare x y = GT.transform(t) (new @t[eq] (=) (=) (=)) x y in 8 | Printf.printf "x == x: %b\n" (compare x x); 9 | Printf.printf "x == y: %b\n" (compare x y); 10 | Printf.printf "x == z: %b\n" (compare x z) 11 | -------------------------------------------------------------------------------- /regression/test016.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b, 'c) t = A of 'a | B of 'b | C of 'c with eq 2 | 3 | -------------------------------------------------------------------------------- /regression/test016.t: -------------------------------------------------------------------------------- 1 | $ ./test016.exe 2 | x == x: true 3 | x == y: false 4 | x == z: false 5 | -------------------------------------------------------------------------------- /regression/test017.ml: -------------------------------------------------------------------------------- 1 | @type t = A of GT.int | B of GT.string | C of GT.int GT.list with eq 2 | 3 | let _ = 4 | let x = A 1 in 5 | let y = B "2" in 6 | let z = C [4] in 7 | let compare x y = GT.transform(t) (new @t[eq]) x y in 8 | Printf.printf "x == x: %b\n" (compare x x); 9 | Printf.printf "x == y: %b\n" (compare x y); 10 | Printf.printf "x == z: %b\n" (compare x z) 11 | -------------------------------------------------------------------------------- /regression/test017.mli: -------------------------------------------------------------------------------- 1 | @type t = A of GT.int | B of GT.string | C of GT.int GT.list with eq 2 | 3 | -------------------------------------------------------------------------------- /regression/test017.t: -------------------------------------------------------------------------------- 1 | $ ./test017.exe 2 | x == x: true 3 | x == y: false 4 | x == z: false 5 | -------------------------------------------------------------------------------- /regression/test018.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b, 'c) t = A of 'a | B of 'b | C of 'c with eq, compare 2 | 3 | let _ = 4 | let x = A 1 in 5 | let y = B "2" in 6 | let z = C "4" in 7 | let compare x y = 8 | match GT.transform(t) 9 | (new @t[compare] GT.compare_primitive GT.compare_primitive GT.compare_primitive) x y 10 | with 11 | | GT.EQ -> "EQ" 12 | | GT.LT -> "LT" 13 | | GT.GT -> "GT" 14 | in 15 | Printf.printf "x == x: %s\n" (compare x x); 16 | Printf.printf "x == y: %s\n" (compare x y); 17 | Printf.printf "x == z: %s\n" (compare x z) 18 | -------------------------------------------------------------------------------- /regression/test018.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b, 'c) t = A of 'a | B of 'b | C of 'c with eq, compare 2 | 3 | -------------------------------------------------------------------------------- /regression/test018.t: -------------------------------------------------------------------------------- 1 | $ ./test018.exe 2 | x == x: EQ 3 | x == y: LT 4 | x == z: LT 5 | -------------------------------------------------------------------------------- /regression/test019.ml: -------------------------------------------------------------------------------- 1 | @type t = A of GT.int | B of GT.string | C of GT.int GT.list with eq, compare 2 | 3 | let _ = 4 | let x = A 1 in 5 | let y = B "2" in 6 | let z = C [4] in 7 | let z' = C [4] in 8 | let z'' = C [] in 9 | let compare x y = 10 | match GT.transform(t) (new @t[compare]) x y with 11 | | GT.GT -> "GT" 12 | | GT.LT -> "LT" 13 | | GT.EQ -> "EQ" 14 | in 15 | Printf.printf "x == x: %s\n" (compare x x); 16 | Printf.printf "x == y: %s\n" (compare x y); 17 | Printf.printf "y == x: %s\n" (compare y x); 18 | Printf.printf "x == z: %s\n" (compare x z); 19 | Printf.printf "z' == z: %s\n" (compare z' z); 20 | Printf.printf "z'' == z: %s\n" (compare z'' z) 21 | -------------------------------------------------------------------------------- /regression/test019.mli: -------------------------------------------------------------------------------- 1 | @type t = A of GT.int | B of GT.string | C of GT.int GT.list with eq, compare 2 | 3 | -------------------------------------------------------------------------------- /regression/test019.t: -------------------------------------------------------------------------------- 1 | $ ./test019.exe 2 | x == x: EQ 3 | x == y: LT 4 | y == x: GT 5 | x == z: LT 6 | z' == z: EQ 7 | z'' == z: LT 8 | -------------------------------------------------------------------------------- /regression/test020.ml: -------------------------------------------------------------------------------- 1 | @type 'a t = A of GT.int | B of GT.string | C of 'a GT.list with eq, compare 2 | 3 | let _ = 4 | let x = A 1 in 5 | let y = B "2" in 6 | let z = C [4] in 7 | let z' = C [4] in 8 | let z'' = C [] in 9 | let compare x y = 10 | let open GT in 11 | match transform(t) (new @t[compare] 12 | (fun y -> transform(int) (new @int[compare]) y)) x y with 13 | | GT.GT -> "GT" 14 | | GT.LT -> "LT" 15 | | GT.EQ -> "EQ" 16 | in 17 | Printf.printf "x == x: %s\n" (compare x x); 18 | Printf.printf "x == y: %s\n" (compare x y); 19 | Printf.printf "y == x: %s\n" (compare y x); 20 | Printf.printf "x == z: %s\n" (compare x z); 21 | Printf.printf "z' == z: %s\n" (compare z' z); 22 | Printf.printf "z'' == z: %s\n" (compare z'' z) 23 | -------------------------------------------------------------------------------- /regression/test020.mli: -------------------------------------------------------------------------------- 1 | @type 'a t = A of GT.int | B of GT.string | C of 'a GT.list with eq, compare 2 | 3 | -------------------------------------------------------------------------------- /regression/test020.t: -------------------------------------------------------------------------------- 1 | $ ./test020.exe 2 | x == x: EQ 3 | x == y: LT 4 | y == x: GT 5 | x == z: LT 6 | z' == z: EQ 7 | z'' == z: LT 8 | -------------------------------------------------------------------------------- /regression/test021.ml: -------------------------------------------------------------------------------- 1 | @type a = [`A of b | `C of GT.int GT.list] with show 2 | and b = [`B of a | `D of GT.string] with show 3 | 4 | class ['extra] show_a_t_stub2 (fora,forb) = object 5 | inherit ['extra] show_a_t_stub (fora,forb) as super 6 | method c_C () a xs = "new " ^ (super#c_C () a xs) 7 | end 8 | 9 | 10 | (* let show_a_fix2 = 11 | * Fix_show_a.fixv 12 | * (fun f -> 13 | * {call = 14 | * fun (type a) (sym : a Ishow_a.i) -> 15 | * (match sym with 16 | * Ishow_a.A -> GT.transform_gc gcata_a (new show_a' f) 17 | * | Ishow_a.B -> GT.transform_gc gcata_b (new show_b_t f) : 18 | * a)}) *) 19 | 20 | let show_a' s = (fst @@ fix_a_b (new show_a_t_stub2) (new show_b_t_stub)) () s 21 | 22 | let _ = 23 | let x = `A (`B (`C [1; 2; 3; 4])) in 24 | let y = `B (`A (`D "3")) in 25 | Printf.printf "%s\n" (GT.transform(a) (new @a[show]) () x); 26 | Printf.printf "%s\n" (GT.transform(b) (new @b[show]) () y); 27 | Printf.printf "%s\n" (show_a' x) 28 | -------------------------------------------------------------------------------- /regression/test021.mli: -------------------------------------------------------------------------------- 1 | (* @type a = [`A of b | `C of GT.int GT.list] 2 | * and b = [`B of a | `D of GT.string] 3 | * with show *) 4 | -------------------------------------------------------------------------------- /regression/test021.t: -------------------------------------------------------------------------------- 1 | $ ./test021.exe 2 | `A (`B (`C ([1; 2; 3; 4]))) 3 | `B (`A (`D ("3"))) 4 | `A (`B (new `C ([1; 2; 3; 4]))) 5 | -------------------------------------------------------------------------------- /regression/test022.ml: -------------------------------------------------------------------------------- 1 | @type 'a t = A of 'a GT.option GT.list with show, eq 2 | 3 | let _ = 4 | let x = A [Some 1; None; Some 2; None] in 5 | let y = A [Some 1; None; Some 2; Some 4] in 6 | let z = A [] in 7 | let si = string_of_int in 8 | Printf.printf "x=%s\n" (GT.show(t) si x); 9 | Printf.printf "y=%s\n" (GT.show(t) si y); 10 | Printf.printf "z=%s\n" (GT.show(t) si z); 11 | Printf.printf "x == x = %b\n" (GT.eq(t) (=) x x); 12 | Printf.printf "x == y = %b\n" (GT.eq(t) (=) x y); 13 | Printf.printf "x == z = %b\n" (GT.eq(t) (=) x z) 14 | -------------------------------------------------------------------------------- /regression/test022.mli: -------------------------------------------------------------------------------- 1 | @type 'a t = A of 'a GT.option GT.list with show, eq 2 | -------------------------------------------------------------------------------- /regression/test022.t: -------------------------------------------------------------------------------- 1 | $ ./test022.exe 2 | x=A ([Some (1); None; Some (2); None]) 3 | y=A ([Some (1); None; Some (2); Some (4)]) 4 | z=A ([]) 5 | x == x = true 6 | x == y = false 7 | x == z = false 8 | -------------------------------------------------------------------------------- /regression/test023.ml: -------------------------------------------------------------------------------- 1 | @type 'a a = [`A of 'a | `B of GT.string] with show, eq, compare 2 | @type b = [`C of GT.int | `D of GT.string] with show, eq, compare 3 | @type 'a c = ['a a | b] with show, eq, compare 4 | 5 | let _ = 6 | let x = `A 3 in 7 | let y = `D "2" in 8 | Printf.printf "%s\n" (GT.show(a) (GT.show GT.int) x); 9 | Printf.printf "%s\n" (GT.show(b) y); 10 | Printf.printf "%s\n" (GT.show(c) (GT.show GT.int) x); 11 | Printf.printf "%s\n" (GT.show(c) (GT.show GT.int) y); 12 | Printf.printf "%b\n" (GT.eq(a) (=) x x); 13 | Printf.printf "%b\n" (GT.eq(b) y y); 14 | Printf.printf "%b\n" (GT.eq(c) (=) x x); 15 | Printf.printf "%b\n" (GT.eq(c) (=) y y); 16 | Printf.printf "%b\n" (GT.eq(c) (=) x y) 17 | -------------------------------------------------------------------------------- /regression/test023.mli: -------------------------------------------------------------------------------- 1 | @type 'a a = [`A of 'a | `B of GT.string] with show, eq, compare 2 | @type b = [`C of GT.int | `D of GT.string] with show, eq, compare 3 | @type 'a c = ['a a | b] with show, eq, compare 4 | -------------------------------------------------------------------------------- /regression/test023.t: -------------------------------------------------------------------------------- 1 | $ ./test023.exe 2 | `A (3) 3 | `D ("2") 4 | `A (3) 5 | `D ("2") 6 | true 7 | true 8 | true 9 | true 10 | false 11 | -------------------------------------------------------------------------------- /regression/test024.ml: -------------------------------------------------------------------------------- 1 | @type 'a a = [`A of 'a | `B of GT.string] with show, eq, compare 2 | @type 'a b = [`C of 'a | `D of GT.string] with show, eq, compare 3 | @type ('a, 'b) c = ['a a | 'b b] with show, eq, compare 4 | 5 | let _ = 6 | let x = `A 3 in 7 | let y = `C 2 in 8 | Printf.printf "%s\n" (GT.show(a) (GT.show GT.int) x); 9 | Printf.printf "%s\n" (GT.show(b) (GT.show GT.int) y); 10 | Printf.printf "%s\n" (GT.show(c) (GT.show GT.int) string_of_int x); 11 | Printf.printf "%s\n" (GT.show(c) (GT.show GT.int) string_of_int y); 12 | Printf.printf "%b\n" (GT.eq(a) (=) x x); 13 | Printf.printf "%b\n" (GT.eq(b) (=) y y); 14 | Printf.printf "%b\n" (GT.eq(c) (=) (=) x x); 15 | Printf.printf "%b\n" (GT.eq(c) (=) (=) y y); 16 | Printf.printf "%b\n" (GT.eq(c) (=) (=) x y); 17 | () 18 | -------------------------------------------------------------------------------- /regression/test024.mli: -------------------------------------------------------------------------------- 1 | @type 'a a = [`A of 'a | `B of GT.string] with show, eq, compare 2 | @type 'a b = [`C of 'a | `D of GT.string] with show, eq, compare 3 | @type ('a, 'b) c = ['a a | 'b b] with show, eq, compare 4 | -------------------------------------------------------------------------------- /regression/test024.t: -------------------------------------------------------------------------------- 1 | $ ./test024.exe 2 | `A (3) 3 | `C (2) 4 | `A (3) 5 | `C (2) 6 | true 7 | true 8 | true 9 | true 10 | false 11 | -------------------------------------------------------------------------------- /regression/test025.ml: -------------------------------------------------------------------------------- 1 | (* The same as test026 but with polymorphic variants *) 2 | @type ('a, 'b) a = [`A of 'a | `B of 'b] with show, eq 3 | @type ('a, 'b) b = [('b, 'a) a] with show, eq 4 | 5 | let _ = 6 | let x = `A 3 in 7 | let y = `A "2" in 8 | Printf.printf "%s\n" (GT.show(a) (GT.show GT.int) (GT.show GT.string) x); 9 | Printf.printf "%s\n" (GT.show(a) (GT.show GT.string) (GT.show GT.int) y); 10 | Printf.printf "%s\n" (GT.show(b) (GT.show GT.string) (GT.show GT.int) x); 11 | Printf.printf "%s\n" (GT.show(b) (GT.show GT.int) (GT.show GT.string) y); 12 | Printf.printf "%b\n" (GT.eq(a) (=) (=) x x); 13 | Printf.printf "%b\n" (GT.eq(b) (=) (=) x x); 14 | -------------------------------------------------------------------------------- /regression/test025.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) a = [`A of 'a | `B of 'b] with show, eq 2 | @type ('a, 'b) b = [('b, 'a) a] with show, eq 3 | -------------------------------------------------------------------------------- /regression/test025.t: -------------------------------------------------------------------------------- 1 | $ ./test025.exe 2 | `A (3) 3 | `A ("2") 4 | `A (3) 5 | `A ("2") 6 | true 7 | true 8 | -------------------------------------------------------------------------------- /regression/test026.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) a = A of 'a | B of 'b with show, eq 2 | @type ('a, 'b) b = ('b, 'a) a with show, eq 3 | 4 | let _ = 5 | let x = A 3 in 6 | let y = A "2" in 7 | let string x = x in 8 | 9 | Printf.printf "%s\n" (GT.show(a) GT.(show int) string x); 10 | Printf.printf "%s\n" (GT.show(a) string GT.(show int) y); 11 | Printf.printf "%s\n" (GT.show(b) string GT.(show int) x); 12 | Printf.printf "%s\n" (GT.show(b) GT.(show int) string y); 13 | Printf.printf "%b\n" (GT.eq(a) (=) (=) x x); 14 | Printf.printf "%b\n" (GT.eq(b) (=) (=) x x); 15 | -------------------------------------------------------------------------------- /regression/test026.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) a = A of 'a | B of 'b with show, eq 2 | @type ('a, 'b) b = ('b, 'a) a with show, eq 3 | -------------------------------------------------------------------------------- /regression/test026.t: -------------------------------------------------------------------------------- 1 | $ ./test026.exe 2 | A (3) 3 | A (2) 4 | A (3) 5 | A (2) 6 | true 7 | true 8 | -------------------------------------------------------------------------------- /regression/test027.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type ('a, 'b) t = {x: int; y: string; a: 'a; b: 'b} with show, gmap, eq, compare, foldl, foldr 4 | 5 | class ['a, 'b, 'self] print fa fb _prereq = object 6 | inherit [unit, 'a, unit, unit, 'b, unit, unit, 'self, unit] @t 7 | method do_t _ {x; y; a; b} = 8 | Printf.printf "%d\n" x; 9 | Printf.printf "%s\n" y; 10 | fa () a; 11 | fb () b; 12 | end 13 | 14 | let _ = 15 | let cs = function EQ -> "EQ" | GT -> "GT" | LT -> "LT" in 16 | let c x y = if x = y then EQ else if x < y then LT else GT in 17 | let x = {x=1; y="2"; a="a"; b=`B} in 18 | let y = {x=1; y="2"; a="3"; b=`B} in 19 | Printf.printf "x == x: %b\n" (transform(t) (new @t[eq] (=) (=)) x x); 20 | Printf.printf "x == y: %b\n" (transform(t) (new @t[eq] (=) (=)) x y); 21 | Printf.printf "compare (x, x) = %s\n" (cs (transform(t) (new @t[compare] c c) x x)); 22 | Printf.printf "compare (x, y) = %s\n" (cs (transform(t) (new @t[compare] c c) x y)); 23 | Printf.printf "compare (y, x) = %s\n" (cs (transform(t) (new @t[compare] c c) y x)); 24 | Printf.printf "%s\n" 25 | (transform(t) 26 | (new @t[show] (fun _ a -> string_of_int a) (fun _ -> function `B -> "`B") ) 27 | () 28 | (transform(t) (new @t[gmap] (fun _ x -> int_of_string x) (fun _ x -> x)) () y) 29 | ); 30 | transform(t) 31 | (new print (fun _ a -> Printf.printf "%s\n" a) (fun _ -> function `B -> Printf.printf "`B\n") ) 32 | () 33 | x 34 | -------------------------------------------------------------------------------- /regression/test027.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = {x: int; y: string; a: 'a; b: 'b} with show, gmap, eq, compare, foldl, foldr 2 | -------------------------------------------------------------------------------- /regression/test027.t: -------------------------------------------------------------------------------- 1 | $ ./test027.exe 2 | x == x: true 3 | x == y: false 4 | compare (x, x) = EQ 5 | compare (x, y) = GT 6 | compare (y, x) = LT 7 | { x=1; y="2"; a=3; b=`B; } 8 | 1 9 | 2 10 | a 11 | `B 12 | -------------------------------------------------------------------------------- /regression/test028.ml: -------------------------------------------------------------------------------- 1 | (* The same as test027 but tuple instead of record *) 2 | open GT 3 | 4 | @type ('a, 'b) t = (int * string * 'a * 'b) with show, gmap, foldr, foldl, eq, compare 5 | 6 | class ['a, 'b, 'self] print fa fb _prereq = object 7 | inherit [unit, 'a, unit, unit, 'b, unit, unit, 'self, unit] @t 8 | method c_T _ (x, y, a, b) = 9 | Printf.printf "%d\n" x; 10 | Printf.printf "%s\n" y; 11 | fa () a; 12 | fb () b; 13 | end 14 | 15 | let _ = 16 | let cs = function EQ -> "EQ" | GT -> "GT" | LT -> "LT" in 17 | let c x y = if x = y then EQ else if x < y then LT else GT in 18 | let x = (1, "2", "a", `B) in 19 | let y = (1, "2", "3", `B) in 20 | Printf.printf "x == x: %b\n" (transform(t) (new @t[eq] (=) (=)) x x); 21 | Printf.printf "x == y: %b\n" (transform(t) (new @t[eq] (=) (=)) x y); 22 | Printf.printf "compare (x, x) = %s\n" (cs (transform(t) (new @t[compare] c c) x x)); 23 | Printf.printf "compare (x, y) = %s\n" (cs (transform(t) (new @t[compare] c c) x y)); 24 | Printf.printf "compare (y, x) = %s\n" (cs (transform(t) (new @t[compare] c c) y x)); 25 | Printf.printf "%s\n" 26 | (transform(t) 27 | (new @t[show] (fun _ a -> string_of_int a) (fun _ -> function `B -> "`B") ) 28 | () 29 | (transform(t) (new @t[gmap] (fun _ x -> int_of_string x) (fun _ x -> x)) () y) 30 | ); 31 | transform(t) 32 | (new print (fun _ a -> Printf.printf "%s\n" a) (fun _ -> function `B -> Printf.printf "`B\n") ) 33 | () 34 | x 35 | -------------------------------------------------------------------------------- /regression/test028.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = (int * string * 'a * 'b) with show, gmap, foldl, foldr, eq, compare 2 | -------------------------------------------------------------------------------- /regression/test028.t: -------------------------------------------------------------------------------- 1 | $ ./test028.exe 2 | x == x: true 3 | x == y: false 4 | compare (x, x) = EQ 5 | compare (x, y) = GT 6 | compare (y, x) = LT 7 | (1, "2", 3, `B) 8 | 1 9 | 2 10 | a 11 | `B 12 | -------------------------------------------------------------------------------- /regression/test029.ml: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = GT.int * (GT.string * ('a * 'b)) 2 | with show, gmap, eq, compare, foldl, foldr 3 | 4 | class ['a, 'b] print (fa: unit -> 'a -> unit) (fb: unit -> 'b -> unit) _fself = 5 | object 6 | inherit [unit, 'a, unit, unit, 'b, unit, unit, _, unit] @t 7 | method c_T () (x, (y, (a, b))) = 8 | Printf.printf "%d\n" x; 9 | Printf.printf "%s\n" y; 10 | fa () a; 11 | fb () b 12 | end 13 | 14 | let printer fa fb subj = 15 | GT.transform(t) (new print fa fb) subj 16 | 17 | let _ = 18 | let cs = function GT.EQ -> "EQ" | GT -> "GT" | LT -> "LT" in 19 | let c x y = if x = y then GT.EQ else if x < y then LT else GT in 20 | let x = (1, ("2", ("a", `B))) in 21 | let y = (1, ("2", ("3", `B))) in 22 | let eq1 a b = GT.transform(t) (new @t[eq] (=) (=)) a b in 23 | Printf.printf "x == x: %b\n" (eq1 x x); 24 | Printf.printf "x == y: %b\n" (eq1 x y); 25 | let cmp1 a b = GT.transform(t) (new @t[compare] c c) a b in 26 | Printf.printf "compare (x, x) = %s\n" (cs @@ cmp1 x x); 27 | Printf.printf "compare (x, y) = %s\n" (cs @@ cmp1 x y); 28 | Printf.printf "compare (y, x) = %s\n" (cs @@ cmp1 y x); 29 | Printf.printf "%s\n" @@ 30 | GT.show(t) GT.(show int) (function `B -> "`B") @@ 31 | GT.gmap(t) int_of_string Fun.id y 32 | ; 33 | GT.transform(t) 34 | (new print 35 | GT.(lift @@ Printf.printf "%s\n") 36 | (fun () -> function `B -> Printf.printf "`B\n")) 37 | () 38 | x 39 | -------------------------------------------------------------------------------- /regression/test029.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = int * (string * ('a * 'b)) 2 | with show, gmap, eq, compare, foldr, foldl 3 | -------------------------------------------------------------------------------- /regression/test029.t: -------------------------------------------------------------------------------- 1 | $ ./test029.exe 2 | x == x: true 3 | x == y: false 4 | compare (x, x) = EQ 5 | compare (x, y) = GT 6 | compare (y, x) = LT 7 | (1, ("2", (3, `B))) 8 | 1 9 | 2 10 | a 11 | `B 12 | -------------------------------------------------------------------------------- /regression/test030.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type ('a, 'b) t = A of ('a * 'b) with show, gmap, foldl, foldr, eq, compare 4 | 5 | class ['a,'b] print fa fb _fself = 6 | object 7 | inherit [unit, 'a, string, unit, 'b, string, unit, ('a,'b) t, unit] @t 8 | method c_A _ _ (a, b) = Printf.printf "A (%s, %s)\n" (fa () a) (fb () b) 9 | end 10 | 11 | let _ = 12 | let cs = function EQ -> "EQ" | GT -> "GT" | LT -> "LT" in 13 | let c x y = if x = y then EQ else if x < y then LT else GT in 14 | let x = A (1, "2") in 15 | let y = A (1, "3") in 16 | Printf.printf "x == x: %b\n" (GT.eq(t) (=) (=) x x); 17 | Printf.printf "x == y: %b\n" (GT.eq(t) (=) (=) x y); 18 | Printf.printf "compare (x, x) = %s\n" (cs (GT.compare(t) c c x x)); 19 | Printf.printf "compare (x, y) = %s\n" (cs (GT.compare(t) c c x y)); 20 | Printf.printf "compare (y, x) = %s\n" (cs (GT.compare(t) c c y x)); 21 | Printf.printf "%s\n" 22 | (GT.show(t) Fun.id string_of_int @@ 23 | GT.gmap(t) string_of_int int_of_string @@ 24 | A (1, "2") 25 | ); 26 | transform(t) (new print (GT.lift string_of_int) (GT.lift Fun.id)) () (A (1, "2")) 27 | -------------------------------------------------------------------------------- /regression/test030.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = A of ('a * 'b) with show, gmap, foldl, foldr, eq, compare 2 | -------------------------------------------------------------------------------- /regression/test030.t: -------------------------------------------------------------------------------- 1 | $ ./test030.exe 2 | x == x: true 3 | x == y: false 4 | compare (x, x) = EQ 5 | compare (x, y) = LT 6 | compare (y, x) = GT 7 | A ((1, 2)) 8 | A (1, 2) 9 | -------------------------------------------------------------------------------- /regression/test031.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type ('a, 'b) t = {x: int; y: string; a: 'a; b: 'b} with show, gmap 4 | 5 | class ['a, 'b] print fa fb _ = 6 | object 7 | inherit [unit, 'a, unit, unit, 'b, unit, unit, _, unit] @t 8 | method do_t () {x; y; a; b } = 9 | Printf.printf "%d\n" x; 10 | Printf.printf "%s\n" y; 11 | let () = fa () a in 12 | let () = fb () b in 13 | () 14 | end 15 | 16 | let _ = 17 | Printf.printf "%s\n" 18 | (GT.show(t) string_of_int Fun.id @@ 19 | GT.gmap(t) int_of_string (fun `B -> "`B") @@ 20 | {x=1; y="2"; a="3"; b=`B} 21 | ) 22 | ; 23 | GT.transform(t) (new print 24 | (fun () -> Printf.printf "%s\n") 25 | (fun () `B -> Printf.printf "`B\n") ) 26 | () 27 | {x=1; y="2"; a="a"; b=`B} 28 | -------------------------------------------------------------------------------- /regression/test031.mli: -------------------------------------------------------------------------------- 1 | @type ('a, 'b) t = {x: int; y: string; a: 'a; b: 'b} with show, gmap 2 | -------------------------------------------------------------------------------- /regression/test031.t: -------------------------------------------------------------------------------- 1 | $ ./test031.exe 2 | { x=1; y="2"; a=3; b=`B; } 3 | 1 4 | 2 5 | a 6 | `B 7 | -------------------------------------------------------------------------------- /regression/test032.ml: -------------------------------------------------------------------------------- 1 | (* Should be merged in another test *) 2 | open GT 3 | 4 | @type test = string with stateful,eval,compare,eq,foldl, foldr,gmap,fmt, html,show 5 | 6 | let _ = 7 | Printf.printf "%s\n" (transform(test) (new @test[show]) () "abc") 8 | -------------------------------------------------------------------------------- /regression/test032.mli: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type test = string with stateful,eval,compare,eq,foldl, foldr,gmap,fmt, html,show 4 | -------------------------------------------------------------------------------- /regression/test032.t: -------------------------------------------------------------------------------- 1 | $ ./test032.exe 2 | "abc" 3 | -------------------------------------------------------------------------------- /regression/test036.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type expr = 4 | | Sub of (expr * expr) | Add of expr * expr | Ident of string | Const of int 5 | with show, html, gmap, foldl, foldr, eq, compare 6 | 7 | let etoHTML e = 8 | HTML.toHTML ( 9 | HTML.html ( 10 | HTML.ul ( 11 | HTML.li (transform(expr) (new @expr[html]) () e) 12 | ) 13 | ) 14 | );; 15 | 16 | @type str = {a : expr; b : expr} with html 17 | 18 | let stoHTML e = 19 | HTML.toHTML ( 20 | HTML.html ( 21 | HTML.ul ( 22 | HTML.li (transform(str) (new @str[html]) () e) 23 | ) 24 | ) 25 | ) 26 | 27 | let _ = 28 | Printf.printf "%s\n" (etoHTML (Add (Ident "b", Add (Sub (Ident "a", Ident "b"), Const 1)))); 29 | Printf.printf "%s\n" (stoHTML {a=(Add (Ident "b", Add (Sub (Ident "a", Ident "b"), Const 1))); b = Ident "c"}); 30 | -------------------------------------------------------------------------------- /regression/test036.mli: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type expr = 4 | | Sub of (expr * expr) | Add of expr * expr | Ident of string | Const of int 5 | with show, html, gmap, foldl, foldr, eq, compare 6 | 7 | @type str = {a : expr; b : expr} with html 8 | -------------------------------------------------------------------------------- /regression/test036.t: -------------------------------------------------------------------------------- 1 | $ ./test036.exe 2 | 3 | 4 | -------------------------------------------------------------------------------- /regression/test037.ml: -------------------------------------------------------------------------------- 1 | module M : sig 2 | @type 'a t1 = [`A | `B of 'a] with show, gmap;; 3 | @type 'a t2 = [`C | `D of 'a] with show, gmap;; 4 | @type 'a t = ['a t1 | 'a t2] with show, gmap;; 5 | end = struct 6 | @type 'a t1 = [`A | `B of 'a] with show, gmap;; 7 | @type 'a t2 = [`C | `D of 'a] with show, gmap;; 8 | @type 'a t = ['a t1 | 'a t2] with show, gmap;; 9 | 10 | let _ = 11 | let a = `B (`B `A) in 12 | let rec mapt1 () x = 13 | GT.transform(t1) (new gmap_t1_t mapt1) () x 14 | in 15 | let rec show1 () x = 16 | GT.transform(t1) (new show_t1_t show1) () x 17 | in 18 | Printf.printf "a=%s, map a=%s\n" (show1 () a) (show1 () (mapt1 () a)); 19 | 20 | let b = `D (`D `C) in 21 | let rec mapt2 () x = 22 | GT.transform(t2) (new gmap_t2_t mapt2) () x 23 | in 24 | let rec show2 () x = 25 | GT.transform(t2) (new show_t2_t show2) () x 26 | in 27 | Printf.printf "b=%s, map b=%s\n" (show2 () b) (show2 () (mapt2 () b)); 28 | 29 | let c = `D (`B (`D `A)) in 30 | let rec mapt () x = 31 | GT.transform(t) (new gmap_t_t mapt) () x 32 | in 33 | let rec show () x = 34 | GT.transform(t) (new show_t_t show) () x 35 | in 36 | Printf.printf "c=%s, map c=%s\n" (show () c) (show () (mapt () c)) 37 | end 38 | -------------------------------------------------------------------------------- /regression/test037.mli: -------------------------------------------------------------------------------- 1 | module M : sig 2 | @type 'a t1 = [`A | `B of 'a] with show, gmap 3 | @type 'a t2 = [`C | `D of 'a] with show, gmap 4 | @type 'a t = ['a t1 | 'a t2] with show, gmap 5 | end 6 | -------------------------------------------------------------------------------- /regression/test037.t: -------------------------------------------------------------------------------- 1 | $ ./test037.exe 2 | a=`B (`B (`A)), map a=`B (`B (`A)) 3 | b=`D (`D (`C)), map b=`D (`D (`C)) 4 | c=`D (`B (`D (`A))), map c=`D (`B (`D (`A))) 5 | -------------------------------------------------------------------------------- /regression/test040.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | @type t = Array of t array with show 4 | -------------------------------------------------------------------------------- /regression/test040.t: -------------------------------------------------------------------------------- 1 | $ ./test040.exe 2 | -------------------------------------------------------------------------------- /regression/test041.ml: -------------------------------------------------------------------------------- 1 | @type ('self) t = 2 | | Abs of 'self 3 | with show,html,gmap,fmt,eval,stateful,foldl,foldr,compare,eq 4 | -------------------------------------------------------------------------------- /regression/test041.t: -------------------------------------------------------------------------------- 1 | $ ./test041.exe 2 | -------------------------------------------------------------------------------- /regression/test042.ml: -------------------------------------------------------------------------------- 1 | module L : sig 2 | @type 'a list = [ `Nil | `Cons of ('a * 'a list) ] with gmap,show 3 | 4 | end = struct 5 | @type 'a list = [ `Nil | `Cons of ('a * 'a list) ] with gmap,show 6 | 7 | let () = 8 | print_endline @@ show_list (Printf.sprintf "%d") @@ 9 | gmap_list ((+)1) @@ 10 | (`Cons (1, `Nil)) 11 | end 12 | -------------------------------------------------------------------------------- /regression/test042.t: -------------------------------------------------------------------------------- 1 | $ ./test042.exe 2 | `Cons (2, `Nil) 3 | -------------------------------------------------------------------------------- /regression/test081.t: -------------------------------------------------------------------------------- 1 | $ ./test081llist.exe 2 | :: (aaa, bbb) 3 | :: (aaa, :: (bbb, [])) 4 | Var (5) Value (asdf) 5 | Value (:: (aaa, Value (:: (bbb, Var (15))))) 6 | Modified implementation: 7 | Var (5) 8 | asdf 9 | Printing of modified logic list 10 | :: (aaa, :: (bbb, Var (15))) 11 | -------------------------------------------------------------------------------- /regression/test081llist.ml: -------------------------------------------------------------------------------- 1 | module AL : sig 2 | @type ('a,'b) alist = [] [@name "nil"] | (::) of 'a * 'b [@name "cons"] 3 | with show,foldl,gmap 4 | end = struct 5 | @type ('a,'b) alist = [] [@name "nil"] | (::) of 'a * 'b [@name "cons"] 6 | with show,foldl,gmap 7 | end 8 | 9 | let () = 10 | let open AL in 11 | let sh xs = GT.show alist Fun.id Fun.id xs in 12 | (* let fo xs = foldl_alist (fun () -> id) (fun () -> id) "" xs in *) 13 | Printf.printf "%s\n%!" (sh @@ "aaa" :: "bbb"); 14 | (* Printf.printf "%s\n%!" (fo @@ Cons ("aaa", "bbb")); *) 15 | () 16 | 17 | module L : sig 18 | @type 'a list = ('a, 'a list) AL.alist with show,gmap,foldl 19 | end = struct 20 | @type 'a list = ('a, 'a list) AL.alist with show,gmap,foldl 21 | end 22 | 23 | let () = 24 | let open L in 25 | let sh x = GT.show list Fun.id x in 26 | Printf.printf "%s\n%!" (sh @@ "aaa" :: "bbb" :: []) 27 | 28 | module Lo : sig 29 | @type 'a logic = Var of GT.int | Value of 'a with show,gmap,foldl 30 | end = struct 31 | @type 'a logic = Var of GT.int | Value of 'a with show,gmap,foldl 32 | end 33 | 34 | let () = 35 | let open Lo in 36 | let sh x = GT.show logic Fun.id x in 37 | Printf.printf "%s\t%s\n%!" (sh @@ Var 5) (sh @@ Value "asdf") 38 | 39 | 40 | module LList : sig 41 | @type 'a llist = ('a, 'a llist) AL.alist Lo.logic with show,gmap,foldl 42 | end = struct 43 | @type 'a llist = ('a, 'a llist) AL.alist Lo.logic with show,gmap,foldl 44 | end 45 | 46 | let () = 47 | let sh x = GT.show LList.llist Fun.id x in 48 | Printf.printf "%s\n%!" (sh @@ Value ("aaa" :: Value ("bbb" :: Var 15)) ) 49 | 50 | 51 | module Lo2 = struct 52 | include Lo 53 | 54 | class ['a, 'self] my_show fa fself = object 55 | inherit ['a, 'self] Lo.show_logic_t fa fself 56 | method c_Value () _ x = fa () x 57 | end 58 | 59 | let logic = 60 | { Lo.logic with 61 | GT.plugins = object 62 | method show fa xs = 63 | GT.transform (Lo.logic) (new my_show (GT.lift fa)) () xs 64 | method gmap x = Lo.logic.GT.plugins#gmap x 65 | method foldl x = Lo.logic.GT.plugins#foldl x 66 | end } 67 | end 68 | 69 | let () = 70 | let open Lo2 in 71 | let sh x = GT.show logic Fun.id x in 72 | Printf.printf "Modified implementation:\n%!"; 73 | Printf.printf "\t%s\n%!" (sh @@ Var 5); 74 | Printf.printf "\t%s\n%!" (sh @@ Value "asdf"); 75 | () 76 | 77 | module ReworkedLList : sig 78 | @type 'a llist = ('a, 'a llist) AL.alist Lo2.logic with show,gmap,foldl 79 | end = struct 80 | @type 'a llist = ('a, 'a llist) AL.alist Lo2.logic with show,gmap,foldl 81 | end 82 | 83 | let () = 84 | let sh x = GT.show ReworkedLList.llist Fun.id x in 85 | Printf.printf "Printing of modified logic list\n"; 86 | Printf.printf "%s\n%!" (sh @@ Value ("aaa" :: (Value ("bbb" :: (Var 15)))) ) 87 | -------------------------------------------------------------------------------- /regression/test082.t: -------------------------------------------------------------------------------- 1 | $ ./test082mutal.exe 2 | -------------------------------------------------------------------------------- /regression/test082mutal.ml: -------------------------------------------------------------------------------- 1 | module T1 = struct 2 | @type ('a, 'b) a = B of ('a, 'b) b | D of 'a 3 | (* and ('a, 'b) c = ('a, 'b) b *) 4 | and ('a, 'b) b = A of ('a, 'b) a | C of 'a * 'b | E 5 | with show 6 | end 7 | 8 | (* module T2 = struct 9 | * (\* Lacmus test about nonregular types: 10 | * leaving mutally recursive classes here strikes regularity restriction *\) 11 | * @type mmm = GT.int 12 | * and uuu = GT.bool 13 | * and www = GT.string 14 | * and 'a class_infos = 'a 15 | * and class_description = GT.int class_infos 16 | * and zzz = GT.char 17 | * and class_declaration = GT.string class_infos 18 | * with fmt 19 | * end 20 | * 21 | * (\* 22 | * type ('a, 'b) a = B of ('a, 'b) b | D of 'a (\* | F of ('a, 'b) a *\) 23 | * and ('a, 'b) b = A of ('a * 'a, 'b) a | C of 'a * 'b | E 24 | * doesn't work because of non-regualrity 25 | * *\) 26 | * open GT 27 | * module T3 = struct 28 | * (\* this is a test about order of functions in _stub classes *\) 29 | * @type core_type = CT 30 | * and class_type = XXX 31 | * and class_declaration = float class_infos 32 | * and 'a class_infos = core_type list 33 | * with fmt 34 | * end *) 35 | 36 | (* 37 | module X = struct 38 | @type a = GT.int GT.list 39 | and b = B of a 40 | with show 41 | end 42 | *) 43 | -------------------------------------------------------------------------------- /regression/test083.t: -------------------------------------------------------------------------------- 1 | $ ./test083polyvar.exe 2 | Original PV: `A (1) 3 | Mapped PV: `A (1) 4 | **************************** 5 | Original pv: `A (1) 6 | Mapped pv and showed as a pv_ext: `A (1) 7 | Original pv_ext: `C (1) 8 | Mapped PV_ext and showed as a pv_ext: `C (1) 9 | **************************** 10 | Original pv_ext: `C (1) 11 | Mapped pv_ext and showed as a pv_ext2: `C (1) 12 | Original pv_ext2: `D (1) 13 | Mapped PV_ext2 and showed as a pv_ext2: `D (1) 14 | **************************** 15 | Original pv_ext2: `D (1) 16 | Mapped pv_ext2 and showed as a pv_ext3: `D (1) 17 | Original pv_ext3: `E (1) 18 | Mapped PV_ext3 and showed as a pv_ext3: `E (1.) 19 | -------------------------------------------------------------------------------- /regression/test083polyvar.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | module PV : sig 4 | @type ('a, 'b) pv = [ `A of 'a | `B of 'b ] with show,gmap 5 | end = struct 6 | @type ('a, 'b) pv = [ `A of 'a | `B of 'b ] with show,gmap 7 | end 8 | 9 | let _ = 10 | let open PV in 11 | Printf.printf "Original PV: %s\nMapped PV: %s\n" 12 | (GT.show pv id id (`A "1")) 13 | (GT.show pv (GT.show GT.int) id @@ 14 | GT.gmap pv int_of_string id (`A "1")) 15 | 16 | module PVExt : sig 17 | @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap 18 | end = struct 19 | @type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a] with show,gmap 20 | end 21 | 22 | let _ = 23 | let open PV in 24 | let open PVExt in 25 | Printf.printf "****************************\n%!"; 26 | Printf.printf "Original pv: %s\n" @@ 27 | GT.show pv id id (`A "1"); 28 | Printf.printf "Mapped pv and showed as a pv_ext: %s\n" @@ 29 | GT.show pv_ext (GT.show GT.int) id @@ 30 | ((GT.gmap pv int_of_string id (`A "1")) :> (_,_) pv_ext); 31 | Printf.printf "Original pv_ext: %s\n" @@ 32 | GT.show pv_ext id id (`C "1"); 33 | Printf.printf "Mapped PV_ext and showed as a pv_ext: %s\n" @@ 34 | GT.show pv_ext (GT.show GT.int) id @@ 35 | GT.gmap pv_ext int_of_string id (`C "1"); 36 | 37 | module PVExt2 : sig 38 | @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap 39 | end = struct 40 | @type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] with show,gmap 41 | end 42 | 43 | let () = 44 | let open PVExt in 45 | let open PVExt2 in 46 | 47 | Printf.printf "****************************\n%!"; 48 | Printf.printf "Original pv_ext: %s\n" @@ 49 | GT.show pv_ext2 id id (`C "1"); 50 | Printf.printf "Mapped pv_ext and showed as a pv_ext2: %s\n" @@ 51 | GT.show pv_ext2 (GT.show GT.int) id @@ 52 | ((GT.gmap pv_ext int_of_string id (`C "1")) :> (_,_) pv_ext2); 53 | Printf.printf "Original pv_ext2: %s\n" @@ 54 | GT.show pv_ext2 id (GT.show GT.int) (`D "1"); 55 | Printf.printf "Mapped PV_ext2 and showed as a pv_ext2: %s\n" @@ 56 | GT.show pv_ext2 (GT.show GT.int) id @@ 57 | GT.gmap pv_ext2 int_of_string id (`D "1") 58 | 59 | module PVExt3 : sig 60 | @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap 61 | end = struct 62 | @type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] with show,gmap 63 | end 64 | 65 | let () = 66 | let open PVExt2 in 67 | let open PVExt3 in 68 | 69 | (* let (_:int) = GT.show pv_ext3 in *) 70 | Printf.printf "****************************\n%!"; 71 | Printf.printf "Original pv_ext2: %s\n" @@ 72 | GT.show pv_ext2 id id (`D "1"); 73 | Printf.printf "Mapped pv_ext2 and showed as a pv_ext3: %s\n" @@ 74 | GT.show pv_ext3 (GT.show GT.int) id id @@ 75 | ((GT.gmap pv_ext2 (int_of_string) id (`D "1")) :> (_,_,_) pv_ext3); 76 | Printf.printf "Original pv_ext3: %s\n" @@ 77 | GT.show pv_ext3 id id id (`E "1"); 78 | Printf.printf "Mapped PV_ext3 and showed as a pv_ext3: %s\n" @@ 79 | GT.show pv_ext3 id id (GT.show GT.float) @@ 80 | GT.gmap pv_ext3 id id float_of_string (`E "1.0"); 81 | 82 | module PVSum = struct 83 | @type ('a,'b) s = [ ('a,'b) PV.pv | ('a,'b) PVExt.pv_ext ] with show,gmap 84 | end 85 | module XXX = struct 86 | @type 'a xxx = [ `XXX of 'a ] with show,gmap 87 | end 88 | module YYY = struct 89 | @type 'a yyy = [ 'a XXX.xxx | ('a,'a) PV.pv ] with show,gmap 90 | end 91 | -------------------------------------------------------------------------------- /regression/test084.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | module PV : sig 4 | @type ('a,'b) pv = [ `A of 'a | `B of 'b * GT.int ] GT.list with show 5 | end = struct 6 | @type ('a,'b) pv = [ `A of 'a | `B of 'b * GT.int ] GT.list with show 7 | end 8 | 9 | let () = 10 | print_endline @@ (GT.show PV.pv (GT.show GT.int) (GT.show GT.int)) [`A 5] -------------------------------------------------------------------------------- /regression/test084.t: -------------------------------------------------------------------------------- 1 | $ ./test084.exe 2 | [`A (5)] 3 | -------------------------------------------------------------------------------- /regression/test086.t: -------------------------------------------------------------------------------- 1 | $ ./test086std.exe 2 | -------------------------------------------------------------------------------- /regression/test086std.ml: -------------------------------------------------------------------------------- 1 | (* The same as test 805 but in camlp5 syntax *) 2 | 3 | module T : sig 4 | @type t2 = GT.int * GT.string with show,gmap,foldl,eq,compare,eval,stateful,html;; 5 | 6 | @type 'a t3 = GT.int * 'a * GT.string with show,gmap,html,foldl,eq,compare,eval,stateful;; 7 | 8 | @type 'a t1 = 'a with show,gmap,html,foldl,eq,compare,eval,stateful;; 9 | 10 | @type bindings = (GT.string * GT.int) GT.list with show,gmap,html,foldl,eq,compare,eval,stateful;; 11 | 12 | @type 'a u1 = 'a GT.option with show,gmap,html,foldl,eq,compare,eval,stateful;; 13 | @type 'a u2 = 'a GT.Lazy.t with show,gmap,foldl,eq,compare,eval,stateful;; 14 | 15 | @type 'a u3 = {aa: GT.int; bb:GT.string} with show,gmap,foldl,eq,compare,eval;; 16 | @type ('a,'b) arrows = ('a -> 'b) GT.list with show,gmap,foldl,eq,compare,eval;; 17 | end = struct 18 | 19 | @type t2 = GT.int * GT.string with show,gmap,html,foldl,eq,compare,eval,stateful;; 20 | 21 | let () = ();; 22 | 23 | @type 'a t3 = GT.int * 'a * GT.string with show,gmap,html,foldl,eq,compare,eval,stateful;; 24 | 25 | @type 'a t4 = GT.bytes with show;; 26 | let () = ();; 27 | @type 'a t1 = 'a with show,gmap,html,foldl,eq,compare,eval,stateful;; 28 | 29 | let () = ();; 30 | 31 | @type bindings = (GT.string * GT.int) GT.list with show,gmap,html,foldl,eq,compare,eval,stateful;; 32 | 33 | let () = ();; 34 | 35 | @type 'a u1 = 'a GT.option with show,gmap,html,foldl,eq,compare,eval,stateful;; 36 | 37 | let () = ();; 38 | 39 | @type 'a u2 = 'a GT.Lazy.t with show,gmap,foldl,eq,compare,eval,stateful;; 40 | 41 | 42 | let () = ();; 43 | 44 | @type 'a u3 = {aa: GT.int; bb:GT.string} with show,gmap,foldl,eq,compare,eval;; 45 | let () = ();; 46 | 47 | @type ('a,'b) arrows = ('a -> 'b) GT.list with show,gmap,foldl,eq,compare,eval;; 48 | end 49 | 50 | (* TODO: implement stateful for records *) 51 | -------------------------------------------------------------------------------- /regression/test087.t: -------------------------------------------------------------------------------- 1 | $ ./test087stateful.exe 2 | 1 3 | 2 4 | 3 5 | -------------------------------------------------------------------------------- /regression/test087stateful.ml: -------------------------------------------------------------------------------- 1 | @type 'data expr_node = 2 | | EConst of 'data 3 | | EAdd of 'data expr * 'data expr 4 | and 'data expr = 5 | { loc : GT.string ; data : 'data expr_node } 6 | with stateful 7 | 8 | let econst c = { loc=""; data = EConst c } 9 | let eadd l r = { loc=""; data = EAdd (l,r) } 10 | 11 | let ((),_) = 12 | GT.stateful expr 13 | (fun env x -> (env,print_endline x)) 14 | () 15 | (eadd ( econst "1" ) (eadd (econst "2") (econst "3"))) 16 | -------------------------------------------------------------------------------- /regression/test089.t: -------------------------------------------------------------------------------- 1 | $ ./test089struct.exe 2 | { info=asdf; node=EConst (19); } 3 | { info=__asdf; node=EConst (19); } 4 | { info=x; node=EAdd ({ info=y; node=EConst (20); }, { info=z; node=EConst (40); }); } 5 | { info=__x; node=EAdd ({ info=__y; node=EConst (20); }, { info=__z; node=EConst (40); }); } 6 | -------------------------------------------------------------------------------- /regression/test089struct.ml: -------------------------------------------------------------------------------- 1 | @type 'info expr_node = 2 | | EConst of GT.int 3 | | EAdd of 'info expr * 'info expr 4 | and 'info expr = 5 | { info : 'info ; node : 'info expr_node } 6 | with show,gmap 7 | 8 | let e1 = {info="asdf"; node=EConst 19} 9 | let e2 = {info="x"; node= EAdd ({info="y";node=EConst 20}, {info="z";node=EConst 40})} 10 | let () = 11 | print_endline @@ GT.show expr Fun.id e1; 12 | print_endline @@ GT.show expr Fun.id @@ GT.gmap expr ((^)"__") e1; 13 | print_endline @@ GT.show expr Fun.id e2; 14 | print_endline @@ GT.show expr Fun.id @@ GT.gmap expr ((^)"__") e2; 15 | () 16 | 17 | (* Example from paper about visitors *) 18 | -------------------------------------------------------------------------------- /regression/test090.t: -------------------------------------------------------------------------------- 1 | $ ./test090eval.exe 2 | -------------------------------------------------------------------------------- /regression/test091.t: -------------------------------------------------------------------------------- 1 | $ ./test091eval.exe 2 | Original: `App (`Abs ("x", `Var ("x")), `Abs ("y", `Var ("y"))) 3 | Converted: `App (`Abs (`Var (0)), `Abs (`Var (0))) 4 | -------------------------------------------------------------------------------- /regression/test705.ml: -------------------------------------------------------------------------------- 1 | @type a = [`A of b | `C of GT.int] with show 2 | and b = [`B of a | `D of GT.string] with show 3 | 4 | @type c = [`E of GT.int GT.list | b] with show 5 | 6 | class ['self] show_c' prereq = object 7 | inherit ['self] @c[show] prereq as super 8 | method c_E i x y = "new " ^ super#c_E i x y 9 | method c_B i x y = "new " ^ super#c_B i x y 10 | method c_D i x y = "new " ^ super#c_D i x y 11 | end 12 | 13 | let _ = 14 | let x = `A (`B (`C 3)) in 15 | let y = `B (`A (`D "3")) in 16 | let z = `E [1; 2; 3] in 17 | Printf.printf "%s\n" (GT.transform(a) (new @a[show]) () x); 18 | Printf.printf "%s\n" (GT.transform(b) (new @b[show]) () y); 19 | Printf.printf "%s\n" (GT.transform(c) (new @c[show]) () z); 20 | Printf.printf "%s\n" (GT.transform(c) (new @c[show]) () y); 21 | Printf.printf "%s\n" (GT.transform(c) (new show_c') () z); 22 | Printf.printf "%s\n" (GT.transform(c) (new show_c') () y) 23 | -------------------------------------------------------------------------------- /regression/test705.t: -------------------------------------------------------------------------------- 1 | $ ./test705.exe 2 | `A (`B (`C (3))) 3 | `B (`A (`D ("3"))) 4 | `E ([1; 2; 3]) 5 | `B (`A (`D ("3"))) 6 | new `E ([1; 2; 3]) 7 | new `B (`A (`D ("3"))) 8 | -------------------------------------------------------------------------------- /regression/test791showT.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | type 'a logic = Value of 'a | Var of int 4 | (* [@@deriving gt { showT } ] *) 5 | 6 | let rec logic_meta_gcata fa tpo trans initial_inh subj = 7 | let self = logic_meta_gcata fa tpo trans in 8 | match subj with 9 | | Value p0 -> trans#c_Value initial_inh (GT.make self subj tpo) (fa p0) 10 | | Var p0 -> trans#c_Var initial_inh (GT.make self subj tpo) p0 11 | let logic_gcata fa transformer initial_inh subj = 12 | let parameter_transforms_obj = object method a = fa end in 13 | logic_meta_gcata (fun x -> GT.make fa x parameter_transforms_obj) 14 | parameter_transforms_obj transformer initial_inh subj 15 | 16 | class type virtual 17 | ['inh,'syn,'tpoT,'type_itself,'gt_a_for_self,'gt_a_for_a] logic_meta_tt = 18 | object 19 | method virtual c_Value : 20 | 'inh -> ('inh,'type_itself,'syn,'tpoT) GT.a -> 'gt_a_for_a -> 'syn 21 | method virtual c_Var : 22 | 'inh -> ('inh,'type_itself,'syn,'tpoT) GT.a -> int -> 'syn 23 | end 24 | class virtual 25 | ['inh,'syn,'tpoT,'type_itself,'gt_a_for_self,'gt_a_for_a] logic_meta_t = 26 | object (self : 'self) 27 | constraint 'self = 28 | ('inh,'syn,'tpoT,'type_itself,'gt_a_for_self,'gt_a_for_a)#logic_meta_tt 29 | end 30 | class virtual ['inh,'syn,'tpoT,'a,'ia,'sa,'gt_a_for_a] logic_t = 31 | object (this) 32 | inherit ['inh,'syn,'tpoT,'a logic,'a logic,'gt_a_for_a] logic_meta_t 33 | end 34 | (* ******************************************************************************** *) 35 | class ['tpoT,'a,'a_holder,'self_holder] showT_meta_logic 36 | (for_a: Format.formatter -> 'a_holder -> unit) 37 | (for_me: Format.formatter -> 'self_holder -> unit) = 38 | object (this) 39 | inherit [ (Format.formatter * string) as 'inh,unit,'tpoT 40 | , 'a,'inh,unit,'a_holder] logic_t 41 | method c_Var (fmt,_) subj p0 = 42 | Format.fprintf fmt "Var (%s)" ((GT.lift (GT.int.GT.plugins)#show ()) p0) 43 | method c_Value (fmt,_) subj (p0 : 'a_holder) = 44 | Format.fprintf fmt "Value (%a)" (fun fmt -> for_a fmt) p0 45 | end 46 | class ['a] showF_logic for_me = 47 | object 48 | inherit 49 | [ < a: ((Format.formatter*string) as 'inh) -> 'a -> unit > as 'tpoT 50 | , 'a, ('inh,'a,unit,'tpoT) GT.a 51 | ,'a logic 52 | ] showT_meta_logic (fun fmt pa -> pa.GT.fx (fmt, "logic")) for_me 53 | end 54 | let logic = 55 | { GT.gcata = logic_gcata 56 | ; GT.plugins = object (self) 57 | method showF fa fmt subj = 58 | logic_gcata fa (new showF_logic (self#showF fa)) (fmt,"asdf") subj 59 | end 60 | } 61 | 62 | type ('a, 'b) glist = Nil | Cons of 'a * 'b [@@deriving gt] 63 | type 'a llist = ('a, 'a llist) glist logic [@@deriving gt] 64 | 65 | 66 | let () = 67 | let rec showF fa fmt xs = logic.GT.plugins#showF fa fmt xs in 68 | Format.fprintf Format.std_formatter "%a@;@?" (showF (fun (fmt,_) -> Format.fprintf fmt "%d")) (Var 5); 69 | Format.fprintf Format.std_formatter "%a@;@?" (showF (fun (fmt,_) -> Format.fprintf fmt "%s")) (Value "asdf"); 70 | () 71 | -------------------------------------------------------------------------------- /regression/test798.t: -------------------------------------------------------------------------------- 1 | $ ./test798gen.exe 2 | Nil 3 | Cons (2, Nil) 4 | Cons (2, Cons (2, Nil)) 5 | Nil 6 | Cons (WTF, Nil) 7 | Cons (3, Cons (4, Nil)) 8 | Nil 9 | Cons (6, Nil) 10 | Cons (7, Cons (8, Nil)) 11 | -------------------------------------------------------------------------------- /regression/test798gen.ml: -------------------------------------------------------------------------------- 1 | type ('a,'b) list_like = Nil | Cons of 'a * 'b 2 | [@@deriving gt ~options:{show}] 3 | 4 | let () = 5 | let rec show fa xs = GT.show list_like fa (show fa) xs 6 | (* glist_gcata (GT.lift fa) (GT.lift @@ show fa) (new show_glist) () xs *) 7 | in 8 | Printf.printf "%s\n%!" (show string_of_int (Nil)); 9 | Printf.printf "%s\n%!" (show string_of_int (Cons (2, Nil))); 10 | Printf.printf "%s\n%!" (show string_of_int (Cons (2, Cons (2, Nil)))); 11 | () 12 | 13 | type 'a list = ('a, 'a list) list_like 14 | [@@deriving gt ~options:{show}] 15 | 16 | let () = 17 | let show fa xs = 18 | GT.transform list (new show_list_t (GT.lift fa)) () xs 19 | in 20 | Printf.printf "%s\n%!" (show string_of_int (Nil)); 21 | Printf.printf "%s\n%!" (show (fun x -> x) (Cons ("WTF", Nil))); 22 | Printf.printf "%s\n%!" (show string_of_int (Cons (3, Cons (4, Nil)))); 23 | () 24 | 25 | type intlist = GT.int list 26 | [@@deriving gt ~options:{show}] 27 | 28 | let () = 29 | let show xs = GT.transform intlist (new show_intlist_t) () xs in 30 | Printf.printf "%s\n%!" (show Nil); 31 | Printf.printf "%s\n%!" (show (Cons (6, Nil))); 32 | Printf.printf "%s\n%!" (show (Cons (7, Cons (8, Nil)))); 33 | () 34 | -------------------------------------------------------------------------------- /regression/test799.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | 4 | (* FIRST PART *) 5 | type ('a,'b) t = OK of 'a | Error of 'b 6 | [@@deriving gt ~options:{show}] 7 | 8 | let () = 9 | let show fa fb (e: (_,_) t) = 10 | GT.transform t (new show_t_t (GT.lift fa) (GT.lift fb)) () e in 11 | printf "%s\n%!" (show (GT.show GT.int) (GT.show GT.string) (OK 1)); 12 | printf "%s\n%!" (show (GT.show GT.int) (GT.show GT.string) (Error "error1")); 13 | () 14 | 15 | 16 | (* SECOND PART *) 17 | type 'a t2 = ('a, GT.string) t 18 | [@@deriving gt ~options:{show}] 19 | 20 | let () = 21 | let show fa (e: _ t2) = 22 | GT.transform t2 (new show_t2_t fa) () e in 23 | printf "%s\n%!" (show (GT.lift @@ GT.show GT.float) (OK 2.)); 24 | printf "%s\n%!" (show (GT.lift @@ GT.show GT.int) (Error "error2")); 25 | () 26 | 27 | 28 | (* THIRD PART *) 29 | type t3 = GT.char t2 30 | [@@deriving gt ~options:{show}] 31 | 32 | let () = 33 | let show (e: t3) = GT.transform t3 (new show_t3_t) () e in 34 | printf "%s\n%!" (show (OK '3')); 35 | printf "%s\n%!" (show (Error "error3")); 36 | () 37 | -------------------------------------------------------------------------------- /regression/test800.ml: -------------------------------------------------------------------------------- 1 | 2 | module PV: sig 3 | type a = A of b | C of GT.int | E of a 4 | and b = B of a | D of GT.string | F of b 5 | [@@deriving gt ~options:{show;gmap}] 6 | end = struct 7 | type a = A of b | C of GT.int | E of a 8 | and b = B of a | D of GT.string | F of b 9 | [@@deriving gt ~options:{show;gmap}] 10 | end 11 | 12 | (* 13 | TODO: 14 | type 'a t = [> `Abs of GT.string * 'a ] as 'a 15 | [@@deriving gt ~options:{show;gmap}] 16 | *) 17 | 18 | 19 | let _ = [%show: GT.int] 20 | 21 | let _ = [%gmap: GT.int] 22 | 23 | let _ = [%fmt: GT.int GT.list] 24 | 25 | let () = 26 | Printf.printf "string %s and int %s\n" ([%show: GT.string] () "asdf") ([%show: GT.int] () 42); 27 | Format.printf "int list %a\n%!" [%fmt: GT.int GT.list] [0;1;2]; 28 | Format.printf "string list %a\n%!" [%fmt: GT.int GT.list] ([%gmap: 'a GT.list] (fun () -> (+)1) () [0;1;2]); 29 | () 30 | -------------------------------------------------------------------------------- /regression/test800.t: -------------------------------------------------------------------------------- 1 | $ ./test800.exe 2 | string "asdf" and int 42 3 | int list [ 0; 1; 2] 4 | string list [ 1; 2; 3] 5 | -------------------------------------------------------------------------------- /regression/test801mutal.ml: -------------------------------------------------------------------------------- 1 | (* currently disabled *) 2 | open Printf 3 | 4 | type 'l a = A of b | C | E of 'l a | D of 'l 5 | and b = I of GT.int a | J | K of b 6 | and all = (GT.int a) GT.list 7 | [@@deriving gt ~options:{show;gmap}] 8 | 9 | (* 10 | class ['self_b] show_b_hack ((show_a,_,_) as prereq) = object 11 | inherit ['self_b] show_b_t_stub prereq 12 | method c_I inh___037_ _ _x__038_ = 13 | Printf.sprintf "I {%s}" 14 | (show_a (GT.lift @@ GT.show GT.int) () _x__038_) 15 | method c_K () _ x = Printf.sprintf "K {%a}" fself x 16 | end 17 | 18 | 19 | let (show_a,show_b, show_all) = fix_a (new show_a_0) (new show_b_hack) (new show_all_0) 20 | (* 21 | let show_a_new eta = 22 | let (a,b, _) = fix_a (new show_a_0) (new show_b_hack) (new show_all_0) in 23 | a eta 24 | 25 | let show_b_new eta = 26 | let (a,b, _) = fix_a (new show_a_0) (new show_b_hack) (new show_all_0) in 27 | a eta 28 | 29 | let show_all2, show_b2 = 30 | let { show_b; show_all } = show_fix_a ~b0:({ show_b_func = new show_b_hack }) () in 31 | (show_all.show_all_trf, show_b.show_b_trf ) 32 | 33 | let show_b2 subj = 34 | let { show_b } = show_fix_a ~b0:({ show_b_func = new show_b_hack }) () in 35 | show_b.show_b_trf () subj*) 36 | 37 | let _ = 38 | printf "Testing show_a\n"; 39 | printf "%s\n" @@ show_a (GT.lift @@ GT.show GT.int) (E C); 40 | printf "%s\n" @@ show_a (GT.lift @@ GT.show GT.int) (A (I C)); 41 | printf "Testing show_b\n"; 42 | printf "%s\n" @@ show_b (I (A J)); 43 | printf "%s\n" @@ show_b (K J); 44 | printf "Testing show_b with fixed b\n"; 45 | printf "%s\n" @@ show_b2 (I (A J)); 46 | printf "%s\n" @@ show_b2 (K J); 47 | 48 | printf "Testing gmap_a\n"; 49 | printf "%s\n" @@ show_a (GT.lift @@ GT.show GT.int) @@ 50 | gmap_a (fun () x -> x+1) (D 6); 51 | printf "Testing show_all with fixed b\n"; 52 | printf "%s\n" @@ show_all [A(K J)]; 53 | 54 | () 55 | *) 56 | -------------------------------------------------------------------------------- /regression/test802.t: -------------------------------------------------------------------------------- 1 | $ ./test802mutal.exe 2 | new! 3 | new! 4 | new! 5 | new! 6 | `A (`B (`A (new D 4))) 7 | new c0! 8 | new! 9 | new c0! 10 | new `B (`A (new `D 4)) 11 | new c0! 12 | new `E 18 13 | -------------------------------------------------------------------------------- /regression/test802mutal.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module PV : sig 4 | type a = 5 | [ `A of b 6 | | `C of GT.int 7 | ] 8 | 9 | and b = 10 | [ `B of a 11 | | `D of GT.string 12 | ] 13 | [@@deriving gt ~options:{ show; gmap }] 14 | end = struct 15 | type a = 16 | [ `A of b 17 | | `C of GT.int 18 | ] 19 | 20 | and b = 21 | [ `B of a 22 | | `D of GT.string 23 | ] 24 | [@@deriving gt ~options:{ show; gmap }] 25 | end 26 | 27 | module Show2 = struct 28 | open PV 29 | 30 | class ['self] show_b_t_stub2 (for_a, for_b) = 31 | object 32 | inherit ['self] show_b_t_stub (for_a, for_b) 33 | method c_C () (_ : b) a = Printf.sprintf "new C (%s)" (for_a () a) 34 | method! c_D () _ s = Printf.sprintf "new D %s" s 35 | end 36 | 37 | let showa0 a = 38 | Printf.printf "new!\n"; 39 | new show_a_t_stub a 40 | ;; 41 | 42 | let showb0 a = 43 | Printf.printf "new!\n"; 44 | new show_b_t_stub2 a 45 | ;; 46 | 47 | let show_a () s = (fst @@ fix_a_b showa0 showb0) () s 48 | let show_b () s = (snd @@ fix_a_b showa0 showb0) () s 49 | let _ = Printf.printf "%s\n" (show_a () (`A (`B (`A (`D "4"))))) 50 | end 51 | 52 | type c = 53 | [ PV.b 54 | | `E of GT.int 55 | ] 56 | [@@deriving gt ~options:{ show }] 57 | 58 | module ShowC = struct 59 | open PV 60 | 61 | class ['extra] show_c_stub2 make_clas = 62 | let show_a2, show_b2 = 63 | Show2.(fix_a_b showa0 (fun _ -> make_clas () (* :> 'extra show_b_t_stub *))) 64 | in 65 | object 66 | inherit [unit, 'extra, string] c_t 67 | inherit ['extra] show_b_t_stub (show_a2, show_b2) 68 | method! c_B () _ a = sprintf "new `B (%s)" (show_a2 () a) 69 | method! c_D () _ s = sprintf "new `D %s" s 70 | method c_E () _ s = sprintf "new `E %d" s 71 | end 72 | 73 | let rec showc0 () = 74 | Printf.printf "new c0!\n"; 75 | new show_c_stub2 showc0 76 | ;; 77 | 78 | let show_c () (s : c) = 79 | let trait () s = gcata_c (showc0 ()) () (s :> c) in 80 | trait () s 81 | ;; 82 | 83 | let _ = 84 | Printf.printf "%s\n" (show_c () (`B (`A (`D "4")))); 85 | Printf.printf "%s\n" (show_c () (`E 18)) 86 | ;; 87 | end 88 | -------------------------------------------------------------------------------- /regression/test803.t: -------------------------------------------------------------------------------- 1 | $ ./test803polyvar.exe 2 | Original PV: `A (1) 3 | Mapped PV: `A (1) 4 | **************************** 5 | Original pv: `A (1) 6 | Mapped pv and showed as a pv_ext: `A (1) 7 | Original pv_ext: `C (1) 8 | Mapped PV_ext and showed as a pv_ext: `C (1) 9 | **************************** 10 | Original pv_ext: `C (1) 11 | Mapped pv_ext and showed as a pv_ext2: `C (1) 12 | Original pv_ext2: `D (1) 13 | Mapped PV_ext2 and showed as a pv_ext2: `D (1) 14 | **************************** 15 | Original pv_ext2: `D (1) 16 | Mapped pv_ext2 and showed as a pv_ext3: `D (1) 17 | Original pv_ext3: `E (1) 18 | Mapped PV_ext3 and showed as a pv_ext3: `E (1.) 19 | -------------------------------------------------------------------------------- /regression/test803polyvar.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | module PV : sig 4 | type ('a, 'b) pv = [ `A of 'a | `B of 'b ] 5 | [@@deriving gt ~options:{ show; gmap }] 6 | 7 | end = struct 8 | type ('a, 'b) pv = [ `A of 'a | `B of 'b ] 9 | [@@deriving gt ~options:{show; gmap }] 10 | 11 | end 12 | 13 | let _ = 14 | let open PV in 15 | Printf.printf "Original PV: %s\nMapped PV: %s\n" 16 | (GT.show pv Fun.id Fun.id (`A "1")) 17 | (GT.show pv (GT.show GT.int) Fun.id @@ 18 | GT.gmap pv int_of_string Fun.id (`A "1")) 19 | 20 | module PVExt : sig 21 | type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a ] 22 | [@@deriving gt ~options:{show; gmap}] 23 | end = struct 24 | type ('a, 'b) pv_ext = [ ('a, 'b) PV.pv | `C of 'a ] 25 | [@@deriving gt ~options:{show; gmap}] 26 | end 27 | 28 | let _ = 29 | let open PV in 30 | let open PVExt in 31 | Printf.printf "****************************\n%!"; 32 | Printf.printf "Original pv: %s\n" @@ 33 | GT.show pv Fun.id Fun.id (`A "1"); 34 | Printf.printf "Mapped pv and showed as a pv_ext: %s\n" @@ 35 | GT.show pv_ext (GT.show GT.int) Fun.id @@ 36 | ((GT.gmap pv int_of_string Fun.id (`A "1")) :> (_,_) pv_ext); 37 | Printf.printf "Original pv_ext: %s\n" @@ 38 | GT.show pv_ext id id (`C "1"); 39 | Printf.printf "Mapped PV_ext and showed as a pv_ext: %s\n" @@ 40 | GT.show pv_ext (GT.show GT.int) Fun.id @@ 41 | ((GT.gmap pv_ext int_of_string Fun.id (`C "1")) :> (_,_) pv_ext); 42 | 43 | module PVExt2 : sig 44 | type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] 45 | [@@deriving gt ~options:{show; gmap}] 46 | end = struct 47 | type ('a, 'b) pv_ext2 = [ ('a, 'b) PVExt.pv_ext | `D of 'a] 48 | [@@deriving gt ~options:{show; gmap}] 49 | end 50 | 51 | let () = 52 | let open PVExt in 53 | let open PVExt2 in 54 | 55 | Printf.printf "****************************\n%!"; 56 | Printf.printf "Original pv_ext: %s\n" @@ 57 | GT.show pv_ext2 Fun.id Fun.id (`C "1"); 58 | Printf.printf "Mapped pv_ext and showed as a pv_ext2: %s\n" @@ 59 | GT.show pv_ext2 (GT.show GT.int) Fun.id 60 | ((GT.gmap pv_ext (int_of_string) Fun.id (`C "1")) :> (_,_) pv_ext2); 61 | Printf.printf "Original pv_ext2: %s\n" @@ 62 | GT.show pv_ext2 Fun.id Fun.id (`D "1"); 63 | Printf.printf "Mapped PV_ext2 and showed as a pv_ext2: %s\n" @@ 64 | GT.show pv_ext2 (GT.show GT.int) Fun.id @@ 65 | GT.gmap pv_ext2 int_of_string Fun.id (`D "1"); 66 | 67 | module PVExt3 : sig 68 | type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] 69 | [@@deriving gt ~options:{show; gmap}] 70 | end = struct 71 | type ('a, 'b, 'c) pv_ext3 = [ ('a, 'b) PVExt2.pv_ext2 | `E of 'c] 72 | [@@deriving gt ~options:{show; gmap}] 73 | end 74 | 75 | let () = 76 | let open PVExt2 in 77 | let open PVExt3 in 78 | 79 | Printf.printf "****************************\n%!"; 80 | Printf.printf "Original pv_ext2: %s\n" @@ 81 | GT.show pv_ext2 Fun.id Fun.id (`D "1"); 82 | Printf.printf "Mapped pv_ext2 and showed as a pv_ext3: %s\n" @@ 83 | GT.show pv_ext3 (GT.show GT.int) Fun.id Fun.id @@ 84 | ((GT.gmap pv_ext2 int_of_string Fun.id (`D "1")) :> (_,_,_) pv_ext3) ; 85 | Printf.printf "Original pv_ext3: %s\n" @@ 86 | GT.show pv_ext3 Fun.id Fun.id Fun.id (`E "1"); 87 | 88 | Printf.printf "Mapped PV_ext3 and showed as a pv_ext3: %s\n" @@ 89 | GT.show pv_ext3 Fun.id Fun.id (GT.show GT.float) @@ 90 | GT.gmap pv_ext3 Fun.id Fun.id float_of_string 91 | (`E "1.0"); 92 | -------------------------------------------------------------------------------- /regression/test804.t: -------------------------------------------------------------------------------- 1 | $ ./test804polyvar.exe 2 | `A (aaa) 3 | Just (`A (a)) Just (`C (ccc)) 4 | -------------------------------------------------------------------------------- /regression/test804polyvar.ml: -------------------------------------------------------------------------------- 1 | module L : sig 2 | type 'a lst = 3 | [ `Nil 4 | | `Cons of 'a * 'a lst 5 | ] 6 | [@@deriving gt ~options:{ gmap }] 7 | end = struct 8 | type 'a lst = 9 | [ `Nil 10 | | `Cons of 'a * 'a lst 11 | ] 12 | [@@deriving gt ~options:{ gmap }] 13 | 14 | let __ 15 | : (('inh -> 'c lst -> 'syn) -> ('e, 'c, 'f, 'inh, [> 'c lst ], 'syn) #lst_t) -> 'inh 16 | -> 'c lst -> 'syn 17 | = 18 | fun eta -> GT.transform_gc gcata_lst eta 19 | ;; 20 | end 21 | 22 | type 'a maybe = 23 | | Just of 'a 24 | | Nothing 25 | [@@deriving gt ~options:{ show; fmt }] 26 | 27 | type 'a pv = [ `A of 'a ] [@@deriving gt ~options:{ show; fmt }] 28 | 29 | let () = 30 | let sh x = GT.show pv Fun.id x in 31 | Printf.printf "%s\n%!" (sh @@ `A "aaa") 32 | ;; 33 | 34 | include ( 35 | struct 36 | type 'a wtf = [ `C of 'a | 'a pv ] maybe [@@deriving gt ~options:{ show; fmt }] 37 | end : 38 | sig 39 | type 'a wtf = [ `C of 'a | 'a pv ] maybe [@@deriving gt ~options:{ show; fmt }] 40 | end) 41 | 42 | let () = 43 | let sh x = GT.show wtf Fun.id x in 44 | Printf.printf "%s\t%s\n%!" (sh @@ Just (`A "a")) (sh @@ Just (`C "ccc")) 45 | ;; 46 | -------------------------------------------------------------------------------- /regression/test805.t: -------------------------------------------------------------------------------- 1 | $ ./test805std.exe 2 | -------------------------------------------------------------------------------- /regression/test805std.ml: -------------------------------------------------------------------------------- 1 | (* The same as test 086 but in PPX syntax *) 2 | 3 | module T : sig 4 | type t2 = GT.int * GT.string [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 5 | 6 | type 'a t3 = GT.int * 'a * GT.string [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 7 | 8 | type 'a t4 = GT.bytes [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 9 | 10 | type 'a t1 = 'a [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 11 | 12 | type bindings = (GT.string * GT.int) GT.list [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 13 | 14 | type 'a u1 = 'a GT.option [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 15 | type 'a u2 = 'a GT.Lazy.t [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 16 | 17 | type 'a u3 = {aa: GT.int; bb:GT.string} [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; html}] 18 | 19 | type 'a r1 = 'a GT.ref [@@deriving gt ~options:{fmt; html}] 20 | 21 | type ('a,'b) arr1 = ('a * 'b) GT.array [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; html}] 22 | end = struct 23 | type nonrec t2 = GT.int * GT.string [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 24 | 25 | type nonrec 'a t3 = GT.int * 'a * GT.string [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 26 | 27 | type nonrec 'a t4 = GT.bytes [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 28 | 29 | type nonrec 'a t1 = 'a [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 30 | 31 | type nonrec bindings = (GT.string * GT.int) GT.list [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 32 | 33 | type nonrec 'a u1 = 'a GT.option [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 34 | type nonrec 'a u2 = 'a GT.Lazy.t [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; stateful; html}] 35 | 36 | type nonrec 'a u3 = {aa: GT.int; bb:GT.string} [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; html}] 37 | 38 | type nonrec 'a r1 = 'a GT.ref [@@deriving gt ~options:{fmt; html}] 39 | 40 | type nonrec ('a,'b) arr1 = ('a * 'b) GT.array [@@deriving gt ~options:{show; gmap; foldl; eq; compare; eval; html}] 41 | 42 | end 43 | -------------------------------------------------------------------------------- /regression/test806.t: -------------------------------------------------------------------------------- 1 | $ ./test806fmt.exe 2 | { a=1; 3 | b="x"; } 4 | 5 | QQQ ( 6 | "azerty" 7 | ) 8 | LLL 9 | ([ 1; 2; 3] 10 | ) 11 | 12 | [ 1.; 2. 13 | ; 3.; 4.] 14 | Some (A) 15 | Some (B) 16 | None 17 | Some (C) 18 | -------------------------------------------------------------------------------- /regression/test806fmt.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | type t = {a : GT.int; b: GT.string} [@@deriving gt ~options:{fmt}] 4 | 5 | type t2 = 6 | | QQQ of GT.string (** An example doc-comment *) 7 | | LLL of GT.int GT.list 8 | [@@deriving gt ~options:{fmt}] 9 | 10 | let () = 11 | pp_set_margin std_formatter 12; 12 | fprintf std_formatter "%a\n" t.GT.plugins#fmt {a=1; b="x"}; 13 | (* fprintf std_formatter "%a\n" t2.GT.plugins#fmt (RRR {asdf=20}); *) 14 | fprintf std_formatter "%a\n" t2.GT.plugins#fmt (QQQ "azerty"); 15 | fprintf std_formatter "%a\n" t2.GT.plugins#fmt (LLL [1;2;3]); 16 | fprintf std_formatter "%a\n" 17 | (GT.list.GT.plugins#fmt GT.float.GT.plugins#fmt) 18 | [1.; 2.; 3.; 4.]; 19 | () 20 | 21 | type t3 = Foo of { xxx: GT.int; yyy: GT.int} 22 | | Boo of GT.int * GT.int 23 | [@@deriving gt ~options:{fmt; compare}] 24 | 25 | 26 | type t4 = A | B | C [@@deriving gt ~options:{fmt}] 27 | 28 | let () = 29 | printf "%a\n" (pp_print_list [%fmt: t4 GT.option]) [ Some A; Some B; None; Some C] 30 | -------------------------------------------------------------------------------- /regression/test807.t: -------------------------------------------------------------------------------- 1 | $ ./test807showT.exe 2 | -------------------------------------------------------------------------------- /regression/test807showT.ml: -------------------------------------------------------------------------------- 1 | (* 2 | let id x = x 3 | 4 | let show_typed_string = Printf.sprintf "\"%s\"" 5 | 6 | module AL : sig 7 | type ('a,'b) alist = Nil | Cons of 'a * 'b 8 | [@@deriving gt ~options:{show_typed;}] 9 | end = struct 10 | type ('a,'b) alist = Nil | Cons of 'a * 'b 11 | [@@deriving gt ~options:{show_typed;}] 12 | end 13 | 14 | 15 | let () = 16 | let open AL in 17 | let sh xs = show_typed_alist 18 | "string" show_typed_string 19 | "string" show_typed_string xs 20 | in 21 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", "bbb")); 22 | () 23 | 24 | module L : sig 25 | type 'a list = ('a, 'a list) AL.alist 26 | [@@deriving gt ~options:{show_typed;}] 27 | end = struct 28 | type 'a list = ('a, 'a list) AL.alist 29 | [@@deriving gt ~options:{show_typed;}] 30 | end 31 | 32 | 33 | let () = 34 | let open L in 35 | let sh x = show_typed_list "string" show_typed_string x in 36 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", Cons ("bbb", Nil))) 37 | 38 | 39 | module GT = struct 40 | include GT 41 | let int = 42 | {gcata = int.gcata; 43 | plugins = object 44 | method show_typed = int.plugins#show 45 | method show = int.plugins#show 46 | method gmap = int.plugins#gmap 47 | end 48 | } 49 | end 50 | 51 | module Lo : sig 52 | type 'a logic = Var of GT.int | Value of 'a 53 | [@@deriving gt ~options:{show_typed;}] 54 | end = struct 55 | type 'a logic = Var of GT.int | Value of 'a 56 | [@@deriving gt ~options:{show_typed;}] 57 | end 58 | 59 | (* enhancing a class to print a type for constructor Var *) 60 | class ['a,'extra] show_typed_logic fself typ_a fa = object 61 | inherit ['a, 'extra] Lo.show_typed_logic_t fself typ_a fa 62 | method c_Var () _a = 63 | Format.sprintf "Var(%s : %s)" 64 | ((GT.int.GT.plugins)#show_typed _a) 65 | typ_a 66 | end 67 | 68 | let rec custom_show_typed_logic typ_a fa subj = 69 | GT.fix0 70 | (fun self -> Lo.gcata_logic ((new show_typed_logic) self typ_a fa) ()) 71 | subj 72 | 73 | let () = 74 | let open Lo in 75 | let sh x = custom_show_typed_logic "string" show_typed_string x in 76 | Printf.printf "%s\t%s\n%!" (sh @@ Var 5) (sh @@ Value "asdf") 77 | 78 | module LList : sig 79 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 80 | [@@deriving gt ~options:{show_typed;}] 81 | end = struct 82 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 83 | [@@deriving gt ~options:{show_typed;}] 84 | end 85 | 86 | let () = 87 | let sh x = LList.show_typed_llist "string" show_typed_string x in 88 | Printf.printf "%s\n%!" (sh @@ Value (Cons ("aaa", Value (Cons ("bbb", Var 15)))) ) 89 | 90 | 91 | (* Now let's try show_typed for mutal recursion *) 92 | 93 | module Mutal : sig 94 | type 'a foo = F1 of 'a | F2 of 'a boo 95 | and 'b boo = B1 of 'b | B2 of 'b foo 96 | [@@deriving gt ~options:{show_typed;}] 97 | end = struct 98 | type 'a foo = F1 of 'a | F2 of 'a boo 99 | and 'b boo = B1 of 'b | B2 of 'b foo 100 | [@@deriving gt ~options:{show_typed;}] 101 | 102 | let () = 103 | let sh1 x = show_typed_foo "string" show_typed_string x in 104 | let sh2 x = show_typed_boo "string" show_typed_string x in 105 | 106 | Printf.printf "%s\n%!" (sh1 @@ F2 (B2 (F1 "asdf"))); 107 | Printf.printf "%s\n%!" (sh1 @@ F2 (B2 (F2 (B1 "z")))); 108 | Printf.printf "%s\n%!" (sh2 @@ B2 (F2 (B2 (F1 "asdf"))) ); 109 | Printf.printf "%s\n%!" (sh2 @@ B2 (F2 (B2 (F2 (B1 "z")))) ); 110 | () 111 | end 112 | 113 | *) 114 | -------------------------------------------------------------------------------- /regression/test810cool.ml: -------------------------------------------------------------------------------- 1 | module Types = 2 | struct 3 | module Stdlib = struct include Stdlib let ref = GT.ref end 4 | (* TODO: ise ppx_import here *) 5 | type type_expr = Types.type_expr = { 6 | mutable desc : Types.type_desc; 7 | mutable level : int; 8 | mutable scope : int option; 9 | id : int; 10 | }[@@deriving gt] 11 | and row_desc = Types.row_desc = 12 | { 13 | row_fields: (Asttypes.label * row_field) list ; 14 | row_more: type_expr ; 15 | row_bound: unit ; 16 | row_closed: bool ; 17 | row_fixed: bool ; 18 | row_name: (Path.t * type_expr list) option }[@@deriving gt] 19 | and type_desc = Types.type_desc = 20 | | Tvar of string option 21 | | Tarrow of Asttypes.arg_label * type_expr * type_expr * commutable 22 | | Ttuple of type_expr list 23 | | Tconstr of Path.t * type_expr list * abbrev_memo Pervasives.ref 24 | | Tobject of type_expr * (Path.t * type_expr list) option 25 | Pervasives.ref 26 | | Tfield of string * field_kind * type_expr * type_expr 27 | | Tnil 28 | | Tlink of type_expr 29 | | Tsubst of type_expr 30 | | Tvariant of row_desc 31 | | Tunivar of string option 32 | | Tpoly of type_expr * type_expr list 33 | | Tpackage of Path.t * Longident.t list * type_expr list [@@deriving 34 | gt] 35 | and row_field = Types.row_field = 36 | | Rpresent of type_expr option 37 | | Reither of bool * type_expr list * bool * row_field option 38 | Pervasives.ref 39 | | Rabsent [@@deriving gt] 40 | and abbrev_memo = Types.abbrev_memo = 41 | | Mnil 42 | | Mcons of Asttypes.private_flag * Path.t * type_expr * type_expr * 43 | abbrev_memo 44 | | Mlink of abbrev_memo Pervasives.ref [@@deriving gt] 45 | and field_kind = Types.field_kind = 46 | | Fvar of field_kind option Pervasives.ref 47 | | Fpresent 48 | | Fabsent [@@deriving gt] 49 | and commutable = Types.commutable = 50 | | Cok 51 | | Cunknown 52 | | Clink of commutable Pervasives.ref [@@deriving gt] 53 | end 54 | -------------------------------------------------------------------------------- /regression/test811.t: -------------------------------------------------------------------------------- 1 | $ ./test811compare.exe 2 | -------------------------------------------------------------------------------- /regression/test811compare.ml: -------------------------------------------------------------------------------- 1 | module T1 = struct 2 | type ('a,'b) t = A of 'a | B of 'b * GT.int 3 | [@@deriving gt ~options:{ compare }] 4 | 5 | let () = 6 | let cmp1 x y = GT.compare t (GT.compare GT.int) (GT.compare GT.string) x y in 7 | assert (GT.EQ = cmp1 (A 5) (A 5) ); 8 | assert (GT.EQ = cmp1 (B ("",5)) (B ("",5)) ); 9 | assert (GT.EQ <> cmp1 (A 5) (B ("",5)) ); 10 | assert (GT.LT = cmp1 (A 5) (B ("",5)) ); 11 | assert (GT.GT = cmp1 (B ("",5)) (A 5)); 12 | () 13 | end 14 | (* 15 | (* testing polymorphic variants *) 16 | module T2 = struct 17 | type 'b t2 = [ `A | `B of 'b * GT.int ] 18 | [@@deriving gt ~options:{ compare}] 19 | 20 | let () = 21 | let cmp1 x y = compare_t2 (GT.compare GT.string) x y in 22 | assert (GT.EQ = cmp1 `A `A ); 23 | assert (GT.EQ = cmp1 (`B ("",5)) (`B ("",5)) ); 24 | assert (GT.EQ <> cmp1 `A (`B ("",5)) ); 25 | (* I'm not sure why the answer is not LT here *) 26 | assert (GT.EQ <> cmp1 `A (`B ("",5)) ); 27 | assert (GT.EQ <> cmp1 (`B ("",5)) `A ); 28 | () 29 | end 30 | *) 31 | module T3 = struct 32 | type 'a t = { q: GT.int; w: GT.string; e: 'a GT.list } 33 | [@@deriving gt ~options:{ compare; eq}] 34 | 35 | let () = 36 | let cmp1 x y = GT.compare t (GT.compare GT.string) x y in 37 | let eq1 x y = GT.eq t (GT.eq GT.string) x y in 38 | let a = { q=5; w="asd"; e= [""] } in 39 | let b = { q=6; w="asd"; e= [""] } in 40 | assert (GT.EQ = cmp1 a a); 41 | assert (GT.LT = cmp1 a b); 42 | assert (eq1 a a); 43 | assert (not(eq1 a b)); 44 | () 45 | end 46 | 47 | 48 | (* module T4 = struct 49 | * type 'a t = ('a * 'a) T3.t 50 | * [@@deriving gt ~options:{ show; compare; eq}] 51 | * 52 | * let () = 53 | * let a = { T3.q=5; w="asd"; e= ["",""] } in 54 | * let b = { T3.q=6; w="asd"; e= ["",""] } in 55 | * let c = { T3.q=6; w="ase"; e= ["",""] } in 56 | * 57 | * let cmp1 x y = compare_t (GT.compare GT.string) x y in 58 | * assert (GT.EQ = cmp1 a a); 59 | * assert (GT.LT = cmp1 a b); 60 | * assert (GT.LT = cmp1 b c); 61 | * let eq1 x y = eq_t (GT.eq GT.string) x y in 62 | * assert ( eq1 a a ); 63 | * assert (not(eq1 a b)); 64 | * assert (not(eq1 b c)); 65 | * () 66 | * end *) 67 | 68 | module T5 = struct 69 | type t = Foo of { aaa: GT.int; bbb: GT.int } 70 | [@@deriving gt ~options:{ compare; eq}] 71 | 72 | let () = 73 | let a = Foo { aaa= 5; bbb= 11} in 74 | let b = Foo { aaa= 5; bbb= 11} in 75 | let cmp1 = GT.compare t in 76 | let eq1 = GT.eq t in 77 | assert (GT.EQ = cmp1 a a); 78 | assert (GT.EQ = cmp1 a b); 79 | assert (eq1 a a); 80 | assert (eq1 a b); 81 | end 82 | -------------------------------------------------------------------------------- /regression/test812.t: -------------------------------------------------------------------------------- 1 | $ ./test812html.exe 2 | -------------------------------------------------------------------------------- /regression/test812html.ml: -------------------------------------------------------------------------------- 1 | type t = { a : GT.int; b : GT.string } 2 | [@@deriving gt ~options:{html}] 3 | 4 | type 'a t2 = A of GT.int | C of 'a * GT.int 5 | [@@deriving gt ~options:{html}] 6 | 7 | (* type t3 = D of t | E of GT.int t2 8 | * [@@deriving gt ~options:{html}] *) 9 | 10 | type t4 = GT.int t2 11 | [@@deriving gt ~options:{html}] 12 | 13 | (* 14 | let () = 15 | let ch = open_out "/tmp/out.html" in 16 | let fmt = Format.formatter_of_out_channel ch in 17 | 18 | let x1 = {a=5; b="beeeee"} in 19 | Format.fprintf fmt "%s\n\n%!" @@ HTML.toHTML @@ 20 | GT.html t x1; 21 | 22 | let x2 = A 5655 in 23 | Format.fprintf fmt "%s\n\n%!" @@ HTML.toHTML @@ 24 | GT.html t2 (GT.html GT.float) x2; 25 | 26 | let x3 = C (3.1415, 888) in 27 | Format.fprintf fmt "%s\n\n%!" @@ HTML.toHTML @@ 28 | GT.html t2 (GT.html GT.float) x3; 29 | 30 | let x4 = D x1 in 31 | Format.fprintf fmt "%s\n\n%!" @@ HTML.toHTML @@ 32 | GT.html t3 x4; 33 | 34 | let x5 = E (A 18) in 35 | Format.fprintf fmt "%s\n\n%!" @@ HTML.toHTML @@ 36 | GT.html t3 x5; 37 | 38 | Format.pp_force_newline fmt (); 39 | close_out ch 40 | *) 41 | -------------------------------------------------------------------------------- /regression/test813.t: -------------------------------------------------------------------------------- 1 | $ ./test813htmlTy.exe 2 | -------------------------------------------------------------------------------- /regression/test813htmlTy.ml: -------------------------------------------------------------------------------- 1 | (* generating HTML5 with TyXML is not repaired *) 2 | (* 3 | open Html_tyxml_api 4 | 5 | type t = { a : int; b : string } 6 | [@@deriving gt ~options:{html}] 7 | 8 | type 'a t2 = A of int | C of 'a * int 9 | [@@deriving gt ~options:{html}] 10 | 11 | type t3 = D of t | E of int t2 12 | [@@deriving gt ~options:{html}] 13 | 14 | type t4 = int t2 15 | [@@deriving gt ~options:{html}] 16 | 17 | let () = 18 | let ch = open_out "/tmp/out.html" in 19 | let fmt = Format.formatter_of_out_channel ch in 20 | let t1 = {a=5; b="beeeee"} in 21 | Tyxml.Html.pp_elt () fmt (html_t t1); 22 | Tyxml.Html.pp_elt () fmt (Tyxml_html.hr ()); 23 | 24 | let t2 = A 5655 in 25 | Tyxml.Html.pp_elt () fmt (html_t2 float.GT.plugins#html t2); 26 | Tyxml.Html.pp_elt () fmt (Tyxml_html.hr ()); 27 | 28 | let t3 = C (3.1415, 888) in 29 | Tyxml.Html.pp_elt () fmt (html_t2 float.GT.plugins#html t3); 30 | Tyxml.Html.pp_elt () fmt (Tyxml_html.hr ()); 31 | 32 | let t4 = D t1 in 33 | Tyxml.Html.pp_elt () fmt (html_t3 t4); 34 | Tyxml.Html.pp_elt () fmt (Tyxml_html.hr ()); 35 | 36 | let t5 = E (A 18) in 37 | Tyxml.Html.pp_elt () fmt (html_t3 t5); 38 | Tyxml.Html.pp_elt () fmt (Tyxml_html.hr ()); 39 | 40 | close_out ch 41 | *) 42 | -------------------------------------------------------------------------------- /regression/test814nonreg.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | module Y = struct 4 | type 'a s = SS of 'a 5 | and t = GT.int s 6 | and u = GT.float s 7 | [@@deriving gt ~options:{show}] 8 | 9 | let () = 10 | let () = printf "%s\n%!" @@ GT.(show s) (sprintf "%S") (SS "asdf") in 11 | let () = printf "%s\n%!" @@ GT.(show s) (sprintf "%b") (SS true) in 12 | let () = printf "%s\n%!" @@ GT.(show t) (SS 42) in 13 | let () = printf "%s\n%!" @@ GT.(show u) (SS 3.1415) in 14 | () 15 | 16 | class ['a,'extra_s] show_s_t2 (fa,_,_) = object 17 | inherit [unit,'a,string,unit,'extra_s,string] s_t 18 | method c_SS () _ x = Printf.sprintf "THE '%a'" fa x 19 | end 20 | let show_s2 call fa () subj = 21 | GT.transform_gc gcata_s (new show_s_t2 call fa) () subj 22 | 23 | 24 | let show = Fix_show_s.fixv (fun f -> 25 | { call = fun (type a) (sym : a Ishow_s.i) : a -> 26 | match sym with 27 | | Ishow_s.S -> show_s2 f 28 | | Ishow_s.U -> show_u_0 f 29 | | Ishow_s.T -> show_t_0 f 30 | }) 31 | 32 | let show_s fa = show.call Ishow_s.S (GT.lift fa) () 33 | 34 | let () = 35 | printf "After overriding a method\n%!"; 36 | printf "%s\n%!" @@ show_s (sprintf "%s") (SS "ZZZZZZZ") 37 | 38 | end 39 | -------------------------------------------------------------------------------- /regression/test815.t: -------------------------------------------------------------------------------- 1 | $ ./test815abstr.exe 2 | -------------------------------------------------------------------------------- /regression/test815abstr.ml: -------------------------------------------------------------------------------- 1 | module M: sig 2 | type foo 3 | [@@deriving gt ~options: { gmap } ] 4 | 5 | type t = T of foo 6 | [@@deriving gt ~options: { gmap } ] 7 | 8 | 9 | end = struct 10 | type foo = Foo of GT.string * GT.int 11 | [@@deriving gt ~options: { gmap } ] 12 | 13 | type t = T of foo 14 | [@@deriving gt ~options: { gmap } ] 15 | 16 | let make_t n = T (Foo (string_of_int n, n)) 17 | end 18 | -------------------------------------------------------------------------------- /regression/test816.t: -------------------------------------------------------------------------------- 1 | $ ./test816hash.exe 2 | use new value 3 | use old value 4 | use new value 5 | -------------------------------------------------------------------------------- /regression/test816hash.ml: -------------------------------------------------------------------------------- 1 | (* This decoration is required because hashconsing for standart types is 2 | * not yet included in GT module 3 | * 4 | * Actual example is below. 5 | *) 6 | module GT = struct 7 | include GT 8 | 9 | module H : 10 | sig 11 | type t 12 | (* Call [hc tbl a] return (possibly) updated hash table with 13 | * possible old value if [a] was already seen. 14 | *) 15 | val hc : t -> 'a -> t * 'a 16 | val create : unit -> t 17 | end = 18 | struct 19 | module H = Hashtbl.Make (struct 20 | type t = Obj.t 21 | let hash = Hashtbl.hash 22 | let equal new_ old = 23 | (* Printf.printf "%s %d\n%!" __FILE__ __LINE__; *) 24 | if Hashtbl.hash new_ <> Hashtbl.hash old 25 | then false 26 | else if Obj.(tag @@ repr new_) <> Obj.(tag @@ repr old) 27 | then false 28 | else if Obj.(size @@ repr new_) <> Obj.(size @@ repr old) 29 | then false 30 | else 31 | List.fold_left (fun acc n -> 32 | (Obj.field (Obj.repr new_) n == Obj.field (Obj.repr old) n) && acc 33 | ) true (List.init Obj.(size @@ repr old) (fun n -> n)) 34 | 35 | end) 36 | type t = Obj.t H.t 37 | 38 | let create () = H.create 37 39 | let hc h x = 40 | (* Printf.printf "%s %d\n%!" __FILE__ __LINE__; *) 41 | if Obj.(is_int @@ repr x) then (h,x) 42 | else 43 | let o = Obj.repr x in 44 | try 45 | let old = Obj.magic @@ H.find h o in 46 | print_endline "use old value"; 47 | (h,old) 48 | with Not_found -> 49 | H.add h o o; 50 | print_endline "use new value"; 51 | h, x 52 | end 53 | 54 | type h = {hc : 'a . H.t -> 'a -> H.t * 'a} 55 | 56 | let hf = {hc = H.hc} 57 | 58 | let int = 59 | { GT.gcata = int.GT.gcata 60 | ; fix = (fun c -> transform_gc gcata_int c) 61 | ; plugins = object 62 | method hash h n = (h,n) 63 | end 64 | } 65 | 66 | let hash c = c.plugins#hash 67 | end 68 | 69 | (* Interesting part goes here *) 70 | 71 | type expr = Const of GT.int | Binop of expr * expr 72 | [@@deriving gt ~options: { hash } ] 73 | 74 | (* reuses old (Const 5) when accessing another (Const 5) *) 75 | let (_,_) = 76 | let h = GT.H.create () in 77 | (* [GT.hash typ] takes a value and return its copy where all equal subtrees 78 | * have the same location in memory 79 | *) 80 | GT.hash (expr) h (Binop (Const 5, Const 5)) 81 | -------------------------------------------------------------------------------- /regression/test817.t: -------------------------------------------------------------------------------- 1 | $ ./test817logic.exe 2 | [] 3 | :: (2, []) 4 | :: (2, :: (2, [])) 5 | [] 6 | :: (WTF, []) 7 | :: (3, :: (4, [])) 8 | [] 9 | :: (6, []) 10 | :: (7, :: (8, [])) 11 | Default logic values 12 | Var (5) 13 | Value (6) 14 | Modified logic values 15 | Var (5) 16 | 6 17 | Modified logic list values 18 | [] 19 | :: (6, []) 20 | -------------------------------------------------------------------------------- /regression/test817logic.ml: -------------------------------------------------------------------------------- 1 | type ('a,'b) list_like = [] [@name "nil"] | (::) of 'a * 'b [@name "cons"] 2 | [@@deriving gt ~options:{show}] 3 | 4 | 5 | let () = 6 | let rec show fa xs = GT.show list_like fa (show fa) xs in 7 | Printf.printf "%s\n%!" (show string_of_int []); 8 | Printf.printf "%s\n%!" (show string_of_int [2]); 9 | Printf.printf "%s\n%!" (show string_of_int [2;2]); 10 | () 11 | 12 | type 'a list = ('a, 'a list) list_like 13 | [@@deriving gt ~options:{show}] 14 | 15 | let () = 16 | let show fa xs = 17 | GT.transform list (new show_list_t (GT.lift fa)) () xs 18 | in 19 | Printf.printf "%s\n%!" (show string_of_int []); 20 | Printf.printf "%s\n%!" (show (fun x -> x) ["WTF"]); 21 | Printf.printf "%s\n%!" (show string_of_int [3;4]); 22 | () 23 | 24 | let () = () 25 | 26 | 27 | type nonrec intlist = GT.int list 28 | [@@deriving gt ~options:{show}] 29 | 30 | let () = 31 | let show xs = GT.transform intlist (new show_intlist_t) () xs in 32 | Printf.printf "%s\n%!" (show []); 33 | Printf.printf "%s\n%!" (show [6]); 34 | Printf.printf "%s\n%!" (show [7;8]); 35 | () 36 | 37 | module Lo = struct 38 | type 'a t = Var of GT.int | Value of 'a [@@deriving gt ~options:{show}] 39 | end 40 | 41 | let () = 42 | let show xs = GT.show Lo.t (GT.show GT.int) xs in 43 | Printf.printf "Default logic values\n%!"; 44 | Printf.printf "\t%s\n%!" (show (Var 5)); 45 | Printf.printf "\t%s\n%!" (show (Value 6)); 46 | () 47 | 48 | module Lo2 = struct 49 | type 'a t = 'a Lo.t = Var of GT.int | Value of 'a [@@deriving gt ~options:{show}] 50 | 51 | class ['a, 'self] my_show fa fself = object 52 | inherit ['a, 'self] Lo.show_t_t fa fself 53 | method c_Value () _ x = fa () x 54 | end 55 | 56 | let t = 57 | { Lo.t with 58 | GT.plugins = object 59 | method show fa xs = 60 | GT.transform (Lo.t) (new my_show (GT.lift fa)) () xs 61 | end } 62 | end 63 | 64 | let () = 65 | let show xs = GT.show Lo2.t (GT.show GT.int) xs in 66 | Printf.printf "Modified logic values\n%!"; 67 | Printf.printf "\t%s\n%!" (show (Var 5)); 68 | Printf.printf "\t%s\n%!" (show (Value 6)); 69 | () 70 | 71 | module LList2 = struct 72 | type 'a t = ('a, 'a t) list_like Lo2.t [@@deriving gt ~options:{show}] 73 | end 74 | 75 | let () = 76 | let show xs = GT.show LList2.t (GT.show GT.int) xs in 77 | Printf.printf "Modified logic list values\n%!"; 78 | Printf.printf "\t%s\n%!" (show @@ Value []); 79 | Printf.printf "\t%s\n%!" (show @@ Value (6 :: Value [])); 80 | () 81 | -------------------------------------------------------------------------------- /regression/test818.t: -------------------------------------------------------------------------------- 1 | $ ./test818complex.exe 2 | { re=0.000000; im=1.000000 } 3 | -------------------------------------------------------------------------------- /regression/test818complex.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | print_endline @@ GT.show GT.complex Complex.i -------------------------------------------------------------------------------- /regression/test820.t: -------------------------------------------------------------------------------- 1 | $ ./test820spec.exe 2 | { a=5; b=""; } 3 | -------------------------------------------------------------------------------- /regression/test820spec.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | (* 4 | (* Have become broken when we intrduced combinatorial type abbreviations *) 5 | type 'a maybe = Just of 'a | Nothing [@@deriving gt ~options: { show } ] 6 | 7 | module P = struct 8 | type t = (int -> string) maybe 9 | [@@deriving gt ~options:{ show={ _1 = (fun () _ -> "") } }] 10 | end 11 | 12 | let () = 13 | Printf.printf "%s\n%!" @@ GT.show P.t @@ Just (fun x -> "?") 14 | *) 15 | 16 | module O = struct 17 | type t = { a:int; b:(string [@opaque]) } [@@deriving gt ~options: { show } ] 18 | end 19 | 20 | let () = 21 | Printf.printf "%s\n%!" @@ GT.show O.t { O.a = 5; O.b = "asdf" } 22 | -------------------------------------------------------------------------------- /regression/test821.t: -------------------------------------------------------------------------------- 1 | $ ./test821clab.exe 2 | C { xxx="asdf"; yyy=1; } 3 |
    C
  • xxx"asdf"
  • yyy1
4 | -------------------------------------------------------------------------------- /regression/test821clab.ml: -------------------------------------------------------------------------------- 1 | type 'a t = C of {xxx: 'a; yyy: GT.int} 2 | [@@deriving gt ~options:{ html; fmt; gmap; show; compare; eq; foldl }] 3 | 4 | let () = 5 | let x1 = C {xxx="asdf"; yyy=1} in 6 | GT.fmt t GT.string.plugins#fmt Format.std_formatter x1; 7 | Format.printf "%s" @@ HTML.toHTML @@ 8 | GT.html t (GT.html GT.string) x1; 9 | () 10 | -------------------------------------------------------------------------------- /regression/test822.ml: -------------------------------------------------------------------------------- 1 | type 'a t = C of 'a 2 | [@@deriving gt ~options:{ show }] 3 | 4 | 5 | let () = 6 | print_endline @@ GT.show(t) (GT.show GT.int) (C 1) 7 | 8 | 9 | type 'a tree = Leaf | Node of 'a * 'a tree GT.list 10 | [@@deriving gt ~options:{ show }] 11 | -------------------------------------------------------------------------------- /regression/test822.t: -------------------------------------------------------------------------------- 1 | $ ./test822.exe 2 | C (1) 3 | -------------------------------------------------------------------------------- /regression/test823.t: -------------------------------------------------------------------------------- 1 | $ ./test823list.exe 2 | -------------------------------------------------------------------------------- /regression/test823list.ml: -------------------------------------------------------------------------------- 1 | (* type 'a list = [] | (::) of 'a * 'a list 2 | * [@@deriving gt ~options:{ show; html; fmt; gmap; eval; stateful; foldl; foldr; compare; eq }] *) 3 | 4 | 5 | (* type 'a option = None | Some of 'a 6 | * [@@deriving gt ~options:{ show; html; fmt; gmap; eval; stateful; foldl; foldr; compare; eq }] *) 7 | 8 | (* type ('a,'b) tuple2 = T2 of 'a * 'b 9 | * [@@deriving gt ~options:{ show; html; fmt; gmap; eval; stateful; foldl; foldr; compare; eq }] *) 10 | 11 | 12 | module L : sig 13 | type 'a list = [ `Nil | `Cons of ('a * 'a list) ] 14 | [@@deriving gt ~options:{ (* show; *) gmap; }] 15 | end = struct 16 | type 'a list = [ `Nil | `Cons of ('a * 'a list) ] 17 | [@@deriving gt ~options:{ (* show; *) gmap; }] 18 | end 19 | -------------------------------------------------------------------------------- /regression/test824.t: -------------------------------------------------------------------------------- 1 | $ ./test824mut.exe 2 | [ ("gl", 3 | Lambda { lam_argname=None; lam_api=[]; lam_eff=HEmpty; lam_body=CInt (5); 4 | lam_is_rec=true; 5 | }); ("gl", 6 | Lambda { lam_argname=None; lam_api=[]; lam_eff=HEmpty; 7 | lam_body=CInt (5); lam_is_rec=true; 8 | }); ("gl", 9 | Lambda { lam_argname=None; lam_api=[]; lam_eff=HEmpty; 10 | lam_body=CInt (5); lam_is_rec=true; 11 | }); ("gl", 12 | Lambda { lam_argname=None; lam_api=[]; lam_eff=HEmpty; 13 | lam_body=CInt (5); lam_is_rec=true; 14 | })] 15 | -------------------------------------------------------------------------------- /regression/test824mut.ml: -------------------------------------------------------------------------------- 1 | module MyIdent = struct 2 | type nonrec t = GT.string [@@deriving gt ~options:{ fmt }] 3 | end 4 | 5 | type api = (MyIdent.t * term) GT.list 6 | and term = LI of heap GT.option * MyIdent.t 7 | | CInt of GT.int 8 | | BinOp of term * term 9 | | Unit 10 | | Call of term * term 11 | | Union of (pf * term) GT.list 12 | | Lambda of { lam_argname: MyIdent.t GT.option 13 | ; lam_api : api 14 | ; lam_eff : heap 15 | ; lam_body : term 16 | ; lam_is_rec: GT.bool 17 | } 18 | 19 | (* TODO: it should be path here *) 20 | and t = HAssoc of (MyIdent.t * term) GT.list 21 | | HMerge of (pf * t) GT.list 22 | | HCmps of heap * heap 23 | | HCall of term * term 24 | | HEmpty 25 | 26 | and pf = LogicBinOp of pf * pf 27 | | Not of pf 28 | | EQident of MyIdent.t * MyIdent.t 29 | | PFTrue 30 | | PFFalse 31 | | Term of term 32 | and heap = t [@@deriving gt ~options:{ fmt }] 33 | 34 | let api1 = 35 | [ ("gl", Lambda { lam_api=[]; lam_argname=None; lam_eff=HEmpty; lam_body=(CInt 5); lam_is_rec=true }) 36 | ; ("gl", Lambda { lam_api=[]; lam_argname=None; lam_eff=HEmpty; lam_body=(CInt 5); lam_is_rec=true }) 37 | ; ("gl", Lambda { lam_api=[]; lam_argname=None; lam_eff=HEmpty; lam_body=(CInt 5); lam_is_rec=true }) 38 | ; ("gl", Lambda { lam_api=[]; lam_argname=None; lam_eff=HEmpty; lam_body=(CInt 5); lam_is_rec=true }) 39 | ] 40 | 41 | let () = 42 | (GT.fmt api) Format.std_formatter api1 43 | -------------------------------------------------------------------------------- /regression/test825.t: -------------------------------------------------------------------------------- 1 | $ ./test825tuples.exe 2 | -------------------------------------------------------------------------------- /regression/test825tuples.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) p = GT.int * (GT.string * 'a) 2 | [@@deriving gt ~options:{show; gmap; compare; foldl }] 3 | 4 | type ('a, 'b, 'c) triple = 'a * 'b * 'c 5 | [@@deriving gt ~options:{show; gmap; compare; foldl }] 6 | 7 | type ('a, 'b, 'c) quattre = 'a * 'b * 'c * 'c 8 | [@@deriving gt ~options:{show; gmap; compare; foldl }] 9 | 10 | include (struct 11 | type t = GT.int * GT.string 12 | [@@deriving gt ~options:{show; gmap; compare; eq; eval; foldl; html; stateful }] 13 | end : sig 14 | type t = GT.int * GT.string 15 | [@@deriving gt ~plugins:{show; gmap; compare; eq; eval; foldl; html; stateful }] 16 | end) 17 | -------------------------------------------------------------------------------- /regression/test826.t: -------------------------------------------------------------------------------- 1 | $ ./test826antiph.exe 2 | "asdf" 3 | -------------------------------------------------------------------------------- /regression/test826antiph.ml: -------------------------------------------------------------------------------- 1 | include (struct 2 | type nonrec 'a foo = 'a [@@deriving gt ~options:{show; gmap; compare; foldl; eval; }] 3 | end : sig 4 | type 'a foo = 'a [@@deriving gt ~options:{show; gmap; compare; foldl; eval; }] 5 | end) 6 | 7 | let () = 8 | print_endline @@ GT.show foo (GT.show GT.string) "asdf" 9 | -------------------------------------------------------------------------------- /regression/test827.ml: -------------------------------------------------------------------------------- 1 | let () = print_endline "test827" 2 | 3 | type 'a aaa = 'a bbb GT.list 4 | and 'b bbb = 'b aaa GT.option 5 | 6 | (* [@@deriving gt ~options:{ show }] *) 7 | 8 | class virtual ['ia, 'a, 'sa, 'inh, 'extra, 'syn] aaa_t = 9 | object 10 | inherit ['ia bbb, 'a bbb, 'sa bbb, 'inh, 'extra, 'syn] GT.list_t 11 | end 12 | 13 | class virtual ['ib, 'b, 'sb, 'inh, 'extra, 'syn] bbb_t = 14 | object 15 | inherit ['ib aaa, 'b aaa, 'sb aaa, 'inh, 'extra, 'syn] GT.option_t 16 | end 17 | 18 | let gcata_aaa = GT.gcata_list 19 | let gcata_bbb = GT.gcata_option 20 | 21 | class ['a, 'extra_aaa] show_aaa_t_stub (_fself_aaa, show_bbb) 22 | (fa : unit -> _ -> string) = 23 | object 24 | inherit [unit, 'a, string, unit, 'extra_aaa, string] aaa_t 25 | constraint 'extra_aaa = 'a aaa 26 | 27 | inherit 28 | ['a bbb, 'extra_aaa] GT.show_list_t 29 | (show_bbb fa) 30 | (_fself_aaa : unit -> _ aaa -> string) 31 | end 32 | 33 | class ['b, 'extra_bbb] show_bbb_t_stub (show_aaa, _fself_bbb) 34 | (fb : unit -> _ -> string) = 35 | object 36 | inherit [unit, 'b, string, unit, 'extra_bbb, string] bbb_t 37 | constraint 'extra_bbb = 'b bbb 38 | inherit ['b aaa, 'extra_bbb] GT.show_option_t (show_aaa fb) _fself_bbb 39 | end 40 | 41 | let show_aaa_0 = fun eta -> 42 | new show_aaa_t_stub eta 43 | 44 | let fix_aaa aaa0 bbb0 = 45 | let rec traitaaa fa inh (subj : _) = 46 | gcata_aaa (aaa0 (traitaaa, traitbbb) fa) inh subj 47 | and traitbbb fb inh subj = 48 | gcata_bbb (bbb0 (traitaaa, traitbbb) fb) inh subj 49 | in 50 | (traitaaa, traitbbb) 51 | 52 | let show_bbb_0 = fun eta -> 53 | new show_bbb_t_stub eta 54 | 55 | (* let show_aaa eta__001_ = 56 | let f, _ = fix_aaa show_aaa_0 show_bbb_0 in 57 | f eta__001_ 58 | 59 | let show_bbb eta__002_ = 60 | let _, f = fix_aaa show_aaa_0 show_bbb_0 in 61 | f eta__002_ 62 | *) 63 | -------------------------------------------------------------------------------- /regression/test827.t: -------------------------------------------------------------------------------- 1 | $ ./test827.exe 2 | test827 3 | -------------------------------------------------------------------------------- /regression/test827mut.ml: -------------------------------------------------------------------------------- 1 | class virtual ['ia, 'a, 'sa, 'inh, 'syn] list_t = 2 | object 3 | method virtual c_Nil : 'inh -> 'syn 4 | method virtual c_Cons : 'inh -> 'a -> 'a list -> 'syn 5 | end 6 | 7 | let gcata_list tr inh s = 8 | match s with 9 | | [] -> tr#c_Nil inh 10 | | x :: xs -> tr#c_Cons inh x xs 11 | ;; 12 | 13 | class ['a, 'sa, 'syn] gmap_list_t fa fself = 14 | object 15 | constraint 'syn = 'sa list 16 | inherit [unit, 'a, 'sa, unit, 'syn] list_t 17 | method c_Nil _ = [] 18 | method c_Cons _ x xs = fa () x :: fself () xs 19 | end 20 | 21 | class virtual ['ia, 'a, 'sa, 'inh, 'syn] option_t = 22 | object 23 | method virtual c_None : 'inh -> 'syn 24 | method virtual c_Some : 'inh -> 'a -> 'syn 25 | end 26 | 27 | let gcata_option tr inh subj = 28 | match subj with 29 | | None -> tr#c_None inh 30 | | Some x -> tr#c_Some inh x 31 | ;; 32 | 33 | class ['a, 'sa, 'syn] gmap_option_t fa _fself = 34 | object 35 | constraint 'syn = 'sa option 36 | inherit [unit, 'a, 'sa, unit, 'syn] option_t 37 | method c_None () = None 38 | method c_Some () x = Some (fa () x) 39 | end 40 | 41 | type 'a bbb = AAA of 'a * 'a bbb GT.list 42 | and 'a aaa = BBB of 'a * 'a bbb GT.option [@@deriving gt ~options:{ gmap }] 43 | 44 | let __ (type a b) : (a -> b) -> a bbb -> b bbb = fun eta -> GT.gmap bbb eta 45 | -------------------------------------------------------------------------------- /regression/test828.t: -------------------------------------------------------------------------------- 1 | $ ./test828mut.exe 2 | -------------------------------------------------------------------------------- /regression/test828combi.ml: -------------------------------------------------------------------------------- 1 | type t = A of GT.int [@@deriving gt ~options:{show}] 2 | 3 | let () = Format.printf "Should be an ADT: `%s`\n%!" (GT.show t (A 5)) 4 | 5 | (* Let's override implementation to use fancy printing *) 6 | let t = 7 | { 8 | GT.gcata = gcata_t; 9 | GT.fix = (fun eta -> GT.transform_gc gcata_t eta); 10 | GT.plugins = (object method show (A n) = string_of_int n end) 11 | } 12 | 13 | let () = Format.printf "Should be a number: `%s`\n%!" (GT.show t (A 5)) 14 | 15 | (* By default t2 as being type abbreviation constructed in combinatorial manner 16 | (by not using class for type t *) 17 | type t2 = t [@@deriving gt ~options:{show}] 18 | let () = Format.printf "Should be a number: `%s`\n%!" (GT.show t2 (A 5)) 19 | -------------------------------------------------------------------------------- /regression/test828mut.ml: -------------------------------------------------------------------------------- 1 | class virtual ['ia, 'a, 'sa, 'inh, 'syn] list_t = 2 | object 3 | method virtual c_Nil : 'inh -> 'syn 4 | method virtual c_Cons : 'inh -> 'a -> 'a list -> 'syn 5 | end 6 | 7 | let gcata_list tr inh s = 8 | match s with 9 | | [] -> tr#c_Nil inh 10 | | x :: xs -> tr#c_Cons inh x xs 11 | ;; 12 | 13 | class ['a, 'sa, 'syn] gmap_list_t fa fself = 14 | object 15 | constraint 'syn = 'sa list 16 | inherit [unit, 'a, 'sa, unit, 'syn] list_t 17 | method c_Nil _ = [] 18 | method c_Cons _ x xs = fa () x :: fself () xs 19 | end 20 | 21 | class virtual ['ia, 'a, 'sa, 'inh, 'syn] option_t = 22 | object 23 | method virtual c_None : 'inh -> 'syn 24 | method virtual c_Some : 'inh -> 'a -> 'syn 25 | end 26 | 27 | let gcata_option tr inh subj = 28 | match subj with 29 | | None -> tr#c_None inh 30 | | Some x -> tr#c_Some inh x 31 | ;; 32 | 33 | class ['a, 'sa, 'syn] gmap_option_t fa _fself = 34 | object 35 | constraint 'syn = 'sa option 36 | inherit [unit, 'a, 'sa, unit, 'syn] option_t 37 | method c_None () = None 38 | method c_Some () x = Some (fa () x) 39 | end 40 | 41 | include ( 42 | struct 43 | type 'a aaa = 'a bbb GT.option 44 | and 'a bbb = 'a bbb GT.list [@@deriving gt ~options:{ gmap }] 45 | 46 | let __ (type a b) : (a -> b) -> a bbb -> b bbb = fun eta -> GT.gmap bbb eta 47 | end : 48 | sig 49 | type 'a aaa = 'a bbb GT.option 50 | and 'a bbb = 'a bbb GT.list [@@deriving gt ~options:{ gmap }] 51 | end) 52 | -------------------------------------------------------------------------------- /regression/test829.t: -------------------------------------------------------------------------------- 1 | $ ./test829enum.exe 2 | 0 1 2 3 | 65 66 67 4 | -------------------------------------------------------------------------------- /regression/test829enum.ml: -------------------------------------------------------------------------------- 1 | type t = A | B | C of int [@@deriving gt ~plugins:{enum}] 2 | 3 | let () = Format.printf "%d %d %d\n%!" (GT.enum t A) (GT.enum t B) (GT.enum t (C 1)) 4 | 5 | 6 | type u = [ `A | `B | `C of int ] [@@deriving gt ~options:{enum}] 7 | let () = Format.printf "%d %d %d\n%!" (GT.enum u `A) (GT.enum u `B) (GT.enum u (`C 1)) 8 | 9 | 10 | 11 | type arr = GT.int GT.array [@@deriving gt ~options:{enum}] 12 | 13 | type list = (GT.int -> GT.int) GT.list [@@deriving gt ~options:{enum}] 14 | 15 | type rec1 = { rec1_f1: int } [@@deriving gt ~options:{enum}] 16 | let __ { rec1_f1 }= { rec1_f1 = 23 + rec1_f1 } 17 | 18 | [@@@ocaml.warning "-27"] 19 | 20 | type 'a alg_constr = Constr1 of { count: 'a } [@@deriving gt ~options:{enum}] 21 | 22 | let __ = Constr1 { count = 23. } -------------------------------------------------------------------------------- /regression/test830.t: -------------------------------------------------------------------------------- 1 | $ ./test830mut.exe 2 | -------------------------------------------------------------------------------- /regression/test830mut.ml: -------------------------------------------------------------------------------- 1 | type 'a logic = 2 | | Var 3 | | Value of 'a 4 | [@@deriving gt ~options:{ gmap }] 5 | (* 6 | type nonrec ('a, 'a0) targ_fuly = T of 'a0 * 'a [@@deriving gt ~options:{ gmap }] 7 | 8 | type nonrec ('a, 'a1, 'a0) jtyp_fuly = 9 | | Array of 'a1 10 | | V of 'a0 11 | [@@deriving gt ~options:{ gmap }] 12 | 13 | type 'a targ_logic = ('a, 'a jtyp_logic) targ_fuly logic 14 | 15 | and 'a jtyp_logic = ('a, 'a jtyp_logic, 'a targ_logic) jtyp_fuly logic 16 | [@@deriving gt ~options:{ gmap }] 17 | 18 | let (_ : ('a -> 'b) -> 'a targ_logic -> 'b targ_logic) = fun eta -> GT.gmap targ_logic eta 19 | 20 | let __ : 'a 'b. ('a -> 'b) -> 'a jtyp_logic -> 'b jtyp_logic = 21 | fun eta -> GT.gmap jtyp_logic eta 22 | ;; *) 23 | 24 | type nonrec ('a, 'a0) targ_fuly = T of 'a0 * 'a [@@deriving gt ~options:{ gmap }] 25 | 26 | type nonrec ('a, 'a1, 'a0) jtyp_fuly = 27 | | Array of 'a1 28 | | V of 'a0 29 | [@@deriving gt ~options:{ gmap }] 30 | 31 | type 'a targ_logic = ('a, 'a jtyp_logic) targ_fuly logic 32 | 33 | and 'a jtyp_logic = ('a, 'a jtyp_logic, 'a targ_logic) jtyp_fuly logic 34 | [@@deriving gt ~options:{ gmap }] 35 | 36 | let __ (type a b) : (a -> b) -> a jtyp_logic -> b jtyp_logic = 37 | fun eta -> GT.gmap jtyp_logic eta 38 | ;; 39 | -------------------------------------------------------------------------------- /regression/test840.t: -------------------------------------------------------------------------------- 1 | $ ./test840garrique.exe 2 | 17 3 | 2 4 | 17 5 | 2 6 | (\_3 -> (x + 1)) 7 | -------------------------------------------------------------------------------- /regression_ppx/.gitignore: -------------------------------------------------------------------------------- 1 | /*.log 2 | *.diff 3 | 4 | -------------------------------------------------------------------------------- /regression_ppx/test029.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | type ('a, 'b) t = int * (string * ('a * 'b)) 4 | [@@deriving gt ~show ~gmap ~eq ~compare] 5 | 6 | 7 | class ['a, 'b] print _ fa fb = 8 | object 9 | inherit ['a, unit, unit, 'b, unit, unit, unit, unit, _] class_t 10 | method c_Pair () x (y, (a, b)) = 11 | Printf.printf "%d\n" x; 12 | Printf.printf "%s\n" y; 13 | fa () a; 14 | fb () b; 15 | end 16 | 17 | let printer fa fb subj = 18 | GT.fix0 (fun self -> GT.transform t (new print self fa fb) ()) subj 19 | 20 | let _ = 21 | let cs = function EQ -> "EQ" | GT -> "GT" | LT -> "LT" in 22 | let c x y = if x = y then EQ else if x < y then LT else GT in 23 | let x = (1, ("2", ("a", `B))) in 24 | let y = (1, ("2", ("3", `B))) in 25 | 26 | let eq1 fa fb x y = 27 | GT.fix0 (fun self -> transform(t) (new eq_t self fa fb )) x y 28 | in 29 | let cmp1 fa fb x y = 30 | GT.fix0 (fun self -> transform(t) (new compare_t self fa fb )) x y 31 | in 32 | 33 | Printf.printf "x == x: %b\n" (eq1 (=) (=) x x); 34 | Printf.printf "x == y: %b\n" (eq1 (=) (=) x y); 35 | Printf.printf "compare (x, x) = %s\n" (cs @@ cmp1 c c x x); 36 | Printf.printf "compare (x, y) = %s\n" (cs @@ cmp1 c c x y); 37 | Printf.printf "compare (y, x) = %s\n" (cs @@ cmp1 c c y x); 38 | Printf.printf "%s\n" @@ 39 | GT.show t string_of_int (function `B -> "`B") @@ 40 | GT.gmap t int_of_string (fun x -> x) y 41 | ; 42 | printer 43 | (fun _ a -> Printf.printf "%s\n" a) 44 | (fun _ -> function `B -> Printf.printf "`B\n") 45 | x 46 | -------------------------------------------------------------------------------- /regression_ppx/test037.ml: -------------------------------------------------------------------------------- 1 | type 'a t1 = [`A | `B of 'a] [@@deriving gt ~show ~gmap] 2 | type 'a t2 = [`C | `D of 'a] [@@deriving gt ~show ~gmap] 3 | type 'a t = ['a t1 | 'a t2] [@@deriving gt ~show ~gmap] 4 | 5 | let _ = 6 | let a = `B (`B `A) in 7 | let rec mapt1 x = 8 | GT.fix0 (fun self -> GT.transform(t1) (new gmap_t1 self self) ()) x 9 | in 10 | let rec show1 x = 11 | GT.fix0 (fun self -> GT.transform(t1) (new show_t1 self self) ()) x 12 | in 13 | Printf.printf "a=%s, map a=%s\n" (show1 a) (show1 (mapt1 a)); 14 | 15 | let b = `D (`D `C) in 16 | let rec mapt2 x = 17 | GT.fix0 (fun self -> GT.transform(t2) (new gmap_t2 self self) ()) x 18 | in 19 | let rec show2 x = 20 | GT.fix0 (fun self -> GT.transform(t2) (new show_t2 self self) ()) x 21 | in 22 | Printf.printf "b=%s, map b=%s\n" (show2 b) (show2 (mapt2 b)); 23 | 24 | let c = `D (`B (`D `A)) in 25 | let rec mapt x = 26 | GT.fix0 (fun self -> GT.transform(t) (new gmap_t self self) ()) x 27 | in 28 | let rec show x = 29 | GT.fix0 (fun self -> GT.transform(t) (new show_t self self) ()) x 30 | in 31 | Printf.printf "c=%s, map c=%s\n" (show c) (show (mapt c)) 32 | -------------------------------------------------------------------------------- /regression_ppx/test089struct.ml: -------------------------------------------------------------------------------- 1 | type 'info expr_node = 2 | | EConst of GT.int 3 | | EAdd of 'info expr * 'info expr 4 | and 'info expr = 5 | { info : 'info ; node : 'info expr_node } 6 | [@@deriving gt ~show ~gmap ] 7 | 8 | 9 | let e1 = {info="asdf"; node=EConst 19} 10 | let e2 = {info="x"; node= EAdd ({info="y";node=EConst 20}, {info="z";node=EConst 40})} 11 | let () = 12 | print_endline @@ show_expr (fun s -> s) e1; 13 | print_endline @@ show_expr (fun s -> s) @@ gmap_expr ((^)"__") e1; 14 | print_endline @@ show_expr (fun s -> s) e2; 15 | print_endline @@ show_expr (fun s -> s) @@ gmap_expr ((^)"__") e2; 16 | () 17 | -------------------------------------------------------------------------------- /regression_ppx/test801.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | module AL : sig 4 | type ('a,'b) alist = Nil | Cons of 'a * 'b 5 | [@@deriving gt ~gmap ~show ~foldl ] 6 | end = struct 7 | type ('a,'b) alist = Nil | Cons of 'a * 'b 8 | [@@deriving gt ~gmap ~show ~foldl ] 9 | end 10 | 11 | 12 | 13 | let () = 14 | let open AL in 15 | let sh xs = show_alist id id xs in 16 | (* let fo xs = foldl_alist (fun () -> id) (fun () -> id) "" xs in *) 17 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", "bbb")); 18 | (* Printf.printf "%s\n%!" (fo @@ Cons ("aaa", "bbb")); *) 19 | () 20 | 21 | module L : sig 22 | type 'a list = ('a, 'a list) AL.alist 23 | [@@deriving gt ~gmap ~show ~foldl ] 24 | 25 | end = struct 26 | type 'a list = ('a, 'a list) AL.alist 27 | [@@deriving gt ~gmap ~show ~foldl ] 28 | end 29 | 30 | let () = 31 | let open L in 32 | let sh x = show_list id x in 33 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", Cons ("bbb", Nil))) 34 | 35 | module Lo : sig 36 | type 'a logic = Var of GT.int | Value of 'a 37 | [@@deriving gt ~gmap ~show ~foldl ] 38 | end = struct 39 | type 'a logic = Var of GT.int | Value of 'a 40 | [@@deriving gt ~gmap ~show ~foldl ] 41 | end 42 | 43 | let () = 44 | let open Lo in 45 | let sh x = show_logic id x in 46 | Printf.printf "%s\t%s\n%!" (sh @@ Var 5) (sh @@ Value "asdf") 47 | 48 | module LList : sig 49 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 50 | [@@deriving gt ~gmap ~show ~foldl ] 51 | end = struct 52 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 53 | [@@deriving gt ~gmap ~show ~foldl ] 54 | end 55 | 56 | let () = 57 | let sh x = LList.show_llist id x in 58 | Printf.printf "%s\n%!" (sh @@ Value (Cons ("aaa", Value (Cons ("bbb", Var 15)))) ) 59 | -------------------------------------------------------------------------------- /regression_ppx/test802.log: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PLTools/GT/7eda298fa0bc4e4bb96f3dcfbb20efebc38ae4af/regression_ppx/test802.log -------------------------------------------------------------------------------- /regression_ppx/test805nonrec.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | type 'a maybe = Just of 'a | Nothing [@@deriving gt ~gmap ~show ] 4 | 5 | module P = struct 6 | type ('a,'b) p = 'a * 'b [@@deriving gt ~gmap ~show ] 7 | end 8 | open P 9 | type nonrec ('a,'b) p = ('a,'b) p maybe [@@deriving gt ~gmap ~show ] 10 | 11 | (* There is an issue with nonrec that when we will define a class 12 | we will not be able to see previous type `p`. 13 | *) 14 | module Test2 = struct 15 | open P 16 | type ('a,'b) p = ('a,'b) p maybe [@@deriving gt ~gmap ~show ] 17 | end 18 | -------------------------------------------------------------------------------- /regression_ppx/test807showT.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | let show_typed_string = Printf.sprintf "\"%s\"" 4 | 5 | module AL : sig 6 | type ('a,'b) alist = Nil | Cons of 'a * 'b 7 | [@@deriving gt ~show ~show_typed ~gmap ] 8 | end = struct 9 | type ('a,'b) alist = Nil | Cons of 'a * 'b 10 | [@@deriving gt ~show ~show_typed ~gmap ] 11 | end 12 | 13 | 14 | let () = 15 | let open AL in 16 | let sh xs = show_typed_alist 17 | "string" show_typed_string 18 | "string" show_typed_string xs 19 | in 20 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", "bbb")); 21 | () 22 | 23 | module L : sig 24 | type 'a list = ('a, 'a list) AL.alist 25 | [@@deriving gt ~show_typed ] 26 | end = struct 27 | type 'a list = ('a, 'a list) AL.alist 28 | [@@deriving gt ~show_typed ] 29 | end 30 | 31 | 32 | let () = 33 | let open L in 34 | let sh x = show_typed_list "string" show_typed_string x in 35 | Printf.printf "%s\n%!" (sh @@ Cons ("aaa", Cons ("bbb", Nil))) 36 | 37 | 38 | module GT = struct 39 | include GT 40 | let int = 41 | {gcata = int.gcata; 42 | plugins = object 43 | method show_typed = int.plugins#show 44 | method show = int.plugins#show 45 | method gmap = int.plugins#gmap 46 | end 47 | } 48 | end 49 | 50 | module Lo : sig 51 | type 'a logic = Var of GT.int | Value of 'a 52 | [@@deriving gt ~show_typed ] 53 | end = struct 54 | type 'a logic = Var of GT.int | Value of 'a 55 | [@@deriving gt ~show_typed ] 56 | end 57 | 58 | (* enhancing a class to print a type for constructor Var *) 59 | class ['a,'extra] show_typed_logic fself typ_a fa = object 60 | inherit ['a, 'extra] Lo.show_typed_logic fself typ_a fa 61 | method c_Var () _a = 62 | Format.sprintf "Var(%s : %s)" 63 | ((GT.int.GT.plugins)#show_typed _a) 64 | typ_a 65 | end 66 | 67 | let rec custom_show_typed_logic typ_a fa subj = 68 | GT.fix0 69 | (fun self -> Lo.gcata_logic ((new show_typed_logic) self typ_a fa) ()) 70 | subj 71 | 72 | let () = 73 | let open Lo in 74 | let sh x = custom_show_typed_logic "string" show_typed_string x in 75 | Printf.printf "%s\t%s\n%!" (sh @@ Var 5) (sh @@ Value "asdf") 76 | 77 | module LList : sig 78 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 79 | [@@deriving gt ~show_typed ] 80 | end = struct 81 | type 'a llist = ('a, 'a llist) AL.alist Lo.logic 82 | [@@deriving gt ~show_typed ] 83 | end 84 | 85 | let () = 86 | let sh x = LList.show_typed_llist "string" show_typed_string x in 87 | Printf.printf "%s\n%!" (sh @@ Value (Cons ("aaa", Value (Cons ("bbb", Var 15)))) ) 88 | 89 | 90 | (* Now let's try show_typed for mutal recursion *) 91 | 92 | module Mutal = struct 93 | type 'a foo = F1 of 'a | F2 of 'a boo 94 | and 'b boo = B1 of 'b | B2 of 'b foo 95 | [@@deriving gt ~show_typed ] 96 | 97 | let () = 98 | let sh1 x = show_typed_foo "string" show_typed_string x in 99 | let sh2 x = show_typed_boo "string" show_typed_string x in 100 | 101 | Printf.printf "%s\n%!" (sh1 @@ F2 (B2 (F1 "asdf"))); 102 | Printf.printf "%s\n%!" (sh1 @@ F2 (B2 (F2 (B1 "z")))); 103 | Printf.printf "%s\n%!" (sh2 @@ B2 (F2 (B2 (F1 "asdf"))) ); 104 | Printf.printf "%s\n%!" (sh2 @@ B2 (F2 (B2 (F2 (B1 "z")))) ); 105 | () 106 | end 107 | -------------------------------------------------------------------------------- /regression_ppx/test809struct.ml: -------------------------------------------------------------------------------- 1 | type 'info expr_node = 2 | | EConst of GT.int 3 | | EAdd of 'info expr * 'info expr 4 | and 'info expr = 5 | { info : 'info ; node : 'info expr_node } 6 | [@@deriving gt ~show ~gmap ] 7 | 8 | 9 | let e1 = {info="asdf"; node=EConst 19} 10 | let e2 = {info="x"; node= EAdd ({info="y";node=EConst 20}, {info="z";node=EConst 40})} 11 | let () = 12 | print_endline @@ show_expr (fun s -> s) e1; 13 | print_endline @@ show_expr (fun s -> s) @@ gmap_expr ((^)"__") e1; 14 | print_endline @@ show_expr (fun s -> s) e2; 15 | print_endline @@ show_expr (fun s -> s) @@ gmap_expr ((^)"__") e2; 16 | () 17 | -------------------------------------------------------------------------------- /regression_ppx/test810lists.ml: -------------------------------------------------------------------------------- 1 | open GT 2 | 3 | type 'a list = Cons of 'a * 'a list | Nil [@@deriving gt ~gmap ~show ] 4 | type t = [ `A | `B ] list 5 | [@@deriving gt ~gmap ~show ] 6 | 7 | 8 | (* type ('a,'b) demo = 'a * 'b *) 9 | (* type nonrec ('a,'b) demo = ('a,'b) demo list *) 10 | -------------------------------------------------------------------------------- /sample/.gitignore: -------------------------------------------------------------------------------- 1 | # test files for OCaml parsetree HTMLizer 2 | /test.ml 3 | /out.html 4 | /out.fmt.txt 5 | *.aux 6 | *.nav 7 | *.out 8 | *.snm 9 | *.toc 10 | *.vrb 11 | -------------------------------------------------------------------------------- /sample/a.ml: -------------------------------------------------------------------------------- 1 | let f x = 1 + x 2 | -------------------------------------------------------------------------------- /sample/bullet.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PLTools/GT/7eda298fa0bc4e4bb96f3dcfbb20efebc38ae4af/sample/bullet.gif -------------------------------------------------------------------------------- /sample/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -warn-error -A -w -7-32-39)))) 5 | 6 | (executable 7 | (name expr) 8 | (modules Expr) 9 | (libraries GT) 10 | (preprocess 11 | (action 12 | (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) 13 | (preprocessor_deps 14 | (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) 15 | 16 | (executable 17 | (name lambdas) 18 | (modules Lambdas) 19 | (libraries GT) 20 | (preprocess 21 | (action 22 | (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) 23 | (preprocessor_deps 24 | (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) 25 | 26 | (executable 27 | (name nameless) 28 | (modules Nameless) 29 | (libraries GT) 30 | (preprocess 31 | (action 32 | (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) 33 | (preprocessor_deps 34 | (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) 35 | 36 | (executable 37 | (name lists) 38 | (modules Lists) 39 | (flags 40 | (:standard -rectypes -w -27)) 41 | (libraries GT) 42 | (preprocess 43 | (action 44 | (run %{project_root}/camlp5/pp5+gt+plugins+dump.exe %{input-file}))) 45 | (preprocessor_deps 46 | (file %{project_root}/camlp5/pp5+gt+plugins+dump.exe))) 47 | -------------------------------------------------------------------------------- /sample/lists.ml: -------------------------------------------------------------------------------- 1 | module AL : sig 2 | @type ('a,'b) alist = [] [@name "nil"] | (::) of 'a * 'b [@name "cons"] 3 | with show,foldl,gmap 4 | end = struct 5 | @type ('a,'b) alist = [] [@name "nil"] | (::) of 'a * 'b [@name "cons"] 6 | with show,foldl,gmap 7 | end 8 | 9 | let () = 10 | let open AL in 11 | let sh xs = GT.show alist Fun.id Fun.id xs in 12 | Printf.printf "%s\n%!" (sh @@ "aaa" :: "bbb"); 13 | () 14 | 15 | module L : sig 16 | @type 'a list = ('a, 'a list) AL.alist with show,gmap,foldl 17 | end = struct 18 | @type 'a list = ('a, 'a list) AL.alist with show,gmap,foldl 19 | end 20 | 21 | let () = 22 | let open L in 23 | let sh x = GT.show list Fun.id x in 24 | Printf.printf "%s\n%!" (sh @@ "aaa" :: "bbb" :: []) 25 | 26 | module Lo : sig 27 | @type 'a logic = Var of GT.int | Value of 'a with show,gmap,foldl 28 | end = struct 29 | @type 'a logic = Var of GT.int | Value of 'a with show,gmap,foldl 30 | end 31 | 32 | let () = 33 | let open Lo in 34 | let sh x = GT.show logic Fun.id x in 35 | Printf.printf "%s\t%s\n%!" (sh @@ Var 5) (sh @@ Value "asdf") 36 | 37 | 38 | module LList : sig 39 | @type 'a llist = ('a, 'a llist) AL.alist Lo.logic with show,gmap,foldl 40 | end = struct 41 | @type 'a llist = ('a, 'a llist) AL.alist Lo.logic with show,gmap,foldl 42 | end 43 | 44 | let () = 45 | let sh x = GT.show LList.llist Fun.id x in 46 | Printf.printf "%s\n%!" (sh @@ Value ("aaa" :: Value ("bbb" :: Var 15)) ) 47 | 48 | module Lo2 = struct 49 | (* printing logic values without a constructor Value *) 50 | include Lo 51 | 52 | class ['a, 'self] my_show fa fself = object 53 | inherit ['a, 'self] Lo.show_logic_t fa fself 54 | method c_Value () _ x = fa () x 55 | end 56 | 57 | let logic = 58 | { Lo.logic with 59 | GT.plugins = object 60 | method show fa xs = 61 | GT.transform (Lo.logic) (new my_show (GT.lift fa)) () xs 62 | method gmap x = Lo.logic.GT.plugins#gmap x 63 | method foldl x = Lo.logic.GT.plugins#foldl x 64 | end } 65 | end 66 | 67 | let () = 68 | let open Lo2 in 69 | let sh x = GT.show logic Fun.id x in 70 | Printf.printf "Modified implementation:\n%!"; 71 | Printf.printf "\t%s\n%!" (sh @@ Var 5); 72 | Printf.printf "\t%s\n%!" (sh @@ Value "asdf"); 73 | () 74 | 75 | module ReworkedLList : sig 76 | @type 'a llist = ('a, 'a llist) AL.alist Lo2.logic with show,gmap,foldl 77 | end = struct 78 | @type 'a llist = ('a, 'a llist) AL.alist Lo2.logic with show,gmap,foldl 79 | end 80 | 81 | let () = 82 | let sh x = GT.show ReworkedLList.llist Fun.id x in 83 | Printf.printf "Printing of modified logic list\n"; 84 | Printf.printf "%s\n%!" (sh @@ Value ("aaa" :: (Value ("bbb" :: (Var 15)))) ) 85 | -------------------------------------------------------------------------------- /sample/minus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PLTools/GT/7eda298fa0bc4e4bb96f3dcfbb20efebc38ae4af/sample/minus.gif -------------------------------------------------------------------------------- /sample/mktree.css: -------------------------------------------------------------------------------- 1 | /* Put this inside a @media qualifier so Netscape 4 ignores it */ 2 | @media screen, print { 3 | /* Turn off list bullets */ 4 | ul.mktree li { list-style: none; } 5 | /* Control how "spaced out" the tree is */ 6 | ul.mktree, ul.mktree ul , ul.mktree li { margin-left:10px; padding:0px; } 7 | /* Provide space for our own "bullet" inside the LI */ 8 | ul.mktree li .bullet { padding-left: 15px; } 9 | /* Show "bullets" in the links, depending on the class of the LI that the link's in */ 10 | ul.mktree li.liOpen .bullet { cursor: pointer; background: url(minus.gif) center left no-repeat; } 11 | ul.mktree li.liClosed .bullet { cursor: pointer; background: url(plus.gif) center left no-repeat; } 12 | ul.mktree li.liBullet .bullet { cursor: default; background: url(bullet.gif) center left no-repeat; } 13 | /* Sublists are visible or not based on class of parent LI */ 14 | ul.mktree li.liOpen ul { display: block; } 15 | ul.mktree li.liClosed ul { display: none; } 16 | /* Format menu items differently depending on what level of the tree they are in */ 17 | ul.mktree li { font-size: 12pt; } 18 | ul.mktree li ul li { font-size: 10pt; } 19 | ul.mktree li ul li ul li { font-size: 8pt; } 20 | ul.mktree li ul li ul li ul li { font-size: 6pt; } 21 | } 22 | -------------------------------------------------------------------------------- /sample/nameless.ml: -------------------------------------------------------------------------------- 1 | @type ('name, 'lam) lam = 2 | [ `App of 'lam * 'lam 3 | | `Var of 'name 4 | ] with show 5 | 6 | let index xs v = 7 | let rec helper i = function 8 | | [] -> failwith "No such variable introduced" 9 | | h :: _ when h = v -> i 10 | | _ :: tl -> helper (1+i) tl 11 | in 12 | helper 0 xs 13 | 14 | class [ 'lam , 'nless ] lam_to_nameless 15 | (flam : string list -> 'lam -> 'nless) = 16 | object 17 | inherit 18 | [ string list , string , int 19 | , string list , 'lam , 'nless 20 | , string list , 'lam , 'nless ] lam_t 21 | method c_App env _ l r = 22 | `App (flam env l, flam env r) 23 | method c_Var env _ x = `Var (index env x) 24 | end 25 | 26 | @type ('name , 'lam) abs = [ `Abs of 'name * 'lam ] with show 27 | 28 | class [ 'lam , 'nless ] abs_to_nameless 29 | (flam : string list -> 'lam -> 'nless) = 30 | object 31 | inherit [ string list, string, int 32 | , string list, 'lam, 'nless 33 | , string list, 'lam, 'nless ] abs_t 34 | method c_Abs env _ name term = 35 | `Abs (flam (name :: env) term) 36 | end 37 | 38 | @type ('name, 'lam) term = 39 | [ ('name, 'lam) lam 40 | | ('name, 'lam) abs ] with show 41 | 42 | @type named = (GT.string, named) term with show 43 | @type nameless = [ (GT.int , nameless) lam | `Abs of nameless ] with show 44 | 45 | class to_nameless (f : string list -> named -> nameless) = 46 | object 47 | inherit [ string list , named , nameless ] named_t 48 | inherit [ named , nameless ] lam_to_nameless f 49 | inherit [ named , nameless ] abs_to_nameless f 50 | end 51 | 52 | let to_nameless term = 53 | GT.transform(named) 54 | (fun fself -> new to_nameless fself) 55 | [] 56 | term 57 | 58 | let () = 59 | Format.printf "%s\n%!" (GT.show nameless (to_nameless (`Abs ("x", `Var "x")))); 60 | Format.printf "%s\n%!" (GT.show nameless (to_nameless (`Abs ("x", `Abs ("y", `Var "x"))) ) ) 61 | -------------------------------------------------------------------------------- /sample/old/murec.ml: -------------------------------------------------------------------------------- 1 | generic t = 2 | Var of [string] 3 | | P of p 4 | | Const of [int] 5 | | Add of t * t 6 | | Sub of t * t 7 | and p = C of [int] | V of [string] | E of t 8 | 9 | (* 10 | let show = GT.transform(t) (new @t[show]) () 11 | 12 | let _ = 13 | Printf.printf "%s\n" (show (Add (P (C 1), Var "a"))) 14 | *) 15 | -------------------------------------------------------------------------------- /sample/old/show.ml: -------------------------------------------------------------------------------- 1 | 2 | open Pa_gt.Plugin 3 | 4 | let _ = 5 | register "show" 6 | (fun loc d -> 7 | let module H = Helper (struct let loc = loc end) in 8 | H.( 9 | { 10 | inh = T.id "unit"; 11 | syn = T.id "string"; 12 | proper_args = List.map (fun (Variable (_, a)) -> a) d.type_args; 13 | arg_img = (fun _ -> T.id "string") 14 | }, 15 | (fun env constr -> 16 | let concat x y = E.app [E.lid "^"; x; y] in 17 | concat 18 | (snd 19 | (List.fold_left 20 | (fun (first, expr as acc) arg -> 21 | let append e = 22 | false, concat expr (if first then e else concat (E.str ", ") e) 23 | in 24 | match arg with 25 | | arg, Arbitrary ctyp -> 26 | (match ctyp with 27 | | <:ctyp< $lid:tname$ >> -> 28 | (match tname with 29 | | "int" -> append (E.app [E.lid "string_of_int"; E.lid arg]) 30 | | "string" -> append (E.lid arg) 31 | | _ -> acc 32 | ) 33 | | _ -> acc 34 | ) 35 | | arg, _ -> 36 | append (E.app [E.fx (E.lid arg); E.unit]) 37 | ) 38 | (true, E.str (constr.constr ^ " (")) 39 | constr.args 40 | ) 41 | ) 42 | (E.str ")") 43 | ) 44 | ) 45 | ) 46 | -------------------------------------------------------------------------------- /sample/plus.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PLTools/GT/7eda298fa0bc4e4bb96f3dcfbb20efebc38ae4af/sample/plus.gif -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -warn-error -A -w -32)))) 5 | 6 | (library 7 | (name View) 8 | (public_name GT.View) 9 | (modules View) 10 | (flags 11 | (:standard -w -27-33 -warn-error -A))) 12 | 13 | (library 14 | (name HTML) 15 | (public_name GT.HTML) 16 | (libraries View) 17 | (modules HTML) 18 | (flags 19 | (:standard -w -27-33 -warn-error -A))) 20 | 21 | (library 22 | (name GT) 23 | (public_name GT) 24 | (modules GT) 25 | (libraries HTML) 26 | (synopsis "Generic transformers for algebraic types") 27 | (preprocessor_deps 28 | ;(package GT-p5) 29 | (file %{project_root}/src/macro.m4) 30 | (file %{project_root}/camlp5/pp5+gt+dump.exe)) 31 | (preprocess 32 | (per_module 33 | ((action 34 | (run 35 | sh 36 | -c 37 | "m4 %{project_root}/src/macro.m4 %{input-file} > GT.tmp && %{project_root}/camlp5/pp5+gt+dump.exe -impl GT.tmp && rm -f GT.tmp")) 38 | GT))) 39 | (flags 40 | (:standard -w -27-33))) 41 | 42 | ; (library 43 | ; (name syntax_p5) 44 | ; (public_name GT.syntax) 45 | ; (wrapped false) 46 | ; (modules) 47 | ; (libraries GT-p5)) 48 | -------------------------------------------------------------------------------- /work/.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=compact 2 | sequence-style = terminator 3 | -------------------------------------------------------------------------------- /work/demo1.ml: -------------------------------------------------------------------------------- 1 | type 'a list = 'a List.t = [] | ( :: ) of 'a * 'a list [@@deriving fold] 2 | 3 | type 'a btree = Leaf of 'a | Node of 'a btree * 'a btree [@@deriving fold] 4 | 5 | module Manual = struct 6 | let rec sum_list = function [] -> 0 | n :: xs -> n + sum_list xs 7 | 8 | let%test _ = sum_list [ 1; 2; 3 ] = 6 9 | 10 | let%test _ = sum_list [ 1; 2; 3 ] = 6 11 | 12 | let rec sum_btree = function 13 | | Leaf n -> n 14 | | Node (l, r) -> sum_btree l + sum_btree r 15 | 16 | let%test _ = sum_btree (Node (Node (Leaf 1, Leaf 2), Leaf 3)) = 6 17 | 18 | let rec fold_btree_left f acc = function 19 | | Leaf _ -> f acc 1 20 | | Node (l, r) -> fold_btree_left f (fold_btree_left f acc l) r 21 | 22 | let sum_btree2 t = fold_btree_left (fun x y -> 1 + x + y) 0 t 23 | 24 | let%test _ = 25 | let s = sum_btree2 (Node (Node (Leaf 1, Leaf 2), Leaf 3)) in 26 | s = 6 27 | end 28 | 29 | let sum_list2 xs = fold_list ( + ) 0 xs 30 | 31 | let%test _ = sum_list2 [ 1; 2; 3 ] = 6 32 | 33 | let sum_btree2 t = fold_btree ( + ) 0 t 34 | 35 | let () = () 36 | 37 | let%test _ = sum_btree2 (Node (Node (Leaf 1, Leaf 2), Leaf 3)) = 6 38 | -------------------------------------------------------------------------------- /work/demo2.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | type expr = Const of int | Var of string | Binop of string * expr * expr 4 | 5 | let rec show = function 6 | | Const n -> sprintf "Const %d" n 7 | | Var x -> sprintf "Var %s" x 8 | | Binop (o, l, r) -> sprintf "Binop (%S , %s , %s)" o (show l) (show r) 9 | 10 | let prio = function "*" | "/" -> 2 | "+" | "-" -> 1 | _ -> 0 11 | let br s = asprintf "(%s)" s 12 | 13 | let pretty e = 14 | let rec helper p = function 15 | | Const n -> string_of_int n 16 | | Var x -> x 17 | | Binop (o, l, r) -> 18 | let po = prio o in 19 | sprintf "%s %s %s" (helper po l) o (helper po r) 20 | |> if po <= p then br else Fun.id in 21 | helper min_int e 22 | 23 | let gcata i tr = function 24 | | Const n -> tr#const i n 25 | | Var x -> tr#var i x 26 | | Binop (o, l, r) -> tr#binop i o l r 27 | 28 | let rec pretty inh e = 29 | gcata inh 30 | (object 31 | method const _ n = string_of_int n 32 | 33 | method var _ x = x 34 | 35 | method binop p o l r = 36 | let po = prio o in 37 | sprintf "%s %s %s" (pretty po l) o (pretty po r) 38 | |> if po <= p then br else Fun.id 39 | end ) 40 | e 41 | 42 | (* let%test _ = pretty () (Var "x") = "x" *) 43 | 44 | class virtual ['i, 'self, 's] show_expr = 45 | object 46 | method virtual const : 'i -> int -> 's 47 | 48 | method virtual var : 'i -> string -> 's 49 | 50 | method virtual binop : 'i -> string -> expr -> expr -> 's 51 | end 52 | 53 | class pretty fself = 54 | object 55 | inherit [int, _, string] show_expr 56 | 57 | method const _ = sprintf "%d" 58 | 59 | method var _ = Fun.id 60 | 61 | method binop p o l r = 62 | let po = prio o in 63 | sprintf "%s %s %s" (fself po l) o (fself po r) 64 | |> if po <= p then br else Fun.id 65 | end 66 | -------------------------------------------------------------------------------- /work/demo_mutual.ml: -------------------------------------------------------------------------------- 1 | type ab = A | B of cd 2 | and cd = C | D of ab 3 | 4 | module Default = struct 5 | 6 | 7 | end 8 | 9 | 10 | module Attempt1 = struct 11 | open Printf 12 | 13 | class show_abcd ((fab : unit -> ab -> string), (fcd: unit -> cd -> string)) = object 14 | method c_A () (_:ab) = "A" 15 | method c_B () (_:ab) (cd: cd) : string = sprintf "C (%s)" (fcd () cd) 16 | method c_C () (_:cd) = "C" 17 | method c_D () (_:cd) (ab: ab) = sprintf "D (%s)" (fab () ab) 18 | end 19 | 20 | let gcata_ab tr i = function 21 | | A -> tr#c_A i A 22 | | B cd -> tr#c_B i (B cd) cd 23 | let gcata_cd tr i = function 24 | | C -> tr#c_C i C 25 | | D ab -> tr#c_D i (D ab) ab 26 | 27 | let fix_decl constr = 28 | let rec trait_ab inh subj = 29 | gcata_ab (constr (trait_ab, trait_cd)) inh subj 30 | and trait_cd inh subj = gcata_cd (constr (trait_ab, trait_cd)) inh subj in 31 | (trait_ab, gcata_ab) 32 | (* Тут по сути мы экономим только на том, что объект один, а не два *) 33 | 34 | end 35 | 36 | 37 | 38 | module Attempt2 = struct 39 | open Printf 40 | 41 | let gcata_ab tr i = function 42 | | A -> tr#c_A i A 43 | | B cd -> tr#c_B i (B cd) cd 44 | let gcata_cd tr i = function 45 | | C -> tr#c_C i C 46 | | D ab -> tr#c_D i (D ab) ab 47 | 48 | class show_abcd = object(tr) 49 | method c_A () (_:ab) = "A" 50 | method c_B () (_:ab) (cd: cd) : string = sprintf "C (%s)" (tr#gcata_cd () cd) 51 | method c_C () (_:cd) = "C" 52 | method c_D () (_:cd) (ab: ab) = sprintf "D (%s)" (tr#gcata_ab () ab) 53 | 54 | method gcata_ab = gcata_ab tr 55 | method gcata_cd = gcata_cd tr 56 | end 57 | 58 | 59 | let fix_abcd constr = 60 | let rec trait_ab inh subj = 61 | gcata_ab constr inh subj 62 | and trait_cd inh subj = gcata_cd constr inh subj in 63 | (trait_ab, trait_cd) 64 | (* Тут по сути мы экономим только на том, что объект один, а не два *) 65 | 66 | let (show_ab, show_cd) = fix_abcd (new show_abcd) 67 | 68 | (* or more precisely *) 69 | let show_ab () x = gcata_ab (new show_abcd) () x 70 | end 71 | -------------------------------------------------------------------------------- /work/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | (:standard -w -32)))) 5 | 6 | (library 7 | (name demo1) 8 | (modules demo1) 9 | (inline_tests) 10 | (preprocess 11 | (pps ppx_expect ppx_deriving.fold))) 12 | 13 | (library 14 | (name demo2) 15 | (modules demo2) 16 | (inline_tests) 17 | (preprocess 18 | (pps ppx_expect ppx_deriving.fold))) 19 | 20 | (executable 21 | (name demo_mutual) 22 | (modules demo_mutual) 23 | ) 24 | --------------------------------------------------------------------------------