diff --git a/.github/workflows/doc.yml b/.github/workflows/doc.yml index 47cc783a9..cdd57bf5a 100644 --- a/.github/workflows/doc.yml +++ b/.github/workflows/doc.yml @@ -22,7 +22,7 @@ jobs: - name: setup ocaml uses: avsm/setup-ocaml@v1 with: - ocaml-version: 4.07.1 + ocaml-version: 4.09.1 - name: install deps run: | diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml index 574f47e7b..0b4607b51 100644 --- a/.github/workflows/main.yml +++ b/.github/workflows/main.yml @@ -16,9 +16,9 @@ jobs: strategy: matrix: coq_version: - - '8.15' + - '8.16' ocaml_version: - - '4.07-flambda' + - '4.09-flambda' - '4.13-flambda' steps: - uses: actions/checkout@v2 @@ -28,5 +28,11 @@ jobs: coq_version: ${{ matrix.coq_version }} ocaml_version: ${{ matrix.ocaml_version }} export: 'OPAMWITHTEST' + install: | + startGroup "Install dependencies" + opam pin add -n -y -k path $PACKAGE $WORKDIR + opam update -y + opam install -y -j 2 $PACKAGE --deps-only + endGroup env: OPAMWITHTEST: 'true' diff --git a/.nix/config.nix b/.nix/config.nix index 928dbf06a..3595b9e00 100644 --- a/.nix/config.nix +++ b/.nix/config.nix @@ -31,21 +31,31 @@ ## select an entry to build in the following `bundles` set ## defaults to "default" - default-bundle = "default"; + default-bundle = "master"; ## write one `bundles.name` attribute set per ## alternative configuration ## When generating GitHub Action CI, one workflow file ## will be created per bundle - bundles.default = { - ## You can override Coq and other Coq coqPackages - ## through the following attribute - coqPackages.coq.override.version = "8.15"; - coqPackages.hierarchy-builder.override.version = "master"; - coqPackages.graph-theory.override.version = "master"; - coqPackages.mathcomp-analysis.override.version = "master"; - + bundles = { + master = { + coqPackages.coq.override.version = "master"; + coqPackages.hierarchy-builder.override.version = "master"; + coqPackages.graph-theory.override.version = "master"; + coqPackages.mathcomp-analysis.override.version = "master"; + }; + + "8.15" = { + + ## You can override Coq and other Coq coqPackages + ## through the following attribute + coqPackages.coq.override.version = "8.15"; + coqPackages.hierarchy-builder.override.version = "master"; + coqPackages.graph-theory.override.version = "master"; + coqPackages.mathcomp-analysis.override.version = "master"; + }; + ## In some cases, light overrides are not available/enough ## in which case you can use either # coqPackages..overrideAttrs = o: ; diff --git a/Changelog.md b/Changelog.md index 676100692..362635347 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,20 @@ # Changelog +## Unreleased + +Requires Elpi 1.15.0 and Coq 8.16. + +### HOAS +- Change arguments are passed after elaboration +- New attribute `#[arguments(raw)]` to get arguments in raw format +- Change raw inductive declaration using `|` to mark non-uniform + parameters is expected to not pass uniform parameters to the inductive + type (the same behavior applies to elaborated arguments) + +### Vernacular +- New `Accumulate File ` to be used in tandem with Coq 8.16 + `From Extra Dependency as ` + ## [1.14.0] - 07-04-2022 Requires Elpi 1.15.0 and Coq 8.15. diff --git a/Makefile b/Makefile index d5643702c..5957ade52 100644 --- a/Makefile +++ b/Makefile @@ -29,24 +29,48 @@ else DOCDEP= endif -DOCDIR=$(shell $(COQBIN)/coqc -where)/../../share/doc/coq-elpi/ +ifndef DOCDIR +DOCDIR=$(shell $(COQBIN)/coqc -where)/../../share/doc/coq-elpi +endif + +ifndef COQDOCINSTALL +COQDOCINSTALL=$(DESTDIR)$(DOCDIR) +endif -all: build test -build: Makefile.coq $(DEPS) +all: + $(MAKE) build-core + $(MAKE) test-core + $(MAKE) examples + $(MAKE) build-apps + $(MAKE) test-apps + +build-core: Makefile.coq $(DEPS) @echo "########################## building plugin ##########################" @if [ -x $(COQBIN)/coqtop.byte ]; then \ $(MAKE) --no-print-directory -f Makefile.coq bytefiles; \ fi @$(MAKE) --no-print-directory -f Makefile.coq opt + +build-apps: build-core @echo "########################## building APPS ############################" - @$(foreach app,$(APPS),$(MAKE) -C $(app) $@ &&) true + @$(foreach app,$(APPS),$(MAKE) -C $(app) build &&) true -test: Makefile.test.coq $(DEPS) build +build: build-core build-apps + +test-core: Makefile.test.coq $(DEPS) build-core @echo "########################## testing plugin ##########################" @$(MAKE) --no-print-directory -f Makefile.test.coq + +test-apps: build-apps @echo "########################## testing APPS ############################" - @$(foreach app,$(APPS),$(MAKE) -C $(app) $@ &&) true + @$(foreach app,$(APPS),$(MAKE) -C $(app) test &&) true + +test: test-core test-apps + +examples: Makefile.examples.coq $(DEPS) build-core + @echo "############################ examples ############################" + @$(MAKE) --no-print-directory -f Makefile.examples.coq doc: $(DOCDEP) @echo "########################## generating doc ##########################" @@ -69,8 +93,10 @@ doc: $(DOCDEP) Makefile.coq Makefile.coq.conf: src/coq_elpi_builtins_HOAS.ml src/coq_elpi_config.ml _CoqProject @$(COQBIN)/coq_makefile -f _CoqProject -o Makefile.coq @$(MAKE) --no-print-directory -f Makefile.coq .merlin -Makefile.test.coq Makefile.test.coq.conf: _CoqProject +Makefile.test.coq Makefile.test.coq.conf: _CoqProject.test @$(COQBIN)/coq_makefile -f _CoqProject.test -o Makefile.test.coq +Makefile.examples.coq Makefile.examples.coq.conf: _CoqProject.examples + @$(COQBIN)/coq_makefile -f _CoqProject.examples -o Makefile.examples.coq src/coq_elpi_builtins_HOAS.ml: elpi/coq-HOAS.elpi Makefile.coq.local echo "(* Automatically generated from $<, don't edit *)" > $@ echo "let code = {|" >> $@ @@ -100,17 +126,17 @@ install: @echo "########################## installing APPS ############################" @$(foreach app,$(APPS),$(MAKE) -C $(app) $@ &&) true @echo "########################## installing doc ############################" - -mkdir -p $(DESTDIR)$(DOCDIR) - -cp doc/* $(DESTDIR)$(DOCDIR) + -mkdir -p $(COQDOCINSTALL) + -cp doc/* $(COQDOCINSTALL) @echo "########################## installed ############################" # compile just one file theories/%.vo: force @$(MAKE) --no-print-directory -f Makefile.coq $@ -tests/%.vo: force build Makefile.test.coq +tests/%.vo: force build-core Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ -examples/%.vo: force build Makefile.test.coq +examples/%.vo: force build-core Makefile.test.coq @$(MAKE) --no-print-directory -f Makefile.test.coq $@ SPACE=$(XXX) $(YYY) diff --git a/Makefile.coq.local b/Makefile.coq.local index 1211cee06..de6e205d3 100644 --- a/Makefile.coq.local +++ b/Makefile.coq.local @@ -6,7 +6,6 @@ theories/elpi.vo: $(wildcard elpi/*.elpi) merlin-hook:: - echo "PKG camlp5" >> .merlin echo "S $(abspath $(ELPIDIR))" >> .merlin echo "B $(abspath $(ELPIDIR))" >> .merlin if [ "$(ELPIDIR)" != "elpi/findlib/elpi" ]; then\ @@ -18,5 +17,5 @@ install-extra:: install -m 0644 elpi-builtin.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 coq-builtin.elpi "$(COQLIBINSTALL)/$$df";\ install -m 0644 elpi/coq-lib.elpi "$(COQLIBINSTALL)/$$df";\ - install -m 0644 elpi/elpi-elaborator.elpi "$(COQLIBINSTALL)/$$df" + install -m 0644 elpi/elpi_elaborator.elpi "$(COQLIBINSTALL)/$$df" diff --git a/Makefile.examples.coq b/Makefile.examples.coq new file mode 100644 index 000000000..bebef4b0b --- /dev/null +++ b/Makefile.examples.coq @@ -0,0 +1,951 @@ +########################################################################## +## # The Coq Proof Assistant / The Coq Development Team ## +## v # Copyright INRIA, CNRS and contributors ## +## /dev/null 2>/dev/null; echo $$?)) +STDTIME?=command time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=command time +endif +endif +else +STDTIME?=command time -f $(TIMEFMT) +endif + +COQBIN?= +ifneq (,$(COQBIN)) +# add an ending / +COQBIN:=$(COQBIN)/ +endif + +# Coq binaries +COQC ?= "$(COQBIN)coqc" +COQTOP ?= "$(COQBIN)coqtop" +COQCHK ?= "$(COQBIN)coqchk" +COQNATIVE ?= "$(COQBIN)coqnative" +COQDEP ?= "$(COQBIN)coqdep" +COQDOC ?= "$(COQBIN)coqdoc" +COQPP ?= "$(COQBIN)coqpp" +COQMKFILE ?= "$(COQBIN)coq_makefile" +OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" + +# Timing scripts +COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" +BEFORE ?= +AFTER ?= + +# OCaml binaries +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkall +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkall +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc +CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack + +# DESTDIR is prepended to all installation paths +DESTDIR ?= + +# Debug builds, typically -g to OCaml, -debug to Coq. +CAMLDEBUG ?= +COQDEBUG ?= + +# Extra packages to be linked in (as in findlib -package) +CAMLPKGS ?= +FINDLIBPKGS = -package coq-core.plugins.ltac $(CAMLPKGS) + +# Option for making timing files +TIMING?= +# Option for changing sorting of timing output file +TIMING_SORT_BY ?= auto +# Option for changing the fuzz parameter on the output file +TIMING_FUZZ ?= 0 +# Option for changing whether to use real or user time for timing tables +TIMING_REAL?= +# Option for including the memory column(s) +TIMING_INCLUDE_MEM?= +# Option for sorting by the memory column +TIMING_SORT_BY_MEM?= +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line + +TGTS ?= + +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT +DESTDIR := $(DSTROOT) +endif + +# Substitution of the path by appending $(DESTDIR) if needed. +# The variable $(COQMF_WINDRIVE) can be needed for Cygwin environments. +windrive_path = $(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(1)),$(1)) +destination_path = $(if $(DESTDIR),$(DESTDIR)/$(call windrive_path,$(1)),$(1)) + +# Installation paths of libraries and documentation. +COQLIBINSTALL ?= $(call destination_path,$(COQLIB)/user-contrib) +COQDOCINSTALL ?= $(call destination_path,$(DOCDIR)/coq/user-contrib) +COQPLUGININSTALL ?= $(call destination_path,$(COQCORELIB)/..) +COQTOPINSTALL ?= $(call destination_path,$(COQLIB)/toploop) # FIXME: Unused variable? + +# findlib files installation +FINDLIBPREINST= mkdir -p "$(COQPLUGININSTALL)/" +FINDLIBDESTDIR= -destdir "$(COQPLUGININSTALL)/" + +# we need to move out of sight $(METAFILE) otherwise findlib thinks the +# package is already installed +findlib_install = \ + $(HIDE)if [ "$(METAFILE)" ]; then \ + $(FINDLIBPREINST) && \ + mv "$(METAFILE)" "$(METAFILE).skip" ; \ + "$(OCAMLFIND)" install $(2) $(FINDLIBDESTDIR) $(FINDLIBPACKAGE) $(1); \ + rc=$$?; \ + mv "$(METAFILE).skip" "$(METAFILE)"; \ + exit $$rc; \ + fi +findlib_remove = \ + $(HIDE)if [ ! -z "$(METAFILE)" ]; then\ + "$(OCAMLFIND)" remove $(FINDLIBDESTDIR) $(FINDLIBPACKAGE); \ + fi + + +########## End of parameters ################################################## +# What follows may be relevant to you only if you need to +# extend this Makefile. If so, look for 'Extension point' here and +# put in Makefile.examples.coq.local double colon rules accordingly. +# E.g. to perform some work after the all target completes you can write +# +# post-all:: +# echo "All done!" +# +# in Makefile.examples.coq.local +# +############################################################################### + + + + +# Flags ####################################################################### +# +# We define a bunch of variables combining the parameters. +# To add additional flags to coq, coqchk or coqdoc, set the +# {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. +# To overwrite the default choice and set your own flags entirely, set the +# {COQ,COQCHK,COQDOC}FLAGS variable. + +SHOW := $(if $(VERBOSE),@true "",@echo "") +HIDE := $(if $(VERBOSE),,@) + +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +OPT?= + +# The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d +ifeq '$(OPT)' '-byte' +USEBYTE:=true +DYNOBJ:=.cma +DYNLIB:=.cma +else +USEBYTE:= +DYNOBJ:=.cmxs +DYNLIB:=.cmxs +endif + +# these variables are meant to be overridden if you want to add *extra* flags +COQEXTRAFLAGS?= +COQCHKEXTRAFLAGS?= +COQDOCEXTRAFLAGS?= + +# Find the last argument of the form "-native-compiler FLAG" +COQUSERNATIVEFLAG:=$(strip \ +$(subst -native-compiler-,,\ +$(lastword \ +$(filter -native-compiler-%,\ +$(subst -native-compiler ,-native-compiler-,\ +$(strip $(COQEXTRAFLAGS))))))) + +COQFILTEREDEXTRAFLAGS:=$(strip \ +$(filter-out -native-compiler-%,\ +$(subst -native-compiler ,-native-compiler-,\ +$(strip $(COQEXTRAFLAGS))))) + +COQACTUALNATIVEFLAG:=$(lastword $(COQMF_COQ_NATIVE_COMPILER_DEFAULT) $(COQMF_COQPROJECTNATIVEFLAG) $(COQUSERNATIVEFLAG)) + +ifeq '$(COQACTUALNATIVEFLAG)' 'yes' + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" + COQDONATIVE="yes" +else +ifeq '$(COQACTUALNATIVEFLAG)' 'ondemand' + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" + COQDONATIVE="no" +else + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "no" + COQDONATIVE="no" +endif +endif + +# these flags do NOT contain the libraries, to make them easier to overwrite +COQFLAGS?=-q $(OTHERFLAGS) $(COQFILTEREDEXTRAFLAGS) $(COQNATIVEFLAG) +COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) +COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) + +COQDOCLIBS?=$(COQLIBS_NOML) + +# The version of Coq being run and the version of coq_makefile that +# generated this makefile +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) +COQMAKEFILE_VERSION:=8.16+alpha + +# COQ_SRC_SUBDIRS is for user-overriding, usually to add +# `user-contrib/Foo` to the includes, we keep COQCORE_SRC_SUBDIRS for +# Coq's own core libraries, which should be replaced by ocamlfind +# options at some point. +COQ_SRC_SUBDIRS?= +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") + +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) +# ocamldoc fails with unknown argument otherwise +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) + +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif + +# Files ####################################################################### +# +# We here define a bunch of variables about the files being part of the +# Coq project in order to ease the writing of build target and build rules + +VDFILE := .Makefile.examples.coq.d + +ALLSRCFILES := \ + $(MLGFILES) \ + $(MLFILES) \ + $(MLPACKFILES) \ + $(MLLIBFILES) \ + $(MLIFILES) + +# helpers +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) +strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + +VO = vo +VOS = vos + +VOFILES = $(VFILES:.v=.$(VO)) +GLOBFILES = $(VFILES:.v=.glob) +HTMLFILES = $(VFILES:.v=.html) +GHTMLFILES = $(VFILES:.v=.g.html) +BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) +TEXFILES = $(VFILES:.v=.tex) +GTEXFILES = $(VFILES:.v=.g.tex) +CMOFILES = \ + $(MLGFILES:.mlg=.cmo) \ + $(MLFILES:.ml=.cmo) \ + $(MLPACKFILES:.mlpack=.cmo) +CMXFILES = $(CMOFILES:.cmo=.cmx) +OFILES = $(CMXFILES:.cmx=.o) +CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) +CMXAFILES = $(CMAFILES:.cma=.cmxa) +CMIFILES = \ + $(CMOFILES:.cmo=.cmi) \ + $(MLIFILES:.mli=.cmi) +# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just +# a .mlg file +CMXSFILES = \ + $(MLPACKFILES:.mlpack=.cmxs) \ + $(CMXAFILES:.cmxa=.cmxs) \ + $(if $(MLPACKFILES)$(CMXAFILES),,\ + $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) + +# files that are packed into a plugin (no extension) +PACKEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) +# files that are archived into a .cma (mllib) +LIBEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) +CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) +CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) +OBJFILES = $(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES = \ + $(OBJFILES:.o=.cmi) \ + $(OBJFILES:.o=.cmx) \ + $(OBJFILES:.o=.cmxs) +FINDLIBPACKAGE=$(patsubst .%,%,$(suffix $(METAFILE))) + +# trick: wildcard filters out non-existing files, so that `install` doesn't show +# warnings and `clean` doesn't pass to rm a list of files that is too long for +# the shell. +NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) +FILESTOINSTALL = \ + $(VOFILES) \ + $(VFILES) \ + $(GLOBFILES) \ + $(NATIVEFILES) +FINDLIBFILESTOINSTALL = \ + $(CMIFILESTOINSTALL) +ifeq '$(HASNATDYNLINK)' 'true' +DO_NATDYNLINK = yes +FINDLIBFILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +else +DO_NATDYNLINK = +endif + +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) + +# Compilation targets ######################################################### + +all: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all + +all.timing.diff: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all.timing.diff + +ifeq (0,$(TIMING_REAL)) +TIMING_REAL_ARG := +TIMING_USER_ARG := --user +else +ifeq (1,$(TIMING_REAL)) +TIMING_REAL_ARG := --real +TIMING_USER_ARG := +else +TIMING_REAL_ARG := +TIMING_USER_ARG := +endif +endif + +ifeq (0,$(TIMING_INCLUDE_MEM)) +TIMING_INCLUDE_MEM_ARG := --no-include-mem +else +TIMING_INCLUDE_MEM_ARG := +endif + +ifeq (1,$(TIMING_SORT_BY_MEM)) +TIMING_SORT_BY_MEM_ARG := --sort-by-mem +else +TIMING_SORT_BY_MEM_ARG := +endif + +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff + +# Extension points for actions to be performed before/after the all target +pre-all:: + @# Extension point + $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ + echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ + echo "W: while the current Coq version is $(COQ_VERSION)";\ + fi +.PHONY: pre-all + +post-all:: + @# Extension point +.PHONY: post-all + +real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) +.PHONY: real-all + +real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) +.PHONY: real-all.timing.diff + +bytefiles: $(CMOFILES) $(CMAFILES) +.PHONY: bytefiles + +optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) +.PHONY: optfiles + +# FIXME, see Ralf's bugreport +# quick is deprecated, now renamed vio +vio: $(VOFILES:.vo=.vio) +.PHONY: vio +quick: vio + $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") +.PHONY: quick + +vio2vo: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +.PHONY: vio2vo + +# quick2vo is undocumented +quick2vo: + $(HIDE)make -j $(J) vio + $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ + viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ + if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ + done); \ + echo "VIO2VO: $$VIOFILES"; \ + if [ -n "$$VIOFILES" ]; then \ + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ + fi +.PHONY: quick2vo + +checkproofs: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +.PHONY: checkproofs + +vos: $(VOFILES:%.vo=%.vos) +.PHONY: vos + +vok: $(VOFILES:%.vo=%.vok) +.PHONY: vok + +validate: $(VOFILES) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS_NOML) $^ +.PHONY: validate + +only: $(TGTS) +.PHONY: only + +# Documentation targets ####################################################### + +html: $(GLOBFILES) $(VFILES) + $(SHOW)'COQDOC -d html $(GAL)' + $(HIDE)mkdir -p html + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) + +mlihtml: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -d $@' + $(HIDE)mkdir $@ || rm -rf $@/* + $(HIDE)$(CAMLDOC) -html \ + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) + +all-mli.tex: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -latex $@' + $(HIDE)$(CAMLDOC) -latex \ + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) + +all.ps: $(VFILES) + $(SHOW)'COQDOC -ps $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +all.pdf: $(VFILES) + $(SHOW)'COQDOC -pdf $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +# FIXME: not quite right, since the output name is different +gallinahtml: GAL=-g +gallinahtml: html + +all-gal.ps: GAL=-g +all-gal.ps: all.ps + +all-gal.pdf: GAL=-g +all-gal.pdf: all.pdf + +# ? +beautify: $(BEAUTYFILES) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' +.PHONY: beautify + +# Installation targets ######################################################## +# +# There rules can be extended in Makefile.examples.coq.local +# Extensions can't assume when they run. + +install: META + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code + $(HIDE)for f in $(FILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + # findlib needs the package to not be installed, so we remove it before + # installing it + $(call findlib_remove) + $(call findlib_install, META $(FINDLIBFILESTOINSTALL)) + $(HIDE)$(MAKE) install-extra -f "$(SELF)" +install-extra:: + @# Extension point +.PHONY: install install-extra + +META: $(METAFILE) + $(HIDE)if [ "$(METAFILE)" ]; then \ + cat "$(METAFILE)" | grep -v 'directory.*=.*' > META; \ + fi + +install-byte: + $(call findlib_install, $(CMAFILES) $(CMOFILESTOINSTALL), -add) + +install-doc:: html mlihtml + @# Extension point + $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)for i in html/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done + $(HIDE)install -d \ + "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)for i in mlihtml/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done +.PHONY: install-doc + +uninstall:: + @# Extension point + $(call findlib_remove) + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ + rm -f "$$instf" &&\ + echo RM "$$instf" ;\ + done + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + echo RMDIR "$(COQLIBINSTALL)/$$df/" &&\ + (rmdir "$(COQLIBINSTALL)/$$df/" 2>/dev/null || true); \ + done +.PHONY: uninstall + +uninstall-doc:: + @# Extension point + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true +.PHONY: uninstall-doc + +# Cleaning #################################################################### +# +# There rules can be extended in Makefile.examples.coq.local +# Extensions can't assume when they run. + +clean:: + @# Extension point + $(SHOW)'CLEAN' + $(HIDE)rm -f $(CMOFILES) + $(HIDE)rm -f $(CMIFILES) + $(HIDE)rm -f $(CMAFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXAFILES) + $(HIDE)rm -f $(CMXSFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) + $(HIDE)rm -f $(MLGFILES:.mlg=.ml) + $(HIDE)rm -f $(ALLDFILES) + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)find . -name .coq-native -type d -empty -delete + $(HIDE)rm -f $(VOFILES) + $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(VOFILES:.vo=.vos) + $(HIDE)rm -f $(VOFILES:.vo=.vok) + $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) + $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex + $(HIDE)rm -f $(VFILES:.v=.glob) + $(HIDE)rm -f $(VFILES:.v=.tex) + $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)rm -f META + $(HIDE)rm -rf html mlihtml +.PHONY: clean + +cleanall:: clean + @# Extension point + $(SHOW)'CLEAN *.aux *.timing' + $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) + $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) + $(HIDE)rm -f .lia.cache .nia.cache +.PHONY: cleanall + +archclean:: + @# Extension point + $(SHOW)'CLEAN *.cmx *.o' + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) +.PHONY: archclean + + +# Compilation rules ########################################################### + +$(MLIFILES:.mli=.cmi): %.cmi: %.mli + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< + +$(MLGFILES:.mlg=.ml): %.ml: %.mlg + $(SHOW)'COQPP $<' + $(HIDE)$(COQPP) $< + +# Stupid hack around a deficient syntax: we cannot concatenate two expansions +$(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< + +# Same hack +$(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml + $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' + $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $(FOR_PACK) $< + + +$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ + -shared -o $@ $< + +$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ + +$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ + + +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ + -shared -o $@ $< + +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx | %.mlpack + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $< + +$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack + $(SHOW)'CAMLC -pack -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack + $(SHOW)'CAMLOPT -pack -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ + +# This rule is for _CoqProject with no .mllib nor .mlpack +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx + $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ + -shared -o $@ $< + +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + +$(VOFILES): %.vo: %.v | $(VDFILE) + $(SHOW)COQC $< + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) +ifeq ($(COQDONATIVE), "yes") + $(SHOW)COQNATIVE $@ + $(HIDE)$(COQNATIVE) $(COQLIBS) $@ +endif + +# FIXME ?merge with .vo / .vio ? +$(GLOBFILES): %.glob: %.v + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vio): %.vio: %.v + $(SHOW)COQC -vio $< + $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vos): %.vos: %.v + $(SHOW)COQC -vos $< + $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vok): %.vok: %.v + $(SHOW)COQC -vok $< + $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing + $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + +$(BEAUTYFILES): %.v.beautified: %.v + $(SHOW)'BEAUTIFY $<' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< + +$(TEXFILES): %.tex: %.v + $(SHOW)'COQDOC -latex $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(GTEXFILES): %.g.tex: %.v + $(SHOW)'COQDOC -latex -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(SHOW)'COQDOC -html $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(SHOW)'COQDOC -html -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +# Dependency files ############################################################ + +ifndef MAKECMDGOALS + -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) + endif +endif + +.SECONDARY: $(ALLDFILES) + +redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) + +GENMLFILES:=$(MLGFILES:.mlg=.ml) +$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) + +$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +# If this makefile is created using a _CoqProject we have coqdep get +# options from it. This avoids argument length limits for pathological +# projects. Note that extra options might be on the command line. +VDFILE_FLAGS:=$(if _CoqProject.examples,-f _CoqProject.examples,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) + +$(VDFILE): _CoqProject.examples $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) $(if $(strip $(METAFILE)),-m "$(METAFILE)") -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) + +# Misc ######################################################################## + +byte: + $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" +.PHONY: byte + +opt: + $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" +.PHONY: opt + +# This is deprecated. To extend this makefile use +# extension points and Makefile.examples.coq.local +printenv:: + $(warning printenv is deprecated) + $(warning write extensions in Makefile.examples.coq.local or include Makefile.examples.coq.conf) + @echo 'COQLIB = $(COQLIB)' + @echo 'COQCORELIB = $(COQCORELIB)' + @echo 'DOCDIR = $(DOCDIR)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' + @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' + @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' + @echo 'COQCORE_SRC_SUBDIRS = $(COQCORE_SRC_SUBDIRS)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIB = $(COQLIBS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' +.PHONY: printenv + +# Generate a .merlin file. If you need to append directives to this +# file you can extend the merlin-hook target in Makefile.examples.coq.local +.merlin: + $(SHOW)'FILL .merlin' + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin + $(HIDE)echo 'B $(COQCORELIB)' >> .merlin + $(HIDE)echo 'S $(COQCORELIB)' >> .merlin + $(HIDE)$(foreach d,$(COQCORE_SRC_SUBDIRS), \ + echo 'B $(COQCORELIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'S $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) + $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" +.PHONY: merlin + +merlin-hook:: + @# Extension point +.PHONY: merlin-hook + +# prints all variables +debug: + $(foreach v,\ + $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ + $(.VARIABLES))),\ + $(info $(v) = $($(v)))) +.PHONY: debug + +.DEFAULT_GOAL := all + +# Users can create Makefile.examples.coq.local-late to hook into double-colon rules +# or add other needed Makefile code, using defined +# variables if necessary. +-include Makefile.examples.coq.local-late + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/Makefile.examples.coq.conf b/Makefile.examples.coq.conf new file mode 100644 index 000000000..acb06d3cb --- /dev/null +++ b/Makefile.examples.coq.conf @@ -0,0 +1,64 @@ +# This configuration file was generated by running: +# /home/gares/COQ/master/_build/install/default/bin////coq_makefile -f _CoqProject.examples -o Makefile.examples.coq + + +############################################################################### +# # +# Project files. # +# # +############################################################################### + +COQMF_VFILES = examples/tutorial_elpi_lang.v examples/tutorial_coq_elpi_HOAS.v examples/tutorial_coq_elpi_command.v examples/tutorial_coq_elpi_tactic.v examples/example_reflexive_tactic.v examples/example_curry_howard_tactics.v examples/example_data_base.v examples/example_record_expansion.v examples/example_record_to_sigma.v examples/example_fuzzer.v examples/example_generalize.v examples/example_import_projections.v +COQMF_MLIFILES = +COQMF_MLFILES = +COQMF_MLGFILES = +COQMF_MLPACKFILES = +COQMF_MLLIBFILES = +COQMF_METAFILE = +COQMF_CMDLINE_VFILES = + +############################################################################### +# # +# Path directives (-I, -R, -Q). # +# # +############################################################################### + +COQMF_OCAMLLIBS = -I src/ +COQMF_SRC_SUBDIRS = src/ +COQMF_COQLIBS = -I src/ -Q theories elpi -Q examples elpi.examples -Q tests elpi.tests -Q elpi unreleased +COQMF_COQLIBS_NOML = -Q theories elpi -Q examples elpi.examples -Q tests elpi.tests -Q elpi unreleased +COQMF_CMDLINE_COQLIBS = + +############################################################################### +# # +# Coq configuration. # +# # +############################################################################### + +COQMF_COQLIB=/home/gares/COQ/master/_build/install/default/lib/coq/ +COQMF_COQCORELIB=/home/gares/COQ/master/_build/install/default/lib/coq-core/ +COQMF_DOCDIR=/home/gares/COQ/master/_build/default/../install/default/share/doc/ +COQMF_OCAMLFIND=/home/gares/.opam/4.09.1/bin/ocamlfind +COQMF_CAMLFLAGS=-thread -rectypes -w -a+1..3-4+5..8-9+10..26-27+28..40-41-42+43-44-45+46..47-48+49..57-58+59..66-67-68+69-70 -bin-annot -safe-string -strict-sequence +COQMF_WARN=-warn-error +a-3 +COQMF_HASNATDYNLINK=true +COQMF_COQ_SRC_SUBDIRS=boot config lib clib kernel library engine pretyping interp gramlib parsing proofs tactics toplevel printing ide stm vernac plugins/btauto plugins/cc plugins/derive plugins/extraction plugins/firstorder plugins/funind plugins/ltac plugins/ltac2 plugins/micromega plugins/nsatz plugins/ring plugins/rtauto plugins/ssr plugins/ssrmatching plugins/syntax +COQMF_COQ_NATIVE_COMPILER_DEFAULT=no +COQMF_WINDRIVE= + +############################################################################### +# # +# Native compiler. # +# # +############################################################################### + +COQMF_COQPROJECTNATIVEFLAG = + +############################################################################### +# # +# Extra variables. # +# # +############################################################################### + +COQMF_OTHERFLAGS = '-w' '+elpi.deprecated' '-bt' +COQMF_INSTALLCOQDOCROOT = elpi diff --git a/README.md b/README.md index b452750ed..8f21a76b0 100644 --- a/README.md +++ b/README.md @@ -55,7 +55,8 @@ At the time of writing Proof General does not handle quotations correctly, see P In particular `Elpi Accumulate lp:{{ .... }}.` is used in tutorials to mix Coq and Elpi code without escaping. Coq-Elpi also accepts `Elpi Accumulate " .... ".` but strings part of the Elpi code needs to be escaped. Finally, for non-tutorial material, one can always put -the code in an external file and use `Elpi Accumulate File "filename" From some.load.path.` instead. +the code in an external file declared with `From some.load.path Extra Dependency "filename" as f.` +and use `Elpi Accumulate File f.`. CoqIDE does handle quotations. The installation process puts [coq-elpi.lang](etc/coq-elpi.lang) diff --git a/_CoqProject b/_CoqProject index 9025b1838..394c7401b 100644 --- a/_CoqProject +++ b/_CoqProject @@ -22,6 +22,7 @@ theories/elpi.v theories/wip/memoization.v -I src +src/META.coq-elpi src/coq_elpi_vernacular_syntax.mlg src/coq_elpi_vernacular.ml diff --git a/_CoqProject.examples b/_CoqProject.examples new file mode 100644 index 000000000..adb000ccc --- /dev/null +++ b/_CoqProject.examples @@ -0,0 +1,22 @@ +-arg -w -arg +elpi.deprecated +-arg -bt + +-Q theories elpi +-Q examples elpi.examples +-Q tests elpi.tests +-I src/ +-Q elpi unreleased +-docroot elpi + +examples/tutorial_elpi_lang.v +examples/tutorial_coq_elpi_HOAS.v +examples/tutorial_coq_elpi_command.v +examples/tutorial_coq_elpi_tactic.v +examples/example_reflexive_tactic.v +examples/example_curry_howard_tactics.v +examples/example_data_base.v +examples/example_record_expansion.v +examples/example_record_to_sigma.v +examples/example_fuzzer.v +examples/example_generalize.v +examples/example_import_projections.v diff --git a/_CoqProject.test b/_CoqProject.test index bc7d1d4cb..6e7d5ed50 100644 --- a/_CoqProject.test +++ b/_CoqProject.test @@ -8,22 +8,18 @@ -Q elpi unreleased -docroot elpi -examples/tutorial_elpi_lang.v -examples/tutorial_coq_elpi_HOAS.v -examples/tutorial_coq_elpi_command.v -examples/tutorial_coq_elpi_tactic.v -examples/example_reflexive_tactic.v -examples/example_curry_howard_tactics.v -examples/example_data_base.v -examples/example_record_expansion.v -examples/example_record_to_sigma.v -examples/example_fuzzer.v -examples/example_generalize.v -examples/example_import_projections.v - tests/test_API.v +tests/test_API_elaborate.v +tests/test_API_typecheck.v +tests/test_API_env.v +tests/test_API_module.v +tests/test_API_section.v +tests/test_API_TC_CS.v +tests/test_API_arguments.v +tests/test_API_notations.v tests/test_API2.v tests/test_HOAS.v +tests/test_arg_HOAS.v tests/test_quotation.v tests/test_vernacular1.v tests/test_vernacular2.v diff --git a/apps/NES/Makefile.coq.local b/apps/NES/Makefile.coq.local deleted file mode 100644 index 20833514d..000000000 --- a/apps/NES/Makefile.coq.local +++ /dev/null @@ -1 +0,0 @@ -theories/NES.vo: $(wildcard elpi/*.elpi) diff --git a/apps/NES/theories/NES.v b/apps/NES/theories/NES.v index 487ccf125..0f0c13544 100644 --- a/apps/NES/theories/NES.v +++ b/apps/NES/theories/NES.v @@ -1,3 +1,5 @@ +From elpi.apps.NES Extra Dependency "nes.elpi" as nes. + From elpi Require Import elpi. Elpi Db NES.db lp:{{ @@ -15,7 +17,7 @@ pred ns o:path, o:modpath. Elpi Command NES.Status. Elpi Accumulate Db NES.db. -Elpi Accumulate File "nes.elpi" From elpi.apps.NES. +Elpi Accumulate File nes. Elpi Accumulate lp:{{ main _ :- @@ -29,7 +31,7 @@ Elpi Typecheck. Elpi Export NES.Status. Elpi Command NES.Begin. -Elpi Accumulate File "nes.elpi" From elpi.apps.NES. +Elpi Accumulate File nes. Elpi Accumulate lp:{{ main [str NS] :- nes.begin-path {nes.string->ns NS}. @@ -41,7 +43,7 @@ Elpi Typecheck. Elpi Export NES.Begin. Elpi Command NES.End. -Elpi Accumulate File "nes.elpi" From elpi.apps.NES. +Elpi Accumulate File nes. Elpi Accumulate lp:{{ main [str NS] :- nes.end-path {nes.string->ns NS}. @@ -55,7 +57,7 @@ Elpi Export NES.End. Elpi Command NES.Open. Elpi Accumulate Db NES.db. -Elpi Accumulate File "nes.elpi" From elpi.apps.NES. +Elpi Accumulate File nes. Elpi Accumulate lp:{{ main [str NS] :- nes.open-path {nes.string->ns NS}. diff --git a/apps/derive/Makefile.coq.local b/apps/derive/Makefile.coq.local index a25487080..52342f93b 100644 --- a/apps/derive/Makefile.coq.local +++ b/apps/derive/Makefile.coq.local @@ -1,25 +1,3 @@ -theories/derive.vo: $(wildcard elpi/*.elpi) -theories/derive/bcongr.vo: elpi/bcongr.elpi -theories/derive/eqK.vo: elpi/eqK.elpi -theories/derive/eq.vo: elpi/eq.elpi -theories/derive/invert.vo: elpi/invert.elpi -theories/derive/param1_congr.vo: elpi/param1_congr.elpi -theories/derive/param1_trivial.vo: elpi/param1_trivial.elpi -theories/derive/projK.vo: elpi/projK.elpi -theories/derive/cast.vo: elpi/cast.elpi -theories/derive/eqOK_trivial.vo: elpi/eqOK_trivial.elpi -theories/derive/idx2inv.vo: elpi/idx2inv.elpi -theories/derive/isK.vo: elpi/isK.elpi -theories/derive/param1_functor.vo: elpi/param1_functor.elpi -theories/derive/param1.vo: elpi/param1.elpi elpi/paramX-lib.elpi -theories/derive/eqcorrect.vo: elpi/eqcorrect.elpi -theories/derive/eqOK.vo: elpi/eqOK.elpi -theories/derive/induction.vo: elpi/induction.elpi -theories/derive/map.vo: elpi/map.elpi -theories/derive/param1_inhab.vo: elpi/param1_inhab.elpi -theories/derive/param2.vo: elpi/param2.elpi elpi/paramX-lib.elpi -theories/derive/lens.vo: elpi/lens.elpi -theories/derive/lens_laws.vo: elpi/lens_laws.elpi coverage: @for F in $(wildcard theories/derive/*.v); do\ diff --git a/apps/derive/elpi/paramX-lib.elpi b/apps/derive/elpi/paramX_lib.elpi similarity index 100% rename from apps/derive/elpi/paramX-lib.elpi rename to apps/derive/elpi/paramX_lib.elpi diff --git a/apps/derive/examples/usage.v b/apps/derive/examples/usage.v index c3c00d1db..312c4c602 100644 --- a/apps/derive/examples/usage.v +++ b/apps/derive/examples/usage.v @@ -3,6 +3,7 @@ *) From elpi.apps Require Import derive. +Set Uniform Inductive Parameters. (** The basic invocation is with just one argument, the inductive type name *) @@ -19,7 +20,7 @@ Inductive tickle A := stop | more : A -> tickle -> tickle. (** In this case the command is elaborated to: Module tickle. - Inductive tickle A := stop | more : A -> tickle-> tickle. + Inductive tickle A := stop | more : A -> tickle -> tickle. derive tickle. End tickle. Notation tickle := tickle.tickle. diff --git a/apps/derive/tests/test_derive.v b/apps/derive/tests/test_derive.v index 69ea58792..28f233e72 100644 --- a/apps/derive/tests/test_derive.v +++ b/apps/derive/tests/test_derive.v @@ -87,7 +87,7 @@ Check Vector_induction : forall A PA (P : forall n, nat_is_nat n -> Vector.t A n (* ---------------------------------------------------- *) -Inductive W A := B (f : A -> W A). +Inductive W A := B (f : A -> W). Elpi derive W. (* Not implemented yet :-/ *) @@ -97,7 +97,7 @@ Fail Check W_induction : forall A (P : W A -> Type), (* ---------------------------------------------------- *) -Inductive horror A (a : A) : forall T, T -> Type := K W w (k : horror A a W w) : horror A a W w. +Inductive horror A (a : A) : forall T, T -> Type := K W w (k : horror W w) : horror W w. Elpi derive horror. Fail Check horror_induction : @@ -107,7 +107,7 @@ Fail Check horror_induction : (* ---------------------------------------------------- *) Inductive rtree A : Type := - Leaf (n : A) | Node (l : list (rtree A)). + Leaf (n : A) | Node (l : list rtree). Elpi derive rtree XXX. diff --git a/apps/derive/tests/test_derive_stdlib.v b/apps/derive/tests/test_derive_stdlib.v index f1af8ab65..94c201300 100644 --- a/apps/derive/tests/test_derive_stdlib.v +++ b/apps/derive/tests/test_derive_stdlib.v @@ -1,5 +1,5 @@ (* Some standard data types using different features *) -From Coq Require Int63. +From Coq Require Uint63. From Coq Require Floats. Module Coverage. @@ -62,7 +62,7 @@ Inductive large := | K25(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) | K26(_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit) (_ : unit). -Inductive prim_int := PI (i : Int63.int). +Inductive prim_int := PI (i : Uint63.int). Inductive prim_float := PF (f : PrimFloat.float). Record fo_record := { f1 : peano; f2 : unit; }. diff --git a/apps/derive/tests/test_eqOK.v b/apps/derive/tests/test_eqOK.v index bdf839f32..fab5d69ac 100644 --- a/apps/derive/tests/test_eqOK.v +++ b/apps/derive/tests/test_eqOK.v @@ -64,10 +64,12 @@ Check enum_eq_OK : ok enum enum_eq. From elpi.apps Require Import test_param1_functor. Import test_param1_functor.Coverage. +Set Uniform Inductive Parameters. + Module OtherTests. Import test_param1_functor.Coverage. -Inductive dlist A := dnil | dcons (a : pair A peano) (l : dlist A). +Inductive dlist A := dnil | dcons (a : pair A peano) (l : dlist). Elpi derive.param1 dlist. Elpi derive.param1.inhab is_dlist. diff --git a/apps/derive/tests/test_invert.v b/apps/derive/tests/test_invert.v index 8b9c7a479..85c5c9edb 100644 --- a/apps/derive/tests/test_invert.v +++ b/apps/derive/tests/test_invert.v @@ -1,9 +1,10 @@ From elpi.apps Require Import derive.invert. +Set Uniform Inductive Parameters. Inductive test A : bool -> Type := - K1 : test A true -| K2 : forall x, A -> test A (negb x) -> test A (negb (negb x)). + K1 : test true +| K2 : forall x, A -> test (negb x) -> test (negb (negb x)). Elpi derive.invert test. @@ -12,7 +13,7 @@ Check K1_inv : forall A b, b = true -> test_inv A b. Check K2_inv : forall A b, forall x, A -> test_inv A (negb x) -> b = negb (negb x) -> test_inv A b. Inductive listR A PA : list A -> Type := - | nilR : listR A PA (@nil A) - | consR : forall a : A, PA a -> forall xs : list A, listR A PA xs -> listR A PA (cons a xs). + | nilR : listR (@nil A) + | consR : forall a : A, PA a -> forall xs : list A, listR xs -> listR (cons a xs). Elpi derive.invert listR. \ No newline at end of file diff --git a/apps/derive/tests/test_param1.v b/apps/derive/tests/test_param1.v index f0d0bd6fe..712465fa6 100644 --- a/apps/derive/tests/test_param1.v +++ b/apps/derive/tests/test_param1.v @@ -59,6 +59,7 @@ Check is_enum : pred enum. End Test. (* other tests by Cyril *) +Set Uniform Inductive Parameters. Module OtherTests. @@ -75,7 +76,7 @@ Fixpoint fin_length n (v : fin n) := Elpi derive.param1 fin_length. Inductive vec (A : Type) : nat -> Type := - vnil : vec A 0 | vcons : A -> forall n : nat, vec A n -> vec A (S n). + vnil : vec 0 | vcons : A -> forall n : nat, vec n -> vec (S n). Elpi derive.param1 vec. Fixpoint vec_length (A : Type) n (v : vec A n) := diff --git a/apps/derive/tests/test_param2.v b/apps/derive/tests/test_param2.v index 43e833d8b..e73cb8f65 100644 --- a/apps/derive/tests/test_param2.v +++ b/apps/derive/tests/test_param2.v @@ -1,5 +1,7 @@ From elpi.apps Require Import derive.param2. +Set Uniform Inductive Parameters. + Elpi derive.param2 unit R. Elpi derive.param2 nat R. Elpi derive.param2 list R. @@ -25,7 +27,7 @@ Fixpoint fin_length n (v : fin n) := Elpi derive.param2 fin_length R. Inductive vec (A : Type) : nat -> Type := - vnil : vec A 0 | vcons : A -> forall n : nat, vec A n -> vec A (S n). + vnil : vec 0 | vcons : A -> forall n : nat, vec n -> vec (S n). Elpi derive.param2 vec R. Fixpoint vec_length (A : Type) n (v : vec A n) := diff --git a/apps/derive/theories/derive.v b/apps/derive/theories/derive.v index 149583a97..57ccec47c 100644 --- a/apps/derive/theories/derive.v +++ b/apps/derive/theories/derive.v @@ -3,6 +3,12 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) + +(* since non-uniform inductive parameters are rarely used and the inference + code from the kernel is not easily accessible, we require the user to + be explicit about them, eg Inductive foo U1 U2 | NU1 NU2 := ... *) +#[global] Set Uniform Inductive Parameters. + (** The derive command The derive command can be invoked in two ways. - [derive ] @@ -45,6 +51,29 @@ A derivation different from d can be skipped [#[only(d)]] attribute. *) +From elpi.apps.derive Extra Dependency "eq.elpi" as eq. +From elpi.apps.derive Extra Dependency "isK.elpi" as isK. +From elpi.apps.derive Extra Dependency "map.elpi" as map. +From elpi.apps.derive Extra Dependency "projK.elpi" as projK. +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. +From elpi.apps.derive Extra Dependency "param1_functor.elpi" as param1_functor. +From elpi.apps.derive Extra Dependency "param1_congr.elpi" as param1_congr. +From elpi.apps.derive Extra Dependency "param1_inhab.elpi" as param1_inhab. +From elpi.apps.derive Extra Dependency "param1_trivial.elpi" as param1_trivial. +From elpi.apps.derive Extra Dependency "invert.elpi" as invert. +From elpi.apps.derive Extra Dependency "idx2inv.elpi" as idx2inv. +From elpi.apps.derive Extra Dependency "induction.elpi" as induction. +From elpi.apps.derive Extra Dependency "injection.elpi" as injection. +From elpi.apps.derive Extra Dependency "bcongr.elpi" as bcongr. +From elpi.apps.derive Extra Dependency "discriminate.elpi" as discriminate. +From elpi.apps.derive Extra Dependency "eqK.elpi" as eqK. +From elpi.apps.derive Extra Dependency "eqcorrect.elpi" as eqcorrect. +From elpi.apps.derive Extra Dependency "eqOK.elpi" as eqOK. +From elpi.apps.derive Extra Dependency "param2.elpi" as param2. +From elpi.apps.derive Extra Dependency "lens.elpi" as lens. +From elpi.apps.derive Extra Dependency "lens_laws.elpi" as lens_laws. +From elpi.apps.derive Extra Dependency "derive.elpi" as derive. From elpi.apps Require Export derive.eq @@ -70,64 +99,64 @@ From elpi.apps Require Export Elpi Command derive. Elpi Accumulate Db derive.eq.db. -Elpi Accumulate File "eq.elpi" From elpi.apps.derive. +Elpi Accumulate File eq. Elpi Accumulate Db derive.isK.db. -Elpi Accumulate File "isK.elpi" From elpi.apps.derive. +Elpi Accumulate File isK. Elpi Accumulate Db derive.map.db. -Elpi Accumulate File "map.elpi" From elpi.apps.derive. +Elpi Accumulate File map. Elpi Accumulate Db derive.projK.db. -Elpi Accumulate File "projK.elpi" From elpi.apps.derive. +Elpi Accumulate File projK. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. -Elpi Accumulate File "param1_functor.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_functor. Elpi Accumulate Db derive.param1.congr.db. -Elpi Accumulate File "param1_congr.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_congr. Elpi Accumulate Db derive.param1.inhab.db. -Elpi Accumulate File "param1_inhab.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_inhab. Elpi Accumulate Db derive.param1.trivial.db. -Elpi Accumulate File "param1_trivial.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_trivial. Elpi Accumulate Db derive.invert.db. -Elpi Accumulate File "invert.elpi" From elpi.apps.derive. +Elpi Accumulate File invert. Elpi Accumulate Db derive.idx2inv.db. -Elpi Accumulate File "idx2inv.elpi" From elpi.apps.derive. +Elpi Accumulate File idx2inv. Elpi Accumulate Db derive.induction.db. -Elpi Accumulate File "induction.elpi" From elpi.apps.derive. +Elpi Accumulate File induction. Elpi Accumulate Db derive.bcongr.db. -Elpi Accumulate File "injection.elpi" From elpi.apps.derive. -Elpi Accumulate File "bcongr.elpi" From elpi.apps.derive. +Elpi Accumulate File injection. +Elpi Accumulate File bcongr. Elpi Accumulate Db derive.eqK.db. -Elpi Accumulate File "discriminate.elpi" From elpi.apps.derive. -Elpi Accumulate File "eqK.elpi" From elpi.apps.derive. +Elpi Accumulate File discriminate. +Elpi Accumulate File eqK. Elpi Accumulate Db derive.eqcorrect.db. -Elpi Accumulate File "eqcorrect.elpi" From elpi.apps.derive. +Elpi Accumulate File eqcorrect. -Elpi Accumulate File "eqOK.elpi" From elpi.apps.derive. +Elpi Accumulate File eqOK. -Elpi Accumulate File "param2.elpi" From elpi.apps.derive. +Elpi Accumulate File param2. Elpi Accumulate Db derive.param2.db. -Elpi Accumulate File "lens.elpi" From elpi.apps.derive. +Elpi Accumulate File lens. Elpi Accumulate Db derive.lens.db. -Elpi Accumulate File "lens_laws.elpi" From elpi.apps.derive. +Elpi Accumulate File lens_laws. -Elpi Accumulate File "derive.elpi" From elpi.apps.derive. +Elpi Accumulate File derive. Elpi Accumulate lp:{{ % runs P in a context where Coq #[attributes] are parsed diff --git a/apps/derive/theories/derive/bcongr.v b/apps/derive/theories/derive/bcongr.v index b4a983658..e64b974f1 100644 --- a/apps/derive/theories/derive/bcongr.v +++ b/apps/derive/theories/derive/bcongr.v @@ -3,6 +3,9 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "injection.elpi" as injection. +From elpi.apps.derive Extra Dependency "bcongr.elpi" as bcongr. + From Coq Require Export Bool. From elpi Require Export elpi. From elpi.apps Require Export derive.projK. @@ -28,8 +31,8 @@ bcongr-db K _ :- Elpi Command derive.bcongr. Elpi Accumulate Db derive.bcongr.db. Elpi Accumulate Db derive.projK.db. -Elpi Accumulate File "injection.elpi" From elpi.apps.derive. -Elpi Accumulate File "bcongr.elpi" From elpi.apps.derive. +Elpi Accumulate File injection. +Elpi Accumulate File bcongr. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.bcongr.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/cast.v b/apps/derive/theories/derive/cast.v index 9ddbe319e..8fd1602ed 100644 --- a/apps/derive/theories/derive/cast.v +++ b/apps/derive/theories/derive/cast.v @@ -3,13 +3,16 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "cast.elpi" as cast. + From elpi Require Export elpi. Elpi Db derive.cast.db lp:{{ type cast-db int -> term -> prop. }}. + Elpi Command derive.cast. Elpi Accumulate Db derive.cast.db. -Elpi Accumulate File "cast.elpi" From elpi.apps.derive. +Elpi Accumulate File cast. Elpi Accumulate lp:{{ main [int N] :- diff --git a/apps/derive/theories/derive/eq.v b/apps/derive/theories/derive/eq.v index 234335a60..bb8d6baf5 100644 --- a/apps/derive/theories/derive/eq.v +++ b/apps/derive/theories/derive/eq.v @@ -2,6 +2,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "eq.elpi" as eq. From Coq Require Export Bool. From elpi Require Export elpi. @@ -33,7 +34,7 @@ type eq-for inductive -> constant -> prop. Elpi Command derive.eq. Elpi Accumulate Db derive.eq.db. -Elpi Accumulate File "eq.elpi" From elpi.apps.derive. +Elpi Accumulate File eq. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.eq.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/eqK.v b/apps/derive/theories/derive/eqK.v index ab4dac4b8..cdd1f30e7 100644 --- a/apps/derive/theories/derive/eqK.v +++ b/apps/derive/theories/derive/eqK.v @@ -3,6 +3,9 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "discriminate.elpi" as discriminate. +From elpi.apps.derive Extra Dependency "eqK.elpi" as eqK. + From elpi Require Export elpi. From elpi.apps Require Export derive.bcongr derive.eq derive.isK. @@ -40,11 +43,11 @@ eqK-db K _ :- Elpi Command derive.eqK. Elpi Accumulate Db derive.isK.db. -Elpi Accumulate File "discriminate.elpi" From elpi.apps.derive. +Elpi Accumulate File discriminate. Elpi Accumulate Db derive.bcongr.db. Elpi Accumulate Db derive.eq.db. Elpi Accumulate Db derive.eqK.db. -Elpi Accumulate File "eqK.elpi" From elpi.apps.derive. +Elpi Accumulate File eqK. Elpi Accumulate lp:{{ main [str I, str Prefix] :- !, coq.locate I (indt GR), derive.eqK.main GR Prefix _. main [str I] :- !, coq.locate I (indt GR), derive.eqK.main GR "eq_axiom_" _. diff --git a/apps/derive/theories/derive/eqOK.v b/apps/derive/theories/derive/eqOK.v index 1bee099dc..829ab6cb0 100644 --- a/apps/derive/theories/derive/eqOK.v +++ b/apps/derive/theories/derive/eqOK.v @@ -3,19 +3,23 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. +From elpi.apps.derive Extra Dependency "eqOK.elpi" as eqOK. -From elpi Require Export elpi. From elpi.apps Require Export derive.param1 derive.param1_inhab derive.param1_trivial derive.eqK derive.eqcorrect. +From elpi Require Export elpi. +From elpi.apps Require Export derive.param1 derive.param1_inhab derive.param1_trivial derive.eqK derive.eqcorrect. Elpi Command derive.eqOK. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.inhab.db. Elpi Accumulate Db derive.param1.trivial.db. Elpi Accumulate Db derive.eqcorrect.db. -Elpi Accumulate File "eqOK.elpi" From elpi.apps.derive. +Elpi Accumulate File eqOK. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.eqOK.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/eqcorrect.v b/apps/derive/theories/derive/eqcorrect.v index 9a3ccd203..36b7980e1 100644 --- a/apps/derive/theories/derive/eqcorrect.v +++ b/apps/derive/theories/derive/eqcorrect.v @@ -3,14 +3,16 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "eqcorrect.elpi" as eqcorrect. + From elpi Require Export elpi. From elpi.apps Require Export derive.eq derive.map derive.induction derive.eqK. -From Coq Require Import ssreflect Int63. +From Coq Require Import ssreflect Uint63. Lemma uint63_eq_correct i : is_uint63 i -> eq_axiom_at PrimInt63.int PrimInt63.eqb i. Proof. -move=> _ j; case: (Int63.eqb_spec i j); case: PrimInt63.eqb => [-> // _|_ abs]; +move=> _ j; case: (Uint63.eqb_spec i j); case: PrimInt63.eqb => [-> // _|_ abs]; [ by constructor | by constructor=> /abs ]. Qed. Register uint63_eq_correct as elpi.derive.uint63_eq_correct. @@ -35,7 +37,7 @@ Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate Db derive.eq.db. Elpi Accumulate Db derive.eqK.db. Elpi Accumulate Db derive.eqcorrect.db. -Elpi Accumulate File "eqcorrect.elpi" From elpi.apps.derive. +Elpi Accumulate File eqcorrect. Elpi Accumulate lp:{{ main [str I, str Name] :- !, coq.locate I (indt GR), derive.eqcorrect.main GR Name _. main [str I] :- !, coq.locate I (indt GR), coq.gref->id (indt GR) ID, Name is ID ^ "_eq_correct", derive.eqcorrect.main GR Name _. diff --git a/apps/derive/theories/derive/idx2inv.v b/apps/derive/theories/derive/idx2inv.v index 12dedd4f6..6905226f8 100644 --- a/apps/derive/theories/derive/idx2inv.v +++ b/apps/derive/theories/derive/idx2inv.v @@ -3,21 +3,25 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1_functor.elpi" as param1_functor. +From elpi.apps.derive Extra Dependency "idx2inv.elpi" as idx2inv. -From elpi Require Export elpi. From elpi.apps Require Export derive.param1 derive.param1_functor derive.invert. +From elpi Require Export elpi. +From elpi.apps Require Export derive.param1 derive.param1_functor derive.invert. Elpi Db derive.idx2inv.db lp:{{ type idx2inv-db inductive -> inductive -> constant -> constant -> prop. }}. Elpi Command derive.idx2inv. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. -Elpi Accumulate File "param1_functor.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_functor. Elpi Accumulate Db derive.invert.db. Elpi Accumulate Db derive.idx2inv.db. -Elpi Accumulate File "idx2inv.elpi" From elpi.apps.derive. +Elpi Accumulate File idx2inv. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.idx2inv.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.idx2inv.main GR "_to_" _. diff --git a/apps/derive/theories/derive/induction.v b/apps/derive/theories/derive/induction.v index be2ac6726..6809b5d86 100644 --- a/apps/derive/theories/derive/induction.v +++ b/apps/derive/theories/derive/induction.v @@ -2,8 +2,12 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. +From elpi.apps.derive Extra Dependency "induction.elpi" as induction. -From elpi Require Export elpi. From elpi.apps Require Export derive.param1 derive.param1_functor. +From elpi Require Export elpi. +From elpi.apps Require Export derive.param1 derive.param1_functor. Elpi Db derive.induction.db lp:{{ @@ -18,14 +22,14 @@ induction-db T _ :- Elpi Command derive.induction. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.functor.db. Elpi Accumulate Db derive.induction.db. -Elpi Accumulate File "induction.elpi" From elpi.apps.derive. +Elpi Accumulate File induction. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.induction.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/invert.v b/apps/derive/theories/derive/invert.v index 52df16c33..2d8bdcb27 100644 --- a/apps/derive/theories/derive/invert.v +++ b/apps/derive/theories/derive/invert.v @@ -3,6 +3,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "invert.elpi" as invert. From elpi Require Export elpi. @@ -10,7 +11,7 @@ Elpi Db derive.invert.db lp:{{ type invert-db gref -> gref -> prop. }}. Elpi Command derive.invert. Elpi Accumulate Db derive.invert.db. -Elpi Accumulate File "invert.elpi" From elpi.apps.derive. +Elpi Accumulate File invert. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.invert.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.invert.main GR "_inv" _. diff --git a/apps/derive/theories/derive/isK.v b/apps/derive/theories/derive/isK.v index 154264c34..6e29843c3 100644 --- a/apps/derive/theories/derive/isK.v +++ b/apps/derive/theories/derive/isK.v @@ -3,6 +3,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "isK.elpi" as isK. From elpi Require Export elpi. @@ -19,7 +20,7 @@ Elpi Db derive.isK.db lp:{{ Elpi Command derive.isK. Elpi Accumulate Db derive.isK.db. -Elpi Accumulate File "isK.elpi" From elpi.apps.derive. +Elpi Accumulate File isK. Elpi Accumulate lp:{{ main [str I,str O] :- !, coq.locate I (indt GR), derive.isK.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/lens.v b/apps/derive/theories/derive/lens.v index 717f3a60b..21ad0e0e4 100644 --- a/apps/derive/theories/derive/lens.v +++ b/apps/derive/theories/derive/lens.v @@ -2,6 +2,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "lens.elpi" as lens. From elpi Require Export elpi. @@ -26,7 +27,7 @@ Elpi Db derive.lens.db lp:{{ }}. Elpi Command derive.lens. -Elpi Accumulate File "lens.elpi" From elpi.apps.derive. +Elpi Accumulate File lens. Elpi Accumulate Db derive.lens.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.lens.main GR O _. diff --git a/apps/derive/theories/derive/lens_laws.v b/apps/derive/theories/derive/lens_laws.v index 714deed96..bb1ee4cab 100644 --- a/apps/derive/theories/derive/lens_laws.v +++ b/apps/derive/theories/derive/lens_laws.v @@ -2,6 +2,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "lens_laws.elpi" as lens_laws. From elpi Require Export elpi. From elpi.apps Require Export derive.lens. @@ -32,7 +33,7 @@ Register exchange as elpi.derive.lens.exchange. Register exchange_on as elpi.derive.lens.exchange_on. Elpi Command derive.lens_laws. -Elpi Accumulate File "lens_laws.elpi" From elpi.apps.derive. +Elpi Accumulate File lens_laws. Elpi Accumulate Db derive.lens.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.lens-laws.main GR O _. diff --git a/apps/derive/theories/derive/map.v b/apps/derive/theories/derive/map.v index a553aca0f..55e6634b0 100644 --- a/apps/derive/theories/derive/map.v +++ b/apps/derive/theories/derive/map.v @@ -2,6 +2,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "map.elpi" as map. From elpi Require Export elpi. @@ -11,7 +12,7 @@ Elpi Db derive.map.db lp:{{ type map-db term -> term -> term -> prop. }}. Elpi Command derive.map. Elpi Accumulate Db derive.map.db. -Elpi Accumulate File "map.elpi" From elpi.apps.derive. +Elpi Accumulate File map. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.map.main GR O _. main [str I] :- !, diff --git a/apps/derive/theories/derive/param1.v b/apps/derive/theories/derive/param1.v index c4c727cf3..f27a8437e 100644 --- a/apps/derive/theories/derive/param1.v +++ b/apps/derive/theories/derive/param1.v @@ -2,6 +2,8 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. From elpi Require Export elpi. @@ -71,8 +73,8 @@ realiR T TR :- }}. Elpi Command derive.param1. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I GR, derive.param1.main GR O _. diff --git a/apps/derive/theories/derive/param1_congr.v b/apps/derive/theories/derive/param1_congr.v index ab94baffa..30bd70b32 100644 --- a/apps/derive/theories/derive/param1_congr.v +++ b/apps/derive/theories/derive/param1_congr.v @@ -6,17 +6,20 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1_congr.elpi" as param1_congr. -From elpi Require Export elpi. From elpi.apps Require Export derive.param1. +From elpi Require Export elpi. +From elpi.apps Require Export derive.param1. Elpi Db derive.param1.congr.db lp:{{ type param1-congr-db constructor -> term -> prop. }}. Elpi Command derive.param1.congr. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. Elpi Accumulate Db derive.param1.congr.db. -Elpi Accumulate File "param1_congr.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_congr. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.congr.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.congr.main GR "congr_" _. diff --git a/apps/derive/theories/derive/param1_functor.v b/apps/derive/theories/derive/param1_functor.v index cda3de37a..8fd40cff4 100644 --- a/apps/derive/theories/derive/param1_functor.v +++ b/apps/derive/theories/derive/param1_functor.v @@ -6,6 +6,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "param1_functor.elpi" as param1_functor. From elpi Require Export elpi. @@ -15,7 +16,7 @@ Elpi Db derive.param1.functor.db lp:{{ Elpi Command derive.param1.functor. Elpi Accumulate Db derive.param1.functor.db. -Elpi Accumulate File "param1_functor.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_functor. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.functor.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.functor.main GR "_functor" _. diff --git a/apps/derive/theories/derive/param1_inhab.v b/apps/derive/theories/derive/param1_inhab.v index b41ed5039..84cd88f6e 100644 --- a/apps/derive/theories/derive/param1_inhab.v +++ b/apps/derive/theories/derive/param1_inhab.v @@ -3,6 +3,9 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. +From elpi.apps.derive Extra Dependency "param1_inhab.elpi" as param1_inhab. From elpi Require Export elpi. From elpi.apps Require Export derive.param1. @@ -39,11 +42,11 @@ param1-inhab-db-args [T,P|Args] [T,P,Q|PArgs] :- param1-inhab-db P Q, param1-inh }}. Elpi Command derive.param1.inhab. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.inhab.db. -Elpi Accumulate File "param1_inhab.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_inhab. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.inhab.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.inhab.main GR "_witness" _. diff --git a/apps/derive/theories/derive/param1_trivial.v b/apps/derive/theories/derive/param1_trivial.v index 22a0813ac..f0ef1b9e0 100644 --- a/apps/derive/theories/derive/param1_trivial.v +++ b/apps/derive/theories/derive/param1_trivial.v @@ -3,6 +3,9 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param1.elpi" as param1. +From elpi.apps.derive Extra Dependency "param1_trivial.elpi" as param1_trivial. From elpi Require Export elpi. From elpi.apps Require Export derive.param1 derive.param1_congr derive.param1_inhab. @@ -44,13 +47,13 @@ param1-trivial-db-args [T,P|Args] [T,P,Q|PArgs] :- param1-trivial-db P Q, param1 }}. Elpi Command derive.param1.trivial. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param1.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param1. Elpi Accumulate Db derive.param1.db. Elpi Accumulate Db derive.param1.inhab.db. Elpi Accumulate Db derive.param1.congr.db. Elpi Accumulate Db derive.param1.trivial.db. -Elpi Accumulate File "param1_trivial.elpi" From elpi.apps.derive. +Elpi Accumulate File param1_trivial. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.param1.trivial.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.param1.trivial.main GR "_trivial" _. diff --git a/apps/derive/theories/derive/param2.v b/apps/derive/theories/derive/param2.v index b62f3b9df..e59038b4e 100644 --- a/apps/derive/theories/derive/param2.v +++ b/apps/derive/theories/derive/param2.v @@ -2,6 +2,8 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "paramX_lib.elpi" as paramX. +From elpi.apps.derive Extra Dependency "param2.elpi" as param2. From elpi Require Export elpi. @@ -35,8 +37,8 @@ Elpi Db derive.param2.db lp:{{ Elpi Command derive.param2. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. -Elpi Accumulate File "param2.elpi" From elpi.apps.derive. +Elpi Accumulate File paramX. +Elpi Accumulate File param2. Elpi Accumulate Db derive.param2.db. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I GR, derive.param2.main GR O _. diff --git a/apps/derive/theories/derive/projK.v b/apps/derive/theories/derive/projK.v index 8e3afaff7..e05eeb073 100644 --- a/apps/derive/theories/derive/projK.v +++ b/apps/derive/theories/derive/projK.v @@ -5,6 +5,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.derive Extra Dependency "projK.elpi" as projK. From elpi Require Export elpi. @@ -21,7 +22,7 @@ projK-db GR N _ :- Elpi Command derive.projK. Elpi Accumulate Db derive.projK.db. -Elpi Accumulate File "projK.elpi" From elpi.apps.derive. +Elpi Accumulate File projK. Elpi Accumulate lp:{{ main [str I, str O] :- !, coq.locate I (indt GR), derive.projK.main GR O _. main [str I] :- !, coq.locate I (indt GR), derive.projK.main GR "proj" _. diff --git a/apps/eltac/tests/test_discriminate.v b/apps/eltac/tests/test_discriminate.v index 63b71fc8d..eedcc00a5 100644 --- a/apps/eltac/tests/test_discriminate.v +++ b/apps/eltac/tests/test_discriminate.v @@ -2,10 +2,10 @@ From elpi.apps Require Import eltac.discriminate. Set Implicit Arguments. -Inductive foo (A B : Type) : nat -> Type := - | K : foo A B 0 - | K1 : forall n, foo A B n -> foo A B (S n) - | K2 : forall n, (A -> foo A (B*B) n) -> foo A B (n+n). +Inductive foo (A : Type) | (B : Type) : nat -> Type := + | K : foo B 0 + | K1 : forall n, foo B n -> foo B (S n) + | K2 : forall n, (A -> foo (B*B) n) -> foo B (n+n). Elpi derive.isK foo. diff --git a/apps/eltac/theories/discriminate.v b/apps/eltac/theories/discriminate.v index 675a9a8b9..8e3237863 100644 --- a/apps/eltac/theories/discriminate.v +++ b/apps/eltac/theories/discriminate.v @@ -1,10 +1,12 @@ +From elpi.apps.derive Extra Dependency "discriminate.elpi" as discriminate. + From elpi.apps Require Export derive.isK derive.bcongr derive.eqK. (** A tactic proving the current goal out of a false equation *) Elpi Tactic discriminate. Elpi Accumulate Db derive.isK.db. -Elpi Accumulate File "discriminate.elpi" From elpi.apps.derive. +Elpi Accumulate File discriminate. Elpi Accumulate lp:{{ solve (goal _ Ev Ty _ [trm E] ) [] :- !, of E Eq ER, !, ltac.discriminate ER Eq Ty Ev. diff --git a/apps/eltac/theories/injection.v b/apps/eltac/theories/injection.v index 5a4eb2c38..711045b54 100644 --- a/apps/eltac/theories/injection.v +++ b/apps/eltac/theories/injection.v @@ -1,10 +1,12 @@ +From elpi.apps.derive Extra Dependency "injection.elpi" as injection. + From elpi.apps Require Export derive.projK derive.bcongr. (** A tactic pushing an equation under a constructor *) Elpi Tactic injection. Elpi Accumulate Db derive.projK.db. -Elpi Accumulate File "injection.elpi" From elpi.apps.derive. +Elpi Accumulate File injection. Elpi Accumulate lp:{{ solve (goal _ _ _ _ [trm E] as G) NG :- !, of E Eq ER, !, ltac.injection ER Eq _ P, diff --git a/apps/locker/Makefile.coq.local b/apps/locker/Makefile.coq.local deleted file mode 100644 index 5ac016414..000000000 --- a/apps/locker/Makefile.coq.local +++ /dev/null @@ -1 +0,0 @@ -theories/locker.vo: elpi/locker.elpi \ No newline at end of file diff --git a/apps/locker/tests/test_locker.v b/apps/locker/tests/test_locker.v index 03fb45239..340d8786e 100644 --- a/apps/locker/tests/test_locker.v +++ b/apps/locker/tests/test_locker.v @@ -55,3 +55,10 @@ lock Definition cons3 [A] `{EqDecision A} x xs := @cons A x xs. Definition foo3 := cons3 0 nil. About cons3. End Bug_286. + +(* https://coq.zulipchat.com/#narrow/stream/253928-Elpi-users-.26-devs/topic/Reifying.20terms.20with.20ltac.20.2F.20if-then-else.20.2F.20complex.20match *) + +Module elab. +mlock Definition y (z : nat) := ltac:(exact z). +mlock Definition q (b : bool) := if b then 1 else 0. +End elab. diff --git a/apps/locker/theories/locker.v b/apps/locker/theories/locker.v index fb8c266fc..6987e53ff 100644 --- a/apps/locker/theories/locker.v +++ b/apps/locker/theories/locker.v @@ -2,6 +2,7 @@ license: GNU Lesser General Public License Version 2.1 or later ------------------------------------------------------------------------- *) +From elpi.apps.locker Extra Dependency "locker.elpi" as locker. From Coq Require Import ssreflect. From elpi Require Import elpi. @@ -29,7 +30,7 @@ lock Definition foo : T := bo. *) Elpi Command lock. -Elpi Accumulate File "locker.elpi" From elpi.apps.locker. +Elpi Accumulate File locker. Elpi Accumulate lp:{{ main [const-decl ID (some Bo) Ty] :- !, attributes A, @@ -64,7 +65,7 @@ mlock Definition foo : T := bo. *) Elpi Command mlock. -Elpi Accumulate File "locker.elpi" From elpi.apps.locker. +Elpi Accumulate File locker. Elpi Accumulate lp:{{ main [const-decl ID (some Bo) Ty] :- !, locker.module-lock ID Bo Ty. main _ :- coq.error "Usage: mlock Definition ...". diff --git a/coq-builtin.elpi b/coq-builtin.elpi index e287933b6..7f396a049 100644 --- a/coq-builtin.elpi +++ b/coq-builtin.elpi @@ -792,7 +792,7 @@ external pred coq.env.primitive-projections i:inductive, % -- Universes -------------------------------------------------------- -% Univ.Universe.t +% universe level typeabbrev univ (ctype "univ"). @@ -817,16 +817,9 @@ external pred coq.univ.new i:list id, o:univ. % [coq.univ.sup U1 U2] constrains U2 = U1 + 1 external pred coq.univ.sup i:univ, i:univ. -% [coq.univ.max U1 U2 U3] constrains U3 = max U1 U2 -external pred coq.univ.max i:univ, i:univ, o:univ. - -% Very low level, don't use - -% [coq.univ.algebraic-max U1 U2 U3] constrains U3 = Max(U1,U2) *E* -external pred coq.univ.algebraic-max i:univ, i:univ, o:univ. - -% [coq.univ.algebraic-sup U1 U2] constrains U2 = Sup(U1) *E* -external pred coq.univ.algebraic-sup i:univ, o:univ. +% [coq.univ.pts-triple U1 U2 U3] constrains U3 = universe of product with +% domain in U1 and codomain in U2) +external pred coq.univ.pts-triple i:univ, i:univ, o:univ. % -- Primitive -------------------------------------------------------- diff --git a/coq-elpi.opam b/coq-elpi.opam index 1b2c34ce4..9e38644e1 100644 --- a/coq-elpi.opam +++ b/coq-elpi.opam @@ -14,9 +14,8 @@ build: [ [ make "build" "COQBIN=%{bin}%/" "ELPIDIR=%{prefix}%/lib/elpi" "OCAML install: [ make "install" "COQBIN=%{bin}%/" "ELPIDIR=%{prefix}%/lib/elpi" ] depends: [ "stdlib-shims" - "ocaml" {>= "4.07"} "elpi" {>= "1.15.0" & < "1.16.0~"} - "coq" {>= "8.15" & < "8.16~" } + "coq" {>= "8.16" & < "8.17~" } ] tags: [ "category:Miscellaneous/Coq Extensions" diff --git a/elpi/coq-lib.elpi b/elpi/coq-lib.elpi index 1ac12da79..8f7871f3f 100644 --- a/elpi/coq-lib.elpi +++ b/elpi/coq-lib.elpi @@ -103,7 +103,7 @@ coq.saturate Ty T O :- whd Ty [] (prod N Src Tgt) [], !, coq.saturate _ X X. % [copy A B] can be used to perform a replacement, eg -% (copy (const "foo") (const "bar) :- !) => copy A B +% (copy (const "foo") (const "bar") :- !) => copy A B % traverses A replacing foo with bar. pred copy i:term, o:term. :name "copy:start" @@ -290,19 +290,19 @@ coq.typecheck-indt-decl (record ID A _IDK FDecl) Diag :- do-ok! Diag [ pred coq.typecheck-indt-decl-c i:term, i:term, i:indc-decl, o:diagnostic. coq.typecheck-indt-decl-c I S (constructor _ID Arity) Diag :- coq.arity->term Arity T, do-ok! Diag [ coq.typecheck-ty T KS, - coq.typecheck-indt-decl-c.unify-arrow-tgt I S T, + coq.typecheck-indt-decl-c.unify-arrow-tgt I 0 S T, lift-ok (coq.arity->sort S IS) "", lift-ok (if (IS = typ U1, KS = typ U2) (coq.univ.leq U2 U1) true) "constructor universe too large" ]. -pred coq.typecheck-indt-decl-c.unify-arrow-tgt i:term, i:term, i:term, o:diagnostic. -coq.typecheck-indt-decl-c.unify-arrow-tgt I A (prod N S T) D :- - @pi-decl N S x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I A (T x) D. -coq.typecheck-indt-decl-c.unify-arrow-tgt I A (let N S B T) D :- - @pi-def N S B x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I A (T x) D. -coq.typecheck-indt-decl-c.unify-arrow-tgt I A Concl D :- +pred coq.typecheck-indt-decl-c.unify-arrow-tgt i:term, i:int, i:term, i:term, o:diagnostic. +coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (prod N S T) D :- + @pi-decl N S x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (T x) D. +coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (let N S B T) D :- + @pi-def N S B x\ coq.typecheck-indt-decl-c.unify-arrow-tgt I P A (T x) D. +coq.typecheck-indt-decl-c.unify-arrow-tgt I P A Concl D :- coq.count-prods A N, - coq.mk-n-holes N Args, + coq.mk-n-holes {calc (N + P)} Args, coq.mk-app I Args IArgs, coq.unify-eq Concl IArgs D. @@ -322,7 +322,7 @@ coq.elaborate-indt-decl-skeleton (inductive ID I Arity KDecl) (inductive ID I Ar coq.elaborate-arity-skeleton Arity _ Arity1, d\ coq.arity->term Arity1 A1, do-ok! d [ coq.typecheck-indt-decl.heuristic-var-type A1, - d\ @pi-parameter ID A1 i\ map-ok (KDecl i) (coq.elaborate-indt-decl-skeleton-c i A1) (KDecl1 i) d + d\ @pi-parameter ID A1 i\ map-ok (KDecl i) (coq.elaborate-indt-decl-skeleton-c i Arity1) (KDecl1 i) d ] ]. coq.elaborate-indt-decl-skeleton (record ID A IDK FDecl) (record ID A1 IDK FDecl1) Diag :- do-ok! Diag [ @@ -340,19 +340,24 @@ coq.elaborate-indt-decl-skeleton-fields U (field Att ID A Fields) (field Att ID coq.elaborate-indt-decl-skeleton-fields U (Fields p) (Fields1 p) d ]. -pred coq.elaborate-indt-decl-skeleton-c i:term, i:term, i:indc-decl, o:indc-decl, o:diagnostic. -coq.elaborate-indt-decl-skeleton-c I S (constructor ID Arity) (constructor ID Arity1) Diag :- do-ok! Diag [ +pred coq.elaborate-indt-decl-skeleton-c i:term, i:arity, i:indc-decl, o:indc-decl, o:diagnostic. +coq.elaborate-indt-decl-skeleton-c I SA (constructor ID Arity) (constructor ID Arity1) Diag :- do-ok! Diag [ coq.elaborate-arity-skeleton Arity KS Arity1, - coq.typecheck-indt-decl-c.unify-arity-tgt I S Arity1, - lift-ok (coq.arity->sort S IS) "", + coq.typecheck-indt-decl-c.unify-arity I 0 SA Arity1, + lift-ok (coq.arity->sort {coq.arity->term SA} IS) "", lift-ok (if (IS = typ U1, KS = typ U2) (coq.univ.leq U2 U1) true) "constructor universe too large" ]. -pred coq.typecheck-indt-decl-c.unify-arity-tgt i:term, i:term, i:arity, o:diagnostic. -coq.typecheck-indt-decl-c.unify-arity-tgt I A (parameter ID _ T C) D :- - @pi-parameter ID T p\ coq.typecheck-indt-decl-c.unify-arity-tgt I A (C p) D. -coq.typecheck-indt-decl-c.unify-arity-tgt I A (arity C) D :- - coq.typecheck-indt-decl-c.unify-arrow-tgt I A C D. +pred coq.typecheck-indt-decl-c.unify-arity i:term, i:int, i:arity, i:arity, o:diagnostic. +coq.typecheck-indt-decl-c.unify-arity I PNO (parameter _ _ T1 A) (parameter ID _ T C) D :- do-ok! D [ + coq.unify-eq T1 T, + lift-ok (PNO1 is PNO + 1) "", + d\ @pi-parameter ID T p\ coq.typecheck-indt-decl-c.unify-arity I PNO1 (A p) (C p) d +]. +coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (parameter ID _ T C) D :- + @pi-parameter ID T p\ coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (C p) D. +coq.typecheck-indt-decl-c.unify-arity I PNO (arity A) (arity C) D :- + coq.typecheck-indt-decl-c.unify-arrow-tgt I PNO A C D. % Lifts coq.elaborate-skeleton to arity pred coq.elaborate-arity-skeleton i:arity, o:universe, o:arity, o:diagnostic. diff --git a/elpi/elpi-elaborator.elpi b/elpi/elpi_elaborator.elpi similarity index 99% rename from elpi/elpi-elaborator.elpi rename to elpi/elpi_elaborator.elpi index 4082f8d28..e11355db6 100644 --- a/elpi/elpi-elaborator.elpi +++ b/elpi/elpi_elaborator.elpi @@ -370,7 +370,7 @@ pred pts i:universe, i:universe, o:universe. pts prop prop prop. pts (typ U) prop prop :- if (var U) (coq.univ.new [] U) true. -pts (typ T1) (typ T2) (typ M) :- coq.univ.max T1 T2 M. +pts (typ T1) (typ T2) (typ M) :- coq.univ.pts-triple T1 T2 M. pts prop (typ T2) (typ T2). pts (uvar as X) (prop as Y) R :- coq.univ.new [] U, X = typ U, pts X Y R. diff --git a/examples/tutorial_coq_elpi_command.v b/examples/tutorial_coq_elpi_command.v index b1a2814bd..085f4e522 100644 --- a/examples/tutorial_coq_elpi_command.v +++ b/examples/tutorial_coq_elpi_command.v @@ -144,11 +144,10 @@ Elpi hello (0 = 1). (*| -Terms are received *raw*, in the sense that no elaboration has been -performed. In the example above the type argument to `eq` has not -been synthesized to be `nat`. As we will see later the -:builtin:`coq.typecheck` API -can be used to satisfy typing constraints. +Since Coq-Elpi 1.15, terms are received in elaborated form, meaning +that the elaborator of Coq is used to pre-process them. +In the example above the type argument to `eq` has +been synthesized to be `nat`. |*) @@ -157,15 +156,15 @@ Elpi hello Record test := { f1 : nat; f2 : f1 = 1 }. (*| -Global declarations are received raw as well. In the case of `Definition test` -the optional body (would be :e:`none` for an `Axiom` declaration) is present -while the type is omitted (that is, a variable :e:`X1` is used in place of the -type). +Global declarations are received in elaborated form as well. +In the case of `Definition test` the optional body (would be +:e:`none` for an `Axiom` declaration) is present +while the omitted type is inferred (to be `Prop`). In the case of the `Record` declaration remark that each field has a few attributes, like being a coercions (the `:>` in Coq's syntax). Also note that -the type of the record (which was omitted) defaults to `Type` -(for some level :e:`X0`). Finally note that the type of the second field +the type of the record (which was omitted) defaults to `Type`. +Finally note that the type of the second field sees :e:`c0` (the value of the first field). See the :type:`argument` data type @@ -175,11 +174,17 @@ for a detailed decription of all the arguments a command can receive. Processing raw arguments ------------------------ -There are two ways to process term arguments: typechecking and elaboration. +It is sometimes useful to receive arguments in raw format, +so that no elaboration has been performed. +This can be achieved by using the +`#[arguments(raw)]` attributed when the command is declared. + +Then, thre are two ways to process term arguments: +typechecking and elaboration. |*) -Elpi Command check_arg. +#[arguments(raw)] Elpi Command check_arg. Elpi Accumulate lp:{{ main [trm T] :- @@ -220,11 +225,11 @@ into the natural numbers. Indeed the `Check` commands works. The call to :builtin:`coq.typecheck` modifies the term in place, it can assign implicit arguments (like the type parameter of `eq`) but it cannot modify the structure of the term. To do so, one has to use the -:builtin:`coq.elaborate-skeleton` -API. +:builtin:`coq.elaborate-skeleton` API. |*) +#[arguments(raw)] Elpi Command elaborate_arg. Elpi Accumulate lp:{{ @@ -247,7 +252,10 @@ is a copy of :e:`T` where the hole after `eq` is synthesized and the value It is also possible to manipulate term arguments before typechecking them, but note that all the considerations on holes in the tutorial about -the HOAS representation of Coq terms apply here. +the HOAS representation of Coq terms apply here. An example of tool +taking advantage of this possibility is Hierarchy Builder: the declarations +it receives would not typecheck in the current context, but do once the +context is temporarily augmented with ad-hoc canonical structure instances. ======== Examples diff --git a/examples/tutorial_coq_elpi_tactic.v b/examples/tutorial_coq_elpi_tactic.v index cef4df379..452d8ca39 100644 --- a/examples/tutorial_coq_elpi_tactic.v +++ b/examples/tutorial_coq_elpi_tactic.v @@ -1024,8 +1024,8 @@ Elpi Accumulate default lp:{{ }}. Elpi Typecheck. -From Coq Require Import Int63. -Open Scope int63_scope. +From Coq Require Import Uint63. +Open Scope uint63_scope. Fail Definition baz : list nat := default 1. (* .fails *) diff --git a/src/META.coq-elpi b/src/META.coq-elpi new file mode 100644 index 000000000..b1aa861ed --- /dev/null +++ b/src/META.coq-elpi @@ -0,0 +1,10 @@ +package "elpi" ( + directory = "." + description = "Coq Elpi" + requires = "coq-core.plugins.ltac stdlib-shims elpi" + archive(byte) = "elpi_plugin.cma" + archive(native) = "elpi_plugin.cmxa" + plugin(byte) = "elpi_plugin.cma" + plugin(native) = "elpi_plugin.cmxs" +) +directory = "." diff --git a/src/coq_elpi_HOAS.ml b/src/coq_elpi_HOAS.ml index f8a83be0a..956d1b511 100644 --- a/src/coq_elpi_HOAS.ml +++ b/src/coq_elpi_HOAS.ml @@ -152,16 +152,12 @@ let in_coq_fresh_annot_id ~depth ~coq_ctx dbl t = let univin, isuniv, univout, univ_to_be_patched = let { CD.cin; isc; cout }, univ = CD.declare { CD.name = "univ"; - doc = "Univ.Universe.t"; + doc = "universe level"; pp = (fun fmt x -> - let s = Pp.string_of_ppcmds (Univ.Universe.pr x) in - let l = string_split_on_char '.' s in - let s = match List.rev l with - | x :: y :: _ -> y ^ "." ^ x - | _ -> s in + let s = Pp.string_of_ppcmds (Sorts.debug_print x) in Format.fprintf fmt "«%s»" s); - compare = Univ.Universe.compare; - hash = Univ.Universe.hash; + compare = Sorts.compare; + hash = Sorts.hash; hconsed = false; constants = []; } in @@ -599,10 +595,10 @@ let section_ids env = (* map from Elpi evars and Coq's universe levels *) module UM = F.Map(struct - type t = Univ.Universe.t - let compare = Univ.Universe.compare - let show x = Pp.string_of_ppcmds @@ Univ.Universe.pr x - let pp fmt x = Format.fprintf fmt "%a" Pp.pp_with (Univ.Universe.pr x) + type t = Sorts.t + let compare = Sorts.compare + let show x = Pp.string_of_ppcmds @@ Sorts.debug_print x + let pp fmt x = Format.fprintf fmt "%a" Pp.pp_with (Sorts.debug_print x) end) let um = S.declare ~name:"coq-elpi:evar-univ-map" @@ -611,9 +607,9 @@ let um = S.declare ~name:"coq-elpi:evar-univ-map" let new_univ state = S.update_return engine state (fun ({ sigma } as x) -> let sigma, v = Evd.new_univ_level_variable UState.UnivRigid sigma in - let u = Univ.Universe.make v in + let u = Sorts.sort_of_univ @@ Univ.Universe.make v in let sigma = Evd.add_universe_constraints sigma - (UnivProblem.Set.singleton (UnivProblem.ULe (Univ.type1_univ,u))) in + (UnivProblem.Set.singleton (UnivProblem.ULe (Sorts.type1,u))) in { x with sigma }, u) (* We patch data_of_cdata by forcing all output universes that @@ -655,10 +651,10 @@ let universe = B Sorts.sprop, M (fun ~ok ~ko -> function Sorts.SProp -> ok | _ -> ko ())); K("typ","predicative sort of data (carries a level)",A(univ,N), - B Sorts.sort_of_univ, + B (fun x -> x), M (fun ~ok ~ko -> function - | Sorts.Type x -> ok x - | Sorts.Set -> ok Univ.type0_univ + | Sorts.Type _ as x -> ok x + | Sorts.Set -> ok Sorts.set | _ -> ko ())); ] } |> API.ContextualConversion.(!<) @@ -674,8 +670,8 @@ let in_elpi_sort s = (match s with | Sorts.SProp -> E.mkGlobal spropc | Sorts.Prop -> E.mkGlobal propc - | Sorts.Set -> E.mkApp typc (univin Univ.type0_univ) [] - | Sorts.Type u -> E.mkApp typc (univin u) []) + | Sorts.Set -> E.mkApp typc (univin Sorts.set) [] + | Sorts.Type _ as u -> E.mkApp typc (univin u) []) [] let in_elpi_flex_sort t = E.mkApp sortc (E.mkApp typc t []) [] @@ -1165,7 +1161,7 @@ let body_of_constant state c = S.update_return engine state (fun x -> let sigma = Evd.merge_context_set Evd.univ_rigid x.sigma ctx in let sigma = match priv with | Opaqueproof.PrivateMonomorphic () -> sigma - | Opaqueproof.PrivatePolymorphic (_, ctx) -> + | Opaqueproof.PrivatePolymorphic ctx -> let ctx = Util.on_snd (Univ.subst_univs_level_constraints (Univ.make_instance_subst inst)) ctx in Evd.merge_context_set Evd.univ_rigid sigma ctx in @@ -1188,8 +1184,20 @@ let is_sort ~depth x = let is_prod ~depth x = match E.look ~depth x with - | E.App(s,_,[_;_]) -> prodc == s - | _ -> false + | E.App(s,_,[ty;bo]) when prodc == s -> + begin match E.look ~depth bo with + | E.Lam bo -> Some(ty,bo) + | _ -> None end + | _ -> None + +let is_let ~depth x = + match E.look ~depth x with + | E.App(s,_,[ty;d;bo]) when letc == s -> + begin match E.look ~depth bo with + | E.Lam bo -> Some(ty,d,bo) + | _ -> None end + | _ -> None + let is_lam ~depth x = match E.look ~depth x with @@ -1384,7 +1392,7 @@ and lp2constr ~calldepth syntactic_constraints coq_ctx ~depth state ?(on_ty=fals pr_coq_ctx coq_ctx (get_sigma state) ++ cut () ++ str"Did you forget to load some hypotheses with => ?")) else - err Pp.(str"wrong constant:" ++ str (E.Constants.show n)) + err Pp.(str"lp2constr: wrong constant: " ++ int n ++ str " " ++ str (E.Constants.show n)) (* app *) | E.App(c,x,[]) when appc == c -> begin @@ -1692,7 +1700,7 @@ let mk_goal hyps rev ty ev args = let in_elpi_goal state ~args ~hyps ~raw_ev ~ty ~ev = mk_goal hyps raw_ev ty ev args -let sealed_goal2lp ~depth ~args ~in_elpi_arg state k = +let sealed_goal2lp ~depth ~args ~in_elpi_tac_arg state k = let calldepth = depth in let env = get_global_env state in let sigma = get_sigma state in @@ -1703,7 +1711,7 @@ let sealed_goal2lp ~depth ~args ~in_elpi_arg state k = under_coq2elpi_ctx ~calldepth state goal_ctx ~mk_ctx_item:(fun _ t -> E.mkApp nablac (E.mkLam t) []) (fun coq_ctx hyps ~depth state -> - let state, args, gls_args = API.Utils.map_acc (in_elpi_arg ~depth ?calldepth:(Some calldepth) coq_ctx [] sigma) state args in + let state, args, gls_args = API.Utils.map_acc (in_elpi_tac_arg ~depth ?calldepth:(Some calldepth) coq_ctx [] sigma) state args in let args = List.flatten args in let state, hyps, raw_ev, ev, goal_ty, gls = in_elpi_evar_concl evar_concl ~raw_uvar:elpi_raw_goal_evar elpi_goal_evar @@ -1711,7 +1719,7 @@ let sealed_goal2lp ~depth ~args ~in_elpi_arg state k = state, E.mkApp sealc (in_elpi_goal state ~args ~hyps ~raw_ev ~ty:goal_ty ~ev) [], gls_args @ gls) in state, g, evar_decls @ gls -let solvegoal2query sigma goals loc args ~in_elpi_arg ~depth:calldepth state = +let solvegoal2query sigma goals loc args ~in_elpi_tac_arg ~depth:calldepth state = let state = S.set command_mode state false in (* tactic mode *) @@ -1722,7 +1730,7 @@ let solvegoal2query sigma goals loc args ~in_elpi_arg ~depth:calldepth state = if not (Evd.is_undefined sigma goal) then err Pp.(str (Printf.sprintf "Evar %d is not a goal" (Evar.repr goal))); - sealed_goal2lp ~depth:calldepth ~in_elpi_arg ~args state goal) state goals in + sealed_goal2lp ~depth:calldepth ~in_elpi_tac_arg ~args state goal) state goals in let state, ek = F.Elpi.make ~name:"NewGoals" state in let newgls = E.mkUnifVar ek ~args:[] state in @@ -1736,7 +1744,7 @@ let solvegoal2query sigma goals loc args ~in_elpi_arg ~depth:calldepth state = ;; let sealed_goal2lp ~depth state goal = - sealed_goal2lp ~depth ~args:[] ~in_elpi_arg:(fun ~depth ?calldepth _ _ _ _ _ -> assert false) state goal + sealed_goal2lp ~depth ~args:[] ~in_elpi_tac_arg:(fun ~depth ?calldepth _ _ _ _ _ -> assert false) state goal let customtac2query sigma goals loc text ~depth:calldepth state = match goals with @@ -1764,9 +1772,9 @@ let customtac2query sigma goals loc text ~depth:calldepth state = type 'arg tactic_main = Solve of 'arg list | Custom of string -let goals2query sigma goals loc ~main ~in_elpi_arg ~depth state = +let goals2query sigma goals loc ~main ~in_elpi_tac_arg ~depth state = match main with - | Solve args -> solvegoal2query sigma goals loc args ~in_elpi_arg ~depth state + | Solve args -> solvegoal2query sigma goals loc args ~in_elpi_tac_arg ~depth state | Custom text -> customtac2query sigma goals loc text ~depth state let eat_n_lambdas ~depth t upto state = @@ -2082,10 +2090,6 @@ let in_elpi_imp ~depth st x = assert (gl = []); st, x -let in_elpi_explicit ~depth state = - let _, x = in_elpi_imp ~depth state Glob_term.Explicit in - x - let parameterc = E.Constants.declare_global_symbol "parameter" let arityc = E.Constants.declare_global_symbol "arity" let constructorc = E.Constants.declare_global_symbol "constructor" @@ -2121,12 +2125,9 @@ let in_elpi_field atts n ty fields = E.mkApp fieldc atts [in_elpi_id n; ty; E.mkLam fields] let in_elpi_indtdecl_inductive state find id arity constructors = - match find with - | Vernacexpr.Inductive_kw | Vernacexpr.Variant -> - E.mkApp inductivec (in_elpi_id id) [in_elpi_bool state true; arity;E.mkLam @@ U.list_to_lp_list constructors] - | Vernacexpr.CoInductive -> - E.mkApp inductivec (in_elpi_id id) [in_elpi_bool state false; arity;E.mkLam @@ U.list_to_lp_list constructors] - | Vernacexpr.Record | Vernacexpr.Structure | Vernacexpr.Class _ -> assert false + let coind = not (Declarations.CoFinite = find) in + E.mkApp inductivec (in_elpi_id id) [in_elpi_bool state coind; arity;E.mkLam @@ U.list_to_lp_list constructors] + let in_elpi_indtdecl_constructor id ty = E.mkApp constructorc (in_elpi_id id) [ty] @@ -2177,72 +2178,6 @@ let readback_arity ~depth coq_ctx constraints state t = aux_arity coq_ctx ~depth [] [] state [] t ;; -let mk_ctx_item_parameter ~depth state impls = fun i _ name ty bo rest -> - let impls = List.rev impls in - if bo <> None then err Pp.(str"arities with let-in are not supported"); - let imp = - try List.nth impls i - with Failure _ -> in_elpi_explicit ~depth state in - in_elpi_parameter ~imp name ty rest - -let mk_ctx_item_record_field ~depth state atts = fun i _ name ty bo rest -> - if bo <> None then err Pp.(str"record fields with let-in are not supported"); - let state, atts, gls = record_field_attributes.API.Conversion.embed ~depth state (Elpi.Builtin.Given atts.(i)) in - in_elpi_field atts name ty rest - -(* TODO: clarify the x\ is after the decl !! *) -let under_coq2elpi_relctx ~calldepth state ctx - ?(coq_ctx = mk_coq_context ~options:default_options state) - ?(mk_ctx_item=fun _ decl _ _ _ -> mk_pi_arrow decl) - kont -= - let open Context.Rel.Declaration in - let gls = ref [] in - let rec aux i ~depth coq_ctx hyps state = function - | [] -> - let state, t, gls_t = kont coq_ctx hyps ~depth state in - gls := gls_t @ !gls; - state, t - | LocalAssum (Context.{binder_name=coq_name}, ty) as e :: rest -> - let name = coq_name in - let state, ty, gls_ty = constr2lp coq_ctx ~calldepth ~depth:(depth) state ty in - gls := gls_ty @ !gls; - let hyp = mk_decl ~depth name ~ty in - let hyps = { ctx_entry = hyp ; depth = depth } :: hyps in - let coq_ctx = push_coq_ctx_local depth e coq_ctx in - let state, rest = aux (succ i) ~depth:(depth+1) coq_ctx hyps state rest in - state, mk_ctx_item i hyp name ty None rest - | LocalDef (Context.{binder_name=coq_name},bo,ty) as e :: rest -> - let name = coq_name in - let state, ty, gls_ty = constr2lp coq_ctx ~calldepth ~depth:(depth) state ty in - let state, bo, gls_bo = constr2lp coq_ctx ~calldepth ~depth:(depth) state bo in - gls := gls_ty @ gls_bo @ !gls; - let hyp = mk_def ~depth name ~bo ~ty in - let hyps = { ctx_entry = hyp ; depth = depth } :: hyps in - let coq_ctx = push_coq_ctx_local depth e coq_ctx in - let state, rest = aux (succ i) ~depth:(depth+1) coq_ctx hyps state rest in - state, mk_ctx_item i hyp name ty (Some bo) rest - in - let state, t = aux 0 ~depth:calldepth coq_ctx [] state (List.rev ctx) in - state, t, !gls - -let in_elpi_imp_list ~depth state impls = - let in_elpi_imp state x = - let state, i = in_elpi_imp ~depth state x in - state, i, [] in - let state, impls, _ = API.Utils.map_acc in_elpi_imp state impls in - state, impls - -let embed_arity ~depth coq_ctx constraints state (relctx,impls,ty) = - let calldepth = depth in - let state, impls = in_elpi_imp_list ~depth state impls in - under_coq2elpi_relctx ~calldepth state relctx - ~mk_ctx_item:(mk_ctx_item_parameter ~depth state impls) - (fun coq_ctx hyps ~depth state -> - let state, ty, gl = constr2lp coq_ctx ~calldepth ~depth state ty in - state, in_elpi_arity ty, gl) -;; - let lp2inductive_entry ~depth coq_ctx constraints state t = let lp2constr coq_ctx ~depth state t = @@ -2457,113 +2392,341 @@ let lp2inductive_entry ~depth coq_ctx constraints state t = str (pp2string P.(term depth) t)) in aux_decl coq_ctx ~depth [] [] state [] t +;; -let inductive_kind_of_recursivity_kind = function - | Declarations.Finite -> Vernacexpr.Inductive_kw - | Declarations.CoFinite -> Vernacexpr.CoInductive - | Declarations.BiFinite -> Vernacexpr.Inductive_kw +let rec safe_combine3 l1 l2 l3 ~default3 = + match l1, l2, l3 with + | [], [], [] -> [] + | x::xs, y::ys, z::zs -> (x,y,z) :: safe_combine3 xs ys zs ~default3 + | x::xs, y::ys, [] -> (x,y,default3) :: safe_combine3 xs ys [] ~default3 + | _ -> raise (Invalid_argument "safe_combine3") + +let rec safe_combine2_impls l1 l2 ~default2 = + match l1, l2 with + | [], _ -> [] + | x::xs, y::ys -> (x,y) :: safe_combine2_impls xs ys ~default2 + | x::xs, [] -> (x,default2) :: safe_combine2_impls xs [] ~default2 +let safe_combine2_impls l1 l2 ~default2 = + let l = safe_combine2_impls (List.rev l1) l2 ~default2 in + List.rev l + + +(* convention: nuparams are also in each constructor *) +type 'a ctx_entry = { id : Id.t; typ : EConstr.t; extra : 'a } +type constructor = { id : Id.t; arity : Glob_term.binding_kind ctx_entry list; typ : EConstr.t } +type ind_decl = + | Inductive of { + id : Id.t; + nuparams : Glob_term.binding_kind ctx_entry list; + typ : EConstr.t; + constructors : constructor list; + kind : Declarations.recursivity_kind; + } + | Record of { + id : Id.t; + kid : Id.t; + typ : EConstr.t; + fields : record_field_att list ctx_entry list; + } +type hoas_ind = { + params : Glob_term.binding_kind ctx_entry list; + decl : ind_decl; +} -let safe_chop n l = - let rec aux n acc l = - if n = 0 then List.rev acc, l - else - match l with - | [] -> List.rev acc, [] - | x :: xs -> aux (n-1) (x :: acc) xs +let mk_parameter2 ~depth name impl ty rest state = + let state, imp = in_elpi_imp ~depth state impl in + state, in_elpi_parameter ~imp name ty rest + +let mk_ctx_item_record_field ~depth name atts ty rest state = + let state, atts, gls = record_field_attributes.API.Conversion.embed ~depth state (Elpi.Builtin.Given atts) in + state, in_elpi_field atts name ty rest + +let under_coq2elpi_relctx ~calldepth state (ctx : 'a ctx_entry list) ~coq_ctx ~mk_ctx_item kont = + let gls = ref [] in + let rec aux ~depth coq_ctx hyps state = function + | [] -> + let state, t, gls_t = kont coq_ctx hyps ~depth state in + gls := gls_t @ !gls; + state, t + | { id; typ; extra } :: rest -> + let name = Names.Name id in + let state, ty, gls_ty = constr2lp coq_ctx ~calldepth ~depth state typ in + gls := gls_ty @ !gls; + let hyp = mk_decl ~depth name ~ty in + let hyps = { ctx_entry = hyp ; depth = depth } :: hyps in + let e = Context.Rel.Declaration.LocalAssum (Context.annotR name, typ) in + let coq_ctx = push_coq_ctx_local depth e coq_ctx in + let state, rest = aux ~depth:(depth+1) coq_ctx hyps state rest in + mk_ctx_item ~depth name extra ty rest state in - aux n [] l + let state, t = aux ~depth:calldepth coq_ctx [] state (List.rev ctx) in + state, t, !gls +;; -let inductive_decl2lp ~depth coq_ctx constraints state (mutind,(mind,ind),(i_impls,k_impls)) = +let embed_arity ~depth coq_ctx state (relctx,ty) = let calldepth = depth in - let allparams = List.map EConstr.of_rel_decl mind.Declarations.mind_params_ctxt in - let kind = inductive_kind_of_recursivity_kind mind.Declarations.mind_finite in - let name = Name ind.Declarations.mind_typename in - let paramsno = mind.Declarations.mind_nparams_rec in - let allparamsno = mind.Declarations.mind_nparams in - - let i_impls_params, i_impls_nuparams = safe_chop paramsno i_impls in - let state, i_impls_params = in_elpi_imp_list ~depth state i_impls_params in - let nuparams, params = CList.chop (mind.Declarations.mind_nparams - paramsno) allparams in - let nuparamsno = List.length nuparams in + under_coq2elpi_relctx ~calldepth ~coq_ctx state relctx + ~mk_ctx_item:mk_parameter2 + (fun coq_ctx hyps ~depth state -> + let state, ty, gl = constr2lp coq_ctx ~calldepth ~depth state ty in + state, in_elpi_arity ty, gl) +;; + + +let hoas_ind2lp ~depth coq_ctx state { params; decl } = + let calldepth = depth in + under_coq2elpi_relctx ~calldepth ~coq_ctx state params + ~mk_ctx_item:mk_parameter2 + (fun coq_ctx hyps ~depth state -> match decl with + | Inductive { id; nuparams; typ; constructors; kind } -> + let sigma = get_sigma state in + let paramsno = List.length params in + (* Relocation to match Coq's API. + * From + * Ind, Params, NuParams |- ktys + * To + * Params, Ind, NuParams |- ktys + *) + let rec iter n acc f = + if n = 0 then acc + else iter (n-1) (f acc) f in + let subst arityno = CList.init (arityno + paramsno + 1) (fun i -> + let i = i + 1 in (* init is 0 based, rels are 1 base *) + if i = arityno + paramsno + 1 then + let ind = EC.mkRel (arityno + 1) in + iter paramsno ind (fun x -> EConstr.mkLambda (Context.anonR,EConstr.mkProp,EConstr.Vars.lift 1 x)) + else if i > arityno then EC.mkRel(i+1) + else EC.mkRel i) in + let reloc ctx t = + let t = EC.Vars.substl (subst (List.length ctx)) t in + Reductionops.nf_beta (Global.env()) sigma t in + + let state, arity, gls1 = embed_arity ~depth coq_ctx state (nuparams,typ) in + let coq_ctx = push_coq_ctx_local depth (Context.Rel.Declaration.LocalAssum(Context.anonR,EConstr.mkProp)) coq_ctx in + let depth = depth+1 in + let embed_constructor state { id; arity; typ } = + let kctx = arity in + let state, karity, gl = embed_arity ~depth coq_ctx state (kctx,reloc kctx typ) in + state, in_elpi_indtdecl_constructor (Name id) karity, gl in + let state, ks, gls2 = + API.Utils.map_acc embed_constructor state constructors in + state, in_elpi_indtdecl_inductive state kind (Name id) arity ks, List.flatten [gls1 ; gls2] + | Record { id; kid; typ; fields } -> + let embed_record_constructor state fields = + under_coq2elpi_relctx ~calldepth:depth state fields + ~coq_ctx + ~mk_ctx_item:mk_ctx_item_record_field + (fun coq_ctx hyps ~depth state -> state, in_elpi_indtdecl_endrecord (), []) + in + let state, sort, gls1 = constr2lp coq_ctx ~calldepth ~depth state typ in + let state, rd, gls2 = embed_record_constructor state fields in + state, in_elpi_indtdecl_record (Name id) sort (Name kid) rd, gls1 @ gls2 + ) +;; + +let param2ctx l = + let open Context.Rel.Declaration in + List.map (function + | LocalAssum( { Context.binder_name = Anonymous },typ), (Glob_term.Explicit as bk) -> { id = Id.of_string "_"; typ; extra = bk } + | LocalAssum( { Context.binder_name = Name id },typ), bk -> { id; typ; extra = bk } + | LocalDef _, _ -> nYI "let-in in inductive parameters" + | _ -> assert false) l + +let nonexpimpls impls = + let rec aux = function + | [] -> [] + | Glob_term.Explicit :: l -> aux l + | l -> l in + aux (List.rev impls) + +let drop_nparams_from_ctx n ctx = + let ctx, _ = CList.chop (List.length ctx - n) ctx in + ctx + +let inductive_decl2lp ~depth coq_ctx constraints state (mutind,(mind,ind),(i_impls,k_impls)) = + let { Declarations.mind_params_ctxt; + mind_finite = kind; + mind_nparams = allparamsno; + mind_nparams_rec = paramsno; + mind_ntypes = ntyps; + mind_record } = mind in + let allparams = List.map EConstr.of_rel_decl mind_params_ctxt in + let allparams = safe_combine2_impls allparams i_impls ~default2:Glob_term.Explicit |> param2ctx in + let nuparamsno = allparamsno - paramsno in + let nuparams, params = CList.chop nuparamsno allparams in + let { Declarations.mind_consnames = constructor_names; + mind_typename = id; + mind_nf_lc = constructor_types } = ind in + let arity_w_params = Inductive.type_of_inductive ((mind,ind),Univ.Instance.empty) in let sigma = get_sigma state in - let drop_nparams_from_ctx n ctx = - let ctx, _ = CList.chop (List.length ctx - n) ctx in - ctx in - let drop_upto_nparams_from_ctx n ctx = - let ctx, _ = safe_chop (List.length ctx - n) ctx in - ctx in let drop_nparams_from_term n x = let x = EConstr.of_constr x in let ctx, sort = EConstr.decompose_prod_assum sigma x in let ctx = drop_nparams_from_ctx n ctx in EConstr.it_mkProd_or_LetIn sort ctx in - let move_allbutnparams_from_ctx_to n ctx t = - let inline, keep = CList.chop (List.length ctx - n) ctx in - keep, EConstr.it_mkProd_or_LetIn t inline in - let k_impls = List.map (drop_upto_nparams_from_ctx paramsno) k_impls in - let arity = - drop_nparams_from_term allparamsno - (Inductive.type_of_inductive ((mind,ind),Univ.Instance.empty)) in - let knames = CArray.map_to_list (fun x -> Name x) ind.Declarations.mind_consnames in - let ntyps = mind.Declarations.mind_ntypes in - let ktys = CArray.map_to_list (fun (ctx,x) -> - let (ctx,x) = - Term.it_mkProd_or_LetIn x ctx |> - Inductive.abstract_constructor_type_relatively_to_inductive_types_context ntyps mutind |> - Term.decompose_prod_assum in - let ctx = drop_nparams_from_ctx paramsno @@ List.map EConstr.of_rel_decl ctx in - move_allbutnparams_from_ctx_to nuparamsno ctx @@ EConstr.of_constr x) ind.Declarations.mind_nf_lc in - (* Relocation to match Coq's API. - * From - * Ind, Params, NuParams |- ktys - * To - * Params, Ind, NuParams |- ktys - *) - let rec iter n acc f = - if n = 0 then acc - else iter (n-1) (f acc) f in - let subst = CList.init (allparamsno + 1) (fun i -> - let i = i + 1 in (* init is 0 based, rels are 1 base *) - if i = allparamsno + 1 then - let ind = EC.mkRel (nuparamsno + 1) in - iter paramsno ind (fun x -> EConstr.mkLambda (Context.anonR,EConstr.mkProp,EConstr.Vars.lift 1 x)) - else if i > nuparamsno then EC.mkRel(i+1) - else EC.mkRel i) in - let reloc t = Reductionops.nf_beta (Global.env()) sigma @@ EC.Vars.substl subst t in -under_coq2elpi_relctx ~calldepth state params - ~mk_ctx_item:(mk_ctx_item_parameter ~depth state i_impls_params) - (fun coq_ctx hyps ~depth state -> - if mind.Declarations.mind_record = Declarations.NotRecord then - let state, arity, gls1 = - embed_arity ~depth coq_ctx constraints state (nuparams,i_impls_nuparams,arity) in - let coq_ctx = push_coq_ctx_local depth (Context.Rel.Declaration.LocalAssum(Context.anonR,EConstr.mkProp)) coq_ctx in - let depth = depth+1 in - let embed_constructor state (kname,(kctx,kty),kimpl) = - let state, karity, gl = - embed_arity ~depth coq_ctx constraints state (kctx,kimpl,reloc kty) in - state, in_elpi_indtdecl_constructor kname karity, gl in - let state, ks, gls2 = - API.Utils.map_acc embed_constructor state (CList.combine3 knames ktys k_impls) in - state, in_elpi_indtdecl_inductive state kind name arity ks, List.flatten [gls1 ; gls2] - else - let kid, kty, kimpl = - match knames, ktys, k_impls with - | [id], [ty], [impl] -> id, ty, impl - | _ -> assert false in - let embed_record_constructor state (ctx,kty) kimpl = - let more_ctx, _ = EConstr.decompose_prod_assum sigma kty in - let ty_as_ctx = more_ctx @ ctx in - let atts = Array.make (List.length ty_as_ctx) [] in - under_coq2elpi_relctx ~calldepth:depth state ty_as_ctx - ~coq_ctx - ~mk_ctx_item:(mk_ctx_item_record_field ~depth state atts) - (fun coq_ctx hyps ~depth state -> state, in_elpi_indtdecl_endrecord (), []) - in - let state, sort, gls1 = constr2lp coq_ctx ~calldepth ~depth state arity in - let state, rd, gls2 = embed_record_constructor state kty kimpl in - state, in_elpi_indtdecl_record name sort kid rd, gls1 @ gls2 - ) + let decl = + if mind_record = Declarations.NotRecord then + let typ = drop_nparams_from_term allparamsno arity_w_params in + let constructors = + safe_combine3 (Array.to_list constructor_names) (Array.to_list constructor_types) k_impls ~default3:[] |> + List.map (fun (id,(ctx,x),impls) -> + let x = + Term.it_mkProd_or_LetIn x ctx |> + Inductive.abstract_constructor_type_relatively_to_inductive_types_context ntyps mutind in + let nonexpimplsno = List.length (nonexpimpls impls) in + let ctx, typ = Term.decompose_prod_n_assum (max allparamsno nonexpimplsno) x in + let ctx = EConstr.of_rel_context ctx in + let typ = EConstr.of_constr typ in + let ctx = safe_combine2_impls ctx impls ~default2:Glob_term.Explicit in + let arity = drop_nparams_from_ctx paramsno ctx |> param2ctx in + { id; arity; typ }) in + Inductive { nuparams; id; typ; kind; constructors } + else + let kid = constructor_names.(0) in + if (nuparamsno != 0) then nYI "record with non uniform paramters"; + let projections = Structures.Structure.((find (mutind,0)).projections) in + let fieldsno = List.length projections in + let kctx, _ = constructor_types.(0) in + let kctx = EConstr.of_rel_context kctx in + let kctx = drop_nparams_from_ctx paramsno kctx in + if (List.length kctx != fieldsno) then CErrors.anomaly Pp.(str"record fields number != projections"); + let typ = drop_nparams_from_term allparamsno arity_w_params in + let open Structures.Structure in + let fields_atts = List.map (fun { proj_name; proj_body; proj_canonical } -> + proj_name, + (match proj_body with + | None -> Coercion false + | Some c -> Coercion (Coercionops.coercion_exists (Names.GlobRef.ConstRef c))) :: + (Canonical proj_canonical) :: []) + (List.rev projections) in + let param2field l = + let open Context.Rel.Declaration in + List.map (function + | LocalAssum( { Context.binder_name = Anonymous },typ), (Anonymous,atts) -> { id = Id.of_string "_"; typ; extra = atts } + | LocalAssum( { Context.binder_name = Name id },typ), (Name id1,atts) when Id.equal id id1 -> { id; typ; extra = atts } + | LocalAssum _, _ -> CErrors.anomaly Pp.(str"record fields names != projections"); + | LocalDef _, _ -> nYI "let-in in record fields parameters") l in + let fields = List.combine kctx fields_atts |> param2field in + Record { id; kid; typ; fields } + in + let ind = { params; decl } in + hoas_ind2lp ~depth coq_ctx state ind ;; + +let inference_nonuniform_params_off = + CWarnings.create + ~name:"elpi.unsupported-nonuniform-parameters-inference" + ~category:"elpi" Pp.(fun () -> + strbrk"Inference of non-uniform parameters is not available in Elpi, please use the explicit | mark in the inductive declaration or Set Uniform Inductive Parameters") + +let inductive_entry2lp ~depth coq_ctx constraints state e = + let open ComInductive.Mind_decl in + let open Entries in + let { mie; nuparams; univ_binders; implicits; uctx } = e in + let i_impls, k_impls = match implicits with + | [i,k] -> + List.map binding_kind_of_manual_implicit i, + List.map (List.map binding_kind_of_manual_implicit) k + | _ -> nYI "mutual inductives" in + let ind = match mie.mind_entry_inds with + | [ x ] -> x + | _ -> nYI "mutual inductives" in + if not (Names.Id.Map.is_empty univ_binders) then nYI "universe binders inductives"; + let indno = 1 in + let state = + S.update engine state (fun e -> + { e with sigma = Evd.merge_context_set UState.univ_flexible e.sigma uctx}) in + let state = match mie.mind_entry_universes with + | Template_ind_entry ctx -> + S.update engine state (fun e -> + { e with sigma = Evd.merge_context_set UState.univ_flexible e.sigma ctx}) + | Monomorphic_ind_entry -> state + | Polymorphic_ind_entry _ -> nYI "univpoly ind" in + let allparams = mie.mind_entry_params in + let allparams = Vars.lift_rel_context indno allparams in + let kind = mie.mind_entry_finite in + let nuparamsno = + match nuparams with + | Some x -> x + | None -> + let open Declarations in + match kind with + | BiFinite -> 0 + | Finite | CoFinite -> inference_nonuniform_params_off (); 0 in + let allparams = EConstr.of_rel_context allparams in + let allparams = safe_combine2_impls allparams i_impls ~default2:Glob_term.Explicit |> param2ctx in + let nuparams, params = CList.chop nuparamsno allparams in + let id = ind.mind_entry_typename in + let typ = EConstr.of_constr ind.mind_entry_arity in + let constructors = List.combine ind.mind_entry_consnames ind.mind_entry_lc in + let constructors = List.map (fun (id,typ) -> + (* FIXME, arity could be longer *) + { id; arity = nuparams; typ = EConstr.of_constr typ }) constructors in + let ind = { params; decl = Inductive { id; nuparams; typ; kind; constructors } } in + hoas_ind2lp ~depth coq_ctx state ind +;; + +let record_entry2lp ~depth coq_ctx constraints state e = + let open Record.Record_decl in + let open Record.Data in + let open Entries in + let { mie; impls; ubinders; globnames; global_univ_decls; records; _ } = e in + let i_impls, k_impls = match impls with + | [i,k] -> + List.map binding_kind_of_manual_implicit i, + List.map (List.map binding_kind_of_manual_implicit) k + | _ -> nYI "mutual record" in + let ind = match mie.mind_entry_inds with + | [ x ] -> x + | _ -> nYI "mutual record" in + let record = match records with + | [ x ] -> x + | _ -> nYI "mutual record" in + let indno = 1 in + + if not (Names.Id.Map.is_empty ubinders) then nYI "universe binders record"; + if not (Names.Id.Map.is_empty (snd globnames)) then nYI "universe gbinders record"; + + let state = global_univ_decls |> Option.cata (fun ctx -> + S.update engine state (fun e -> + { e with sigma = Evd.merge_context_set UState.univ_flexible e.sigma ctx})) state in + + let state = match mie.mind_entry_universes with + | Template_ind_entry ctx -> + S.update engine state (fun e -> + { e with sigma = Evd.merge_context_set UState.univ_flexible e.sigma ctx}) + | Monomorphic_ind_entry -> state + | Polymorphic_ind_entry _ -> nYI "univpoly ind" in + + let params = mie.mind_entry_params in + let params = Vars.lift_rel_context indno params in + + let params = EConstr.of_rel_context params in + let params = safe_combine2_impls params i_impls ~default2:Glob_term.Explicit |> param2ctx in + let _paramsno = List.length params in + + let id = ind.mind_entry_typename in + let typ = EConstr.of_constr ind.mind_entry_arity in + let kid = List.hd ind.mind_entry_consnames in + + let fieldsno = List.length record.coers in + let kctx, _ = Term.decompose_prod_assum @@ List.hd ind.mind_entry_lc in + let kctx = EConstr.of_rel_context kctx in + if (List.length kctx != fieldsno) then CErrors.anomaly Pp.(str"record fields number != projections"); + + let fields = List.map2 (fun { pf_subclass; pf_canonical } -> + let open Context.Rel.Declaration in + function + | LocalAssum( { Context.binder_name = Anonymous },typ) -> + { id = Id.of_string "_"; typ; extra = [Coercion pf_subclass; Canonical pf_canonical] } + | LocalAssum( { Context.binder_name = Name id },typ) -> + { id; typ; extra = [Coercion pf_subclass; Canonical pf_canonical] } + | _ -> nYI "let-in in record fields" + ) (List.rev record.coers) kctx in + + let ind = { params; decl = Record { id; kid; typ; fields } } in + hoas_ind2lp ~depth coq_ctx state ind + (* ********************************* }}} ********************************** *) (* ****************************** API ********************************** *) diff --git a/src/coq_elpi_HOAS.mli b/src/coq_elpi_HOAS.mli index 69cbe318a..ec96ccb9d 100644 --- a/src/coq_elpi_HOAS.mli +++ b/src/coq_elpi_HOAS.mli @@ -96,6 +96,14 @@ val inductive_decl2lp : depth:int -> empty coq_context -> constraints -> State.t -> (Names.MutInd.t * (Declarations.mutual_inductive_body * Declarations.one_inductive_body) * (Glob_term.binding_kind list * Glob_term.binding_kind list list)) -> State.t * term * Conversion.extra_goals +val inductive_entry2lp : + depth:int -> empty coq_context -> constraints -> State.t -> ComInductive.Mind_decl.t -> + State.t * term * Conversion.extra_goals + +val record_entry2lp : + depth:int -> empty coq_context -> constraints -> State.t -> Record.Record_decl.t -> + State.t * term * Conversion.extra_goals + val in_elpi_id : Names.Name.t -> term val in_elpi_bool : State.t -> bool -> term val in_elpi_parameter : Names.Name.t -> imp:term -> term -> term -> term @@ -103,7 +111,7 @@ val in_elpi_arity : term -> term val in_elpi_indtdecl_record : Names.Name.t -> term -> Names.Name.t -> term -> term val in_elpi_indtdecl_endrecord : unit -> term val in_elpi_indtdecl_field : depth:int -> State.t -> record_field_spec -> term -> term -> State.t * term -val in_elpi_indtdecl_inductive : State.t -> Vernacexpr.inductive_kind -> Names.Name.t -> term -> term list -> term +val in_elpi_indtdecl_inductive : State.t -> Declarations.recursivity_kind -> Names.Name.t -> term -> term list -> term val in_elpi_indtdecl_constructor : Names.Name.t -> term -> term val sealed_goal2lp : depth:int -> State.t -> Evar.t -> State.t * term * Conversion.extra_goals @@ -143,7 +151,7 @@ val constructor : constructor Conversion.t val constant : global_constant Conversion.t val universe : Sorts.t Conversion.t val global_constant_of_globref : Names.GlobRef.t -> global_constant -val abbreviation : Globnames.syndef_name Conversion.t +val abbreviation : Globnames.abbreviation Conversion.t val implicit_kind : Glob_term.binding_kind Conversion.t val collect_term_variables : depth:int -> term -> Names.Id.t list type primitive_value = @@ -158,12 +166,13 @@ module GRSet : Elpi.API.Utils.Set.S with type elt = Names.GlobRef.t (* CData relevant for other modules, e.g the one exposing Coq's API *) val isuniv : RawOpaqueData.t -> bool -val univout : RawOpaqueData.t -> Univ.Universe.t -val univin : Univ.Universe.t -> term -val univ : Univ.Universe.t Conversion.t +val univout : RawOpaqueData.t -> Sorts.t +val univin : Sorts.t -> term +val univ : Sorts.t Conversion.t val is_sort : depth:int -> term -> bool -val is_prod : depth:int -> term -> bool +val is_prod : depth:int -> term -> (term * term) option (* ty, bo @ depth+1 *) +val is_let : depth:int -> term -> (term * term * term) option (* ty, d, bo @ depth+1 *) val is_lam : depth:int -> term -> (term * term) option (* ty, bo @ depth+1 *) val isname : RawOpaqueData.t -> bool @@ -186,7 +195,7 @@ type record_field_att = | Canonical of bool val record_field_att : record_field_att Conversion.t -val new_univ : State.t -> State.t * Univ.Universe.t +val new_univ : State.t -> State.t * Sorts.t val add_constraints : State.t -> UnivProblem.Set.t -> State.t val type_of_global : State.t -> Names.GlobRef.t -> State.t * EConstr.types val body_of_constant : State.t -> Names.Constant.t -> State.t * EConstr.t option @@ -213,8 +222,8 @@ type hyp = { ctx_entry : term; depth : int } type 'arg tactic_main = Solve of 'arg list | Custom of string val goals2query : - Evd.evar_map -> Goal.goal list -> Elpi.API.Ast.Loc.t -> main:'a tactic_main -> - in_elpi_arg:(depth:int -> ?calldepth:int -> 'b coq_context -> hyp list -> Evd.evar_map -> State.t -> 'a -> State.t * term list * Conversion.extra_goals) -> + Evd.evar_map -> Evar.t list -> Elpi.API.Ast.Loc.t -> main:'a tactic_main -> + in_elpi_tac_arg:(depth:int -> ?calldepth:int -> 'b coq_context -> hyp list -> Evd.evar_map -> State.t -> 'a -> State.t * term list * Conversion.extra_goals) -> depth:int -> State.t -> State.t * (Elpi.API.Ast.Loc.t * term) * Conversion.extra_goals val tclSOLUTION2EVD : Evd.evar_map -> 'a Elpi.API.Data.solution -> unit Proofview.tactic diff --git a/src/coq_elpi_arg_HOAS.ml b/src/coq_elpi_arg_HOAS.ml index 5881c0f1a..67b2e5247 100644 --- a/src/coq_elpi_arg_HOAS.ml +++ b/src/coq_elpi_arg_HOAS.ml @@ -10,48 +10,89 @@ open Coq_elpi_utils open Coq_elpi_HOAS open Names +let push_name x = function + | Names.Name.Name id -> + let decl = Context.Named.Declaration.LocalAssum (Context.make_annot id Sorts.Relevant, Constr.mkProp) in + { x with Genintern.genv = Environ.push_named decl x.Genintern.genv } + | _ -> x + +let push_gdecl (name,_,_,_) x = push_name x name + +let push_glob_ctx glob_ctx x = + List.fold_right push_gdecl glob_ctx x + +let push_inductive_in_intern_env intern_env name params arity user_impls = + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, ty = Pretyping.understand_tcc env sigma ~expected_type:Pretyping.IsType (Coq_elpi_utils.mk_gforall arity params) in + Constrintern.compute_internalization_env env sigma ~impls:intern_env + Constrintern.Inductive [name] [ty] [user_impls] + +let intern_tactic_constr = Ltac_plugin.Tacintern.intern_constr + +let intern_global_constr { Ltac_plugin.Tacintern.genv = env } ~intern_env t = + let sigma = Evd.from_env env in + Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls:intern_env ~pattern_mode:false ~ltacvars:Constrintern.empty_ltac_sign t + +let intern_global_constr_ty { Ltac_plugin.Tacintern.genv = env } ~intern_env t = + let sigma = Evd.from_env env in + Constrintern.intern_gen Pretyping.IsType env sigma ~impls:intern_env ~pattern_mode:false ~ltacvars:Constrintern.empty_ltac_sign t + +let intern_global_context { Ltac_plugin.Tacintern.genv = env } ~intern_env ctx = + Constrintern.intern_context env ~bound_univs:UnivNames.empty_binders intern_env ctx + +module Cmd = struct + type raw_term = Constrexpr.constr_expr type glob_term = Genintern.glob_constr_and_expr type top_term = Ltac_plugin.Tacinterp.interp_sign * Genintern.glob_constr_and_expr +type raw_record_decl = Vernacentries.Preprocessed_Mind_decl.record +type glob_record_decl = Genintern.glob_sign * raw_record_decl +type top_record_decl = Geninterp.interp_sign * glob_record_decl -type raw_record_decl = { +type raw_indt_decl = Vernacentries.Preprocessed_Mind_decl.inductive +type glob_indt_decl = Genintern.glob_sign * raw_indt_decl +type top_indt_decl = Geninterp.interp_sign * glob_indt_decl + +type raw_record_decl_elpi = { name : qualified_name; parameters : Constrexpr.local_binder_expr list; sort : Constrexpr.sort_expr option; constructor : Names.Id.t option; fields : (Vernacexpr.local_decl_expr * Vernacexpr.record_field_attr) list -} -type glob_record_decl = { +} +type glob_record_decl_elpi = { name : string list * Names.Id.t; constructorname : Names.Id.t option; params : Glob_term.glob_decl list; arity : Glob_term.glob_constr; fields : (Glob_term.glob_constr * Coq_elpi_HOAS.record_field_spec) list } -type top_record_decl = Geninterp.interp_sign * glob_record_decl + let pr_raw_record_decl _ _ _ = Pp.str "TODO: pr_raw_record_decl" let pr_glob_record_decl _ _ _ = Pp.str "TODO: pr_glob_record_decl" let pr_top_record_decl _ _ _ = Pp.str "TODO: pr_top_record_decl" -type raw_indt_decl = { - finiteness : Vernacexpr.inductive_kind; +type raw_indt_decl_elpi = { + finiteness : Declarations.recursivity_kind; name : qualified_name; parameters : Constrexpr.local_binder_expr list; - non_uniform_parameters : Constrexpr.local_binder_expr list; + non_uniform_parameters : Constrexpr.local_binder_expr list option; arity : Constrexpr.constr_expr option; constructors : (Names.lident * Constrexpr.constr_expr) list; } -type glob_indt_decl = { - finiteness : Vernacexpr.inductive_kind; +type glob_indt_decl_elpi = { + finiteness : Declarations.recursivity_kind; name : string list * Names.Id.t; arity : Glob_term.glob_constr; params : Glob_term.glob_decl list; nuparams : Glob_term.glob_decl list; + nuparams_given : bool; constructors : (Names.Id.t * Glob_term.glob_constr) list; } -type top_indt_decl = Geninterp.interp_sign * glob_indt_decl + let pr_raw_indt_decl _ _ _ = Pp.str "TODO: pr_raw_indt_decl" let pr_glob_indt_decl _ _ _ = Pp.str "TODO: pr_glob_indt_decl" let pr_top_indt_decl _ _ _ = Pp.str "TODO: pr_top_indt_decl" @@ -60,13 +101,15 @@ type raw_constant_decl = { name : qualified_name; typ : Constrexpr.local_binder_expr list * Constrexpr.constr_expr option; body : Constrexpr.constr_expr option; + red : Genredexpr.raw_red_expr option; } -type glob_constant_decl = { +type glob_constant_decl_elpi = { name : string list * Names.Id.t; params : Glob_term.glob_decl list; typ : Glob_term.glob_constr; body : Glob_term.glob_constr option; } +type glob_constant_decl = Genintern.glob_sign * raw_constant_decl type top_constant_decl = Geninterp.interp_sign * glob_constant_decl let pr_raw_constant_decl _ _ _ = Pp.str "TODO: pr_raw_constant_decl" @@ -75,64 +118,36 @@ let pr_top_constant_decl _ _ _ = Pp.str "TODO: pr_top_constant_decl" type raw_context_decl = Constrexpr.local_binder_expr list -type glob_context_decl = Glob_term.glob_decl list +type glob_context_decl = Genintern.glob_sign * raw_context_decl type top_context_decl = Geninterp.interp_sign * glob_context_decl let pr_raw_context_decl _ _ _ = Pp.str "TODO: pr_raw_context_decl" let pr_glob_context_decl _ _ _ = Pp.str "TODO: pr_glob_context_decl" let pr_top_context_decl _ _ _ = Pp.str "TODO: pr_top_context_decl" -type raw_ltac_arg = raw_term -type glob_ltac_arg = Glob_term.glob_constr -type top_ltac_arg = Geninterp.interp_sign * Names.Id.t - -let pr_raw_ltac_arg _ _ _ = Pp.str "TODO: pr_raw_ltac_arg" -let pr_glob_ltac_arg _ _ _ = Pp.str "TODO: pr_glob_ltac_arg" -let pr_top_ltac_arg _ _ _ = Pp.str "TODO: pr_top_ltac_arg" - - -type ltac_ty = Int | String | Term | List of ltac_ty - -type tac -type cmd - -type ('a,'b,'c,'d,'e,'f,_) arg = - | Int : int -> ('a,'b,'c,'d,'e,'f,_ ) arg - | String : string -> ('a,'b,'c,'d,'e,'f,_ ) arg - | Term : 'a -> ('a,'b,'c,'d,'e,'f,_ ) arg - | LTac : ltac_ty * 'f -> ('a,'b,'c,'d,'e,'f,tac) arg - | RecordDecl : 'b -> ('a,'b,'c,'d,'e,'f,cmd) arg - | IndtDecl : 'c -> ('a,'b,'c,'d,'e,'f,cmd) arg - | ConstantDecl : 'd -> ('a,'b,'c,'d,'e,'f,cmd) arg - | Context : 'e -> ('a,'b,'c,'d,'e,'f,cmd) arg - -type 'a raw_arg = (raw_term, raw_record_decl, raw_indt_decl, raw_constant_decl,raw_context_decl,raw_ltac_arg,'a) arg -type ('a,'b) glob_arg = ('b, glob_record_decl, glob_indt_decl, glob_constant_decl,glob_context_decl,Glob_term.glob_constr,'a) arg -type top_arg = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl, top_ltac_arg,cmd) arg -type top_tac_arg = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl, top_ltac_arg,tac) arg - - let pr_arg f g h i j x = match x with - | Int n -> Pp.int n - | String s -> Pp.qstring s - | Term s -> f s - | RecordDecl s -> g s - | IndtDecl s -> h s - | ConstantDecl s -> i s - | Context c -> j c - -let pr_tac_arg f k x = match x with - | Int n -> Pp.int n - | String s -> Pp.qstring s - | Term s -> f s - | LTac(_, s) -> k s - -let pr_glob_constr_and_expr env sigma = function - | (_, Some c) -> - Ppconstr.pr_constr_expr env sigma c - | (c, None) -> - Printer.pr_glob_constr_env env sigma c - -let pp_raw_arg env sigma = +type ('a,'b,'c,'d,'e) t = + | Int : int -> ('a,'b,'c,'d,'e) t + | String : string -> ('a,'b,'c,'d,'e) t + | Term : 'a -> ('a,'b,'c,'d,'e) t + | RecordDecl : 'b -> ('a,'b,'c,'d,'e) t + | IndtDecl : 'c -> ('a,'b,'c,'d,'e) t + | ConstantDecl : 'd -> ('a,'b,'c,'d,'e) t + | Context : 'e -> ('a,'b,'c,'d,'e) t + +type raw = (raw_term, raw_record_decl, raw_indt_decl, raw_constant_decl, raw_context_decl) t +type glob = (glob_term, glob_record_decl, glob_indt_decl, glob_constant_decl, glob_context_decl) t +type top = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl) t + +let pr_arg f g h i j x = match x with +| Int n -> Pp.int n +| String s -> Pp.qstring s +| Term s -> f s +| RecordDecl s -> g s +| IndtDecl s -> h s +| ConstantDecl s -> i s +| Context c -> j c + +let pp_raw env sigma : raw -> Pp.t = pr_arg (Ppconstr.pr_constr_expr env sigma) (pr_raw_record_decl env sigma) @@ -140,78 +155,75 @@ let pp_raw_arg env sigma = (pr_raw_constant_decl env sigma) (pr_raw_context_decl env sigma) -let pp_raw_tac_arg env sigma = - pr_tac_arg - (Ppconstr.pr_constr_expr env sigma) - (pr_raw_ltac_arg env sigma) - -let pp_glob_arg env sigma = +let pr_glob_constr_and_expr env sigma = function + | (_, Some c) -> + Ppconstr.pr_constr_expr env sigma c + | (c, None) -> + Printer.pr_glob_constr_env env sigma c + +let pp_glob env sigma : glob -> Pp.t = pr_arg (pr_glob_constr_and_expr env sigma) (pr_glob_record_decl env sigma) (pr_glob_indt_decl env sigma) (pr_glob_constant_decl env sigma) (pr_glob_context_decl env sigma) - -let pp_glob_tac_arg env sigma = - pr_tac_arg - (pr_glob_constr_and_expr env sigma) - (pr_glob_ltac_arg env sigma) -let pp_top_arg env sigma = +let pp_top env sigma : top -> Pp.t = pr_arg (fun (_,x) -> pr_glob_constr_and_expr env sigma x) (pr_top_record_decl env sigma) (pr_top_indt_decl env sigma) (pr_top_constant_decl env sigma) (pr_top_context_decl env sigma) - -let pp_top_tac_arg env sigma = - pr_tac_arg - (fun (_,x) -> pr_glob_constr_and_expr env sigma x) - (pr_top_ltac_arg env sigma) - -let push_name x = function - | Names.Name.Name id -> - let decl = Context.Named.Declaration.LocalAssum (Context.make_annot id Sorts.Relevant, Constr.mkProp) in - { x with Genintern.genv = Environ.push_named decl x.Genintern.genv } - | _ -> x - -let push_gdecl (name,_,_,_) x = push_name x name - -let push_glob_ctx glob_ctx x = - List.fold_right push_gdecl glob_ctx x - - -let push_inductive_in_intern_env intern_env name params arity user_impls = - let env = Global.env () in - let sigma = Evd.from_env env in - let sigma, ty = Pretyping.understand_tcc env sigma ~expected_type:Pretyping.IsType (Coq_elpi_utils.mk_gforall arity params) in - Constrintern.compute_internalization_env env sigma ~impls:intern_env - Constrintern.Inductive [name] [ty] [user_impls] - -let intern_tactic_constr = Ltac_plugin.Tacintern.intern_constr - -let intern_global_constr { Ltac_plugin.Tacintern.genv = env } ~intern_env t = - let sigma = Evd.from_env env in - Constrintern.intern_gen Pretyping.WithoutTypeConstraint env sigma ~impls:intern_env ~pattern_mode:false ~ltacvars:Constrintern.empty_ltac_sign t - -let intern_global_constr_ty { Ltac_plugin.Tacintern.genv = env } ~intern_env t = - let sigma = Evd.from_env env in - Constrintern.intern_gen Pretyping.IsType env sigma ~impls:intern_env ~pattern_mode:false ~ltacvars:Constrintern.empty_ltac_sign t - -let intern_global_context { Ltac_plugin.Tacintern.genv = env } ~intern_env ctx = - Constrintern.intern_context env ~bound_univs:UnivNames.empty_binders intern_env ctx - -let subst_global_constr s t = Detyping.subst_glob_constr (Global.env()) s t -let subst_global_decl s (n,bk,ot,t) = - (n,bk,Option.map (subst_global_constr s) ot,subst_global_constr s t) - + let sep_last_qualid = function | [] -> "_", [] | l -> CList.sep_last l -let intern_record_decl glob_sign { name; sort; parameters; constructor; fields } = + let of_coq_inductive_definition id = + let open Vernacentries.Preprocessed_Mind_decl in + let { flags; typing_flags; private_ind; uniform; inductives } = id in + if List.length inductives != 1 then nYI "mutual inductives"; + let inductive = List.hd inductives in + let (((name),(parameters,non_uniform_parameters),arity,constructors),notations) = inductive in + if notations != [] then CErrors.user_err Pp.(str "notations not supported"); + let name = [Names.Id.to_string name.CAst.v] in + let constructors = + List.map (fun (coercion,c) -> + if coercion then CErrors.user_err Pp.(str "coercion flag not supported"); + c) constructors in + { + finiteness = flags.finite; + name; + parameters; + non_uniform_parameters; + arity; + constructors; + } + let of_coq_record_definition id = + let open Vernacentries.Preprocessed_Mind_decl in + let { flags; primitive_proj; kind; records; } : record = id in + if List.length records != 1 then nYI "mutual inductives"; + let open Record.Ast in + let { name; is_coercion; binders : Constrexpr.local_binder_expr list; cfs; idbuild; sort; default_inhabitant_id : Names.Id.t option; } = List.hd records in + if is_coercion then CErrors.user_err Pp.(str "coercion flag not supported"); + let name = [Names.Id.to_string name.CAst.v] in + let sort = sort |> Option.map (fun sort -> + match sort.CAst.v with + | Constrexpr.CSort s -> s + | _ -> CErrors.user_err ?loc:sort.CAst.loc Pp.(str "only explicits sorts are supported")) in + { + name; + parameters = binders; + sort; + constructor = Some idbuild; + fields = cfs + } + +let intern_record_decl glob_sign (it : raw_record_decl) = glob_sign, it + +let raw_record_decl_to_glob glob_sign ({ name; sort; parameters; constructor; fields } : raw_record_decl_elpi) : glob_record_decl_elpi = let name, space = sep_last_qualid name in let sort = match sort with | Some x -> Constrexpr.CSort x @@ -237,23 +249,24 @@ let intern_record_decl glob_sign { name; sort; parameters; constructor; fields } (glob_sign_params,intern_env,[]) fields in { name = (space, Names.Id.of_string name); arity; params; constructorname = constructor; fields = List.rev fields } -let subst_record_decl s { name; arity; params; constructorname; fields } = - let arity = subst_global_constr s arity in - let fields = List.map (fun (t,att) -> subst_global_constr s t,att) fields in - { name; arity; params; constructorname; fields } - -let intern_indt_decl glob_sign { finiteness; name; parameters; non_uniform_parameters; arity; constructors } = +let raw_indt_decl_to_glob glob_sign ({ finiteness; name; parameters; non_uniform_parameters; arity; constructors } : raw_indt_decl_elpi) : glob_indt_decl_elpi = let name, space = sep_last_qualid name in let name = Names.Id.of_string name in let indexes = match arity with | Some x -> x | None -> CAst.make Constrexpr.(CSort (Glob_term.UAnonymous {rigid=true})) in let intern_env, params = intern_global_context glob_sign ~intern_env:Constrintern.empty_internalization_env parameters in - let intern_env, nuparams = intern_global_context glob_sign ~intern_env non_uniform_parameters in + let nuparams_given, nuparams = + match non_uniform_parameters with + | Some l -> true, l + | None -> false, [] in + let intern_env, nuparams = intern_global_context glob_sign ~intern_env nuparams in let params = List.rev params in let nuparams = List.rev nuparams in let allparams = params @ nuparams in - let user_impls : Impargs.manual_implicits = List.map Coq_elpi_utils.manual_implicit_of_gdecl allparams in + let user_impls : Impargs.manual_implicits = + if nuparams_given then List.map Coq_elpi_utils.manual_implicit_of_gdecl nuparams + else List.map Coq_elpi_utils.manual_implicit_of_gdecl allparams in let glob_sign_params = push_glob_ctx allparams glob_sign in let arity = intern_global_constr_ty ~intern_env glob_sign_params indexes in let glob_sign_params_self = push_name glob_sign_params (Names.Name name) in @@ -261,48 +274,54 @@ let intern_indt_decl glob_sign { finiteness; name; parameters; non_uniform_param let constructors = List.map (fun (id,ty) -> id.CAst.v, intern_global_constr_ty glob_sign_params_self ~intern_env ty) constructors in - { finiteness; name = (space, name); arity; params; nuparams; constructors } - -let subst_indt_decl s { finiteness; name; arity; params; nuparams; constructors } = - let arity = subst_global_constr s arity in - let params = List.map (subst_global_decl s) params in - let nuparams = List.map (subst_global_decl s) nuparams in - let constructors = List.map (fun (id,t) -> id, subst_global_constr s t) constructors in - { finiteness; name; arity; params; nuparams; constructors } + { finiteness; name = (space, name); arity; params; nuparams; nuparams_given; constructors } +let intern_indt_decl glob_sign (it : raw_indt_decl) = glob_sign, it let expr_hole = CAst.make @@ Constrexpr.CHole(None,Namegen.IntroAnonymous,None) -let intern_context_decl glob_sign fields = +let raw_context_decl_to_glob glob_sign fields = let _intern_env, fields = intern_global_context ~intern_env:Constrintern.empty_internalization_env glob_sign fields in List.rev fields +let intern_context_decl glob_sign (it : raw_context_decl) = glob_sign, it -let subst_context_decl s l = - let subst = subst_global_constr s in - l |> List.map (fun (name,bk,bo,ty) -> name, bk, Option.map subst bo, subst ty) - -let intern_constant_decl glob_sign ({ name; typ = (params,typ); body } : raw_constant_decl) = +let raw_decl_name_to_glob name = let name, space = sep_last_qualid name in + (space, Names.Id.of_string name) + +let raw_constant_decl_to_constr ~depth coq_ctx state { name; typ = (bl,typ); body; red } = + let env = coq_ctx.env in + let sigma = get_sigma state in + match body, typ with + | Some body, _ -> + let sigma, red = option_map_acc (Ltac_plugin.Tacinterp.interp_redexp env) sigma red in + let sigma, (body, typ), impargs = + ComDefinition.interp_definition ~program_mode:false + env sigma Constrintern.empty_internalization_env bl red body typ + in + let state, gls0 = set_current_sigma ~depth state sigma in + let typ = option_default (fun () -> Retyping.get_type_of env sigma body) typ in + state, typ, Some body, gls0 + | None, Some typ -> + assert(red = None); + let sigma, typ, impargs = + ComAssumption.interp_assumption ~program_mode:false + env sigma Constrintern.empty_internalization_env bl typ in + let state, gls0 = set_current_sigma ~depth state sigma in + state, typ, None, gls0 + | _ -> assert false + + +let raw_constant_decl_to_glob glob_sign ({ name; typ = (params,typ); body } : raw_constant_decl) = let intern_env, params = intern_global_context glob_sign ~intern_env:Constrintern.empty_internalization_env params in let glob_sign_params = push_glob_ctx params glob_sign in let params = List.rev params in let typ = Option.default expr_hole typ in let typ = intern_global_constr_ty ~intern_env glob_sign_params typ in let body = Option.map (intern_global_constr ~intern_env glob_sign_params) body in - { name = (space, Names.Id.of_string name); params; typ; body } - -let subst_constant_decl s { name; params; typ; body } = - let typ = subst_global_constr s typ in - let params = List.map (subst_global_decl s) params in - let body = Option.map (subst_global_constr s) body in - { name; params; typ; body } + { name = raw_decl_name_to_glob name; params; typ; body } +let intern_constant_decl glob_sign (it : raw_constant_decl) = glob_sign, it -let glob_tac_arg glob_sign = function - | Int _ as x -> glob_sign, x - | String _ as x -> glob_sign, x - | Term t -> glob_sign, Term (intern_tactic_constr glob_sign t) - | LTac(ty,t) -> glob_sign, LTac (ty,fst @@ intern_tactic_constr glob_sign t) - -let glob_arg glob_sign = function +let glob glob_sign : raw -> glob = function | Int _ as x -> x | String _ as x -> x | Term t -> Term (intern_tactic_constr glob_sign t) @@ -311,36 +330,10 @@ let glob_arg glob_sign = function | ConstantDecl t -> ConstantDecl (intern_constant_decl glob_sign t) | Context c -> Context (intern_context_decl glob_sign c) -let subst_arg mod_subst = function - | Int _ as x -> x - | String _ as x -> x - | Term t -> - Term (Ltac_plugin.Tacsubst.subst_glob_constr_and_expr mod_subst t) - | RecordDecl t -> - RecordDecl (subst_record_decl mod_subst t) - | IndtDecl t -> - IndtDecl (subst_indt_decl mod_subst t) - | ConstantDecl t -> - ConstantDecl (subst_constant_decl mod_subst t) - | Context t -> - Context (subst_context_decl mod_subst t) - -let subst_tac_arg mod_subst = function - | Int _ as x -> x - | String _ as x -> x - | Term t -> - Term (Ltac_plugin.Tacsubst.subst_glob_constr_and_expr mod_subst t) - | LTac(ty,t) -> - LTac(ty,(Detyping.subst_glob_constr (Global.env()) mod_subst t)) -let subst_tac_arg_glob mod_subst = function - | Int _ as x -> x - | String _ as x -> x - | Term t -> - Term (Detyping.subst_glob_constr (Global.env()) mod_subst t) - | LTac(ty,t) -> - LTac(ty,(Detyping.subst_glob_constr (Global.env()) mod_subst t)) - -let interp_arg ist env evd = function +let subst _mod_subst _x = + CErrors.anomaly Pp.(str "command arguments should not be substituted") + +let interp ist env evd : glob -> top = function | Int _ as x -> x | String _ as x -> x | Term t -> Term(ist,t) @@ -349,16 +342,88 @@ let interp_arg ist env evd = function | ConstantDecl t -> (ConstantDecl(ist,t)) | Context c -> (Context(ist,c)) -let interp_tac_arg return ist = function -| Int _ as x -> return x -| String _ as x -> return x -| Term t -> return @@ Term(ist,t) -| LTac(ty,v) -> - let id = - match DAst.get v with - | Glob_term.GVar id -> id - | _ -> assert false in - return @@ LTac(ty,(ist,id)) +end + +module Tac = struct + +type raw_term = Constrexpr.constr_expr +type glob_term = Genintern.glob_constr_and_expr +type top_term = Geninterp.interp_sign * Genintern.glob_constr_and_expr + +type raw_ltac_term = Constrexpr.constr_expr +type glob_ltac_term = Glob_term.glob_constr +type top_ltac_term = Geninterp.interp_sign * Names.Id.t + +type ltac_ty = Int | String | Term | List of ltac_ty + +type ('a,'f) t = + | Int : int -> ('a,'f) t + | String : string -> ('a,'f) t + | Term : 'a -> ('a,'f) t + | LTac : ltac_ty * 'f -> ('a,'f) t + +type raw = (raw_term, raw_ltac_term) t +type glob = (glob_term, glob_ltac_term) t +type top = (top_term, top_ltac_term) t + +let pr_raw_ltac_arg _ _ _ = Pp.str "TODO: pr_raw_ltac_arg" +let pr_glob_ltac_arg _ _ _ = Pp.str "TODO: pr_glob_ltac_arg" +let pr_top_ltac_arg _ _ _ = Pp.str "TODO: pr_top_ltac_arg" + +let pr_arg f k x = match x with + | Int n -> Pp.int n + | String s -> Pp.qstring s + | Term s -> f s + | LTac(_, s) -> k s + +let pr_glob_constr_and_expr env sigma = function + | (_, Some c) -> + Ppconstr.pr_constr_expr env sigma c + | (c, None) -> + Printer.pr_glob_constr_env env sigma c + +let _pr_glob_constr = Printer.pr_glob_constr_env + +let pp_raw env sigma : raw -> Pp.t = + pr_arg + (Ppconstr.pr_constr_expr env sigma) + (pr_raw_ltac_arg env sigma) + +let pp_glob env sigma = + pr_arg + (pr_glob_constr_and_expr env sigma) + (pr_glob_ltac_arg env sigma) + +let pp_top env sigma : top -> Pp.t = + pr_arg + ((fun (_,x) -> pr_glob_constr_and_expr env sigma x)) + (pr_top_ltac_arg env sigma) + +let glob glob_sign : raw -> _ * glob = function + | Int _ as x -> glob_sign, x + | String _ as x -> glob_sign, x + | Term t -> glob_sign, Term (intern_tactic_constr glob_sign t) + | LTac(ty,t) -> glob_sign, LTac (ty,fst @@ intern_tactic_constr glob_sign t) + +let subst mod_subst = function + | Int _ as x -> x + | String _ as x -> x + | Term t -> + Term (Ltac_plugin.Tacsubst.subst_glob_constr_and_expr mod_subst t) + | LTac(ty,t) -> + LTac(ty,(Detyping.subst_glob_constr (Global.env()) mod_subst t)) + +let interp return ist = function + | Int _ as x -> return x + | String _ as x -> return x + | Term t -> return @@ Term(ist,t) + | LTac(ty,v) -> + let id = + match DAst.get v with + | Glob_term.GVar id -> id + | _ -> assert false in + return @@ LTac(ty,(ist,id)) + let add_genarg tag pr_raw pr_glob pr_top glob subst interp = let wit = Genarg.make0 tag in @@ -371,22 +436,25 @@ let add_genarg tag pr_raw pr_glob pr_top glob subst interp = wit ;; -let wit_elpi_ftactic_arg = add_genarg "elpi_ftactic_arg" - (fun env sigma _ _ _ -> pp_raw_tac_arg env sigma) - (fun env sigma _ _ _ -> pp_glob_tac_arg env sigma) - (fun env sigma _ _ _ -> pp_top_tac_arg env sigma) - glob_tac_arg - subst_tac_arg - interp_tac_arg +let wit = add_genarg "elpi_ftactic_arg" + (fun env sigma _ _ _ -> pp_raw env sigma) + (fun env sigma _ _ _ -> pp_glob env sigma) + (fun env sigma _ _ _ -> pp_top env sigma) + glob + subst + interp + +end -let grecord2lp ~depth state { name; arity; params; constructorname; fields } = +let grecord2lp ~depth state { Cmd.name; arity; params; constructorname; fields } = let open Coq_elpi_glob_quotation in let state, r = do_params params (do_record ~name ~constructorname arity fields) ~depth state in state, r -let contract_params env sigma name params t = +let contract_params env sigma name params nuparams_given t = + if nuparams_given then t else let open Glob_term in let loc = Option.map Coq_elpi_utils.of_coq_loc t.CAst.loc in let rec contract params args = @@ -417,10 +485,19 @@ let contract_params env sigma name params t = | _ -> Glob_ops.map_glob_constr aux x in aux t -let ginductive2lp ~depth state { finiteness; name; arity; params; nuparams; constructors } = +let nogls f ~depth state = + let state, x = f ~depth state in + state, x, () + +let drop_unit f ~depth state = + let state, x, () = f ~depth state in + state, x + + +let ginductive2lp ~depth state { Cmd.finiteness; name; arity; params; nuparams; nuparams_given; constructors } = let open Coq_elpi_glob_quotation in let space, indt_name = name in - let contract state x = contract_params (get_global_env state) (get_sigma state) indt_name params x in + let contract state x = contract_params (get_global_env state) (get_sigma state) indt_name params nuparams_given x in let do_constructor ~depth state (name, ty) = let state, ty = do_params nuparams (do_arity (contract state ty)) ~depth state in state, in_elpi_indtdecl_constructor (Name.Name name) ty @@ -432,43 +509,58 @@ let ginductive2lp ~depth state { finiteness; name; arity; params; nuparams; cons let state, arity = do_params nuparams (do_arity arity) ~depth state in under_ctx short_name term_arity None (fun ~depth state -> let state, constructors = Coq_elpi_utils.list_map_acc (do_constructor ~depth ) state constructors in - state, in_elpi_indtdecl_inductive state finiteness (Name.Name qindt_name) arity constructors) + state, in_elpi_indtdecl_inductive state finiteness (Name.Name qindt_name) arity constructors, ()) ~depth state in - let state, r = do_params params do_inductive ~depth state in + let state, r = do_params params (drop_unit do_inductive) ~depth state in state, r -let option_map_acc f s = function - | None -> s, None - | Some x -> - let s, x = f s x in - s, Some x let in_option = Elpi.(Builtin.option API.BuiltInData.any).API.Conversion.embed -let cdecl2lp ~depth state { name; params; typ; body } = - let open Coq_elpi_glob_quotation in +let decl_name2lp name = let space, constant_name = name in let qconstant_name = Id.of_string_soft @@ String.concat "." (space @ [Id.to_string constant_name]) in + in_elpi_id (Name.Name qconstant_name) + +let cdecl2lp ~depth state { Cmd.name; params; typ; body } = + let open Coq_elpi_glob_quotation in let state, typ = do_params params (do_arity typ) ~depth state in let state, body = option_map_acc (fun state bo -> gterm2lp ~depth state @@ Coq_elpi_utils.mk_gfun bo params) state body in - state, in_elpi_id (Name.Name qconstant_name), typ, body + state, decl_name2lp name, typ, body let ctxitemc = E.Constants.declare_global_symbol "context-item" let ctxendc = E.Constants.declare_global_symbol "context-end" -let rec do_context fields ~depth state = +let rec do_context_glob fields ~depth state = match fields with | [] -> state, E.mkGlobal ctxendc | (name,bk,bo,ty) :: fields -> let open Coq_elpi_glob_quotation in let state, ty = gterm2lp ~depth state ty in let state, bo = option_map_acc (gterm2lp ~depth) state bo in - let state, fields = under_ctx name ty bo (do_context fields) ~depth state in + let state, fields, () = under_ctx name ty bo (nogls (do_context_glob fields)) ~depth state in let state, bo, _ = in_option ~depth state bo in let state, imp = in_elpi_imp ~depth state bk in state, E.mkApp ctxitemc (in_elpi_id name) [imp;ty;bo;E.mkLam fields] +let rec do_context_constr coq_ctx csts fields ~depth state = + let map s x = constr2lp coq_ctx csts ~depth s (EConstr.of_constr x) in + match fields with + | [] -> state, E.mkGlobal ctxendc, [] + | (id,bo,ty,bk) :: fields -> + let name = Name id in + let state, ty, gl0 = map state ty in + let state, bo, gl1 = match bo with + | None -> state, None, [] + | Some bo -> let state, bo, gl = map state bo in state, Some bo, gl in + (* TODO GLS *) + let state, fields, gl2 = Coq_elpi_glob_quotation.under_ctx name ty bo (do_context_constr coq_ctx csts fields) ~depth state in + let state, bo, gl3 = in_option ~depth state bo in + let state, imp = in_elpi_imp ~depth state bk in + state, E.mkApp ctxitemc (in_elpi_id name) [imp;ty;bo;E.mkLam fields], gl0 @ gl1 @ gl2 @ gl3 + + let strc = E.Constants.declare_global_symbol "str" let trmc = E.Constants.declare_global_symbol "trm" let intc = E.Constants.declare_global_symbol "int" @@ -489,33 +581,49 @@ let to_list v = | None -> raise (Taccoerce.CannotCoerceTo "a list") | Some l -> l -type 'a constr2lp = depth:int -> - ?calldepth:int -> - ([> `Options] as 'a) Coq_elpi_HOAS.coq_context -> - API.Data.constraints -> - API.Data.state -> - Evd.econstr -> - API.Data.state * API.Data.term * API.Conversion.extra_goals - -let in_elpi_common_arg_aux : - type a. - depth:int -> ?calldepth:int -> 'c coq_context -> hyp list -> Evd.evar_map -> API.State.t -> constr2lp: 'c constr2lp -> (_,_,_,_,_,_,a) arg -> API.State.t * E.term list * API.Conversion.extra_goals = fun - ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp x -> - match x with - | String x -> state, [E.mkApp strc (CD.of_string x) []], [] - | Int x -> state, [E.mkApp intc (CD.of_int x) []], [] - | Term (ist,glob_or_expr) -> - let closure = Ltac_plugin.Tacinterp.interp_glob_closure ist coq_ctx.env sigma glob_or_expr in - let g = Coq_elpi_utils.detype_closed_glob coq_ctx.env sigma closure in - let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in - let state, t = Coq_elpi_glob_quotation.gterm2lp ~depth state g in - state, [E.mkApp trmc t []], [] - | _ -> assert false +(* if we make coq elaborate an arity, we get a type back. here we try to + recoved an arity to pass that to elpi *) +let best_effort_recover_arity ~depth state typ bl = + let rec aux ~depth state typ bl = + match bl with + | Constrexpr.CLocalAssum(x :: y :: more,k,e)::bl -> + aux ~depth state typ (Constrexpr.CLocalAssum([x],k,e) :: Constrexpr.CLocalAssum(y :: more,k,e) :: bl) + | Constrexpr.CLocalAssum([CAst.{ v = name }],(Constrexpr.Default ik|Constrexpr.Generalized(ik,_)),_)::bl -> + begin match Coq_elpi_HOAS.is_prod ~depth typ with + | None -> state, in_elpi_arity typ + | Some(ty,bo) -> + let state, imp = in_elpi_imp ~depth state ik in + let state, bo = aux ~depth:(depth+1) state bo bl in + state, in_elpi_parameter name ~imp ty bo + end + | _ -> state, in_elpi_arity typ + in + aux ~depth state typ bl + +let in_elpi_string_arg ~depth state x = + state, E.mkApp strc (CD.of_string x) [], [] + +let in_elpi_int_arg ~depth state x = + state, E.mkApp intc (CD.of_int x) [], [] + +let in_elpi_term_arg ~depth state coq_ctx hyps sigma ist glob_or_expr = + let closure = Ltac_plugin.Tacinterp.interp_glob_closure ist coq_ctx.env sigma glob_or_expr in + let g = Coq_elpi_utils.detype_closed_glob coq_ctx.env sigma closure in + let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in + let state, t = Coq_elpi_glob_quotation.gterm2lp ~depth state g in + state, E.mkApp trmc t [], [] -let rec in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp ty ist v = +let in_elpi_elab_term_arg ~depth ?calldepth state coq_ctx hyps sigma ist glob_or_expr = + let sigma, t = Ltac_plugin.Tacinterp.interp_open_constr_with_classes ist coq_ctx.env sigma glob_or_expr in + let state, gls0 = set_current_sigma ~depth state sigma in + let state, t, gls1 = constr2lp_closed ~depth ?calldepth coq_ctx E.no_constraints state t in + state, E.mkApp trmc t [], gls0 @ gls1 + +let singleton (state,x,gls) = state,[x],gls +let rec in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ty ist v = let open Ltac_plugin in - let in_elpi_arg state = in_elpi_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp in - let self ty state = in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp ty ist in + let open Tac in + let self ty state = in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ty ist in let self_list ty state l = try let state, l, gl = API.Utils.map_acc (self ty) state l in @@ -530,10 +638,10 @@ let rec in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp t self_list ty state l | Int -> let n = Taccoerce.coerce_to_int v in - in_elpi_arg state (Int n) + singleton @@ in_elpi_int_arg ~depth state n | String -> let s = my_cast_to_string v in - in_elpi_arg state (String s) + singleton @@ in_elpi_string_arg ~depth state s | Term -> try let t = Taccoerce.Value.cast (Genarg.topwit Stdarg.wit_open_constr) v in let state, t, gls = constr2lp ~depth ?calldepth coq_ctx E.no_constraints state t in @@ -546,51 +654,96 @@ let rec in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp t state, [E.mkApp trmc t []], [] with Taccoerce.CannotCoerceTo _ -> try let id = Taccoerce.coerce_to_hyp coq_ctx.env sigma v in - let state, t, gls = constr2lp ~depth ?calldepth coq_ctx E.no_constraints state (EConstr.mkVar id) in + let state, t, gls = Coq_elpi_HOAS.constr2lp ~depth ?calldepth coq_ctx E.no_constraints state (EConstr.mkVar id) in state, [E.mkApp trmc t []], gls with Taccoerce.CannotCoerceTo _ -> raise (Taccoerce.CannotCoerceTo "a term") -and in_elpi_tac_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp = function +let in_elpi_tac ~depth ?calldepth coq_ctx hyps sigma state x = + let open Tac in + match x with | LTac(ty,(ist,id)) -> let v = try Id.Map.find id ist.Geninterp.lfun with Not_found -> assert false in begin try - in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp ty ist v + in_elpi_ltac_arg ~depth ?calldepth coq_ctx hyps sigma state ty ist v with Ltac_plugin.Taccoerce.CannotCoerceTo s -> let env = Some (coq_ctx.env,sigma) in Ltac_plugin.Taccoerce.error_ltac_variable id env v s end - | x -> in_elpi_common_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp x - -and in_elpi_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp = function - | RecordDecl (_ist,glob_rdecl) -> + | Int x -> singleton @@ in_elpi_int_arg ~depth state x + | String x -> singleton @@ in_elpi_string_arg ~depth state x + | Term (ist,glob_or_expr) -> singleton @@ in_elpi_term_arg ~depth state coq_ctx hyps sigma ist glob_or_expr + +let in_elpi_cmd ~depth ?calldepth coq_ctx state ~raw (x : Cmd.top) = + let open Cmd in + let hyps = [] in + match x with + | RecordDecl (_ist,(glob_sign,raw_rdecl)) when raw -> + let raw_rdecl = of_coq_record_definition raw_rdecl in + let glob_rdecl = raw_record_decl_to_glob glob_sign raw_rdecl in let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in let state, t = grecord2lp ~depth state glob_rdecl in - state, [E.mkApp ideclc t []], [] - | IndtDecl (_ist,glob_indt) -> + state, E.mkApp ideclc t [], [] + | RecordDecl (_ist,(glob_sign,raw_rdecl)) -> + let e = + let open Vernacentries.Preprocessed_Mind_decl in + let { flags = { template; poly; cumulative; udecl; finite }; primitive_proj; kind; records } = raw_rdecl in + Record.interp_structure ~template udecl kind ~cumulative ~poly ~primitive_proj finite records + in + let state, t, gls = record_entry2lp ~depth coq_ctx E.no_constraints state e in + state, E.mkApp ideclc t [], gls + | IndtDecl (_ist,(glob_sign,raw_indt)) when raw -> + let raw_indt = of_coq_inductive_definition raw_indt in + let glob_indt = raw_indt_decl_to_glob glob_sign raw_indt in let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in let state, t = ginductive2lp ~depth state glob_indt in - state, [E.mkApp ideclc t []], [] - | ConstantDecl (_ist,glob_cdecl) -> + state, E.mkApp ideclc t [], [] + | IndtDecl (_ist,(glob_sign,raw_indt)) -> + let e = + let open Vernacentries.Preprocessed_Mind_decl in + let { flags = { template; poly; cumulative; udecl; finite }; typing_flags; uniform; private_ind; inductives } = raw_indt in + match inductives with + | [mind_w_not] -> + ComInductive.interp_mutual_inductive ~env:coq_ctx.env + ~template ~cumulative ~poly ~uniform ~private_ind ?typing_flags + udecl [mind_w_not] finite + | _ -> nYI "(HOAS) mutual inductives" + in + let state, t, gls = inductive_entry2lp ~depth coq_ctx E.no_constraints state e in + state, E.mkApp ideclc t [], gls + | ConstantDecl (_ist,(glob_sign,raw_cdecl)) when raw -> + let glob_cdecl = raw_constant_decl_to_glob glob_sign raw_cdecl in let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in let state, c, typ, body = cdecl2lp ~depth state glob_cdecl in + let state, body, gls = in_option ~depth state body in + state, E.mkApp cdeclc c [body;typ], gls + | ConstantDecl (_ist,(glob_sign,({ name; typ = (bl,_) } as raw_cdecl))) -> + let state, typ, body, gls0 = + raw_constant_decl_to_constr ~depth coq_ctx state raw_cdecl in + let state, typ, gls1 = constr2lp_closed ~depth ?calldepth coq_ctx E.no_constraints state typ in + let state, body, gls2 = + option_map_acc2 (constr2lp_closed ~depth ?calldepth coq_ctx E.no_constraints) state body in + let state, typ = best_effort_recover_arity ~depth state typ bl in let state, body, _ = in_option ~depth state body in - state, [E.mkApp cdeclc c [body;typ]], [] - | Context (_ist,glob_ctx) -> + let c = decl_name2lp (raw_decl_name_to_glob name) in + state, E.mkApp cdeclc c [body;typ], gls0 @ gls1 @ gls2 + | Context (_ist,(glob_sign,raw_ctx)) when raw -> + let glob_ctx = raw_context_decl_to_glob glob_sign raw_ctx in let state = Coq_elpi_glob_quotation.set_coq_ctx_hyps state (coq_ctx,hyps) in - let state, t = do_context glob_ctx ~depth state in - state, [E.mkApp ctxc t []], [] - | x -> in_elpi_common_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp x - -let in_elpi_tac_arg ~depth ?calldepth coq_ctx hyps sigma state t = - in_elpi_tac_arg_aux ~depth ?calldepth coq_ctx hyps sigma state ~constr2lp:Coq_elpi_HOAS.constr2lp t - -let in_elpi_arg ~depth ?calldepth coq_ctx state arg = - let state, args, gls = - in_elpi_arg_aux ~depth ?calldepth coq_ctx [] (Evd.from_env coq_ctx.env) ~constr2lp:Coq_elpi_HOAS.constr2lp_closed_ground state arg in - assert(gls = []); (* only ltac args can generate evars and hence extra goals *) - match args with - | [arg] -> state, arg - | _ -> assert false (* ltac arguments are not global *) + let state, t = do_context_glob glob_ctx ~depth state in + state, E.mkApp ctxc t [], [] + | Context (_ist,(glob_sign,raw_ctx)) -> + let sigma, ctx = ComAssumption.interp_context coq_ctx.env (get_sigma state) raw_ctx in + let state, gls0 = set_current_sigma ~depth state sigma in + let state, t, gls1 = do_context_constr (upcast coq_ctx) E.no_constraints ctx ~depth state in + state, E.mkApp ctxc t [], gls0 @ gls1 + | Int x -> in_elpi_int_arg ~depth state x + | String x -> in_elpi_string_arg ~depth state x + | Term (ist,glob_or_expr) when raw -> + let sigma = get_sigma state in + in_elpi_term_arg ~depth state coq_ctx hyps sigma ist glob_or_expr + | Term (ist,glob_or_expr) -> + let sigma = get_sigma state in + in_elpi_elab_term_arg ~depth ?calldepth state coq_ctx hyps sigma ist glob_or_expr type coq_arg = Cint of int | Cstr of string | Ctrm of EConstr.t diff --git a/src/coq_elpi_arg_HOAS.mli b/src/coq_elpi_arg_HOAS.mli index 7ee927ff3..fe1dec2e2 100644 --- a/src/coq_elpi_arg_HOAS.mli +++ b/src/coq_elpi_arg_HOAS.mli @@ -5,116 +5,102 @@ open Elpi.API.RawData open Coq_elpi_utils +module Cmd : sig + type raw_term = Constrexpr.constr_expr type glob_term = Genintern.glob_constr_and_expr -type top_term = - Ltac_plugin.Tacinterp.interp_sign * Genintern.glob_constr_and_expr +type top_term = Ltac_plugin.Tacinterp.interp_sign * Genintern.glob_constr_and_expr -type raw_record_decl = { - name : qualified_name; - parameters : Constrexpr.local_binder_expr list; - sort : Constrexpr.sort_expr option; - constructor : Names.Id.t option; - fields : (Vernacexpr.local_decl_expr * Vernacexpr.record_field_attr) list -} -type glob_record_decl = { - name : string list * Names.Id.t; - constructorname : Names.Id.t option; - params : Glob_term.glob_decl list; - arity : Glob_term.glob_constr; - fields : (Glob_term.glob_constr * Coq_elpi_HOAS.record_field_spec) list -} +type raw_record_decl = Vernacentries.Preprocessed_Mind_decl.record +type glob_record_decl = Genintern.glob_sign * raw_record_decl type top_record_decl = Geninterp.interp_sign * glob_record_decl -type raw_indt_decl = { - finiteness : Vernacexpr.inductive_kind; - name : qualified_name; - parameters : Constrexpr.local_binder_expr list; - non_uniform_parameters : Constrexpr.local_binder_expr list; - arity : Constrexpr.constr_expr option; - constructors : (Names.lident * Constrexpr.constr_expr) list; -} -type glob_indt_decl = { - finiteness : Vernacexpr.inductive_kind; - name : string list * Names.Id.t; - arity : Glob_term.glob_constr; - params : Glob_term.glob_decl list; - nuparams : Glob_term.glob_decl list; - constructors : (Names.Id.t * Glob_term.glob_constr) list; -} +type raw_indt_decl = Vernacentries.Preprocessed_Mind_decl.inductive +type glob_indt_decl = Genintern.glob_sign * raw_indt_decl type top_indt_decl = Geninterp.interp_sign * glob_indt_decl type raw_constant_decl = { name : qualified_name; typ : Constrexpr.local_binder_expr list * Constrexpr.constr_expr option; body : Constrexpr.constr_expr option; + red : Genredexpr.raw_red_expr option; } val pr_raw_constant_decl : Environ.env -> Evd.evar_map -> raw_constant_decl -> Pp.t -type glob_constant_decl = { - name : string list * Names.Id.t; - params : Glob_term.glob_decl list; - typ : Glob_term.glob_constr; - body : Glob_term.glob_constr option; -} +type glob_constant_decl = Genintern.glob_sign * raw_constant_decl type top_constant_decl = Geninterp.interp_sign * glob_constant_decl type raw_context_decl = Constrexpr.local_binder_expr list -type glob_context_decl = Glob_term.glob_decl list +type glob_context_decl = Genintern.glob_sign * raw_context_decl type top_context_decl = Geninterp.interp_sign * glob_context_decl -type raw_ltac_arg = raw_term -type glob_ltac_arg = Glob_term.glob_constr -type top_ltac_arg = Geninterp.interp_sign * Names.Id.t +type ('a,'b,'c,'d,'e) t = + | Int : int -> ('a,'b,'c,'d,'e) t + | String : string -> ('a,'b,'c,'d,'e) t + | Term : 'a -> ('a,'b,'c,'d,'e) t + | RecordDecl : 'b -> ('a,'b,'c,'d,'e) t + | IndtDecl : 'c -> ('a,'b,'c,'d,'e) t + | ConstantDecl : 'd -> ('a,'b,'c,'d,'e) t + | Context : 'e -> ('a,'b,'c,'d,'e) t -type ltac_ty = Int | String | Term | List of ltac_ty +type raw = (raw_term, raw_record_decl, raw_indt_decl, raw_constant_decl, raw_context_decl) t +type glob = (glob_term, glob_record_decl, glob_indt_decl, glob_constant_decl, glob_context_decl) t +type top = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl) t + +val pp_raw : Environ.env -> Evd.evar_map -> raw -> Pp.t +val pp_glob : Environ.env -> Evd.evar_map -> glob -> Pp.t +val pp_top : Environ.env -> Evd.evar_map -> top -> Pp.t -type tac -type cmd +val glob : Genintern.glob_sign -> raw -> glob +val interp : Geninterp.interp_sign -> Environ.env -> Evd.evar_map -> glob -> top +val subst : Mod_subst.substitution -> glob -> glob + +end -type ('a,'b,'c,'d,'e,'f,_) arg = - | Int : int -> ('a,'b,'c,'d,'e,'f,_ ) arg - | String : string -> ('a,'b,'c,'d,'e,'f,_ ) arg - | Term : 'a -> ('a,'b,'c,'d,'e,'f,_ ) arg - | LTac : ltac_ty * 'f -> ('a,'b,'c,'d,'e,'f,tac) arg - | RecordDecl : 'b -> ('a,'b,'c,'d,'e,'f,cmd) arg - | IndtDecl : 'c -> ('a,'b,'c,'d,'e,'f,cmd) arg - | ConstantDecl : 'd -> ('a,'b,'c,'d,'e,'f,cmd) arg - | Context : 'e -> ('a,'b,'c,'d,'e,'f,cmd) arg +module Tac : sig -type 'a raw_arg = (raw_term, raw_record_decl, raw_indt_decl, raw_constant_decl,raw_context_decl,raw_term,'a) arg -type ('a,'b) glob_arg = ('b, glob_record_decl, glob_indt_decl, glob_constant_decl,glob_context_decl,Glob_term.glob_constr,'a) arg -type top_arg = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl, top_ltac_arg,cmd) arg -type top_tac_arg = (top_term, top_record_decl, top_indt_decl, top_constant_decl, top_context_decl, top_ltac_arg,tac) arg +type raw_term = Constrexpr.constr_expr +type glob_term = Genintern.glob_constr_and_expr +type top_term = Geninterp.interp_sign * Genintern.glob_constr_and_expr + +type raw_ltac_term = Constrexpr.constr_expr +type glob_ltac_term = Glob_term.glob_constr +type top_ltac_term = Geninterp.interp_sign * Names.Id.t + +type ltac_ty = Int | String | Term | List of ltac_ty -val pp_raw_arg : Environ.env -> Evd.evar_map -> cmd raw_arg -> Pp.t -val pp_glob_arg : Environ.env -> Evd.evar_map -> (cmd,glob_term) glob_arg -> Pp.t -val pp_top_arg : Environ.env -> Evd.evar_map -> top_arg -> Pp.t +type ('a,'f) t = + | Int : int -> ('a,'f) t + | String : string -> ('a,'f) t + | Term : 'a -> ('a,'f) t + | LTac : ltac_ty * 'f -> ('a,'f) t -val glob_arg : Genintern.glob_sign -> cmd raw_arg -> (cmd,glob_term) glob_arg -val interp_arg : Geninterp.interp_sign -> Environ.env -> Evd.evar_map -> (cmd,glob_term) glob_arg -> top_arg -val subst_arg : Mod_subst.substitution -> (cmd,glob_term) glob_arg -> (cmd,glob_term) glob_arg +type raw = (raw_term, raw_ltac_term) t +type glob = (glob_term, glob_ltac_term) t +type top = (top_term, top_ltac_term) t -val subst_tac_arg_glob : Mod_subst.substitution -> (tac,Glob_term.glob_constr) glob_arg -> (tac,Glob_term.glob_constr) glob_arg +val subst : Mod_subst.substitution -> glob -> glob +val wit : (raw, glob, top) Genarg.genarg_type -val wit_elpi_ftactic_arg : (tac raw_arg, (tac,glob_term) glob_arg, top_tac_arg) Genarg.genarg_type +end (* for tactics *) -val in_elpi_tac_arg : +val in_elpi_tac : depth:int -> ?calldepth:int -> Coq_elpi_HOAS.full Coq_elpi_HOAS.coq_context -> Coq_elpi_HOAS.hyp list -> Evd.evar_map -> Elpi.API.State.t -> - top_tac_arg -> + Tac.top -> Elpi.API.State.t * term list * Elpi.API.Conversion.extra_goals (* for commands *) -val in_elpi_arg : +val in_elpi_cmd : depth:int -> ?calldepth:int -> Coq_elpi_HOAS.empty Coq_elpi_HOAS.coq_context -> Elpi.API.State.t -> - top_arg -> - Elpi.API.State.t * term + raw:bool -> + Cmd.top -> + Elpi.API.State.t * term * Elpi.API.Conversion.extra_goals type coq_arg = Cint of int | Cstr of string | Ctrm of EConstr.t diff --git a/src/coq_elpi_arg_syntax.mlg b/src/coq_elpi_arg_syntax.mlg index dda37aa4f..ccd510daf 100644 --- a/src/coq_elpi_arg_syntax.mlg +++ b/src/coq_elpi_arg_syntax.mlg @@ -2,7 +2,7 @@ (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) -DECLARE PLUGIN "elpi_plugin" +DECLARE PLUGIN "coq-elpi.elpi" { @@ -142,46 +142,25 @@ let any_kwd strm = | _ -> raise Stream.Failure let any_kwd = Pcoq.Entry.(of_parser "any_symbols_or_kwd" { parser_fun = any_kwd }) -let of_coq_inductive_definition id = - let (((coercion,name),(parameters,non_uniform_parameters),arity,constructors),notations) = id in - if coercion then CErrors.user_err Pp.(str "coercion flag not supported"); - if notations != [] then CErrors.user_err Pp.(str "notations not supported"); - let name = - if Option.has_some (snd name) then CErrors.user_err ?loc:(fst name).CAst.loc Pp.(str "universe binders not supported"); - [Names.Id.to_string (fst name).CAst.v] in - let non_uniform_parameters = Option.default [] non_uniform_parameters in - let constructors = - match constructors with - | Vernacexpr.Constructors constructors -> - List.map (fun (coercion,c) -> - if coercion then CErrors.user_err Pp.(str "coercion flag not supported"); - c) constructors - | Vernacexpr.RecordDecl _ -> CErrors.user_err Pp.(str "in order to declare a record use Record, Class or Structures") in - name, parameters, non_uniform_parameters, arity, constructors - -let of_coq_record_definition id = - let (((coercion,name),(parameters,non_uniform_parameters),sort,constructors),notations) = id in - if coercion then CErrors.user_err Pp.(str "coercion flag not supported"); - if notations != [] then CErrors.user_err Pp.(str "notations not supported"); - let name = - if Option.has_some (snd name) then CErrors.user_err ?loc:(fst name).CAst.loc Pp.(str "universe binders not supported"); - [Names.Id.to_string (fst name).CAst.v] in - if Option.has_some non_uniform_parameters then CErrors.user_err Pp.(str "non-uniform parameters are not supported in record declarations"); - let sort = sort |> Option.map (fun sort -> - match sort.CAst.v with - | Constrexpr.CSort s -> s - | _ -> CErrors.user_err ?loc:sort.CAst.loc Pp.(str "only explicits sorts are supported")) in - let constructor, fields = - match constructors with - | Vernacexpr.Constructors _ -> CErrors.user_err Pp.(str "in order to declare an inductive type use Inductive, CoInductive or Variant") - | Vernacexpr.RecordDecl (constructor, fields) -> - constructor |> Option.map (fun x -> x.CAst.v), fields in - name, sort, parameters, constructor, fields - let pr_attributes _ _ _ atts = Pp.(prlist_with_sep (fun () -> str ",") Attributes.pr_vernac_flag atts) -let wit_elpi_ftactic_arg = EA.wit_elpi_ftactic_arg +let wit_elpi_ftactic_arg = EA.Tac.wit + +let def_body = G_vernac.def_body + +let of_coq_inductive_declaration ~atts kind id = + let open Vernacentries in let open Preprocessed_Mind_decl in + match preprocess_inductive_decl ~atts kind [id] with + | Inductive i -> i + | Record _ -> assert false + +let of_coq_record_declaration ~atts kind id = + let open Vernacentries in let open Preprocessed_Mind_decl in + match preprocess_inductive_decl ~atts kind [id] with + | Inductive _ -> assert false + | Record r -> r + } @@ -201,63 +180,6 @@ GRAMMAR EXTEND Gram [ [ any_kwd -> { !the_kwd }] ]; END -ARGUMENT EXTEND elpi_arg -PRINTED BY { fun _ _ _ -> EA.pp_top_arg env sigma } -INTERPRETED BY { EA.interp_arg } -GLOBALIZED BY { EA.glob_arg } -SUBSTITUTED BY { EA.subst_arg } -RAW_PRINTED BY { fun _ _ _ -> EA.pp_raw_arg env sigma } -GLOB_PRINTED BY { fun _ _ _ -> EA.pp_glob_arg env sigma } -| [ qualified_name(s) ] -> { EA.String (String.concat "." (snd s)) } -| [ integer(n) ] -> { EA.Int n } -| [ string(s) ] -> { EA.String s } - -| [ "Inductive" inductive_definition(id) ] -> { - let name, parameters, non_uniform_parameters, arity, constructors = of_coq_inductive_definition id in - EA.IndtDecl { EA.finiteness = Vernacexpr.Inductive_kw; name = name; arity = arity; parameters = parameters; non_uniform_parameters = non_uniform_parameters; constructors = constructors } } -| [ "CoInductive" inductive_definition(id) ] -> { - let name, parameters, non_uniform_parameters, arity, constructors = of_coq_inductive_definition id in - EA.IndtDecl { EA.finiteness = Vernacexpr.CoInductive; name = name; arity = arity; parameters = parameters; non_uniform_parameters = non_uniform_parameters; constructors = constructors } } -| [ "Variant" inductive_definition(id) ] -> { - let name, parameters, non_uniform_parameters, arity, constructors = of_coq_inductive_definition id in - EA.IndtDecl { EA.finiteness = Vernacexpr.Variant; name = name; arity = arity; parameters = parameters; non_uniform_parameters = non_uniform_parameters; constructors = constructors } } - -| [ "Record" inductive_definition(id) ] -> { - let name, sort, parameters, constructor, fields = of_coq_record_definition id in - EA.RecordDecl { EA.name = name; sort = sort; parameters = parameters; constructor = constructor; fields = fields } } -| [ "Class" inductive_definition(id) ] -> { - let name, sort, parameters, constructor, fields = of_coq_record_definition id in - EA.RecordDecl { EA.name = name; sort = sort; parameters = parameters; constructor = constructor; fields = fields } } -| [ "Structure" inductive_definition(id) ] -> { - let name, sort, parameters, constructor, fields = of_coq_record_definition id in - EA.RecordDecl { EA.name = name; sort = sort; parameters = parameters; constructor = constructor; fields = fields } } - -| [ "Definition" qualified_name(name) telescope(typ) colon_constr_opt(t) ":=" lconstr(b) ] -> { - EA.ConstantDecl { EA.name = snd name; typ = (typ,t); body = Some b } } -| [ "Axiom" qualified_name(name) telescope(typ) colon_constr(t) ] -> { - EA.ConstantDecl { EA.name = snd name; typ = (typ,Some t); body = None } } -| [ "Context" telescope(ty) ] -> { EA.Context ty } - -| [ "(" lconstr(t) ")" ] -> { EA.Term t } - -| [ coq_kwd_or_symbol(x) ] -> { EA.String x } -END - - -ARGUMENT EXTEND elpi_tactic_arg -TYPED AS elpi_ftactic_arg -| [ qualified_name(s) ] -> { EA.String (String.concat "." (snd s)) } -| [ integer(n) ] -> { EA.Int n } -| [ string(s) ] -> { EA.String s } -| [ "(" lconstr(t) ")" ] -> { EA.Term t } -| [ "ltac_string" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.String, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } -| [ "ltac_string_list" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.List EA.String, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } -| [ "ltac_int" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.Int, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } -| [ "ltac_int_list" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.List EA.Int, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } -| [ "ltac_term" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.Term, CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None)) } -| [ "ltac_term_list" ":" "(" ident(t) ")" ] -> { EA.LTac(EA.List EA.Term,(CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } -END - ARGUMENT EXTEND attributes PRINTED BY { pr_attributes } END @@ -284,6 +206,68 @@ GRAMMAR EXTEND Gram GLOBAL: attributes; END +ARGUMENT EXTEND elpi_cmd_arg +PRINTED BY { fun _ _ _ -> EA.Cmd.pp_top env sigma } +INTERPRETED BY { EA.Cmd.interp } +GLOBALIZED BY { EA.Cmd.glob } +SUBSTITUTED BY { EA.Cmd.subst } +RAW_PRINTED BY { fun _ _ _ -> EA.Cmd.pp_raw env sigma } +GLOB_PRINTED BY { fun _ _ _ -> EA.Cmd.pp_glob env sigma } +| [ qualified_name(s) ] -> { EA.Cmd.String (String.concat "." (snd s)) } +| [ integer(n) ] -> { EA.Cmd.Int n } +| [ string(s) ] -> { EA.Cmd.String s } + +| [ "Inductive" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts:[] Vernacexpr.Inductive_kw id) } +| [ "#[" attributes(atts) "]" "Inductive" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts Vernacexpr.Inductive_kw id) } + +| [ "CoInductive" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts:[] Vernacexpr.CoInductive id) } +| [ "#[" attributes(atts) "]" "CoInductive" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts Vernacexpr.CoInductive id) } + +| [ "Variant" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts:[] Vernacexpr.Variant id) } +| [ "#[" attributes(atts) "]" "Variant" inductive_or_record_definition(id) ] -> { EA.Cmd.IndtDecl (of_coq_inductive_declaration ~atts Vernacexpr.Variant id) } + +| [ "Record" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts:[] Vernacexpr.Record id) } +| [ "#[" attributes(atts) "]" "Record" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts Vernacexpr.Record id) } + +| [ "Class" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts:[] Vernacexpr.(Class true) id) } +| [ "#[" attributes(atts) "]" "Class" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts Vernacexpr.(Class true) id) } + +| [ "Structure" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts:[] Vernacexpr.Structure id) } +| [ "#[" attributes(atts) "]" "Structure" inductive_or_record_definition(id) ] -> { EA.Cmd.RecordDecl (of_coq_record_declaration ~atts Vernacexpr.Structure id) } + +(* TODO attributes *) +| [ "Definition" qualified_name(name) def_body(def) ] -> { + match def with + | Vernacexpr.DefineBody(bl,red,c,ty) -> + EA.Cmd.(ConstantDecl { name = snd name; typ = (bl,ty); red; body = Some c }) + | Vernacexpr.ProveBody _ -> + CErrors.user_err ~loc Pp.(str"syntax error: missing Definition body") } +| [ "Axiom" qualified_name(name) telescope(typ) colon_constr(t) ] -> { + EA.Cmd.(ConstantDecl { name = snd name; typ = (typ,Some t); red = None; body = None }) } + + +| [ "Context" telescope(ty) ] -> { EA.Cmd.Context ty } + +| [ "(" lconstr(t) ")" ] -> { EA.Cmd.Term t } + +| [ coq_kwd_or_symbol(x) ] -> { EA.Cmd.String x } +END + + +ARGUMENT EXTEND elpi_tactic_arg +TYPED AS elpi_ftactic_arg +| [ qualified_name(s) ] -> { EA.Tac.String (String.concat "." (snd s)) } +| [ integer(n) ] -> { EA.Tac.Int n } +| [ string(s) ] -> { EA.Tac.String s } +| [ "(" lconstr(t) ")" ] -> { EA.Tac.Term t } +| [ "ltac_string" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.String, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } +| [ "ltac_string_list" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.List EA.Tac.String, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } +| [ "ltac_int" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.Int, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } +| [ "ltac_int_list" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.List EA.Tac.Int, (CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } +| [ "ltac_term" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.Term, CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None)) } +| [ "ltac_term_list" ":" "(" ident(t) ")" ] -> { EA.Tac.LTac(EA.Tac.List EA.Tac.Term,(CAst.make ~loc @@ Constrexpr.CRef (Libnames.qualid_of_string ~loc @@ Names.Id.to_string t,None))) } +END + ARGUMENT EXTEND ltac_attributes PRINTED BY { pr_attributes } INTERPRETED BY { fun ist env evd x -> match DAst.get x with diff --git a/src/coq_elpi_builtins.ml b/src/coq_elpi_builtins.ml index 175b51143..7159b38e6 100644 --- a/src/coq_elpi_builtins.ml +++ b/src/coq_elpi_builtins.ml @@ -42,7 +42,7 @@ let with_pp_options o f = let print_coercions = !Constrextern.print_coercions in let print_parentheses = !Constrextern.print_parentheses in let print_projections = !Constrextern.print_projections in - let print_evar_arguments = !Constrextern.print_evar_arguments in + let print_evar_arguments = !Detyping.print_evar_arguments in let f = match o with | All -> @@ -57,7 +57,7 @@ let with_pp_options o f = Constrextern.print_coercions := true; Constrextern.print_parentheses := true; Constrextern.print_projections := false; - Constrextern.print_evar_arguments := false; + Detyping.print_evar_arguments := false; Constrextern.with_meta_as_hole f | Normal -> (* If no preference is given, we print using Coq's current value *) @@ -73,7 +73,7 @@ let with_pp_options o f = Constrextern.print_coercions := print_coercions; Constrextern.print_parentheses := print_parentheses; Constrextern.print_projections := print_projections; - Constrextern.print_evar_arguments := print_evar_arguments; + Detyping.print_evar_arguments := print_evar_arguments; rc with reraise -> Flags.raw_print := raw_print; @@ -84,7 +84,7 @@ let with_pp_options o f = Constrextern.print_coercions := print_coercions; Constrextern.print_parentheses := print_parentheses; Constrextern.print_projections := print_projections; - Constrextern.print_evar_arguments := print_evar_arguments; + Detyping.print_evar_arguments := print_evar_arguments; raise reraise let pr_econstr_env options env sigma t = @@ -113,7 +113,9 @@ let on_global_state_does_rewind_env api thunk = (); (fun state -> let warn_if_contains_univ_levels ~depth t = let global_univs = UGraph.domain (Environ.universes (Global.env ())) in - let is_global u = + let is_global u = match u with + | Sorts.Set | Sorts.SProp | Sorts.Prop -> true + | Sorts.Type u -> match Univ.Universe.level u with | None -> true | Some l -> Univ.Level.Set.mem l global_univs in @@ -125,7 +127,7 @@ let warn_if_contains_univ_levels ~depth t = let univs = aux ~depth [] t in if univs <> [] then err Pp.(strbrk "The hypothetical clause contains terms of type univ which are not global, you should abstract them out or replace them by global ones: " ++ - prlist_with_sep spc Univ.Universe.pr univs) + prlist_with_sep spc Sorts.debug_print univs) ;; let bool = B.bool @@ -146,9 +148,9 @@ let add_universe_constraint state c = let open UnivProblem in try add_constraints state (Set.singleton c) with - | Univ.UniverseInconsistency p -> + | UGraph.UniverseInconsistency p -> Feedback.msg_debug - (Univ.explain_universe_inconsistency + (UGraph.explain_universe_inconsistency UnivNames.(pr_with_global_universes empty_binders) p); raise Pred.No_clause | Evd.UniversesDiffer | UState.UniversesDiffer -> @@ -157,15 +159,16 @@ let add_universe_constraint state c = let mk_fresh_univ state = new_univ state -let mk_algebraic_super x = Univ.super x -let mk_algebraic_max x y = Univ.Universe.sup x y +let mk_algebraic_super x = Sorts.super x (* I don't want the user to even know that algebraic universes exist *) -let purge_1_algebraic_universe state u = - if Univ.Universe.is_level u then state, u +let purge_1_algebraic_universe state s = match s with +| Sorts.Set | Sorts.Prop | Sorts.SProp -> state, s +| Sorts.Type u -> + if Univ.Universe.is_level u then state, s else let state, v = mk_fresh_univ state in - add_universe_constraint state (constraint_leq u v), v + add_universe_constraint state (constraint_leq s v), v let purge_algebraic_univs state t = let sigma = get_sigma state in @@ -175,10 +178,10 @@ let purge_algebraic_univs state t = match EConstr.kind sigma t with | Constr.Sort s -> begin match EConstr.ESorts.kind sigma s with - | Sorts.Type u -> + | Sorts.Type _ as u -> let new_state, v = purge_1_algebraic_universe !state u in state := new_state; - EConstr.mkType v + EConstr.mkSort v | _ -> EConstr.map sigma aux t end | _ -> EConstr.map sigma aux t in @@ -186,17 +189,20 @@ let purge_algebraic_univs state t = !state, t let univ_super state u v = - let state, u = - if Univ.Universe.is_level u then state, u + let state, u = match u with + | Sorts.Set | Sorts.Prop | Sorts.SProp -> state, u + | Sorts.Type ul -> + if Univ.Universe.is_level ul then state, u else let state, w = mk_fresh_univ state in add_universe_constraint state (constraint_leq u w), w in add_universe_constraint state (constraint_leq (mk_algebraic_super u) v) -let univ_max state u1 u2 = +let univ_product state s1 s2 = + let s = Typeops.sort_of_product (get_global_env state) s1 s2 in let state, v = mk_fresh_univ state in let state = - add_universe_constraint state (constraint_leq (mk_algebraic_max u1 u2) v) in + add_universe_constraint state (constraint_leq s v) in state, v let constr2lp ~depth hyps constraints state t = @@ -354,7 +360,7 @@ type located = | LocGref of Names.GlobRef.t | LocModule of Names.ModPath.t | LocModuleType of Names.ModPath.t - | LocAbbreviation of Globnames.syndef_name + | LocAbbreviation of Globnames.abbreviation let located = let open Conv in let open API.AlgebraicData in declare { ty = TyName "located"; @@ -436,7 +442,7 @@ let cs_pattern = | Sort_cs Sorts.InProp -> ok Sorts.prop state | Sort_cs Sorts.InType -> let state, u = mk_fresh_univ state in - ok (Sorts.sort_of_univ u) state + ok u state | _ -> ko state)) ] } |> CConv.(!<) @@ -848,7 +854,7 @@ let add_axiom_or_variable api id sigma ty local inline = type tac_abbrev = { abbrev_name : qualified_name; tac_name : qualified_name; - tac_fixed_args : (Coq_elpi_arg_HOAS.tac, Glob_term.glob_constr) Coq_elpi_arg_HOAS.glob_arg list; + tac_fixed_args : Coq_elpi_arg_HOAS.Tac.glob list; } @@ -859,30 +865,30 @@ let rec gbpmp = fun f -> function Pcoq.Rule.next r (Pcoq.Symbol.token (Tok.PFIELD (Some x))), (fun a _ -> f a) | [] -> assert false -let cache_abbrev_for_tac (_, { abbrev_name; tac_name = tacname; tac_fixed_args = more_args }) = +let cache_abbrev_for_tac { abbrev_name; tac_name = tacname; tac_fixed_args = more_args } = let action args loc = let open Ltac_plugin in let tac = let open Tacexpr in let elpi_tac = { - mltac_plugin = "elpi_plugin"; + mltac_plugin = "coq-elpi.elpi"; mltac_tactic = "elpi_tac"; } in let elpi_tac_entry = { mltac_name = elpi_tac; mltac_index = 0; } in let more_args = more_args |> List.map (function - | Coq_elpi_arg_HOAS.Int _ as t -> t - | Coq_elpi_arg_HOAS.String _ as t -> t - | Coq_elpi_arg_HOAS.Term t -> + | Coq_elpi_arg_HOAS.Tac.Int _ as t -> t + | Coq_elpi_arg_HOAS.Tac.String _ as t -> t + | Coq_elpi_arg_HOAS.Tac.Term (t,_) -> let expr = Constrextern.extern_glob_constr Constrextern.empty_extern_env t in let rec aux () ({ CAst.v } as orig) = match v with | Constrexpr.CEvar _ -> CAst.make @@ Constrexpr.CHole(None,Namegen.IntroAnonymous,None) | _ -> Constrexpr_ops.map_constr_expr_with_binders (fun _ () -> ()) aux () orig in - Coq_elpi_arg_HOAS.Term (aux () expr) + Coq_elpi_arg_HOAS.Tac.Term (aux () expr) | _ -> assert false) in let tacname = loc, tacname in let tacname = Genarg.in_gen (Genarg.rawwit Coq_elpi_arg_syntax.wit_qualified_name) tacname in - let args = args |> List.map (fun (arg,_) -> Coq_elpi_arg_HOAS.Term arg) in + let args = args |> List.map (fun (arg,_) -> Coq_elpi_arg_HOAS.Tac.Term(arg)) in let args = Genarg.in_gen (Genarg.rawwit (Genarg.wit_list Coq_elpi_arg_syntax.wit_elpi_tactic_arg)) (more_args @ args) in (TacML (elpi_tac_entry, [TacGeneric(None, tacname); TacGeneric(None, args)])) in CAst.make @@ Constrexpr.CHole (None, Namegen.IntroAnonymous, Some (Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) (CAst.make tac))) in @@ -897,21 +903,21 @@ let cache_abbrev_for_tac (_, { abbrev_name; tac_name = tacname; tac_fixed_args = let subst_abbrev_for_tac (subst, { abbrev_name; tac_name; tac_fixed_args }) = { abbrev_name; tac_name; - tac_fixed_args = List.map (Coq_elpi_arg_HOAS.subst_tac_arg_glob subst) tac_fixed_args + tac_fixed_args = List.map (Coq_elpi_arg_HOAS.Tac.subst subst) tac_fixed_args } let inAbbreviationForTactic : tac_abbrev -> Libobject.obj = Libobject.declare_object @@ Libobject.global_object_nodischarge "ELPI-EXPORTED-TAC-ABBREV" ~cache:cache_abbrev_for_tac ~subst:(Some subst_abbrev_for_tac) -let cache_tac_abbrev (q,qualid) = cache_abbrev_for_tac (q,{ +let cache_tac_abbrev qualid = cache_abbrev_for_tac { abbrev_name = qualid; tac_name = qualid; tac_fixed_args = []; -}) +} -let cache_goption_declaration (_, (depr,key,value)) = +let cache_goption_declaration (depr,key,value) = let open Goptions in match value with | BoolValue x -> @@ -997,8 +1003,8 @@ let goption = let open API.AlgebraicData in let open Goptions in declare { } |> CConv.(!<) let module_ast_of_modpath x = - let open Constrexpr in let open Libnames in let open Nametab in - CAst.make @@ CMident (qualid_of_dirpath (dirpath_of_module x)) + let open Libnames in let open Nametab in + qualid_of_dirpath (dirpath_of_module x) let module_ast_of_modtypath x = let open Constrexpr in let open Libnames in let open Nametab in @@ -1577,7 +1583,7 @@ Supported attributes: | Some (primitive,field_specs) -> (* record: projection... *) let names, flags = List.(split (map (fun { name; is_coercion; is_canonical } -> name, - { Record.Internal.pf_subclass = is_coercion ; pf_canonical = is_canonical }) + { Record.Internal.pf_subclass = is_coercion ; pf_reversible = is_coercion ; pf_canonical = is_canonical }) field_specs)) in let is_implicit = List.map (fun _ -> []) names in let open Entries in @@ -1684,7 +1690,7 @@ coq.env.begin-module-type Name :- | None -> Declaremods.Check [] | Some mp -> Declaremods.(Enforce (module_ast_of_modtypath mp)) in let id = Id.of_string name in - let f = module_ast_of_modpath f in + let f = CAst.make (Constrexpr.CMident (module_ast_of_modpath f)) in let mexpr_ast_args = List.map module_ast_of_modpath arguments in let mexpr_ast = List.fold_left (fun hd arg -> CAst.make (Constrexpr.CMapply(hd,arg))) f mexpr_ast_args in @@ -1744,7 +1750,7 @@ coq.env.begin-module-type Name :- In(modpath, "ModPath", Full(unit_ctx, "is like the vernacular Import *E*")), (fun mp ~depth _ _ -> on_global_state "coq.env.import-module" (fun state -> - Declaremods.import_module ~export:false Libobject.unfiltered mp; + Declaremods.import_module ~export:Lib.Import Libobject.unfiltered mp; state, (), []))), DocAbove); @@ -1752,7 +1758,7 @@ coq.env.begin-module-type Name :- In(modpath, "ModPath", Full(unit_ctx, "is like the vernacular Export *E*")), (fun mp ~depth _ _ -> on_global_state "coq.env.export-module" (fun state -> - Declaremods.import_module ~export:true Libobject.unfiltered mp; + Declaremods.import_module ~export:Lib.Export Libobject.unfiltered mp; state, (), []))), DocAbove); @@ -1860,35 +1866,16 @@ denote the same x as before.|}; univ_super state u1 u2, (), [])), DocAbove); - MLCode(Pred("coq.univ.max", + MLCode(Pred("coq.univ.pts-triple", In(univ, "U1", In(univ, "U2", Out(univ, "U3", - Full(unit_ctx, "constrains U3 = max U1 U2")))), + Full(unit_ctx, "constrains U3 = universe of product with domain in U1 and codomain in U2)")))), (fun u1 u2 _ ~depth _ _ state -> - let state, u3 = univ_max state u1 u2 in + let state, u3 = univ_product state u1 u2 in state, !: u3, [])), DocAbove); - LPDoc "Very low level, don't use"; - - MLCode(Pred("coq.univ.algebraic-max", - In(univ, "U1", - In(univ, "U2", - Out(univ, "U3", - Full(unit_ctx, "constrains U3 = Max(U1,U2) *E*")))), - (fun u1 u2 _ ~depth _ _ state -> - state, !: (mk_algebraic_max u1 u2), [])), - DocAbove); - - MLCode(Pred("coq.univ.algebraic-sup", - In(univ, "U1", - Out(univ, "U2", - Full(unit_ctx, "constrains U2 = Sup(U1) *E*"))), - (fun u1 _ ~depth _ _ state -> - state, !: (mk_algebraic_super u1), [])), - DocAbove); - LPDoc "-- Primitive --------------------------------------------------------"; MLData Coq_elpi_utils.uint63; @@ -2029,12 +2016,15 @@ NParams can always be omitted, since it is inferred. (fun (gr, _, source, target) ~depth { options } _ -> on_global_state "coq.coercion.declare" (fun state -> let local = options.local <> Some false in let poly = false in + let nonuniform = false in + let reversible = true in begin match source, target with | B.Given source, B.Given target -> let source = ComCoercion.class_of_global source in - ComCoercion.try_add_new_coercion_with_target gr ~local ~poly ~source ~target + ComCoercion.try_add_new_coercion_with_target gr ~local ~poly + ~nonuniform ~reversible ~source ~target | _, _ -> - ComCoercion.try_add_new_coercion gr ~local ~poly + ComCoercion.try_add_new_coercion gr ~local ~poly ~nonuniform ~reversible end; state, (), []))), DocAbove); @@ -2295,7 +2285,7 @@ Supported attributes: (fun s _ ~depth -> let qualid = Libnames.qualid_of_string s in let sd = - try Nametab.locate_syndef qualid + try Nametab.locate_abbreviation qualid with Not_found -> err Pp.(str "Abbreviation not found: " ++ Libnames.pr_qualid qualid) in !:sd)), DocAbove); @@ -2354,11 +2344,11 @@ Supported attributes: let vars, nenv, env, body = strip_n_lambas nargs env term in let gbody = Coq_elpi_utils.detype env sigma body in let pat, _ = Notation_ops.notation_constr_of_glob_constr nenv gbody in - Syntax_def.declare_syntactic_definition ~local ~onlyparsing options.deprecation name (vars,pat); + Abbreviation.declare_abbreviation ~local ~onlyparsing options.deprecation name (vars,pat); let qname = Libnames.qualid_of_string (Id.to_string name) in match Nametab.locate_extended qname with | Globnames.TrueGlobal _ -> assert false - | Globnames.SynDef sd -> state, !: sd, []))), + | Globnames.Abbrev sd -> state, !: sd, []))), DocAbove); MLCode(Pred("coq.notation.abbreviation", @@ -2367,7 +2357,7 @@ Supported attributes: Out(B.poly "term","Body", Full(global, "Unfolds an abbreviation")))), (fun sd arglist _ ~depth {env} _ state -> - let args, _ = Syntax_def.search_syntactic_definition sd in + let args, _ = Abbreviation.search_abbreviation sd in let nargs = List.length args in let argno = List.length arglist in if nargs > argno then @@ -2402,7 +2392,7 @@ Supported attributes: Out(B.poly "term","Body", Full(global, "Retrieves the body of an abbreviation")))), (fun sd _ _ ~depth {env} _ state -> - let args, _ = Syntax_def.search_syntactic_definition sd in + let args, _ = Abbreviation.search_abbreviation sd in let nargs = List.length args in let open Constrexpr in let binders, vars = List.split (CList.init nargs (fun i -> @@ -2437,12 +2427,12 @@ is equivalent to Elpi Export TacName.|})))), let sigma = get_sigma state in let env = get_global_env state in let tac_fixed_args = more_args |> List.map (function - | Coq_elpi_arg_HOAS.Cint n -> Coq_elpi_arg_HOAS.Int n - | Coq_elpi_arg_HOAS.Cstr s -> Coq_elpi_arg_HOAS.String s - | Coq_elpi_arg_HOAS.Ctrm t -> Coq_elpi_arg_HOAS.Term (Coq_elpi_utils.detype env sigma t)) in + | Coq_elpi_arg_HOAS.Cint n -> Coq_elpi_arg_HOAS.Tac.Int n + | Coq_elpi_arg_HOAS.Cstr s -> Coq_elpi_arg_HOAS.Tac.String s + | Coq_elpi_arg_HOAS.Ctrm t -> Coq_elpi_arg_HOAS.Tac.Term (Coq_elpi_utils.detype env sigma t,None)) in let abbrev_name = Coq_elpi_utils.string_split_on_char '.' name in let tac_name = Coq_elpi_utils.string_split_on_char '.' tacname in - Lib.add_anonymous_leaf @@ inAbbreviationForTactic { abbrev_name; tac_name; tac_fixed_args}; + Lib.add_leaf @@ inAbbreviationForTactic { abbrev_name; tac_name; tac_fixed_args}; state, (), []))), DocAbove); @@ -2929,7 +2919,7 @@ and for all in a .v file which your clients will load. Eg. |}))), (fun key value depr ~depth -> let depr = Option.default false @@ unspec2opt depr in - Lib.add_anonymous_leaf @@ inGoption (depr,key,value))), + Lib.add_leaf @@ inGoption (depr,key,value))), DocAbove); LPDoc "-- Datatypes conversions --------------------------------------------"; diff --git a/src/coq_elpi_builtins.mli b/src/coq_elpi_builtins.mli index 74b8d170e..dc326b72b 100644 --- a/src/coq_elpi_builtins.mli +++ b/src/coq_elpi_builtins.mli @@ -26,4 +26,4 @@ val attribute : (string * attribute_value) Conversion.t (* In tactic mode some APIs are disabled *) val tactic_mode : bool ref -val cache_tac_abbrev : (Libobject.object_name * qualified_name) -> unit +val cache_tac_abbrev : qualified_name -> unit diff --git a/src/coq_elpi_glob_quotation.ml b/src/coq_elpi_glob_quotation.ml index 27f9db649..603ab5285 100644 --- a/src/coq_elpi_glob_quotation.ml +++ b/src/coq_elpi_glob_quotation.ml @@ -78,15 +78,40 @@ let under_ctx name ty bo gterm2lp ~depth state x = state, mk_def ~depth name ~bo:(lift1 bo) ~ty:(lift1 ty) in let new_hyp = { ctx_entry; depth = depth+1 } in set_coq_ctx_hyps state ({ coq_ctx with name2db }, new_hyp :: hyps), Name id in - let state, y = gterm2lp ~depth:(depth+1) (push_env state name) x in + let state, y, gl = gterm2lp ~depth:(depth+1) (push_env state name) x in let state = set_coq_ctx_hyps state orig_ctx in let state = pop_env state in - state, y + state, y, gl let type_gen = ref 0 let is_hole x = match DAst.get x with GHole _ -> true | _ -> false +let universe_level_name evd ({CAst.v=id} as lid) = + try Evd.universe_of_name evd id + with Not_found -> + CErrors.user_err ?loc:lid.CAst.loc + (Pp.(str "Undeclared universe: " ++ Id.print id ++ str ".")) + +let sort env sigma l = match l with +| [] -> assert false +| [u, 0] -> + begin match u with + | GSet -> Sorts.set + | GSProp -> Sorts.sprop + | GProp -> Sorts.prop + | GUniv u -> Sorts.sort_of_univ (Univ.Universe.make u) + | GLocalUniv l -> + let u = universe_level_name sigma l in + Sorts.sort_of_univ (Univ.Universe.make u) + | GRawUniv _ -> assert false (* funind-specific hack *) + end +| [_] | _ :: _ :: _ -> + nYI "(glob)HOAS for Type@{i j}" + +let nogls f ~depth state x = let state, x = f ~depth state x in state, x, () +let noglsk f ~depth state = let state, x = f ~depth state in state, x, () + let rec gterm2lp ~depth state x = debug Pp.(fun () -> str"gterm2lp: depth=" ++ int depth ++ @@ -104,18 +129,18 @@ let rec gterm2lp ~depth state x = incr type_gen; let state, s = API.RawQuery.mk_Arg state ~name:(Printf.sprintf "type_%d" !type_gen) ~args:[] in state, in_elpi_flex_sort s - | GSort(UNamed [name,0]) -> + | GSort(UNamed u) -> let env = get_global_env state in - state, in_elpi_sort (Sorts.sort_of_univ @@ Univ.Universe.make @@ Pretyping.known_glob_level (Evd.from_env env) name) + state, in_elpi_sort (sort env (get_sigma state) u) | GSort(_) -> nYI "(glob)HOAS for Type@{i j}" | GProd(name,_,s,t) -> let state, s = gterm2lp ~depth state s in - let state, t = under_ctx name s None gterm2lp ~depth state t in + let state, t, () = under_ctx name s None (nogls gterm2lp) ~depth state t in state, in_elpi_prod name s t | GLambda(name,_,s,t) -> let state, s = gterm2lp ~depth state s in - let state, t = under_ctx name s None gterm2lp ~depth state t in + let state, t, () = under_ctx name s None (nogls gterm2lp) ~depth state t in state, in_elpi_lam name s t | GLetIn(name,bo , oty, t) -> let state, bo = gterm2lp ~depth state bo in @@ -127,7 +152,7 @@ let rec gterm2lp ~depth state x = let args = List.map (fun (_,x) -> E.mkBound x) (Id.Map.bindings ctx.name2db) in state, E.mkUnifVar uv ~args state | Some ty -> gterm2lp ~depth state ty in - let state, t = under_ctx name ty (Some bo) gterm2lp ~depth state t in + let state, t, () = under_ctx name ty (Some bo) (nogls gterm2lp) ~depth state t in state, in_elpi_let name bo ty t | GHole(_,_,Some arg) when !is_elpi_code arg -> @@ -305,7 +330,7 @@ let rec gterm2lp ~depth state x = let ty = glob_intros_prod tctx ty in let state, ty = gterm2lp ~depth state ty in let bo = glob_intros tctx bo in - let state, bo = under_ctx (Name name) ty None gterm2lp ~depth state bo in + let state, bo, () = under_ctx (Name name) ty None (nogls gterm2lp) ~depth state bo in state, in_elpi_fix (Name name) rno ty bo | GRec _ -> nYI "(glob)HOAS mutual/non-struct fix" | GInt i -> in_elpi_primitive ~depth state (Uint63 i) @@ -340,7 +365,7 @@ let rec do_params params kont ~depth state = | (name,imp,ob,src) :: params -> if ob <> None then Coq_elpi_utils.nYI "defined parameters in a record/inductive declaration"; let state, src = gterm2lp ~depth state src in - let state, tgt = under_ctx name src None (do_params params kont) ~depth state in + let state, tgt, () = under_ctx name src None (noglsk (do_params params kont)) ~depth state in let state, imp = in_elpi_imp ~depth state imp in state, in_elpi_parameter name ~imp src tgt @@ -353,7 +378,7 @@ let rec do_fields fields ~depth state = | [] -> state, in_elpi_indtdecl_endrecord () | (f,({ name; is_coercion; is_canonical } as att)) :: fields -> let state, f = do_term f ~depth state in - let state, fields = under_ctx name f None (do_fields fields) ~depth state in + let state, fields, () = under_ctx name f None (noglsk (do_fields fields)) ~depth state in in_elpi_indtdecl_field ~depth state att f fields let do_record ~name ~constructorname arity fields ~depth state = diff --git a/src/coq_elpi_glob_quotation.mli b/src/coq_elpi_glob_quotation.mli index adb78670c..acaaaa75a 100644 --- a/src/coq_elpi_glob_quotation.mli +++ b/src/coq_elpi_glob_quotation.mli @@ -15,8 +15,8 @@ val under_ctx : Names.Name.t -> term -> term option -> - (depth:int -> State.t -> State.t * 'b) -> - depth:int -> State.t -> State.t * 'b + (depth:int -> State.t -> State.t * 'b * 'c) -> + depth:int -> State.t -> State.t * 'b * 'c val do_term : Glob_term.glob_constr -> diff --git a/src/coq_elpi_utils.ml b/src/coq_elpi_utils.ml index 9ceea3496..823150667 100644 --- a/src/coq_elpi_utils.ml +++ b/src/coq_elpi_utils.ml @@ -104,6 +104,12 @@ let manual_implicit_of_binding_kind name = function | Glob_term.MaxImplicit -> CAst.make (Some (name,true)) | Glob_term.Explicit -> CAst.make None +let binding_kind_of_manual_implicit x = + match x.CAst.v with + | Some (_,false) -> Glob_term.NonMaxImplicit + | Some (_,true) -> Glob_term.MaxImplicit + | None -> Glob_term.Explicit + let manual_implicit_of_gdecl (name,bk,_,_) = manual_implicit_of_binding_kind name bk let lookup_inductive env i = @@ -119,8 +125,8 @@ let locate_qualid qualid = try match Nametab.locate_extended qualid with | Globnames.TrueGlobal gr -> Some (`Gref gr) - | Globnames.SynDef sd -> - match Syntax_def.search_syntactic_definition sd with + | Globnames.Abbrev sd -> + match Abbreviation.search_abbreviation sd with | _, Notation_term.NRef(gr,_) -> Some (`Gref gr) | _ -> Some (`Abbrev sd) with Not_found -> None @@ -228,3 +234,19 @@ let compare_qualified_name = Stdlib.compare let pr_qualified_name = Pp.prlist_with_sep (fun () -> Pp.str".") Pp.str let show_qualified_name = String.concat "." let pp_qualified_name fmt l = Format.fprintf fmt "%s" (String.concat "." l) + +let option_map_acc f s = function + | None -> s, None + | Some x -> + let s, x = f s x in + s, Some x + +let option_map_acc2 f s = function + | None -> s, None, [] + | Some x -> + let s, x, gl = f s x in + s, Some x, gl + +let option_default f = function + | Some x -> x + | None -> f () diff --git a/src/coq_elpi_utils.mli b/src/coq_elpi_utils.mli index ef9933318..4b70d2050 100644 --- a/src/coq_elpi_utils.mli +++ b/src/coq_elpi_utils.mli @@ -21,10 +21,11 @@ val mk_gforall : Glob_term.glob_constr -> Glob_term.glob_decl list -> Glob_term. val mk_gfun : Glob_term.glob_constr -> Glob_term.glob_decl list -> Glob_term.glob_constr val manual_implicit_of_binding_kind : Names.Name.t -> Glob_term.binding_kind -> (Names.Name.t * bool) option CAst.t val manual_implicit_of_gdecl : Glob_term.glob_decl -> (Names.Name.t * bool) option CAst.t +val binding_kind_of_manual_implicit : (Names.Name.t * bool) option CAst.t -> Glob_term.binding_kind val lookup_inductive : Environ.env -> Names.inductive -> Declarations.mutual_inductive_body * Declarations.one_inductive_body val locate_gref : string -> Names.GlobRef.t -val locate_qualid : Libnames.qualid -> [ `Gref of Names.GlobRef.t | `Abbrev of Globnames.syndef_name ] option +val locate_qualid : Libnames.qualid -> [ `Gref of Names.GlobRef.t | `Abbrev of Globnames.abbreviation ] option val fold_elpi_term : (depth:int -> 'a -> Elpi.API.Data.term -> 'a) -> @@ -49,3 +50,7 @@ val compare_qualified_name : qualified_name -> qualified_name -> int val pr_qualified_name : qualified_name -> Pp.t val show_qualified_name : qualified_name -> string val pp_qualified_name : Format.formatter -> qualified_name -> unit + +val option_map_acc : ('a -> 'b -> 'a * 'c) -> 'a -> 'b option -> 'a * 'c option +val option_map_acc2 : (Elpi.API.State.t -> 'b -> Elpi.API.State.t * 'c * Elpi.API.Conversion.extra_goals) -> Elpi.API.State.t -> 'b option -> Elpi.API.State.t * 'c option * Elpi.API.Conversion.extra_goals +val option_default : (unit -> 'a) -> 'a option -> 'a diff --git a/src/coq_elpi_vernacular.ml b/src/coq_elpi_vernacular.ml index ca65350ea..f7810cfbd 100644 --- a/src/coq_elpi_vernacular.ml +++ b/src/coq_elpi_vernacular.ml @@ -100,7 +100,7 @@ and src_string = { sdata : string; sast : Compile.compilation_unit } -type nature = Command | Tactic | Program +type nature = Command of { raw_args : bool } | Tactic | Program of { raw_args : bool } val get : qualified_name -> Compile.compilation_unit list * Compile.compilation_unit list (* code , db *) val get_nature : qualified_name -> nature @@ -144,7 +144,7 @@ and src_string = { sdata : string; sast : EC.compilation_unit } -type nature = Command | Tactic | Program +type nature = Command of { raw_args : bool } | Tactic | Program of { raw_args : bool } let compare_src = Stdlib.compare module SrcSet = Set.Make(struct type t = src let compare = compare_src end) @@ -296,19 +296,19 @@ let append_to_prog name nature l = let in_program : qualified_name * nature option * src list -> Libobject.obj = Libobject.declare_object @@ Libobject.global_object_nodischarge "ELPI" - ~cache:(fun (_,(name,nature,src_ast)) -> + ~cache:(fun (name,nature,src_ast) -> program_src := SLMap.add name (append_to_prog name nature src_ast) !program_src) ~subst:(Some (fun _ -> CErrors.user_err Pp.(str"elpi: No functors yet"))) let init_program name nature = let obj = in_program (name, Some nature, []) in - Lib.add_anonymous_leaf obj + Lib.add_leaf obj ;; let add_to_program name v = let obj = in_program (name, None, v) in - Lib.add_anonymous_leaf obj + Lib.add_leaf obj ;; let append_to_db name (kname,data as l) = @@ -329,22 +329,22 @@ type snippet = { vars : Names.Id.t list; } -let in_db : snippet -> Libobject.obj = +let in_db : Names.Id.t -> snippet -> Libobject.obj = let cache ((_,kname), { program = name; code = p; _ }) = db_name_src := SLMap.add name (append_to_db name (kname,p)) !db_name_src in let import i (_, s as o) = if Int.equal i 1 || s.scope = Coq_elpi_utils.SuperGlobal then cache o in - Libobject.declare_object @@ { (Libobject.default_object "ELPI-DB") with - Libobject.classify_function = (fun ({ scope; program; _ } as o) -> + Libobject.declare_named_object @@ { (Libobject.default_object "ELPI-DB") with + Libobject.classify_function = (fun { scope; program; _ } -> match scope with | Coq_elpi_utils.Local -> Libobject.Dispose - | Coq_elpi_utils.Regular -> Libobject.Substitute o - | Coq_elpi_utils.Global -> Libobject.Keep o - | Coq_elpi_utils.SuperGlobal -> Libobject.Keep o); + | Coq_elpi_utils.Regular -> Libobject.Substitute + | Coq_elpi_utils.Global -> Libobject.Keep + | Coq_elpi_utils.SuperGlobal -> Libobject.Keep); Libobject.load_function = import; Libobject.cache_function = cache; Libobject.subst_function = (fun (_,o) -> o); Libobject.open_function = Libobject.simple_open import; - Libobject.discharge_function = (fun (_,({ scope; program; vars; } as o)) -> + Libobject.discharge_function = (fun (({ scope; program; vars; } as o)) -> if scope = Coq_elpi_utils.Local || (List.exists (fun x -> Lib.is_in_section (Names.GlobRef.VarRef x)) vars) then None else Some o); @@ -352,14 +352,13 @@ let in_db : snippet -> Libobject.obj = let accum = ref 0 let add_to_db program code vars scope = - ignore @@ Lib.add_leaf - (Names.Id.of_string (incr accum; Printf.sprintf "_ELPI_%d" !accum)) - (in_db { program; code; scope; vars }) + ignore @@ Lib.add_leaf + (in_db (Names.Id.of_string (incr accum; Printf.sprintf "_ELPI_%d" !accum)) { program; code; scope; vars }) let lp_command_ast = Summary.ref ~name:"elpi-lp-command" None let in_lp_command_src : src -> Libobject.obj = Libobject.declare_object { Libobject.(default_object "ELPI-LP-COMMAND") with - Libobject.load_function = (fun _ (_,x) -> lp_command_ast := Some x); + Libobject.load_function = (fun _ x -> lp_command_ast := Some x); } let load_command s = let elpi = ensure_initialized () in @@ -368,7 +367,7 @@ let load_command s = fast = unit_from_file ~elpi s } in lp_command_ast := Some ast; - Lib.add_anonymous_leaf (in_lp_command_src ast) + Lib.add_leaf (in_lp_command_src ast) let command_init () = match !lp_command_ast with | None -> CErrors.user_err Pp.(str "Elpi CommandTemplate was not called") @@ -377,7 +376,7 @@ let command_init () = let lp_tactic_ast = Summary.ref ~name:"elpi-lp-tactic" None let in_lp_tactic_ast : src -> Libobject.obj = Libobject.declare_object { Libobject.(default_object "ELPI-LP-TACTIC") with - Libobject.load_function = (fun _ (_,x) -> lp_tactic_ast := Some x); + Libobject.load_function = (fun _ x -> lp_tactic_ast := Some x); } let load_tactic s = let elpi = ensure_initialized () in @@ -386,7 +385,7 @@ let load_tactic s = fast = unit_from_file ~elpi s } in lp_tactic_ast := Some ast; - Lib.add_anonymous_leaf (in_lp_tactic_ast ast) + Lib.add_leaf (in_lp_tactic_ast ast) let tactic_init () = match !lp_tactic_ast with | None -> CErrors.user_err Pp.(str "Elpi TacticTemplate was not called") @@ -439,7 +438,7 @@ let get x = let lp_checker_ast = Summary.ref ~name:"elpi-lp-checker" None let in_lp_checker_ast : EC.compilation_unit list -> Libobject.obj = Libobject.declare_object { Libobject.(default_object "ELPI-LP-CHECKER") with - Libobject.load_function = (fun _ (_,x) -> lp_checker_ast := Some x); + Libobject.load_function = (fun _ x -> lp_checker_ast := Some x); } let load_checker s = @@ -447,7 +446,7 @@ let load_checker s = let basic_checker = unit_from_string ~elpi (Elpi.API.Ast.Loc.initial "(elpi-checker)") Elpi.Builtin_checker.code in let coq_checker = unit_from_file ~elpi s in let p = [basic_checker;coq_checker] in - Lib.add_anonymous_leaf (in_lp_checker_ast p) + Lib.add_leaf (in_lp_checker_ast p) let checker () = match !lp_checker_ast with | None -> CErrors.user_err Pp.(str "Elpi Checker was not called") @@ -456,13 +455,13 @@ let checker () = let lp_printer_ast = Summary.ref ~name:"elpi-lp-printer" None let in_lp_printer_ast : EC.compilation_unit -> Libobject.obj = Libobject.declare_object { Libobject.(default_object "ELPI-LP-PRINTER") with - Libobject.load_function = (fun _ (_,x) -> lp_printer_ast := Some x); + Libobject.load_function = (fun _ x -> lp_printer_ast := Some x); } let load_printer s = let elpi = ensure_initialized () in let ast = unit_from_file ~elpi s in lp_printer_ast := Some ast; - Lib.add_anonymous_leaf (in_lp_printer_ast ast) + Lib.add_leaf (in_lp_printer_ast ast) let printer () = match !lp_printer_ast with | None -> CErrors.user_err Pp.(str "Elpi Printer was not called") @@ -488,9 +487,9 @@ let load_printer = load_printer let load_checker = load_checker let document_builtins = document_builtins -let create_command n = +let create_command ?(raw_args=false) n = let _ = ensure_initialized () in - create_program n Command (command_init()); + create_program n (Command { raw_args }) (command_init()); set_current_program (snd n) let create_tactic n = @@ -498,11 +497,11 @@ let create_tactic n = create_program n Tactic (tactic_init ()); set_current_program (snd n) -let create_program n ~init:(loc,s) = +let create_program ?(raw_args=false) n ~init:(loc,s) = let elpi = ensure_initialized () in let unit = unit_from_string ~elpi loc s in let init = EmbeddedString { sloc = loc; sdata = s; sast = unit} in - create_program n Program init; + create_program n (Program { raw_args }) init; set_current_program (snd n) let create_db n ~init:(loc,s) = @@ -549,7 +548,12 @@ let () = Coq_elpi_builtins.set_accumulate_to_db (fun n x vs ~scope -> let get_and_compile name = let core_units, extra_units = get name in let prog = compile name core_units extra_units in - prog + let raw_args = + match get_nature name with + | Command { raw_args } -> raw_args + | Program { raw_args } -> raw_args + | Tactic -> true in + prog, raw_args let run_static_check query = let checker = compile ["Elpi";"Typecheck"] (checker()) [] in @@ -631,14 +635,14 @@ let run_and_print ~tactic_mode ~print ~static_check program_name program_ast que let run_in_program ?(program = current_program ()) (loc, query) = let elpi = ensure_initialized () in - let program_ast = get_and_compile program in + let program_ast, _ = get_and_compile program in let query_ast = `Ast (parse_goal ~elpi loc query) in run_and_print ~tactic_mode:false ~print:true ~static_check:true program program_ast query_ast ;; let typecheck_program ?(program = current_program ()) () = let elpi = ensure_initialized () in - let program = get_and_compile program in + let program, _ = get_and_compile program in let query_ast = parse_goal ~elpi (API.Ast.Loc.initial "(typecheck)") "true." in let query = EC.query program query_ast in let _ = API.Setup.trace !trace_options in @@ -674,20 +678,20 @@ let atts2impl loc ~depth state atts q = state, ET.mkApp ET.Constants.implc atts [q] ;; let run_program loc name ~atts args = + let program, raw_args = get_and_compile name in let loc = Coq_elpi_utils.of_coq_loc loc in let env = Global.env () in let sigma = Evd.from_env env in let args = args - |> List.map (Coq_elpi_arg_HOAS.glob_arg (Genintern.empty_glob_sign env)) - |> List.map (Coq_elpi_arg_HOAS.interp_arg (Ltac_plugin.Tacinterp.default_ist ()) env sigma) + |> List.map (Coq_elpi_arg_HOAS.Cmd.glob (Genintern.empty_glob_sign env)) + |> List.map (Coq_elpi_arg_HOAS.Cmd.interp (Ltac_plugin.Tacinterp.default_ist ()) env sigma) in let query ~depth state = - let state, args = Coq_elpi_utils.list_map_acc - (Coq_elpi_arg_HOAS.in_elpi_arg ~depth Coq_elpi_HOAS.(mk_coq_context ~options:default_options state)) + let state, args, gls = EU.map_acc + (Coq_elpi_arg_HOAS.in_elpi_cmd ~depth ~raw:raw_args Coq_elpi_HOAS.(mk_coq_context ~options:default_options state)) state args in let state, q = atts2impl loc ~depth state atts (ET.mkApp mainc (EU.list_to_lp_list args) []) in - state, (loc, q), [] in - let program = get_and_compile name in + state, (loc, q), gls in run_and_print ~tactic_mode:false ~print:false ~static_check:false name program (`Fun query) ;; @@ -717,7 +721,7 @@ let print name args = | [x] -> default_blacklist, x | x :: xs -> xs, x in let args = List.map API.RawOpaqueData.of_string args in - let program = get_and_compile name in + let program, _ = get_and_compile name in let query_ast = parse_goal ~elpi (API.Ast.Loc.initial "(print)") "true." in let query = EC.query program query_ast in let loc = { API.Ast.Loc. @@ -745,16 +749,18 @@ let run_tactic_common loc ?(static_check=false) program ~main ?(atts=[]) () = let gls = CList.map Proofview.drop_state gls in Proofview.tclEVARMAP >>= fun sigma -> let query ~depth state = - let state, (loc, q), gls = Coq_elpi_HOAS.goals2query sigma gls loc ~main ~in_elpi_arg:Coq_elpi_arg_HOAS.in_elpi_tac_arg ~depth state in + let state, (loc, q), gls = + Coq_elpi_HOAS.goals2query sigma gls loc ~main + ~in_elpi_tac_arg:Coq_elpi_arg_HOAS.in_elpi_tac ~depth state in let state, qatts = atts2impl loc ~depth state atts q in state, (loc, qatts), gls in - let cprogram = get_and_compile program in + let cprogram, _ = get_and_compile program in match run ~tactic_mode:true ~static_check cprogram (`Fun query) with | API.Execute.Success solution -> Coq_elpi_HOAS.tclSOLUTION2EVD sigma solution | API.Execute.NoMoreSteps -> CErrors.user_err Pp.(str "elpi run out of steps") | API.Execute.Failure -> elpi_fails ~tactic_mode:true program - | exception (Coq_elpi_utils.LtacFail (level, msg)) -> tclFAIL level msg + | exception (Coq_elpi_utils.LtacFail (level, msg)) -> tclFAILn level msg let run_tactic loc program ~atts _ist args = let loc = Coq_elpi_utils.of_coq_loc loc in @@ -763,6 +769,24 @@ let run_tactic loc program ~atts _ist args = let run_in_tactic ?(program = current_program ()) (loc,query) _ist = run_tactic_common loc ~static_check:true program ~main:(Coq_elpi_HOAS.Custom query) () +let accumulate_extra_deps ?(program=current_program()) ids = + let elpi = ensure_initialized () in + let s = ids |> List.map (fun id -> + try ComExtraDeps.query_extra_dep id + with Not_found -> + err Pp.(str"File " ++ Names.Id.print id ++ + str" is unknown; please add a directive like 'From .. Extra Dependency .. as " ++ + Names.Id.print id ++ str"'.")) in + try + let new_src_ast = List.map (fun fname -> + File { + fname; + fast = unit_from_file ~elpi fname; + }) s in + accumulate program new_src_ast + with Failure s -> CErrors.user_err Pp.(str s) + ;; + let accumulate_files ?(program=current_program()) s = let elpi = ensure_initialized () in try @@ -801,9 +825,9 @@ let loc_merge l1 l2 = try Loc.merge l1 l2 with Failure _ -> l1 -let cache_program (q,(nature,p,p_str)) = +let cache_program (nature,p,p_str) = match nature with - | Command -> + | Command _ -> Vernacextend.vernac_extend ~command:("Elpi"^p_str) ~classifier:(fun _ -> Vernacextend.(VtSideff ([], VtNow))) @@ -817,7 +841,7 @@ let cache_program (q,(nature,p,p_str)) = (p_str, Vernacextend.TyNonTerminal (Extend.TUlist0 - (Extend.TUentry (Genarg.get_arg_tag Coq_elpi_arg_syntax.wit_elpi_arg)) + (Extend.TUentry (Genarg.get_arg_tag Coq_elpi_arg_syntax.wit_elpi_cmd_arg)) ,Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Coq_elpi_arg_syntax.wit_elpi_loc), Vernacextend.TyNil)))), @@ -826,14 +850,14 @@ let cache_program (q,(nature,p,p_str)) = None) ] | Tactic -> - Coq_elpi_builtins.cache_tac_abbrev (q,p) - | Program -> + Coq_elpi_builtins.cache_tac_abbrev p + | Program _ -> CErrors.user_err Pp.(str "elpi: Only commands and tactics can be exported") let subst_program = function - | _, (Command, _, _) -> CErrors.user_err Pp.(str"elpi: No functors yet") + | _, (Command _, _, _) -> CErrors.user_err Pp.(str"elpi: No functors yet") | _, (Tactic,_,_ as x) -> x - | _, (Program,_,_) -> assert false + | _, (Program _,_,_) -> assert false let in_exported_program : nature * qualified_name * string -> Libobject.obj = Libobject.declare_object @@ Libobject.global_object_nodischarge "ELPI-EXPORTED" @@ -843,7 +867,7 @@ let in_exported_program : nature * qualified_name * string -> Libobject.obj = let export_command p = let p_str = String.concat "." p in let nature = get_nature p in - Lib.add_anonymous_leaf (in_exported_program (nature,p,p_str)) + Lib.add_leaf (in_exported_program (nature,p,p_str)) let skip ~atts:(skip,only) f x = let m rex = Str.string_match rex Coq_config.version 0 in diff --git a/src/coq_elpi_vernacular.mli b/src/coq_elpi_vernacular.mli index fe70f9e35..e01e1de82 100644 --- a/src/coq_elpi_vernacular.mli +++ b/src/coq_elpi_vernacular.mli @@ -6,14 +6,15 @@ open Coq_elpi_utils type program_name = Loc.t * qualified_name -val create_program : program_name -> init:(Elpi.API.Ast.Loc.t * string) -> unit -val create_command : program_name -> unit +val create_program : ?raw_args:bool -> program_name -> init:(Elpi.API.Ast.Loc.t * string) -> unit +val create_command : ?raw_args:bool -> program_name -> unit val create_tactic : program_name -> unit val create_db : program_name -> init:(Elpi.API.Ast.Loc.t * string) -> unit val typecheck_program : ?program:qualified_name -> unit -> unit val accumulate_files : ?program:qualified_name -> string list -> unit +val accumulate_extra_deps : ?program:qualified_name -> Names.Id.t list -> unit val accumulate_string : ?program:qualified_name -> Elpi.API.Ast.Loc.t * string -> unit val accumulate_db : ?program:qualified_name -> qualified_name -> unit @@ -36,9 +37,9 @@ val print : qualified_name -> string list -> unit open Coq_elpi_arg_HOAS -val run_program : Loc.t -> qualified_name -> atts:Attributes.vernac_flags -> cmd raw_arg list -> unit +val run_program : Loc.t -> qualified_name -> atts:Attributes.vernac_flags -> Cmd.raw list -> unit val run_in_program : ?program:qualified_name -> Elpi.API.Ast.Loc.t * string -> unit -val run_tactic : Loc.t -> qualified_name -> atts:Attributes.vernac_flags -> Geninterp.interp_sign -> top_tac_arg list -> unit Proofview.tactic +val run_tactic : Loc.t -> qualified_name -> atts:Attributes.vernac_flags -> Geninterp.interp_sign -> Tac.top list -> unit Proofview.tactic val run_in_tactic : ?program:qualified_name -> Elpi.API.Ast.Loc.t * string -> Geninterp.interp_sign -> unit Proofview.tactic val export_command : qualified_name -> unit diff --git a/src/coq_elpi_vernacular_syntax.mlg b/src/coq_elpi_vernacular_syntax.mlg index 17db3f08c..5de418136 100644 --- a/src/coq_elpi_vernacular_syntax.mlg +++ b/src/coq_elpi_vernacular_syntax.mlg @@ -2,7 +2,7 @@ (* license: GNU Lesser General Public License Version 2.1 or later *) (* ------------------------------------------------------------------------- *) -DECLARE PLUGIN "elpi_plugin" +DECLARE PLUGIN "coq-elpi.elpi" { @@ -53,6 +53,9 @@ let rec inlogpath q = function let warning_legacy_accumulate = CWarnings.create ~name:"elpi.accumulate-syntax" ~category:"elpi.deprecated" (fun () -> Pp.strbrk "The syntax 'Elpi Accumulate File \"path\"' is deprecated, use 'Elpi Accumulate File \"path\" From logpath'") +let warning_legacy_accumulate2 = + CWarnings.create ~name:"elpi.accumulate-syntax" ~category:"elpi.deprecated" (fun () -> + Pp.strbrk "The syntax 'Elpi Accumulate File \"path\" From logpath' is deprecated, use 'From logpath Extra Dependency \"path\" as name. Elpi Accumulate File name.'") } GRAMMAR EXTEND Gram @@ -92,16 +95,25 @@ END (* Syntax **************************************************************** *) VERNAC COMMAND EXTEND Elpi CLASSIFIED AS SIDEFF +| #[ atts = skip_attribute ] [ "Elpi" "Accumulate" "File" ne_ident_list(ids) ] -> { + EV.skip ~atts EV.accumulate_extra_deps ids } +| #[ atts = skip_attribute ] [ "Elpi" "Accumulate" "Files" ne_ident_list(ids) ] -> { + EV.skip ~atts EV.accumulate_extra_deps ids } +| #[ atts = skip_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "File" ne_ident_list(ids) ] -> { + EV.skip ~atts (EV.accumulate_extra_deps ~program:(snd p)) ids } +| #[ atts = skip_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "Files" ne_ident_list(ids) ] -> { + EV.skip ~atts (EV.accumulate_extra_deps ~program:(snd p)) ids } + | #[ atts = any_attribute ] [ "Elpi" "Accumulate" "File" string_list(s) ] -> { warning_legacy_accumulate (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts EV.accumulate_files s } -| #[ atts = any_attribute ] [ "Elpi" "Accumulate" "File" string_list(s) "From" global(g) ] -> { +| #[ atts = any_attribute ] [ "Elpi" "Accumulate" "File" string_list(s) "From" global(g) ] -> { warning_legacy_accumulate2 (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts EV.accumulate_files (inlogpath g s) } | #[ atts = any_attribute ] [ "Elpi" "Accumulate" "Files" string_list(s) ] -> { warning_legacy_accumulate (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts EV.accumulate_files s } -| #[ atts = any_attribute ] [ "Elpi" "Accumulate" "Files" string_list(s) "From" global(g) ] -> { +| #[ atts = any_attribute ] [ "Elpi" "Accumulate" "Files" string_list(s) "From" global(g) ] -> { warning_legacy_accumulate2 (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts EV.accumulate_files (inlogpath g s) } | #[ atts = any_attribute ] [ "Elpi" "Accumulate" elpi_string(s) ] -> { @@ -110,13 +122,13 @@ VERNAC COMMAND EXTEND Elpi CLASSIFIED AS SIDEFF | #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "File" string_list(s) ] -> { warning_legacy_accumulate (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts (EV.accumulate_files ~program:(snd p)) s } -| #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "File" string_list(s) "From" global(g) ] -> { +| #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "File" string_list(s) "From" global(g) ] -> { warning_legacy_accumulate2 (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts (EV.accumulate_files ~program:(snd p)) (inlogpath g s) } | #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "Files" string_list(s) ] -> { warning_legacy_accumulate (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts (EV.accumulate_files ~program:(snd p)) s } -| #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "Files" string_list(s) "From" global(g) ] -> { +| #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) "Files" string_list(s) "From" global(g) ] -> { warning_legacy_accumulate2 (); let atts = validate_attributes skip_attribute atts in EV.skip ~atts (EV.accumulate_files ~program:(snd p)) (inlogpath g s) } | #[ atts = any_attribute ] [ "Elpi" "Accumulate" qualified_name(p) elpi_string(s) ] -> { @@ -157,11 +169,11 @@ VERNAC COMMAND EXTEND Elpi CLASSIFIED AS SIDEFF EV.print (snd p) s } | #[ atts = any_attribute ] [ "Elpi" "Program" qualified_name(p) elpi_string(s) ] -> { - let () = ignore_unknown_attributes atts in - EV.create_program p ~init:s } + let raw_args = validate_attributes raw_args_attribute atts in + EV.create_program ?raw_args p ~init:s } | #[ atts = any_attribute ] [ "Elpi" "Command" qualified_name(p) ] -> { - let () = ignore_unknown_attributes atts in - EV.create_command p } + let raw_args = validate_attributes raw_args_attribute atts in + EV.create_command ?raw_args p } | #[ atts = any_attribute ] [ "Elpi" "Tactic" qualified_name(p) ] -> { let () = ignore_unknown_attributes atts in EV.create_tactic p } @@ -204,7 +216,7 @@ VERNAC COMMAND EXTEND ElpiRun CLASSIFIED BY { fun _ -> Vernacextend.(VtSideff ([ | #[ atts = any_attribute ] [ "Elpi" "Export" qualified_name(p) ] => { Vernacextend.(VtSideff ([],VtNow)) } -> { let () = ignore_unknown_attributes atts in EV.export_command (snd p) } -| #[ atts = any_attribute ] [ "Elpi" qualified_name(p) elpi_arg_list(args) ] -> { +| #[ atts = any_attribute ] [ "Elpi" qualified_name(p) elpi_cmd_arg_list(args) ] -> { EV.run_program (fst p) (snd p) ~atts args } END diff --git a/tests/test_API.v b/tests/test_API.v index 38621e1fd..433e7e2fa 100644 --- a/tests/test_API.v +++ b/tests/test_API.v @@ -11,163 +11,15 @@ Elpi Query lp:{{ coq.say "Coq version:" V "=" MA "." MI "." P. }}. -(****** typecheck **********************************) -Elpi Query lp:{{ - coq.locate "plus" (const GR), - coq.env.const GR (some BO) TY, - coq.typecheck BO TY ok. -}}. - -Elpi Query lp:{{ - pi x w z\ - decl x `x` {{ nat }} => - def z `z` {{ nat }} x => - (coq.say z, - coq.typecheck z T ok, - coq.say T, - coq.say {coq.term->string z}, - coq.say {coq.term->string T}). -}}. - -Elpi Query lp:{{ - pi x w z\ - decl x `x` {{ nat }} => - decl w `w` {{ nat }} => - def z `z` {{ nat }} w => - (coq.say z, - coq.typecheck z T ok, - coq.say T, - coq.say {coq.term->string z}, - coq.say {coq.term->string T}). -}}. - -Elpi Query lp:{{ - - coq.typecheck {{ Prop Prop }} _ (error E), - coq.say E. - -}}. - - -Elpi Query lp:{{ - coq.unify-leq {{ bool }} {{ nat }} (error Msg), - coq.say Msg. -}}. - -(****** elaborate *******************************) -Module elab. -Axiom T1 : Type. -Axiom T2 : nat -> Type. -Axiom T3 : nat -> Type. - -Axiom f1 : T1 -> Type. -Axiom f3 : forall b, T3 b -> Type. - -Axiom g1 : T1 -> nat -> nat. -Axiom g3 : forall b, T3 b -> nat -> nat. - -Axiom h : forall n , T2 n -> T3 n. - -Coercion f1 : T1 >-> Sortclass. -Coercion f3 : T3 >-> Sortclass. -Coercion g1 : T1 >-> Funclass. -Coercion g3 : T3 >-> Funclass. -Coercion h : T2 >-> T3. - -Elpi Query lp:{{ - - std.assert-ok! (coq.elaborate-skeleton {{ fun n (t : T2 n) (x : t) => t 3 }} TY E) "that was easy", - coq.env.add-const "elab_1" E TY tt _ - -}}. - -Class foo (n : nat). -Definition bar n {f : foo n} := n = n. -#[local] Instance xxx : foo 3. Defined. - -Elpi Query lp:{{ - - std.assert-ok! (coq.elaborate-ty-skeleton {{ bar _ }} TY E) "that was easy", - coq.env.add-const "elab_2" E (sort TY) tt _ - -}}. - -Structure s := { field : Type; #[canonical=no] op : field -> field; }. -Canonical c := {| field := nat; op := (fun x => x) |}. - -Elpi Query lp:{{ - - std.assert-ok! (coq.elaborate-skeleton {{ op _ 3 }} TY E) "that was easy", - coq.env.add-const "elab_3" E TY tt _ - -}}. - -Elpi Accumulate lp:{{ - main [indt-decl D] :- - std.assert-ok! (coq.elaborate-indt-decl-skeleton D D1) "illtyped", - coq.env.add-indt D1 _. - main [const-decl N (some BO) TYA] :- std.do! [ - coq.arity->term TYA TY, - std.assert-ok! (coq.elaborate-ty-skeleton TY _ TY1) "illtyped", - std.assert-ok! (coq.elaborate-skeleton BO TY1 BO1) "illtyped", - coq.env.add-const N BO1 TY1 @transparent! _, - ]. -}}. -Elpi Typecheck. - -Elpi test.API Inductive ind1 (A : T1) := - K1 : ind1 A | K2 : A -> ind1 A. - -Elpi test.API Record ind2 (A : T1) := { - fld1 : A; - fld2 : fld1 = fld1; -}. - -Elpi test.API Record ind3 := { - fld3 :> Type; - fld4 : forall x : fld3, x = x; -}. - -Check (forall x : ind3, x -> Prop). - -Elpi test.API Definition def1 A := fun x : A => x. - -Elpi Query lp:{{ - - std.assert-ok! (coq.elaborate-skeleton {{ op lib:elpi.hole 3 }} TY E) "that was easy 2", - coq.env.add-const "elab_4" E TY tt _ - -}}. - -Elpi Tactic test. -Elpi Accumulate lp:{{ -solve _ _ :- - coq.term->string X S, - X = global (indc Y), - coq.say S. -}}. -Goal True. -Fail elpi test. -Abort. - -Elpi Tactic test2. -Elpi Accumulate lp:{{ -solve _ _ :- - coq.term->string (global (indc Y)) S, - coq.say S. -}}. -Goal True. -elpi test2. -Abort. - -End elab. (****** say *************************************) Elpi Query lp:{{ coq.say "hello world" }}. +(****** warnings *************************************) + Set Warnings "-elpi,-category". Elpi Query lp:{{ coq.warn "this is a generic warning". @@ -214,575 +66,6 @@ Elpi Query lp:{{ std.do! [ coq.locate-all "fdsfdsjkfdksljflkdsjlkfdjkls" [], ]. }}. -(****** env **********************************) - -(* constant *) - -Elpi Query lp:{{ - coq.locate "plus" (const GR), - coq.env.const GR (some BO) TY, - coq.locate "nat" GRNat, Nat = global GRNat, - coq.locate "S" GRSucc, Succ = global GRSucc, - TY = (prod _ Nat _\ prod _ Nat _\ Nat), - BO = (fix _ 0 TY add\ - fun _ Nat n\ fun _ Nat m\ - match n (fun _ Nat _\ Nat) - [ m - , fun _ Nat w\ app[Succ, app[add,w,m]]]). -}}. - -Axiom empty_nat : nat. - -Elpi Query lp:{{ - coq.locate "empty_nat" (const GR), - coq.env.const GR none TY. -}}. - -Section Test. - -Variable A : nat. - -Elpi Query lp:{{ - coq.locate "Vector.nil" GR1, - coq.locate "nat" GR2, - coq.locate "A" GR3, - coq.env.typeof GR1 _, - coq.env.typeof GR2 _, - coq.env.typeof GR3 _. -}}. - -End Test. - -Elpi Query lp:{{ - coq.locate "plus" (const GR), - coq.env.const GR (some BO) TY, - coq.gref->id (const GR) S, - Name is S ^ "_equal", - coq.env.add-const Name BO TY @opaque! NGR, - coq.env.opaque? NGR, - coq.env.const NGR none _, coq.say {coq.gref->id (const NGR)}, - coq.env.const-body NGR (some BO), - rex_match "add_equal" {coq.gref->id (const NGR)}. -}}. - -About add_equal. - -(* axiom *) - -Elpi Query lp:{{ - coq.locate "False" F, - coq.env.add-axiom "myfalse" (global F) GR, - coq.env.opaque? GR, - coq.env.const GR none _, - coq.env.const-body GR none, - coq.say GR. -}}. - -Check myfalse. - -(* record *) - -Set Printing Universes. -Elpi Query lp:{{ - DECL = - (parameter "T" _ {{Type}} t\ - record "eq_class" {{Type}} "mk_eq_class" ( - field [canonical ff, coercion tt] "eq_f" {{bool}} f\ - field _ "eq_proof" {{lp:f = lp:f :> bool}} _\ - end-record)), - coq.say DECL, - coq.env.add-indt DECL GR. -}}. - -Print eq_class. -Check (fun x : eq_class nat => (x : bool)). -Axiom b : bool. -Axiom p : b = b. -Canonical xxx := mk_eq_class bool b p. -Print Canonical Projections. -Fail Check eq_refl _ : eq_f bool _ = b. - -Elpi Query lp:{{ - DECL = - (parameter "T" _ {{Type}} t\ - record "prim_eq_class" {{Type}} "mk_prim_eq_class" ( - field [canonical ff, coercion tt] "prim_eq_f" {{bool}} f\ - field _ "prim_eq_proof" {{lp:f = lp:f :> bool}} _\ - end-record)), - @primitive! => coq.env.add-indt DECL GR, - coq.env.projections GR [some _, some _]. -}}. - -(* primitive records have eta *) -Check fun r : prim_eq_class nat => - eq_refl _ : r = mk_prim_eq_class _ (prim_eq_f _ r) (prim_eq_proof _ r). - -Module II. -Arguments prim_eq_f : default implicits. -Elpi Query lp:{{ - coq.say {{ fun r : prim_eq_class nat => r.(prim_eq_f) }} -}}. - -Definition pc (r : prim_eq_class nat) := r.(prim_eq_f). - -Elpi Query lp:{{ - coq.locate "pc" (const C), - coq.env.const C (some (fun _ _ r\ app[primitive _, r])) _ -}}. - -Elpi Command primp. -Elpi Accumulate lp:{{ - main [const-decl _ (some (fun _ _ r\ app[primitive _, r])) _]. -}}. -Elpi primp Definition pc (r : prim_eq_class nat) := r.(prim_eq_f). - -End II. - -(* inductive *) - -Elpi Command indtest. -Elpi Accumulate lp:{{ -main _ :- - DECL = - (parameter "T" maximal {{Type}} t\ - parameter "x" _ t x\ - inductive "myind" _ (arity (prod `w` t _\ sort prop)) - i\ [ constructor "K1" - (arity (prod `y` t y\ prod _ (app[i,y]) _\app[i,x])) - , constructor "K2" - (arity (app[i,x])) - ] - ), - coq.env.add-indt DECL _, - coq.rename-indt-decl rename rename rename DECL DECL1, - coq.env.add-indt DECL1 _. - -pred rename i:id, o:id. -rename K S :- S is K ^ "1". -}}. -Elpi Query indtest lp:{{ main _ }}. - -Check myind true false : Prop. -Check K2 true : myind true true. -Check myind1 true false : Prop. -Check K21 true : myind1 true true. - -Elpi Query lp:{{ - coq.env.add-indt (parameter "X" _ {{Type}} x\ - inductive "nuind" _ (parameter "n" _ {{ nat }} _\ arity {{ bool -> Type }}) i\ - [constructor "k1" (parameter "n" _ {{nat}} n\ arity (app[i,n,{{true}}])) - ,constructor "k2" (parameter "n" _ {{nat}} n\ - arity (prod `x` (app[i,{{1}},{{false}}]) _\ - (app[i,n,{{false}}]))) - ]) _. -}}. - - -Check fun x : nuind nat 3 false => - match x in nuind _ _ b return @eq bool b b with - | k1 _ _ => (eq_refl : true = true) - | k2 _ _ x => (fun w : nuind nat 1 false => (eq_refl : false = false)) x - end. - -Fail Check fun x : nuind nat 3 false => - match x in nuind _ i_cannot_name_this b return @eq bool b b with - | k1 _ _ => (eq_refl : true = true) - | k2 _ _ x => (fun w : nuind nat 1 false => (eq_refl : false = false)) x - end. - -Elpi Query lp:{{ - pi x\ decl x `x` {{ nat }} => coq.typecheck x T ok, coq.say x T. -}}. - - -Elpi Query lp:{{ - D = (parameter "A" _ {{ Type }} a\ - inductive "tx" _ (parameter "y" _ {{nat}} _\ arity {{ bool -> Type }}) t\ - [ constructor "K1x" (parameter "y" _ {{nat}} y\ arity {{ - forall (x : lp:a) (n : nat) (p : @eq nat (S n) lp:y) (e : lp:t n true), - lp:t lp:y true }}) - , constructor "K2x" (parameter "y" _ {{nat}} y\ arity {{ - lp:t lp:y false }}) ]), - coq.typecheck-indt-decl D ok, - coq.env.add-indt D _. -}}. - -(* module *) - -Elpi Query lp:{{ coq.locate-module "Datatypes" MP, coq.env.module MP L }}. - -Module X. - Unset Auto Template Polymorphism. - Inductive i := . - Definition d := i. - Module Y. - Inductive i := . - Definition d := i. - End Y. -End X. - -Elpi Query lp:{{ - coq.locate-module "X" MP, - coq.env.module MP [ - (indt Xi), (const _), (const _), (const _), (const _), - (const _), - (indt XYi), (const XYr), (const _), (const _), (const _), - (const _) - ], - coq.say {coq.gref->string (indt Xi)}, - rex_match "\\(Top.\\|.*test_API\\)\\.X\\.i$" {coq.gref->string (indt Xi)}, - rex_match "\\(Top.\\|.*test_API\\)\\.X\\.Y\\.i$" {coq.gref->string (indt XYi)}, - (coq.gref->path (indt XYi) ["test_API", "X", "Y" ] ; - coq.gref->path (indt XYi) ["elpi", "tests", "test_API", "X", "Y" ] ; - coq.gref->path (indt XYi) ["Top", "test_API", "X", "Y" ]), - coq.say {coq.gref->path (indt XYi)}, - coq.say {coq.gref->path (const XYr)}, - (coq.gref->path (const XYr) ["test_API", "X", "Y" ] ; - coq.gref->path (const XYr) ["elpi", "tests", "test_API", "X", "Y" ] ; - coq.gref->path (const XYr) ["Top", "test_API", "X", "Y" ] ) -}}. - - -Elpi Query lp:{{ - std.do! [ - coq.env.begin-module-type "TA", - coq.env.add-axiom "z" {{nat}} _, - coq.env.add-axiom "i" {{Type}} _, - coq.env.end-module-type MP_TA, - coq.env.begin-module "A" (some MP_TA), - coq.env.add-const "x" {{3}} _ _ _, - coq.env.begin-module "B" none, - coq.env.add-const "y" {{3}} _ _ GRy, - coq.env.end-module _, - coq.env.add-const "z" (global (const GRy)) _ _ _, - coq.env.add-indt (inductive "i1" _ (arity {{Type}}) i\ []) I, - coq.env.add-const "i" (global (indt I)) _ _ _, % silly limitation in Coq - coq.env.end-module MP, - coq.env.module MP L - %coq.env.module-type MP_TA [TAz,TAi] % name is broken wrt =, don't use it! - ] -}}. -Print A. -Check A.z. -Check A.i. -Print A.i. -Fail Check A.i1_ind. - -Elpi Query lp:{{ - std.do! [ - coq.env.begin-module-type "TF", - coq.env.add-axiom "w" {{nat}} _, - coq.env.end-module-type MP_TF, - coq.locate-module-type "TA" MP_TA, - coq.env.begin-module-functor "F" (some MP_TF) [pr "a" MP_TA, pr "b" MP_TA], - coq.env.import-module {coq.locate-module "a"}, - coq.env.add-const "w" (global {coq.locate "z"}) _ _ _, - coq.env.end-module _ - ] -}}. -Print F. -Module B := F A A. -Print B. -Print B.w. - -Elpi Query lp:{{ - std.do! [ - coq.locate-module-type "TA" MP_TA, - coq.env.begin-module-type-functor "TB" [pr "A" MP_TA], - coq.env.end-module-type _ - ] -}}. -Print TB. - -Elpi Query lp:{{ - coq.env.begin-module "IA" none, - coq.env.include-module {coq.locate-module "A"} _, - coq.env.end-module _. -}}. - -Print IA. - -Module Tmp. -Elpi Query lp:{{ coq.env.import-module { coq.locate-module "IA" } }}. -Check i. -End Tmp. - -Elpi Query lp:{{ - coq.env.begin-module-type "ITA", - coq.env.include-module-type {coq.locate-module-type "TA"} (coq.inline.at 2), - coq.env.end-module-type _. -}}. - -Print ITA. - -(* section *) - -Section SA. -Unset Auto Template Polymorphism. -Variable a : nat. -Inductive ind := K. -Section SB. -Variable b : nat. -Let c := b. -Elpi Query lp:{{ - coq.env.section [CA, CB, CC], - coq.locate "a" (const CA), - coq.locate "b" (const CB), - coq.locate "c" (const CC), - coq.env.const CC (some (global (const CB))) _, - coq.env.add-section-variable "d" {{ nat }} _, - coq.env.add-section-variable "d1" {{ nat }} _, - @local! => coq.env.add-const "e" {{ 3 }} {{ nat }} _ _. -}}. -About d. -Definition e2 := e. -End SB. -Fail Check d. -Fail Check d1. -Check eq_refl : e2 = 3. -End SA. - -Elpi Query lp:{{ - coq.env.begin-section "Foo", - coq.env.add-section-variable "x" {{ nat }} X, - coq.env.section [X], - coq.env.add-const "fx" (global (const X)) _ _ _, - coq.env.end-section. -}}. - -Check fx : nat -> nat. - -Elpi Query lp:{{ - coq.env.add-const "opaque_3" {{ 3 }} _ @opaque! _ -}}. - -About opaque_3. - -Fail Elpi Query lp:{{ - coq.env.add-const "opaque_illtyped" {{ 3 3 }} _ @opaque! _ -}}. -Fail Elpi Query lp:{{ - coq.env.add-const "opaque_illtyped" {{ S True }} _ @opaque! _ -}}. - -(****** typecheck **********************************) - -Require Import List. - -Elpi Query lp:{{ - coq.locate "cons" GRCons, Cons = global GRCons, - coq.locate "nil" GRNil, Nil = global GRNil, - coq.locate "nat" GRNat, Nat = global GRNat, - coq.locate "O" GRZero, Zero = global GRZero, - coq.locate "list" GRList, List = global GRList, - L = app [ Cons, _, Zero, app [ Nil, _ ]], - LE = app [ Cons, Nat, Zero, app [ Nil, Nat ]], - coq.typecheck L (app [ List, Nat ]) ok. -}}. - -Definition nat1 := nat. - -Elpi Query lp:{{ coq.typecheck {{ 1 }} {{ nat1 }} ok }}. - -Definition list1 := list. - -Elpi Query lp:{{ coq.typecheck {{ 1 :: nil }} {{ list1 lp:T }} ok, coq.say T }}. - -Elpi Query lp:{{ coq.typecheck-ty {{ nat }} (typ U) ok, coq.say U }}. - -Elpi Query lp:{{ coq.typecheck-ty {{ nat }} prop (error E), coq.say E }}. - - -(****** TC **********************************) - -Require Import Classes.RelationClasses. - -Axiom T : Type. -Axiom R : T -> T -> Prop. -Axiom Rr : forall x : T, R x x. - -Definition myi : Reflexive R. -Proof. -exact Rr. -Defined. - -Check (_ : Reflexive R). - -Elpi Query lp:{{coq.locate "myi" GR, coq.TC.declare-instance GR 10. }}. - -Check (_ : Reflexive R). - -Elpi Query lp:{{coq.TC.db L}}. -Elpi Query lp:{{coq.locate "RewriteRelation" GR, coq.TC.db-for GR L}}. -Elpi Query lp:{{coq.locate "RewriteRelation" GR, coq.TC.class? GR}}. -Elpi Query lp:{{coq.locate "True" GR, not(coq.TC.class? GR)}}. - -Axiom C : Type -> Type. - -Elpi Query lp:{{ coq.TC.declare-class {{:gref C }} }}. - -Axiom c : C nat. - -#[local] Instance foox : C nat := c. - -(****** CS **********************************) - -Structure eq := mk_eq { carrier : Type; eq_op : carrier -> carrier -> bool; _ : nat }. - -Axiom W : Type. -Axiom Z : W -> W -> bool. -Axiom t : W. - -Definition myc : eq := mk_eq W Z 3. - -Fail Check (eq_op _ t t). - -Elpi Query lp:{{coq.locate "myc" GR, coq.CS.declare-instance GR.}}. - -Check (eq_op _ t t). - -Elpi Query lp:{{ coq.CS.db L }}. - -Elpi Query lp:{{ - coq.locate "eq" (indt I), - coq.env.projections I [some P1, some P2, none], - coq.locate "carrier" (const P1), - coq.locate "eq_op" (const P2) -}}. - -Axiom W1 : Type. -Axiom Z1 : W1 -> W1 -> bool. -Axiom t1 : W1. - -Definition myc1 : eq := mk_eq W1 Z1 3. - -Section CStest. -Elpi Query lp:{{ coq.locate "myc1" GR, @local! => coq.CS.declare-instance GR. }}. - -Check (eq_op _ t1 t1). - -Elpi Query lp:{{ coq.locate "eq_op" P, coq.CS.db-for P _ [_,_] }}. - -Elpi Query lp:{{ coq.locate "W" W, coq.CS.db-for _ (cs-gref W) [_] }}. - -Elpi Query lp:{{ coq.locate "eq_op" P, coq.locate "Z1" W, coq.CS.db-for P (cs-gref W) L, coq.say L, L = [cs-instance P (cs-gref W) {{:gref myc1}}] }}. - -Elpi Query lp:{{ coq.locate "eq_op" P, coq.locate "nat" W, coq.CS.db-for P (cs-gref W) [] }}. - - -End CStest. - -Fail Check (eq_op _ t1 t1). - - -(****** Coercions **********************************) - -Axiom C1 : Type. -Axiom C2 : Type. -Axiom c12 : C1 -> C2. -Axiom c1t : C1 -> Type. -Axiom c1f : C1 -> nat -> nat. - -Elpi Query lp:{{ - coq.locate "c12" GR1, - coq.locate "c1t" GR2, - coq.locate "c1f" GR3, - coq.locate "C1" C1, - % coq.locate "C2" C2, - @global! => coq.coercion.declare (coercion GR1 _ _ _), - @global! => coq.coercion.declare (coercion GR2 _ C1 sortclass), - @global! => coq.coercion.declare (coercion GR3 _ C1 funclass). -}}. - -Check (fun x : C1 => (x : C2)). -Check (fun x : C1 => fun y : x => true). -Check (fun x : C1 => x 3). - -Elpi Query lp:{{coq.coercion.db L}}. - -(***** Syndef *******************************) - -Elpi Query lp:{{ - coq.notation.add-abbreviation "abbr" 2 - {{ fun x _ => x = x }} tt A, - coq.say A -}}. - -About abbr. -Check abbr 4 3. - -Elpi Query lp:{{ - coq.notation.add-abbreviation "abbr2" 1 - {{ fun x _ => x = x }} tt _ -}}. - -About abbr2. -Check abbr2 2 3. - -Elpi Query lp:{{ - coq.notation.abbreviation {coq.locate-abbreviation "abbr2"} [{{ fun x => x }}] T, - coq.say T. -}}. - -Elpi Query lp:{{ - coq.notation.abbreviation-body {coq.locate-abbreviation "abbr2"} 1 - (fun _ _ x\ fun _ _ _\ app[_,_,x,x]). -}}. - -(***** Impargs *******************************) - -Module X2. - -Axiom imp : forall T (x:T), x = x -> Prop. -Arguments imp {_} [_] _ , [_] _ _ . - -Elpi Query lp:{{ - coq.locate "imp" I, - coq.arguments.implicit I - [[maximal,implicit,explicit], [implicit,explicit,explicit]], - @global! => coq.arguments.set-implicit I - [[]], - coq.arguments.implicit I - [[explicit,explicit,explicit]] -}}. -End X2. -About X2.imp. - -Module X3. -Definition foo (T : Type) (x : T) := x. -Arguments foo : clear implicits. - -Fail Check foo 3. - -Elpi Query lp:{{ - @global! => coq.arguments.set-default-implicit {coq.locate "foo"} -}}. - -Check foo 3. - -End X3. - - -(***** Argnames/scopes/simpl *******************************) - -Definition f T (x : T) := x = x. - -Elpi Query lp:{{ - coq.arguments.set-name {coq.locate "f"} [some "S"], - coq.arguments.name {coq.locate "f"} [some "S"], - coq.arguments.set-implicit {coq.locate "f"} [[implicit]], - coq.arguments.set-scope {coq.locate "f"} [some "type"], - coq.arguments.scope {coq.locate "f"} [some "type_scope"] -}}. -About f. -Check f (S:= bool * bool). - -Elpi Query lp:{{ - coq.arguments.set-simplification {coq.locate "f"} (when [] (some 1)) -}}. -About f. -Check f (S:= bool * bool). -Eval simpl in f (S := bool). (***** Univs *******************************) @@ -791,11 +74,11 @@ Elpi Query lp:{{coq.univ.print}}. Elpi Query lp:{{coq.univ.new [] X}}. Elpi Query lp:{{coq.univ.leq X Y}}. Elpi Query lp:{{coq.univ.eq X Y}}. -Elpi Query lp:{{coq.univ.max X Y Z}}. +Elpi Query lp:{{coq.univ.pts-triple X Y Z}}. Elpi Query lp:{{coq.univ.sup X Y}}. -(***** Univs *******************************) +(********* accumulate *************** *) Elpi Db test.db lp:{{type foo string -> prop.}}. Elpi Command test.use.db. @@ -819,7 +102,6 @@ Import test_db_accumulate. Elpi Query lp:{{foo "there"}}. Module xx := test_db_accumulate. -(********* accumulate *************** *) Elpi Db test2.db lp:{{ type foo gref -> prop. @@ -851,48 +133,6 @@ Elpi test2.use.db 1. Section T3. Fail Elpi Db test3.db lp:{{ }}. End T3. Module T3. Fail Elpi Db test3.db lp:{{ }}. End T3. -(********* export *************** *) - -Elpi Command export.me. -Elpi Accumulate lp:{{ main A :- coq.say "hello" A. }}. -Elpi Typecheck. - -Elpi Export export.me. - -export.me 1 2 (nat) "x". - -(************* halt ********************) - -Elpi Command halt. -Elpi Accumulate lp:{{ - main _ :- std.assert! (3 = 2) "ooops". -}}. -Fail Elpi halt. - -(**********************************************) - -Elpi Command test.pp. -Elpi Accumulate lp:{{ -main _ :- std.do! [ - P = coq.pp.box (coq.pp.hv 2) [coq.pp.str "Module", coq.pp.spc, coq.pp.str "Foo", coq.pp.spc, coq.pp.str":=", coq.pp.brk 1 0, coq.pp.str "body", coq.pp.spc, coq.pp.str "End Foo."], - coq.say P, - @ppwidth! 15 => coq.say {coq.pp->string P}, - @ppall! => coq.say {coq.term->string {{ fix foo x y {struct x} := match x in bool with false => y | true => 3 end }} }, - @ppmost! => coq.say {coq.term->string {{ fix foo x y {struct x} := match x in bool with false => y | true => 3 end }} }, -]. -}}. -Elpi Typecheck. -Elpi test.pp. - -(************* using ********************) -Section Using. -Variable A : bool. -Elpi Query lp:{{ coq.env.add-const "foo" {{ 3 }} {{ nat }} @transparent! _ }}. -Elpi Query lp:{{ @using! "All" => coq.env.add-const "bar" {{ 3 }} {{ nat }} @transparent! _ }}. -End Using. -Check foo : nat. -Check bar : bool -> nat. - (* scope grafted clauses, again and across files *) Elpi Db global.db lp:{{ @@ -959,9 +199,45 @@ Import Box.ClausesC. Elpi declare.test "mem" "BOX.ClausesC". Elpi declare.test "length" 3. +(********* options ************) Elpi Query lp:{{ % see test_API.v coq.option.add ["Foo", "Bar"] (coq.option.string (some "x")) tt }}. + + +(********* export *************** *) + +Elpi Command export.me. +Elpi Accumulate lp:{{ main A :- coq.say "hello" A. }}. +Elpi Typecheck. + +Elpi Export export.me. + +export.me 1 2 (nat) "x". + +(************* halt ********************) + +Elpi Command halt. +Elpi Accumulate lp:{{ + main _ :- std.assert! (3 = 2) "ooops". +}}. +Fail Elpi halt. + +(**********************************************) + +Elpi Command test.pp. +Elpi Accumulate lp:{{ +main _ :- std.do! [ + P = coq.pp.box (coq.pp.hv 2) [coq.pp.str "Module", coq.pp.spc, coq.pp.str "Foo", coq.pp.spc, coq.pp.str":=", coq.pp.brk 1 0, coq.pp.str "body", coq.pp.spc, coq.pp.str "End Foo."], + coq.say P, + @ppwidth! 15 => coq.say {coq.pp->string P}, + @ppall! => coq.say {coq.term->string {{ fix foo x y {struct x} := match x in bool with false => y | true => 3 end }} }, + @ppmost! => coq.say {coq.term->string {{ fix foo x y {struct x} := match x in bool with false => y | true => 3 end }} }, +]. +}}. +Elpi Typecheck. +Elpi test.pp. + diff --git a/tests/test_API2.v b/tests/test_API2.v index 350687046..c806f95bb 100644 --- a/tests/test_API2.v +++ b/tests/test_API2.v @@ -71,9 +71,9 @@ main X :- coq.error "not a primitive-value" X. }}. Elpi Typecheck. -From Coq Require Import PrimFloat Int63. +From Coq Require Import PrimFloat Uint63. -Open Scope int63_scope. +Open Scope uint63_scope. Elpi pv (1). Fail Elpi pv (4611686018427387904). (* max_int + 1 *) diff --git a/tests/test_API_TC_CS.v b/tests/test_API_TC_CS.v new file mode 100644 index 000000000..5a5ee4643 --- /dev/null +++ b/tests/test_API_TC_CS.v @@ -0,0 +1,111 @@ +From elpi Require Import elpi. + +Elpi Command TCCS. + +(****** TC **********************************) + +Require Import Classes.RelationClasses. + +Axiom T : Type. +Axiom R : T -> T -> Prop. +Axiom Rr : forall x : T, R x x. + +Definition myi : Reflexive R. +Proof. +exact Rr. +Defined. + +Check (_ : Reflexive R). + +Elpi Query lp:{{coq.locate "myi" GR, coq.TC.declare-instance GR 10. }}. + +Check (_ : Reflexive R). + +Elpi Query lp:{{coq.TC.db L}}. +Elpi Query lp:{{coq.locate "RewriteRelation" GR, coq.TC.db-for GR L}}. +Elpi Query lp:{{coq.locate "RewriteRelation" GR, coq.TC.class? GR}}. +Elpi Query lp:{{coq.locate "True" GR, not(coq.TC.class? GR)}}. + +Axiom C : Type -> Type. + +Elpi Query lp:{{ coq.TC.declare-class {{:gref C }} }}. + +Axiom c : C nat. + +#[local] Instance foox : C nat := c. + +(****** CS **********************************) + +Structure eq := mk_eq { carrier : Type; eq_op : carrier -> carrier -> bool; _ : nat }. + +Axiom W : Type. +Axiom Z : W -> W -> bool. +Axiom t : W. + +Definition myc : eq := mk_eq W Z 3. + +Fail Check (eq_op _ t t). + +Elpi Query lp:{{coq.locate "myc" GR, coq.CS.declare-instance GR.}}. + +Check (eq_op _ t t). + +Elpi Query lp:{{ coq.CS.db L }}. + +Elpi Query lp:{{ + coq.locate "eq" (indt I), + coq.env.projections I [some P1, some P2, none], + coq.locate "carrier" (const P1), + coq.locate "eq_op" (const P2) +}}. + +Axiom W1 : Type. +Axiom Z1 : W1 -> W1 -> bool. +Axiom t1 : W1. + +Definition myc1 : eq := mk_eq W1 Z1 3. + +Section CStest. +Elpi Query lp:{{ coq.locate "myc1" GR, @local! => coq.CS.declare-instance GR. }}. + +Check (eq_op _ t1 t1). + +Elpi Query lp:{{ coq.locate "eq_op" P, coq.CS.db-for P _ [_,_] }}. + +Elpi Query lp:{{ coq.locate "W" W, coq.CS.db-for _ (cs-gref W) [_] }}. + +Elpi Query lp:{{ coq.locate "eq_op" P, coq.locate "Z1" W, coq.CS.db-for P (cs-gref W) L, coq.say L, L = [cs-instance P (cs-gref W) {{:gref myc1}}] }}. + +Elpi Query lp:{{ coq.locate "eq_op" P, coq.locate "nat" W, coq.CS.db-for P (cs-gref W) [] }}. + + +End CStest. + +Fail Check (eq_op _ t1 t1). + + +(****** Coercions **********************************) + +Axiom C1 : Type. +Axiom C2 : Type. +Axiom c12 : C1 -> C2. +Axiom c1t : C1 -> Type. +Axiom c1f : C1 -> nat -> nat. + +Elpi Query lp:{{ + coq.locate "c12" GR1, + coq.locate "c1t" GR2, + coq.locate "c1f" GR3, + coq.locate "C1" C1, + % coq.locate "C2" C2, + @global! => coq.coercion.declare (coercion GR1 _ _ _), + @global! => coq.coercion.declare (coercion GR2 _ C1 sortclass), + @global! => coq.coercion.declare (coercion GR3 _ C1 funclass). +}}. + +Check (fun x : C1 => (x : C2)). +Check (fun x : C1 => fun y : x => true). +Check (fun x : C1 => x 3). + +Elpi Query lp:{{coq.coercion.db L}}. + diff --git a/tests/test_API_arguments.v b/tests/test_API_arguments.v new file mode 100644 index 000000000..e2bef4c3b --- /dev/null +++ b/tests/test_API_arguments.v @@ -0,0 +1,58 @@ +From elpi Require Import elpi. + +Elpi Command arguments. + +(***** Impargs *******************************) + +Module X2. + +Axiom imp : forall T (x:T), x = x -> Prop. +Arguments imp {_} [_] _ , [_] _ _ . + +Elpi Query lp:{{ + coq.locate "imp" I, + coq.arguments.implicit I + [[maximal,implicit,explicit], [implicit,explicit,explicit]], + @global! => coq.arguments.set-implicit I + [[]], + coq.arguments.implicit I + [[explicit,explicit,explicit]] +}}. +End X2. +About X2.imp. + +Module X3. +Definition foo (T : Type) (x : T) := x. +Arguments foo : clear implicits. + +Fail Check foo 3. + +Elpi Query lp:{{ + @global! => coq.arguments.set-default-implicit {coq.locate "foo"} +}}. + +Check foo 3. + +End X3. + + +(***** Argnames/scopes/simpl *******************************) + +Definition f T (x : T) := x = x. + +Elpi Query lp:{{ + coq.arguments.set-name {coq.locate "f"} [some "S"], + coq.arguments.name {coq.locate "f"} [some "S"], + coq.arguments.set-implicit {coq.locate "f"} [[implicit]], + coq.arguments.set-scope {coq.locate "f"} [some "type"], + coq.arguments.scope {coq.locate "f"} [some "type_scope"] +}}. +About f. +Check f (S:= bool * bool). + +Elpi Query lp:{{ + coq.arguments.set-simplification {coq.locate "f"} (when [] (some 1)) +}}. +About f. +Check f (S:= bool * bool). +Eval simpl in f (S := bool). diff --git a/tests/test_API_elaborate.v b/tests/test_API_elaborate.v new file mode 100644 index 000000000..6fed5bf8f --- /dev/null +++ b/tests/test_API_elaborate.v @@ -0,0 +1,173 @@ +From elpi Require Import elpi. + +Elpi Command elaborate. + +(****** elaborate *******************************) +Axiom T1 : Type. +Axiom T2 : nat -> Type. +Axiom T3 : nat -> Type. + +Axiom f1 : T1 -> Type. +Axiom f3 : forall b, T3 b -> Type. + +Axiom g1 : T1 -> nat -> nat. +Axiom g3 : forall b, T3 b -> nat -> nat. + +Axiom h : forall n , T2 n -> T3 n. + +Coercion f1 : T1 >-> Sortclass. +Coercion f3 : T3 >-> Sortclass. +Coercion g1 : T1 >-> Funclass. +Coercion g3 : T3 >-> Funclass. +Coercion h : T2 >-> T3. + +Elpi Query lp:{{ + + std.assert-ok! (coq.elaborate-skeleton {{ fun n (t : T2 n) (x : t) => t 3 }} TY E) "that was easy", + coq.env.add-const "elab_1" E TY tt _ + +}}. + +Class foo (n : nat). +Definition bar n {f : foo n} := n = n. +#[local] Instance xxx : foo 3. Defined. + +Elpi Query lp:{{ + + std.assert-ok! (coq.elaborate-ty-skeleton {{ bar _ }} TY E) "that was easy", + coq.env.add-const "elab_2" E (sort TY) tt _ + +}}. + +Structure s := { field : Type; #[canonical=no] op : field -> field; }. +Canonical c := {| field := nat; op := (fun x => x) |}. + +Elpi Query lp:{{ + + std.assert-ok! (coq.elaborate-skeleton {{ op _ 3 }} TY E) "that was easy", + coq.env.add-const "elab_3" E TY tt _ + +}}. + +(* #[arguments(raw)] *) +Elpi Command test.API2. + +Elpi Accumulate lp:{{ + main [indt-decl D] :- coq.say "raw:" D, + std.assert-ok! (coq.elaborate-indt-decl-skeleton D D1) "illtyped", + coq.env.add-indt D1 I, + coq.env.indt-decl I D2, coq.say "elab:" D2. + main [const-decl N (some BO) TYA] :- std.do! [ + coq.arity->term TYA TY, + std.assert-ok! (coq.elaborate-ty-skeleton TY _ TY1) "illtyped", + std.assert-ok! (coq.elaborate-skeleton BO TY1 BO1) "illtyped", + coq.env.add-const N BO1 TY1 @transparent! _, + ]. +}}. +Elpi Typecheck. + +Elpi test.API2 Inductive ind1 (A : T1) | (B : Type) := + K1 : ind1 B -> ind1 B | K2 : A -> ind1 B | K3 (a : A) : ind1 B. + +(* + +parameter A explicit (global (const «T1»)) c0 \ + inductive ind1 tt + (parameter B explicit (sort (typ X0)) c1 \ arity (sort (typ X1))) c1 \ + [constructor K1 + (parameter B explicit (sort (typ X2)) c2 \ + arity (prod `_` (app [c1, c2]) c3 \ app [c1, c2])), + constructor K2 + (parameter B explicit (sort (typ X3)) c2 \ + arity (prod `_` c0 c3 \ app [c1, c2])), + constructor K3 + (parameter B explicit (sort (typ X4)) c2 \ + arity (prod `a` c0 c3 \ app [c1, c2]))] +0 out of (_ : _UNBOUND_REL_3 _UNBOUND_REL_2 _UNBOUND_REL_1) +0 out of (_ : _UNBOUND_REL_2) +0 out of (_ : _UNBOUND_REL_2) +(A : T1) (B : Type) |- Type + |- (_UNBOUND_REL_3 _UNBOUND_REL_2 _UNBOUND_REL_1 -> + _UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) + |- (_UNBOUND_REL_2 -> _UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) + |- (_UNBOUND_REL_2 -> _UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) +all params = 2, uniform params = 2 +parameter A explicit (global (const «T1»)) c0 \ + parameter B explicit (sort (typ «test_API.23)»)) c1 \ + inductive ind1 tt (arity (sort (typ «test_API.25)»))) c2 \ + [constructor K1 (arity (prod `_` c2 c3 \ c2)), + constructor K2 + (arity (prod `_` (app [global (const «f1»), c0]) c3 \ c2)), + constructor K3 + (arity (prod `_` (app [global (const «f1»), c0]) c3 \ c2))] + + + +elab + +(A : T1) (B : Type) |- Type +(_ : _UNBOUND_REL_3 _UNBOUND_REL_2 _UNBOUND_REL_1) |- (_UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) +(_ : _UNBOUND_REL_2) |- (_UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) +(a : _UNBOUND_REL_2) |- (_UNBOUND_REL_4 _UNBOUND_REL_3 _UNBOUND_REL_2) +all params = 2, uniform params = 1 +parameter A explicit (global (const «T1»)) c0 \ + inductive ind1 tt + (parameter B explicit (sort (typ «test_API.20)»)) c1 \ + arity (sort (typ «test_API.4))»))) c1 \ + [constructor K1 + (parameter _ explicit (app [,, c0, c1]) c2 \ + arity (app [c2, (fun `_` (sort prop) c3 \ c1), c0])), + constructor K2 + (parameter _ explicit (app [global (const «f1»), c0]) c2 \ + arity (app [c2, (fun `_` (sort prop) c3 \ c1), c0])), + constructor K3 + (parameter a explicit (app [global (const «f1»), c0]) c2 \ + arity (app [c2, (fun `_` (sort prop) c3 \ c1), c0]))] +File "./tests/test_API.v", line 123, characters 0-120: +Error: +wrong constant:, + +*) + + +Elpi test.API2 Record ind2 (A : T1) := { + fld1 : A; + fld2 : fld1 = fld1; +}. + +Elpi test.API2 Record ind3 := { + fld3 :> Type; + fld4 : forall x : fld3, x = x; +}. + +Check (forall x : ind3, x -> Prop). + +Elpi test.API2 Definition def1 A := fun x : A => x. + +Elpi Query lp:{{ + + std.assert-ok! (coq.elaborate-skeleton {{ op lib:elpi.hole 3 }} TY E) "that was easy 2", + coq.env.add-const "elab_4" E TY tt _ + +}}. + +Elpi Tactic test. +Elpi Accumulate lp:{{ +solve _ _ :- + coq.term->string X S, + X = global (indc Y), + coq.say S. +}}. +Goal True. +Fail elpi test. +Abort. + +Elpi Tactic test2. +Elpi Accumulate lp:{{ +solve _ _ :- + coq.term->string (global (indc Y)) S, + coq.say S. +}}. +Goal True. +elpi test2. +Abort. diff --git a/tests/test_API_env.v b/tests/test_API_env.v new file mode 100644 index 000000000..65be303a8 --- /dev/null +++ b/tests/test_API_env.v @@ -0,0 +1,303 @@ +From elpi Require Import elpi. +From Coq Require Vector. + +(****** env **********************************) +Elpi Command test. + +(* constant *) + +Elpi Query lp:{{ + coq.locate "plus" (const GR), + coq.env.const GR (some BO) TY, + coq.locate "nat" GRNat, Nat = global GRNat, + coq.locate "S" GRSucc, Succ = global GRSucc, + TY = (prod _ Nat _\ prod _ Nat _\ Nat), + BO = (fix _ 0 TY add\ + fun _ Nat n\ fun _ Nat m\ + match n (fun _ Nat _\ Nat) + [ m + , fun _ Nat w\ app[Succ, app[add,w,m]]]). +}}. + +Axiom empty_nat : nat. + +Elpi Query lp:{{ + coq.locate "empty_nat" (const GR), + coq.env.const GR none TY. +}}. + +Section Test. + +Variable A : nat. + +Elpi Query lp:{{ + coq.locate "Vector.nil" GR1, + coq.locate "nat" GR2, + coq.locate "A" GR3, + coq.env.typeof GR1 _, + coq.env.typeof GR2 _, + coq.env.typeof GR3 _. +}}. + +End Test. + +Elpi Query lp:{{ + coq.locate "plus" (const GR), + coq.env.const GR (some BO) TY, + coq.gref->id (const GR) S, + Name is S ^ "_equal", + coq.env.add-const Name BO TY @opaque! NGR, + coq.env.opaque? NGR, + coq.env.const NGR none _, coq.say {coq.gref->id (const NGR)}, + coq.env.const-body NGR (some BO), + rex_match "add_equal" {coq.gref->id (const NGR)}. +}}. + +About add_equal. + +(* axiom *) + +Elpi Query lp:{{ + coq.locate "False" F, + coq.env.add-axiom "myfalse" (global F) GR, + coq.env.opaque? GR, + coq.env.const GR none _, + coq.env.const-body GR none, + coq.say GR. +}}. + +Check myfalse. + +(* record *) + +Set Printing Universes. +Elpi Query lp:{{ + DECL = + (parameter "T" _ {{Type}} t\ + record "eq_class" {{Type}} "mk_eq_class" ( + field [canonical ff, coercion tt] "eq_f" {{bool}} f\ + field _ "eq_proof" {{lp:f = lp:f :> bool}} _\ + end-record)), + coq.say DECL, + coq.env.add-indt DECL GR. +}}. + +Print eq_class. +Check (fun x : eq_class nat => (x : bool)). +Axiom b : bool. +Axiom p : b = b. +Canonical xxx := mk_eq_class bool b p. +Print Canonical Projections. +Fail Check eq_refl _ : eq_f bool _ = b. + +Elpi Query lp:{{ + DECL = + (parameter "T" _ {{Type}} t\ + record "prim_eq_class" {{Type}} "mk_prim_eq_class" ( + field [canonical ff, coercion tt] "prim_eq_f" {{bool}} f\ + field _ "prim_eq_proof" {{lp:f = lp:f :> bool}} _\ + end-record)), + @primitive! => coq.env.add-indt DECL GR, + coq.env.projections GR [some _, some _]. +}}. + +(* primitive records have eta *) +Check fun r : prim_eq_class nat => + eq_refl _ : r = mk_prim_eq_class _ (prim_eq_f _ r) (prim_eq_proof _ r). + +Module II. +Arguments prim_eq_f : default implicits. +Elpi Query lp:{{ + coq.say {{ fun r : prim_eq_class nat => r.(prim_eq_f) }} +}}. + +Definition pc (r : prim_eq_class nat) := r.(prim_eq_f). + +Elpi Query lp:{{ + coq.locate "pc" (const C), + coq.env.const C (some (fun _ _ r\ app[primitive _, r])) _ +}}. + +Elpi Command primp. +Elpi Accumulate lp:{{ + main [const-decl _ (some (fun _ _ r\ app[primitive _, r])) _]. +}}. +Elpi primp Definition pc (r : prim_eq_class nat) := r.(prim_eq_f). + +End II. + +(* inductive *) + +Elpi Command indtest. +Elpi Accumulate lp:{{ +main _ :- + DECL = + (parameter "T" maximal {{Type}} t\ + parameter "x" _ t x\ + inductive "myind" _ (arity (prod `w` t _\ sort prop)) + i\ [ constructor "K1" + (arity (prod `y` t y\ prod _ (app[i,y]) _\app[i,x])) + , constructor "K2" + (arity (app[i,x])) + ] + ), + coq.env.add-indt DECL _, + coq.rename-indt-decl rename rename rename DECL DECL1, + coq.env.add-indt DECL1 _. + +pred rename i:id, o:id. +rename K S :- S is K ^ "1". +}}. +Elpi Query indtest lp:{{ main _ }}. + +Check myind true false : Prop. +Check K2 true : myind true true. +Check myind1 true false : Prop. +Check K21 true : myind1 true true. + +Elpi Query lp:{{ + coq.env.add-indt (parameter "X" _ {{Type}} x\ + inductive "nuind" _ (parameter "n" _ {{ nat }} _\ arity {{ bool -> Type }}) i\ + [constructor "k1" (parameter "n" _ {{nat}} n\ arity (app[i,n,{{true}}])) + ,constructor "k2" (parameter "n" _ {{nat}} n\ + arity (prod `x` (app[i,{{1}},{{false}}]) _\ + (app[i,n,{{false}}]))) + ]) _. +}}. + + +Check fun x : nuind nat 3 false => + match x in nuind _ _ b return @eq bool b b with + | k1 _ _ => (eq_refl : true = true) + | k2 _ _ x => (fun w : nuind nat 1 false => (eq_refl : false = false)) x + end. + +Fail Check fun x : nuind nat 3 false => + match x in nuind _ i_cannot_name_this b return @eq bool b b with + | k1 _ _ => (eq_refl : true = true) + | k2 _ _ x => (fun w : nuind nat 1 false => (eq_refl : false = false)) x + end. + +Elpi Query lp:{{ + pi x\ decl x `x` {{ nat }} => coq.typecheck x T ok, coq.say x T. +}}. + + +Elpi Query lp:{{ + D = (parameter "A" _ {{ Type }} a\ + inductive "tx" _ (parameter "y" _ {{nat}} _\ arity {{ bool -> Type }}) t\ + [ constructor "K1x" (parameter "y" _ {{nat}} y\ arity {{ + forall (x : lp:a) (n : nat) (p : @eq nat (S n) lp:y) (e : lp:t n true), + lp:t lp:y true }}) + , constructor "K2x" (parameter "y" _ {{nat}} y\ arity {{ + lp:t lp:y false }}) ]), + coq.typecheck-indt-decl D ok, + coq.env.add-indt D _. +}}. + +Module HOAS. + +Inductive ind1 (A : Type) (a : A) | (B : Type) (b : B) : forall C : Type, C -> Type := + | k1 : forall bb, ind1 (B * B)%type bb bool true -> ind1 B b unit tt + | k2 : ind1 B b nat 1. + +Elpi Query lp:{{ + + coq.locate "ind1" (indt I), + coq.env.indt-decl I D, + D1 = + (parameter "A" explicit (sort (typ UA)) c0 \ + parameter "a" explicit c0 c1 \ + inductive "ind1" tt + (parameter "B" explicit (sort (typ UB1)) c2 \ + parameter "b" explicit c2 c3 \ + arity + (prod `C` (sort (typ UC)) c4 \ prod `_` c4 c5 \ sort (typ U))) + c2 \ + [constructor "k1" + (parameter "B" explicit (sort (typ UB2)) c3 \ + parameter "b" explicit c3 c4 \ + arity + (prod `bb` {{ (lp:c3 * lp:c3)%type }} c5 \ + prod `_` (app [c2, {{ (lp:c3 * lp:c3)%type }}, c5, {{ bool }}, {{ true }}]) c6 \ + app [c2, c3, c4, {{ unit }}, {{ tt }}])), + constructor "k2" + (parameter "B" explicit (sort (typ UB3)) c3 \ + parameter "b" explicit c3 c4 \ + arity + (app [c2, c3, c4, {{ nat }}, {{ 1 }}]))]), + std.assert! (D = D1) "coq.env.indt-decl". + +}}. + +Arguments k1 A a B b [bb] _. + +Elpi Query lp:{{ + + coq.locate "ind1" (indt I), + coq.env.indt-decl I D, + D1 = + (parameter "A" explicit (sort (typ UA)) c0 \ + parameter "a" explicit c0 c1 \ + inductive "ind1" tt + (parameter "B" explicit (sort (typ UB1)) c2 \ + parameter "b" explicit c2 c3 \ + arity + (prod `C` (sort (typ UC)) c4 \ prod `_` c4 c5 \ sort (typ U))) + c2 \ + [constructor "k1" + (parameter "B" explicit (sort (typ UB2)) c3 \ + parameter "b" explicit c3 c4 \ + parameter "bb" implicit {{ (lp:c3 * lp:c3)%type }} c5 \ + arity + (prod `_` (app [c2, {{ (lp:c3 * lp:c3)%type }}, c5, {{ bool }}, {{ true }}]) c6 \ + app [c2, c3, c4, {{ unit }}, {{ tt }}])), + constructor "k2" + (parameter "B" explicit (sort (typ UB3)) c3 \ + parameter "b" explicit c3 c4 \ + arity + (app [c2, c3, c4, {{ nat }}, {{ 1 }}]))]), + std.assert! (D = D1) "coq.env.indt-decl + implicits". +}}. + +Record r1 (P : Type) (p : P) : Type := mk_r1 { + f1 :> P -> P; + #[canonical=no] f2 : p = f1 p; +}. + +Elpi Query lp:{{ + + coq.locate "r1" (indt I), + coq.env.indt-decl I D, + D1 = + (parameter "P" explicit (sort (typ UP)) c0 \ + parameter "p" explicit c0 c1 \ + record "r1" (sort (typ UR)) "mk_r1" + (field [coercion tt, canonical tt] "f1" {{ lp:c0 -> lp:c0 }} c2\ + field [coercion ff, canonical ff] "f2" {{ @eq lp:c0 lp:c1 (lp:c2 lp:c1) }} c3\ + end-record) + ), + std.assert! (D = D1) "coq.env.indt-decl + record". + +}}. + +#[nonuniform] Coercion f2 : r1 >-> eq. + +Elpi Query lp:{{ + + coq.locate "r1" (indt I), + coq.env.indt-decl I D, + D1 = + (parameter "P" explicit (sort (typ UP)) c0 \ + parameter "p" explicit c0 c1 \ + record "r1" (sort (typ UR)) "mk_r1" + (field [coercion tt, canonical tt] "f1" {{ lp:c0 -> lp:c0 }} c2\ + field [coercion tt, canonical ff] "f2" {{ @eq lp:c0 lp:c1 (lp:c2 lp:c1) }} c3\ + end-record) + ), + std.assert! (D = D1) "coq.env.indt-decl + record". + +}}. + + +End HOAS. diff --git a/tests/test_API_module.v b/tests/test_API_module.v new file mode 100644 index 000000000..28dbba347 --- /dev/null +++ b/tests/test_API_module.v @@ -0,0 +1,112 @@ +From elpi Require Import elpi. + +Elpi Command modules. + +(* module *) + +Elpi Query lp:{{ coq.locate-module "Datatypes" MP, coq.env.module MP L }}. + +Module X. + Unset Auto Template Polymorphism. + Inductive i := . + Definition d := i. + Module Y. + Inductive i := . + Definition d := i. + End Y. +End X. + +Elpi Query lp:{{ + coq.locate-module "X" MP, + coq.env.module MP [ + (indt Xi), (const _), (const _), (const _), (const _), + (const _), + (indt XYi), (const XYr), (const _), (const _), (const _), + (const _) + ], + coq.say {coq.gref->string (indt Xi)}, + rex_match "\\(Top.\\|.*test_API_module\\)\\.X\\.i$" {coq.gref->string (indt Xi)}, + rex_match "\\(Top.\\|.*test_API_module\\)\\.X\\.Y\\.i$" {coq.gref->string (indt XYi)}, + (coq.gref->path (indt XYi) ["test_API_module", "X", "Y" ] ; + coq.gref->path (indt XYi) ["elpi", "tests", "test_API_module", "X", "Y" ] ; + coq.gref->path (indt XYi) ["Top", "test_API_module", "X", "Y" ]), + coq.say {coq.gref->path (indt XYi)}, + coq.say {coq.gref->path (const XYr)}, + (coq.gref->path (const XYr) ["test_API_module", "X", "Y" ] ; + coq.gref->path (const XYr) ["elpi", "tests", "test_API_module", "X", "Y" ] ; + coq.gref->path (const XYr) ["Top", "test_API_module", "X", "Y" ] ) +}}. + + +Elpi Query lp:{{ + std.do! [ + coq.env.begin-module-type "TA", + coq.env.add-axiom "z" {{nat}} _, + coq.env.add-axiom "i" {{Type}} _, + coq.env.end-module-type MP_TA, + coq.env.begin-module "A" (some MP_TA), + coq.env.add-const "x" {{3}} _ _ _, + coq.env.begin-module "B" none, + coq.env.add-const "y" {{3}} _ _ GRy, + coq.env.end-module _, + coq.env.add-const "z" (global (const GRy)) _ _ _, + coq.env.add-indt (inductive "i1" _ (arity {{Type}}) i\ []) I, + coq.env.add-const "i" (global (indt I)) _ _ _, % silly limitation in Coq + coq.env.end-module MP, + coq.env.module MP L + %coq.env.module-type MP_TA [TAz,TAi] % name is broken wrt =, don't use it! + ] +}}. +Print A. +Check A.z. +Check A.i. +Print A.i. +Fail Check A.i1_ind. + +Elpi Query lp:{{ + std.do! [ + coq.env.begin-module-type "TF", + coq.env.add-axiom "w" {{nat}} _, + coq.env.end-module-type MP_TF, + coq.locate-module-type "TA" MP_TA, + coq.env.begin-module-functor "F" (some MP_TF) [pr "a" MP_TA, pr "b" MP_TA], + coq.env.import-module {coq.locate-module "a"}, + coq.env.add-const "w" (global {coq.locate "z"}) _ _ _, + coq.env.end-module _ + ] +}}. +Print F. +Module B := F A A. +Print B. +Print B.w. + +Elpi Query lp:{{ + std.do! [ + coq.locate-module-type "TA" MP_TA, + coq.env.begin-module-type-functor "TB" [pr "A" MP_TA], + coq.env.end-module-type _ + ] +}}. +Print TB. + +Elpi Query lp:{{ + coq.env.begin-module "IA" none, + coq.env.include-module {coq.locate-module "A"} _, + coq.env.end-module _. +}}. + +Print IA. + +Module Tmp. +Elpi Query lp:{{ coq.env.import-module { coq.locate-module "IA" } }}. +Check i. +End Tmp. + +Elpi Query lp:{{ + coq.env.begin-module-type "ITA", + coq.env.include-module-type {coq.locate-module-type "TA"} (coq.inline.at 2), + coq.env.end-module-type _. +}}. + +Print ITA. + diff --git a/tests/test_API_notations.v b/tests/test_API_notations.v new file mode 100644 index 000000000..2d3dc8869 --- /dev/null +++ b/tests/test_API_notations.v @@ -0,0 +1,33 @@ +From elpi Require Import elpi. + +Elpi Command notations. + +(***** Syndef *******************************) + +Elpi Query lp:{{ + coq.notation.add-abbreviation "abbr" 2 + {{ fun x _ => x = x }} tt A, + coq.say A +}}. + +About abbr. +Check abbr 4 3. + +Elpi Query lp:{{ + coq.notation.add-abbreviation "abbr2" 1 + {{ fun x _ => x = x }} tt _ +}}. + +About abbr2. +Check abbr2 2 3. + +Elpi Query lp:{{ + coq.notation.abbreviation {coq.locate-abbreviation "abbr2"} [{{ fun x => x }}] T, + coq.say T. +}}. + +Elpi Query lp:{{ + coq.notation.abbreviation-body {coq.locate-abbreviation "abbr2"} 1 + (fun _ _ x\ fun _ _ _\ app[_,_,x,x]). +}}. + diff --git a/tests/test_API_section.v b/tests/test_API_section.v new file mode 100644 index 000000000..cac2c39e2 --- /dev/null +++ b/tests/test_API_section.v @@ -0,0 +1,63 @@ +From elpi Require Import elpi. + +Elpi Command section. + +(* section *) + +Section SA. +Unset Auto Template Polymorphism. +Variable a : nat. +Inductive ind := K. +Section SB. +Variable b : nat. +Let c := b. +Elpi Query lp:{{ + coq.env.section [CA, CB, CC], + coq.locate "a" (const CA), + coq.locate "b" (const CB), + coq.locate "c" (const CC), + coq.env.const CC (some (global (const CB))) _, + coq.env.add-section-variable "d" {{ nat }} _, + coq.env.add-section-variable "d1" {{ nat }} _, + @local! => coq.env.add-const "e" {{ 3 }} {{ nat }} _ _. +}}. +About d. +Definition e2 := e. +End SB. +Fail Check d. +Fail Check d1. +Check eq_refl : e2 = 3. +End SA. + +Elpi Query lp:{{ + coq.env.begin-section "Foo", + coq.env.add-section-variable "x" {{ nat }} X, + coq.env.section [X], + coq.env.add-const "fx" (global (const X)) _ _ _, + coq.env.end-section. +}}. + +Check fx : nat -> nat. + +Elpi Query lp:{{ + coq.env.add-const "opaque_3" {{ 3 }} _ @opaque! _ +}}. + +About opaque_3. + +Fail Elpi Query lp:{{ + coq.env.add-const "opaque_illtyped" {{ 3 3 }} _ @opaque! _ +}}. +Fail Elpi Query lp:{{ + coq.env.add-const "opaque_illtyped" {{ S True }} _ @opaque! _ +}}. + +(************* using ********************) +Section Using. +Variable A : bool. +Elpi Query lp:{{ coq.env.add-const "foo" {{ 3 }} {{ nat }} @transparent! _ }}. +Elpi Query lp:{{ @using! "All" => coq.env.add-const "bar" {{ 3 }} {{ nat }} @transparent! _ }}. +End Using. +Check foo : nat. +Check bar : bool -> nat. + diff --git a/tests/test_API_typecheck.v b/tests/test_API_typecheck.v new file mode 100644 index 000000000..73236f031 --- /dev/null +++ b/tests/test_API_typecheck.v @@ -0,0 +1,74 @@ +From elpi Require Import elpi. + +Require Import List. + +Elpi Command typecheck. + +(****** typecheck **********************************) + +Elpi Query lp:{{ + coq.locate "plus" (const GR), + coq.env.const GR (some BO) TY, + coq.typecheck BO TY ok. +}}. + +Elpi Query lp:{{ + pi x w z\ + decl x `x` {{ nat }} => + def z `z` {{ nat }} x => + (coq.say z, + coq.typecheck z T ok, + coq.say T, + coq.say {coq.term->string z}, + coq.say {coq.term->string T}). +}}. + +Elpi Query lp:{{ + pi x w z\ + decl x `x` {{ nat }} => + decl w `w` {{ nat }} => + def z `z` {{ nat }} w => + (coq.say z, + coq.typecheck z T ok, + coq.say T, + coq.say {coq.term->string z}, + coq.say {coq.term->string T}). +}}. + +Elpi Query lp:{{ + + coq.typecheck {{ Prop Prop }} _ (error E), + coq.say E. + +}}. + + +Elpi Query lp:{{ + coq.unify-leq {{ bool }} {{ nat }} (error Msg), + coq.say Msg. +}}. + + +Elpi Query lp:{{ + coq.locate "cons" GRCons, Cons = global GRCons, + coq.locate "nil" GRNil, Nil = global GRNil, + coq.locate "nat" GRNat, Nat = global GRNat, + coq.locate "O" GRZero, Zero = global GRZero, + coq.locate "list" GRList, List = global GRList, + L = app [ Cons, _, Zero, app [ Nil, _ ]], + LE = app [ Cons, Nat, Zero, app [ Nil, Nat ]], + coq.typecheck L (app [ List, Nat ]) ok. +}}. + +Definition nat1 := nat. + +Elpi Query lp:{{ coq.typecheck {{ 1 }} {{ nat1 }} ok }}. + +Definition list1 := list. + +Elpi Query lp:{{ coq.typecheck {{ 1 :: nil }} {{ list1 lp:T }} ok, coq.say T }}. + +Elpi Query lp:{{ coq.typecheck-ty {{ nat }} (typ U) ok, coq.say U }}. + +Elpi Query lp:{{ coq.typecheck-ty {{ nat }} prop (error E), coq.say E }}. + diff --git a/tests/test_HOAS.v b/tests/test_HOAS.v index 3b67cee0b..6d35228f9 100644 --- a/tests/test_HOAS.v +++ b/tests/test_HOAS.v @@ -39,124 +39,6 @@ intro; reflexivity. Qed. -Elpi Command declarations. -Elpi Accumulate lp:{{ - -main [indt-decl A] :- !, - coq.say "raw:" A, - std.assert-ok! (coq.typecheck-indt-decl A) "Illtyped inductive declaration", - coq.say "typed:" A, - coq.env.add-indt A _. -main [const-decl N (some BO) A] :- !, - coq.arity->term A TY, - coq.typecheck BO TY ok, - coq.env.add-const N BO TY _ _. -main [const-decl N none A] :- !, - coq.arity->term A TY, - coq.typecheck-ty TY _ ok, - coq.env.add-axiom N TY _. -main [ctx-decl (context-item "T" _ _ none t\ - context-item "x" _ t none _\ - context-item "l" _ _ (some _) _\ - context-end)]. - -main Args :- coq.error Args. -}}. -Elpi Typecheck. - -Module anonymous_fields. - -Elpi declarations Record foo := { - f : nat -> nat; - _ : f 0 = 0; -}. -Fail Check _elpi_ctx_entry_2_. - -End anonymous_fields. - -From Coq Require Import ssreflect. - -Module record_attributes. - -Elpi declarations -Record foo A (B : A) : Type := { - a of A & A : A; - z (a : A) :> B = B -> A; -#[canonical=no] - x (w := 3) : forall x, a x x = x; - }. - -Elpi Query lp:{{ - coq.locate "foo" (indt I), - coq.env.projections I [some _, some _, some _]. -}}. - -End record_attributes. - -Module inductive_nup. - -Elpi declarations - Inductive foo1 {A1} (A2 : A1) | B1 (B2 : Type) : nat -> Type := - | a_k1 : forall x, foo1 A2 (B1 * B1)%type B2 3 -> foo1 A2 B1 B2 x - | a_k2 : A1 -> foo1 A2 B1 B2 1. -Print foo1. -Check foo1 _ _ _ _ : Type. -Fail Check (foo1 _ _ _ _ _). -Check a_k1 _ _ _ 3 _ : foo1 _ _ _ 3. -Unset Auto Template Polymorphism. -Inductive r (A : Type) (a : A) := R { f :> A -> A; g : A; p : a = g }. - -End inductive_nup. - -Module definition. - -Elpi declarations Definition x1 (P : Type) (w : P) (n : nat) := (n + 1). - -Check x1 : forall P, P -> nat -> nat. -Check refl_equal _ : x1 = fun P w n => n + 1. - -Elpi declarations Axiom y (n : nat) : Type. - -Check y : nat -> Type. - -End definition. - -Module section. - -Elpi declarations Context T (x : T) (l := 3). - -End section. - -Module copy. -Import inductive_nup. - -Elpi Query lp:{{ - coq.locate "foo1" (indt I), - coq.env.indt-decl I D, - coq.say D, - coq.env.add-indt D _. -}}. -Check foo1 _ _ _ _ : Type. -Fail Check (foo1 _ _ _ _ _). -Check a_k1 _ _ _ 3 _ : foo1 _ _ _ 3. - - -Elpi Query lp:{{ - coq.locate "r" (indt I), - coq.env.indt-decl I R, - std.assert! (R = - parameter "A" explicit (sort (typ _)) c0 \ - parameter "a" explicit c0 c1 \ - record "r" (sort (typ _)) "R" - (field [] "f" (prod `_` c0 _\ c0) c2\ - field [] "g" c0 c3\ - field [] "p" (app [global (indt _), c0, c1, c3]) _\ - end-record)) "not a record", - coq.env.add-indt R _. -}}. - -Print r. -End copy. Module kwd. @@ -168,7 +50,7 @@ Elpi Accumulate lp:{{ }}. Elpi Typecheck. -Elpi kwd fun in as 4 end match return => : := { } ; , | "x" 1 H (match x as y in False return nat with end). +Elpi kwd fun in as 4 end match return => : := { } ; , | "x" 1 H (fun x => match x as y in False return nat with end). End kwd. @@ -274,10 +156,12 @@ Elpi Typecheck. Elpi primitive_proj "primitive" (@P.foo) (P.x.(P.p1)) 1 (3%nat). Elpi primitive_proj "primitive" (@P.foo) (P.x.(P.p2)) 2 (false). -Elpi primitive_proj "regular" (@P.foo) (P.p1 P.x) 1 (3%nat). +(* FIXME, in raw mode this works +Elpi primitive_proj "regular" (@P.foo) (@P.p1 _ P.x) 1 (3%nat). Elpi primitive_proj "regular" (@P.foo) (P.p2 P.x) 2 (false). Elpi primitive_proj "regular" (@P.foo) (P.x.(@P.p1 bool)) 1 (3%nat). -Elpi primitive_proj "regular" (@P.foo) (P.x.(@P.p2 bool)) 2 (false). +Elpi primitive_proj "regular" (@P.foo) (P.x.(@P.p2 _)) 2 (false). +*) (* glob of ifte *) diff --git a/tests/test_arg_HOAS.v b/tests/test_arg_HOAS.v new file mode 100644 index 000000000..4a3c07eba --- /dev/null +++ b/tests/test_arg_HOAS.v @@ -0,0 +1,208 @@ + + +From elpi Require Import elpi. + +Elpi Command declarations. +Elpi Accumulate lp:{{ + +main [indt-decl A] :- !, + coq.say "raw:" A, + std.assert-ok! (coq.typecheck-indt-decl A) "Illtyped inductive declaration", + coq.say "typed:" A, + coq.env.add-indt A _. +main [const-decl N (some BO) A] :- !, + coq.arity->term A TY, + std.assert-ok! (coq.typecheck BO TY) "illtyped definition", + coq.env.add-const N BO TY _ _. +main [const-decl N none A] :- !, + coq.arity->term A TY, + std.assert-ok! (coq.typecheck-ty TY _) "illtyped axiom", + coq.env.add-axiom N TY _. +main [ctx-decl (context-item "T" _ _ none t\ + context-item "x" _ t none _\ + context-item "l" _ _ (some _) _\ + context-end)]. + +main Args :- coq.error Args. +}}. +Elpi Typecheck. + +#[arguments(raw)] +Elpi Command raw_declarations. +Elpi Accumulate lp:{{ + +main [indt-decl RA] :- !, + coq.say "raw:" RA, + std.assert-ok! (coq.elaborate-indt-decl-skeleton RA A) "Illtyped inductive declaration", + coq.say "typed:" A, + coq.env.add-indt A _. +main [const-decl N (some RBO) RA] :- !, + coq.arity->term RA RTY, + std.assert-ok! (coq.elaborate-ty-skeleton RTY _ TY) "illtyped arity", + std.assert-ok! (coq.elaborate-skeleton RBO TY BO) "illtyped definition", + coq.env.add-const N BO TY _ _. +main [const-decl N none RA] :- !, + coq.arity->term RA RTY, + std.assert-ok! (coq.elaborate-ty-skeleton RTY _ TY) "illtyped axiom", + coq.env.add-axiom N TY _. +main [ctx-decl (context-item "T" _ _ none t\ + context-item "x" _ t none _\ + context-item "l" _ _ (some _) _\ + context-end)]. + +main Args :- coq.error Args. +}}. +Elpi Typecheck. + +(*****************************************) + +Module inductive_nup. +Elpi declarations + Inductive foo1 {A1} (A2 : A1) | (B1 B2 : Type) : nat -> Type := + | a_k1 : forall x, foo1 (B1 * B1)%type B2 3 -> foo1 B1 B2 x + | a_k2 : A1 -> foo1 B1 B2 1. +Check foo1 _ _ _ _ : Type. +Fail Check (foo1 _ _ _ _ _). +Check a_k1 _ _ _ 3 _ : foo1 _ _ _ 3. +Unset Auto Template Polymorphism. +Inductive r (A : Type) (a : A) := R { f :> A -> A; g : A; p : a = g }. +End inductive_nup. + +Module raw_inductive_nup. +Elpi raw_declarations + Inductive foo1 {A1} (A2 : A1) | (B1 B2 : Type) : nat -> Type := + | a_k1 : forall x, foo1 (B1 * B1)%type B2 3 -> foo1 B1 B2 x + | a_k2 : A1 -> foo1 B1 B2 1. +Check foo1 _ _ _ _ : Type. +Fail Check (foo1 _ _ _ _ _). +Check a_k1 _ _ _ 3 _ : foo1 _ _ _ 3. +Unset Auto Template Polymorphism. +Inductive r (A : Type) (a : A) := R { f :> A -> A; g : A; p : a = g }. +End raw_inductive_nup. + + + +(*****************************************) +Module anonymous_fields. +Elpi declarations +Record foo := { + f : nat -> nat; + _ : f 0 = 0; +}. +Fail Check _elpi_ctx_entry_2_. +End anonymous_fields. + +Module raw_anonymous_fields. +Elpi raw_declarations +Record foo := { + f : nat -> nat; + _ : f 0 = 0; +}. +Fail Check _elpi_ctx_entry_2_. +End raw_anonymous_fields. + +(*****************************************) + +Module record_attributes. +Elpi declarations +Record foo A (B : A) : Type := { + a (_: A) (_ : A) : A; + z (a : A) :> B = B -> A; +#[canonical=no] + x (w := 3) : forall x, a x x = x; + }. +Elpi Query lp:{{ + coq.locate "foo" (indt I), + coq.env.projections I [some _, some _, some _]. +}}. +End record_attributes. + +Module raw_record_attributes. +Elpi raw_declarations +Record foo A (B : A) : Type := { + a (_: A) (_ : A) : A; + z (a : A) :> B = B -> A; +#[canonical=no] + x (w := 3) : forall x, a x x = x; + }. +Elpi Query lp:{{ + coq.locate "foo" (indt I), + coq.env.projections I [some _, some _, some _]. +}}. +End raw_record_attributes. + +(*****************************************) + +Module definition. +Elpi declarations +Definition x1 (P : Type) (w : P) (n : nat) := (n + 1). +Check x1 : forall P, P -> nat -> nat. +Check refl_equal _ : x1 = fun P w n => n + 1. +Elpi declarations Axiom y (n : nat) : Type. +Check y : nat -> Type. +End definition. + +Module raw_definition. +Elpi raw_declarations +Definition x1 (P : Type) (w : P) (n : nat) := (n + 1). +Check x1 : forall P, P -> nat -> nat. +Check refl_equal _ : x1 = fun P w n => n + 1. +Elpi declarations Axiom y (n : nat) : Type. +Check y : nat -> Type. +End raw_definition. + +(*****************************************) + +Module section. +Elpi declarations Context T (x : T) (l := 3). +End section. + +Module raw_section. +Elpi raw_declarations Context T (x : T) (l := 3). +End raw_section. + + +(*****************************************) + +Module full_definition. +Elpi declarations +Definition x (n : nat) := Eval compute in (1 + n). +Goal x 1 = 2. +unfold x. +match goal with |- 2 = 2 => reflexivity end. +Qed. +Definition y (n : nat) : nat := ltac:(exact 1 + n). +End full_definition. + +(*****************************************) + +Module copy. +Import inductive_nup. + +Elpi Query lp:{{ + coq.locate "foo1" (indt I), + coq.env.indt-decl I D, + coq.say D, + coq.env.add-indt D _. +}}. +Check foo1 _ _ _ _ : Type. +Fail Check (foo1 _ _ _ _ _). +Check a_k1 _ _ _ 3 _ : foo1 _ _ _ 3. + + +Elpi Query lp:{{ + coq.locate "r" (indt I), + coq.env.indt-decl I R, + std.assert! (R = + parameter "A" explicit (sort (typ _)) c0 \ + parameter "a" explicit c0 c1 \ + record "r" (sort (typ _)) "R" + (field [coercion tt,canonical tt] "f" (prod `_` c0 _\ c0) c2\ + field [coercion ff,canonical tt] "g" c0 c3\ + field [coercion ff,canonical tt] "p" (app [global (indt _), c0, c1, c3]) _\ + end-record)) "not a record", + coq.env.add-indt R _. +}}. + +Print r. +End copy. \ No newline at end of file diff --git a/tests/test_elaborator.v b/tests/test_elaborator.v index d00fda652..4efab92f0 100644 --- a/tests/test_elaborator.v +++ b/tests/test_elaborator.v @@ -1,8 +1,10 @@ +From unreleased Extra Dependency "elpi_elaborator.elpi" as elab. + From elpi Require Import elpi. Elpi Command test.refiner. -Elpi Accumulate File "elpi-elaborator.elpi" From unreleased. +Elpi Accumulate File elab. Elpi Bound Steps 10000. @@ -148,10 +150,10 @@ Elpi Query lp:{{get-option "of:coerce" tt => }}. (* primitive *) -From Coq Require Import Int63. -Elpi Query lp:{{ of {{ 99%int63 }} T X }}. +From Coq Require Import Uint63. +Elpi Query lp:{{ of {{ 99%uint63 }} T X }}. From Coq Require Import Floats. Elpi Query lp:{{ of {{ 99.3e4%float }} T X }}. -Elpi Query lp:{{ whd1 {{ (99 + 1)%int63 }} {{ 100%int63 }} }}. -Elpi Query lp:{{ not(whd1 {{ (99 + _)%int63 }} _) }}. +Elpi Query lp:{{ whd1 {{ (99 + 1)%uint63 }} {{ 100%uint63 }} }}. +Elpi Query lp:{{ not(whd1 {{ (99 + _)%uint63 }} _) }}. diff --git a/theories/attic/test_CoqEAL.v b/theories/attic/test_CoqEAL.v index cc9d61de9..54166d5f6 100644 --- a/theories/attic/test_CoqEAL.v +++ b/theories/attic/test_CoqEAL.v @@ -23,7 +23,7 @@ Cd "~/git/coq-elpi". Elpi Query param "with-TC-param (param {{O}} X Y)". Elpi Tactic coqeal. -Elpi Accumulate File "paramX-lib.elpi" From elpi.apps.derive. +Elpi Accumulate File "paramX_lib.elpi" From elpi.apps.derive. Elpi Accumulate File "attic/coq-EAL.elpi". Elpi Typecheck coqeal. diff --git a/theories/elpi.v b/theories/elpi.v index cf6f7da86..1516bcfaa 100644 --- a/theories/elpi.v +++ b/theories/elpi.v @@ -1,5 +1,5 @@ From Coq Require Ltac. -Declare ML Module "elpi_plugin". +Declare ML Module "coq-elpi.elpi". (* Generate coq-bultins.elpi *) Elpi Document Builtins.