sigrid/idris2

.gitignore+1−1

@@ -10,7 +10,7 @@ · 9 unmodified lines
10	10
11	11	/dist/idris2.c
12	12
13		−/docs/_build/
	13	+/docs/build/
14	14
15	15	/libs/**/build
16	16	/tests/**/output

INSTALL.md+1−1

@@ -2,7 +2,7 @@ · 1 unmodified line
2	2
3	3	Idris 2 is built using Idris, and provides support for two default code
4	4	generation targets: Chez Scheme, and Racket. To build from source, it requires
5		−at least Idris version 1.3.2 (see https://www.idris-lang.org/download). You
	5	+at least Idris version 1.3.2 (see https://www.idris-lang.org/pages/download.html). You
6	6	can also build from the generated C.
7	7
8	8	## Quick summary:

README.md+2−0

@@ -1,6 +1,8 @@
1	1	Idris 2
2	2	=======
3	3
	4	+[![Build Status](https://travis-ci.org/edwinb/Idris2.svg?branch=master)](https://travis-ci.org/edwinb/Idris2)
	5	+
4	6	This is a pre-alpha implementation of Idris 2, the successor to Idris.
5	7
6	8	* Please note: To build, this requires Idris version 1.3.2 *

docs/Makefile+14−177

@@ -1,183 +1,20 @@
1		−# Makefile for Sphinx documentation
	1	+# Minimal makefile for Sphinx documentation
2	2	#
3	3
4		−# You can set these variables from the command line.
5		−SPHINXOPTS =
6		−SPHINXBUILD = sphinx-build
7		−PAPER =
8		−BUILDDIR = _build
9		−
10		−# User-friendly check for sphinx-build
11		−ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
12		−$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from https://www.sphinx-doc.org/)
13		−endif
14		−
15		−# Internal variables.
16		−PAPEROPT_a4 = -D latex_paper_size=a4
17		−PAPEROPT_letter = -D latex_paper_size=letter
18		−ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
19		−# the i18n builder cannot share the environment and doctrees with the others
20		−I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
21		−
22		−.PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest coverage gettext
	4	+# You can set these variables from the command line, and also
	5	+# from the environment for the first two.
	6	+SPHINXOPTS ?=
	7	+SPHINXBUILD ?= sphinx-build
	8	+SOURCEDIR = source
	9	+BUILDDIR = build
23	10
	11	+# Put it first so that "make" without argument is like "make help".
24	12	help:
25		− @echo "Please use \`make <target>' where <target> is one of"
26		− @echo " html to make standalone HTML files"
27		− @echo " dirhtml to make HTML files named index.html in directories"
28		− @echo " singlehtml to make a single large HTML file"
29		− @echo " pickle to make pickle files"
30		− @echo " json to make JSON files"
31		− @echo " htmlhelp to make HTML files and a HTML help project"
32		− @echo " qthelp to make HTML files and a qthelp project"
33		− @echo " devhelp to make HTML files and a Devhelp project"
34		− @echo " epub to make an epub"
35		− @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
36		− @echo " latexpdf to make LaTeX files and run them through pdflatex"
37		− @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
38		− @echo " text to make text files"
39		− @echo " man to make manual pages"
40		− @echo " texinfo to make Texinfo files"
41		− @echo " info to make Texinfo files and run them through makeinfo"
42		− @echo " gettext to make PO message catalogs"
43		− @echo " changes to make an overview of all changed/added/deprecated items"
44		− @echo " xml to make Docutils-native XML files"
45		− @echo " pseudoxml to make pseudoxml-XML files for display purposes"
46		− @echo " linkcheck to check all external links for integrity"
47		− @echo " doctest to run all doctests embedded in the documentation (if enabled)"
48		− @echo " coverage to run coverage check of the documentation (if enabled)"
49		−
50		−clean:
51		− rm -rf $(BUILDDIR)/*
52		−
53		−html:
54		− $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
55		− @echo
56		− @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
57		−
58		−dirhtml:
59		− $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
60		− @echo
61		− @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
62		−
63		−singlehtml:
64		− $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
65		− @echo
66		− @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
67		−
68		−pickle:
69		− $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
70		− @echo
71		− @echo "Build finished; now you can process the pickle files."
72		−
73		−json:
74		− $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
75		− @echo
76		− @echo "Build finished; now you can process the JSON files."
77		−
78		−htmlhelp:
79		− $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
80		− @echo
81		− @echo "Build finished; now you can run HTML Help Workshop with the" \
82		− ".hhp project file in $(BUILDDIR)/htmlhelp."
83		−
84		−qthelp:
85		− $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
86		− @echo
87		− @echo "Build finished; now you can run "qcollectiongenerator" with the" \
88		− ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
89		− @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/IdrisManual.qhcp"
90		− @echo "To view the help file:"
91		− @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/IdrisManual.qhc"
92		−
93		−devhelp:
94		− $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
95		− @echo
96		− @echo "Build finished."
97		− @echo "To view the help file:"
98		− @echo "# mkdir -p $$HOME/.local/share/devhelp/IdrisManual"
99		− @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/IdrisManual"
100		− @echo "# devhelp"
101		−
102		−epub:
103		− $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
104		− @echo
105		− @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
106		−
107		−latex:
108		− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
109		− @echo
110		− @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
111		− @echo "Run \`make' in that directory to run these through (pdf)latex" \
112		− "(use \`make latexpdf' here to do that automatically)."
113		−
114		−latexpdf:
115		− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
116		− @echo "Running LaTeX files through pdflatex..."
117		− $(MAKE) -C $(BUILDDIR)/latex all-pdf
118		− @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
119		−
120		−latexpdfja:
121		− $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
122		− @echo "Running LaTeX files through platex and dvipdfmx..."
123		− $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
124		− @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
125		−
126		−text:
127		− $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
128		− @echo
129		− @echo "Build finished. The text files are in $(BUILDDIR)/text."
130		−
131		−man:
132		− $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
133		− @echo
134		− @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
135		−
136		−texinfo:
137		− $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
138		− @echo
139		− @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
140		− @echo "Run \`make' in that directory to run these through makeinfo" \
141		− "(use \`make info' here to do that automatically)."
142		−
143		−info:
144		− $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
145		− @echo "Running Texinfo files through makeinfo..."
146		− make -C $(BUILDDIR)/texinfo info
147		− @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
148		−
149		−gettext:
150		− $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
151		− @echo
152		− @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
153		−
154		−changes:
155		− $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
156		− @echo
157		− @echo "The overview file is in $(BUILDDIR)/changes."
158		−
159		−linkcheck:
160		− $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
161		− @echo
162		− @echo "Link check complete; look for any errors in the above output " \
163		− "or in $(BUILDDIR)/linkcheck/output.txt."
164		−
165		−doctest:
166		− $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
167		− @echo "Testing of doctests in the sources finished, look at the " \
168		− "results in $(BUILDDIR)/doctest/output.txt."
169		−
170		−coverage:
171		− $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage
172		− @echo "Testing of coverage in the sources finished, look at the " \
173		− "results in $(BUILDDIR)/coverage/python.txt."
	13	+ @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)
174	14
175		−xml:
176		− $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
177		− @echo
178		− @echo "Build finished. The XML files are in $(BUILDDIR)/xml."
	15	+.PHONY: help Makefile
179	16
180		−pseudoxml:
181		− $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
182		− @echo
183		− @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
	17	+# Catch-all target: route all unknown targets to Sphinx using the new
	18	+# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS).
	19	+%: Makefile
	20	+ @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O)

docs/README.md+6−1

@@ -11,6 +11,7 @@ To build the manual the following dependencies must be met. We assume that you h · 10 unmodified lines
11	11
12	12	Python should be installed by default on most systems.
13	13	Sphinx can be installed either through your hosts package manager or using pip/easy_install.
	14	+Recommended way is to use virtual environment for building documentation.
14	15
15	16	Note [ReadTheDocs](https://readthedocs.org) works with Sphinx
16	17	`v1.2.2`. If you install a more recent version of sphinx then
@@ -18,9 +19,12 @@ Sphinx can be installed either through your hosts package manager or using pip/e · 1 unmodified line
18	19	of readthedocs and be ignored. In the past we had several code-blocks
19	20	disappear because of that.
20	21
21		−The ReadTheDocs theme can be installed using pip as follows:
	22	+The ReadTheDocs theme can be installed in virtual environment using pip as follows:
22	23
23	24	```sh
	25	+python3 -m venv idris2docs_venv
	26	+source idris2docs_venv/bin/activate
	27	+pip install --upgrade pip
24	28	pip install sphinx_rtd_theme
25	29	```
26	30
@@ -32,6 +36,7 @@ LaTeX can be install either using your systems package manager or direct from Te · 5 unmodified lines
32	36	## Build Instructions
33	37
34	38	```sh
	39	+cd docs
35	40	make html
36	41	make latexpdf
37	42	```

docs/make.bat+35−263

@@ -1,263 +1,35 @@
1		−@ECHO OFF
2		−
3		−REM Command file for Sphinx documentation
4		−
5		−if "%SPHINXBUILD%" == "" (
6		− set SPHINXBUILD=sphinx-build
7		−)
8		−set BUILDDIR=_build
9		−set ALLSPHINXOPTS=-d %BUILDDIR%/doctrees %SPHINXOPTS% .
10		−set I18NSPHINXOPTS=%SPHINXOPTS% .
11		−if NOT "%PAPER%" == "" (
12		− set ALLSPHINXOPTS=-D latex_paper_size=%PAPER% %ALLSPHINXOPTS%
13		− set I18NSPHINXOPTS=-D latex_paper_size=%PAPER% %I18NSPHINXOPTS%
14		−)
15		−
16		−if "%1" == "" goto help
17		−
18		−if "%1" == "help" (
19		− :help
20		− echo.Please use `make ^<target^>` where ^<target^> is one of
21		− echo. html to make standalone HTML files
22		− echo. dirhtml to make HTML files named index.html in directories
23		− echo. singlehtml to make a single large HTML file
24		− echo. pickle to make pickle files
25		− echo. json to make JSON files
26		− echo. htmlhelp to make HTML files and a HTML help project
27		− echo. qthelp to make HTML files and a qthelp project
28		− echo. devhelp to make HTML files and a Devhelp project
29		− echo. epub to make an epub
30		− echo. latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter
31		− echo. text to make text files
32		− echo. man to make manual pages
33		− echo. texinfo to make Texinfo files
34		− echo. gettext to make PO message catalogs
35		− echo. changes to make an overview over all changed/added/deprecated items
36		− echo. xml to make Docutils-native XML files
37		− echo. pseudoxml to make pseudoxml-XML files for display purposes
38		− echo. linkcheck to check all external links for integrity
39		− echo. doctest to run all doctests embedded in the documentation if enabled
40		− echo. coverage to run coverage check of the documentation if enabled
41		− goto end
42		−)
43		−
44		−if "%1" == "clean" (
45		− for /d %%i in (%BUILDDIR%\*) do rmdir /q /s %%i
46		− del /q /s %BUILDDIR%\*
47		− goto end
48		−)
49		−
50		−
51		−REM Check if sphinx-build is available and fallback to Python version if any
52		−%SPHINXBUILD% 2> nul
53		−if errorlevel 9009 goto sphinx_python
54		−goto sphinx_ok
55		−
56		−:sphinx_python
57		−
58		−set SPHINXBUILD=python -m sphinx.__init__
59		−%SPHINXBUILD% 2> nul
60		−if errorlevel 9009 (
61		− echo.
62		− echo.The 'sphinx-build' command was not found. Make sure you have Sphinx
63		− echo.installed, then set the SPHINXBUILD environment variable to point
64		− echo.to the full path of the 'sphinx-build' executable. Alternatively you
65		− echo.may add the Sphinx directory to PATH.
66		− echo.
67		− echo.If you don't have Sphinx installed, grab it from
68		− echo.https://www.sphinx-doc.org/
69		− exit /b 1
70		−)
71		−
72		−:sphinx_ok
73		−
74		−
75		−if "%1" == "html" (
76		− %SPHINXBUILD% -b html %ALLSPHINXOPTS% %BUILDDIR%/html
77		− if errorlevel 1 exit /b 1
78		− echo.
79		− echo.Build finished. The HTML pages are in %BUILDDIR%/html.
80		− goto end
81		−)
82		−
83		−if "%1" == "dirhtml" (
84		− %SPHINXBUILD% -b dirhtml %ALLSPHINXOPTS% %BUILDDIR%/dirhtml
85		− if errorlevel 1 exit /b 1
86		− echo.
87		− echo.Build finished. The HTML pages are in %BUILDDIR%/dirhtml.
88		− goto end
89		−)
90		−
91		−if "%1" == "singlehtml" (
92		− %SPHINXBUILD% -b singlehtml %ALLSPHINXOPTS% %BUILDDIR%/singlehtml
93		− if errorlevel 1 exit /b 1
94		− echo.
95		− echo.Build finished. The HTML pages are in %BUILDDIR%/singlehtml.
96		− goto end
97		−)
98		−
99		−if "%1" == "pickle" (
100		− %SPHINXBUILD% -b pickle %ALLSPHINXOPTS% %BUILDDIR%/pickle
101		− if errorlevel 1 exit /b 1
102		− echo.
103		− echo.Build finished; now you can process the pickle files.
104		− goto end
105		−)
106		−
107		−if "%1" == "json" (
108		− %SPHINXBUILD% -b json %ALLSPHINXOPTS% %BUILDDIR%/json
109		− if errorlevel 1 exit /b 1
110		− echo.
111		− echo.Build finished; now you can process the JSON files.
112		− goto end
113		−)
114		−
115		−if "%1" == "htmlhelp" (
116		− %SPHINXBUILD% -b htmlhelp %ALLSPHINXOPTS% %BUILDDIR%/htmlhelp
117		− if errorlevel 1 exit /b 1
118		− echo.
119		− echo.Build finished; now you can run HTML Help Workshop with the ^
120		−.hhp project file in %BUILDDIR%/htmlhelp.
121		− goto end
122		−)
123		−
124		−if "%1" == "qthelp" (
125		− %SPHINXBUILD% -b qthelp %ALLSPHINXOPTS% %BUILDDIR%/qthelp
126		− if errorlevel 1 exit /b 1
127		− echo.
128		− echo.Build finished; now you can run "qcollectiongenerator" with the ^
129		−.qhcp project file in %BUILDDIR%/qthelp, like this:
130		− echo.^> qcollectiongenerator %BUILDDIR%\qthelp\IdrisManual.qhcp
131		− echo.To view the help file:
132		− echo.^> assistant -collectionFile %BUILDDIR%\qthelp\IdrisManual.ghc
133		− goto end
134		−)
135		−
136		−if "%1" == "devhelp" (
137		− %SPHINXBUILD% -b devhelp %ALLSPHINXOPTS% %BUILDDIR%/devhelp
138		− if errorlevel 1 exit /b 1
139		− echo.
140		− echo.Build finished.
141		− goto end
142		−)
143		−
144		−if "%1" == "epub" (
145		− %SPHINXBUILD% -b epub %ALLSPHINXOPTS% %BUILDDIR%/epub
146		− if errorlevel 1 exit /b 1
147		− echo.
148		− echo.Build finished. The epub file is in %BUILDDIR%/epub.
149		− goto end
150		−)
151		−
152		−if "%1" == "latex" (
153		− %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex
154		− if errorlevel 1 exit /b 1
155		− echo.
156		− echo.Build finished; the LaTeX files are in %BUILDDIR%/latex.
157		− goto end
158		−)
159		−
160		−if "%1" == "latexpdf" (
161		− %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex
162		− cd %BUILDDIR%/latex
163		− make all-pdf
164		− cd %~dp0
165		− echo.
166		− echo.Build finished; the PDF files are in %BUILDDIR%/latex.
167		− goto end
168		−)
169		−
170		−if "%1" == "latexpdfja" (
171		− %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex
172		− cd %BUILDDIR%/latex
173		− make all-pdf-ja
174		− cd %~dp0
175		− echo.
176		− echo.Build finished; the PDF files are in %BUILDDIR%/latex.
177		− goto end
178		−)
179		−
180		−if "%1" == "text" (
181		− %SPHINXBUILD% -b text %ALLSPHINXOPTS% %BUILDDIR%/text
182		− if errorlevel 1 exit /b 1
183		− echo.
184		− echo.Build finished. The text files are in %BUILDDIR%/text.
185		− goto end
186		−)
187		−
188		−if "%1" == "man" (
189		− %SPHINXBUILD% -b man %ALLSPHINXOPTS% %BUILDDIR%/man
190		− if errorlevel 1 exit /b 1
191		− echo.
192		− echo.Build finished. The manual pages are in %BUILDDIR%/man.
193		− goto end
194		−)
195		−
196		−if "%1" == "texinfo" (
197		− %SPHINXBUILD% -b texinfo %ALLSPHINXOPTS% %BUILDDIR%/texinfo
198		− if errorlevel 1 exit /b 1
199		− echo.
200		− echo.Build finished. The Texinfo files are in %BUILDDIR%/texinfo.
201		− goto end
202		−)
203		−
204		−if "%1" == "gettext" (
205		− %SPHINXBUILD% -b gettext %I18NSPHINXOPTS% %BUILDDIR%/locale
206		− if errorlevel 1 exit /b 1
207		− echo.
208		− echo.Build finished. The message catalogs are in %BUILDDIR%/locale.
209		− goto end
210		−)
211		−
212		−if "%1" == "changes" (
213		− %SPHINXBUILD% -b changes %ALLSPHINXOPTS% %BUILDDIR%/changes
214		− if errorlevel 1 exit /b 1
215		− echo.
216		− echo.The overview file is in %BUILDDIR%/changes.
217		− goto end
218		−)
219		−
220		−if "%1" == "linkcheck" (
221		− %SPHINXBUILD% -b linkcheck %ALLSPHINXOPTS% %BUILDDIR%/linkcheck
222		− if errorlevel 1 exit /b 1
223		− echo.
224		− echo.Link check complete; look for any errors in the above output ^
225		−or in %BUILDDIR%/linkcheck/output.txt.
226		− goto end
227		−)
228		−
229		−if "%1" == "doctest" (
230		− %SPHINXBUILD% -b doctest %ALLSPHINXOPTS% %BUILDDIR%/doctest
231		− if errorlevel 1 exit /b 1
232		− echo.
233		− echo.Testing of doctests in the sources finished, look at the ^
234		−results in %BUILDDIR%/doctest/output.txt.
235		− goto end
236		−)
237		−
238		−if "%1" == "coverage" (
239		− %SPHINXBUILD% -b coverage %ALLSPHINXOPTS% %BUILDDIR%/coverage
240		− if errorlevel 1 exit /b 1
241		− echo.
242		− echo.Testing of coverage in the sources finished, look at the ^
243		−results in %BUILDDIR%/coverage/python.txt.
244		− goto end
245		−)
246		−
247		−if "%1" == "xml" (
248		− %SPHINXBUILD% -b xml %ALLSPHINXOPTS% %BUILDDIR%/xml
249		− if errorlevel 1 exit /b 1
250		− echo.
251		− echo.Build finished. The XML files are in %BUILDDIR%/xml.
252		− goto end
253		−)
254		−
255		−if "%1" == "pseudoxml" (
256		− %SPHINXBUILD% -b pseudoxml %ALLSPHINXOPTS% %BUILDDIR%/pseudoxml
257		− if errorlevel 1 exit /b 1
258		− echo.
259		− echo.Build finished. The pseudo-XML files are in %BUILDDIR%/pseudoxml.
260		− goto end
261		−)
262		−
263		−:end
	1	+@ECHO OFF
	2	+
	3	+pushd %~dp0
	4	+
	5	+REM Command file for Sphinx documentation
	6	+
	7	+if "%SPHINXBUILD%" == "" (
	8	+ set SPHINXBUILD=sphinx-build
	9	+)
	10	+set SOURCEDIR=source
	11	+set BUILDDIR=build
	12	+
	13	+if "%1" == "" goto help
	14	+
	15	+%SPHINXBUILD% >NUL 2>NUL
	16	+if errorlevel 9009 (
	17	+ echo.
	18	+ echo.The 'sphinx-build' command was not found. Make sure you have Sphinx
	19	+ echo.installed, then set the SPHINXBUILD environment variable to point
	20	+ echo.to the full path of the 'sphinx-build' executable. Alternatively you
	21	+ echo.may add the Sphinx directory to PATH.
	22	+ echo.
	23	+ echo.If you don't have Sphinx installed, grab it from
	24	+ echo.http://sphinx-doc.org/
	25	+ exit /b 1
	26	+)
	27	+
	28	+%SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O%
	29	+goto end
	30	+
	31	+:help
	32	+%SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O%
	33	+
	34	+:end
	35	+popd

docs/source/app/index.rstrenamed from docs/app/index.rst+1−1

@@ -1,4 +1,4 @@
1		−.. _proofs-index:
	1	+.. _app-index:
2	2
3	3	################################
4	4	Structuring Idris 2 Applications

docs/source/backends/chez.rstrenamed from docs/backends/chez.rst+0−0

File renamed without changes.

docs/source/backends/index.rstrenamed from docs/backends/index.rst+0−0

File renamed without changes.

docs/source/backends/racket.rstrenamed from docs/backends/racket.rst+0−0

File renamed without changes.

docs/source/conf.pyrenamed from docs/conf.py+40−173

@@ -1,32 +1,42 @@
1		−# -- coding: utf-8 --
	1	+# Configuration file for the Sphinx documentation builder.
2	2	#
3		−# Idris Manual documentation build configuration file, created by
4		−# sphinx-quickstart on Sat Feb 28 20:41:47 2015.
	3	+# Idris Manual documentation build configuration file, created by
	4	+# sphinx-quickstart on Apr 13, 2020.
5	5	#
6	6	# This file is execfile()d with the current directory set to its
7	7	# containing dir.
8	8	#
9		−# Note that not all possible configuration values are present in this
10		−# autogenerated file.
11		−#
12		−# All configuration values have a default; values that are commented out
13		−# serve to show the default.
14		−
15		−import sys
16		−import os
	9	+# This file only contains a selection of the most common options. For a full
	10	+# list see the documentation:
	11	+# https://www.sphinx-doc.org/en/master/usage/configuration.html
17	12
18		−# True if the readthedocs theme is locally installed
19		−on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
	13	+# -- Path setup --------------------------------------------------------------
20	14
21	15	# If extensions (or modules to document with autodoc) are in another directory,
22	16	# add these directories to sys.path here. If the directory is relative to the
23	17	# documentation root, use os.path.abspath to make it absolute, like shown here.
24		−#sys.path.insert(0, os.path.abspath('.'))
	18	+#
	19	+import os
	20	+import sys
	21	+import sphinx_rtd_theme
	22	+# sys.path.insert(0, os.path.abspath('.'))
	23	+
	24	+
	25	+# -- Project information -----------------------------------------------------
	26	+
	27	+# General information about the project.
	28	+project = 'Idris2'
	29	+copyright = '2020, The Idris Community'
	30	+author = 'The Idris Community'
	31	+
	32	+# The short X.Y version.
	33	+version = '0.0'
	34	+
	35	+# The full version, including alpha/beta/rc tags
	36	+release = '0.0'
25	37
26		−# -- General configuration ------------------------------------------------
27	38
28		−# If your documentation needs a minimal Sphinx version, state it here.
29		−#needs_sphinx = '1.0'
	39	+# -- General configuration ---------------------------------------------------
30	40
31	41	# Add any Sphinx extension module names here, as strings. They can be
32	42	# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
@@ -35,183 +45,40 @@ extensions = [ · 2 unmodified lines
35	45	'sphinx.ext.todo',
36	46	# 'sphinx.ext.pngmath', # imgmath is not supported on readthedocs.
37	47	'sphinx.ext.ifconfig',
38		− 'recommonmark'
	48	+ "sphinx_rtd_theme",
39	49	]
40	50
41	51	# Add any paths that contain templates here, relative to this directory.
42	52	templates_path = ['_templates']
43	53
44		−# The suffix of source filenames.
45		−source_suffix = ['.rst','.md']
46		−
47		−# The encoding of source files.
48		−#source_encoding = 'utf-8-sig'
49		−
50		−# The master toctree document.
51		−master_doc = 'index'
52		−
53		−# General information about the project.
54		−project = u'Idris2'
55		−copyright = u'2019, The Idris Community'
56		−author = u'The Idris Community'
57		−
58		−# The version info for the project you're documenting, acts as replacement for
59		−# \|version\| and \|release\|, also used in various other places throughout the
60		−# built documents.
61		−#
62		−# The short X.Y version.
63		−version = '0.0'
64		−# The full version, including alpha/beta/rc tags.
65		−release = '0.0'
66		−
67		−# The language for content autogenerated by Sphinx. Refer to documentation
68		−# for a list of supported languages.
69		−#
70		−# This is also used if you do content translation via gettext catalogs.
71		−# Usually you set "language" from the command line for these cases.
72		−language = None
73		−
74		−# There are two options for replacing \|today\|: either, you set today to some
75		−# non-false value, then it is used:
76		−#today = ''
77		−# Else, today_fmt is used as the format for a strftime call.
78		−#today_fmt = '%B %d, %Y'
79		−
80	54	# List of patterns, relative to source directory, that match files and
81	55	# directories to ignore when looking for source files.
82		−exclude_patterns = ['_build']
83		−
84		−# The reST default role (used for this markup: `text`) to use for all
85		−# documents.
86		−#default_role = None
	56	+# This pattern also affects html_static_path and html_extra_path.
	57	+exclude_patterns = []
87	58
88		−# If true, '()' will be appended to :func: etc. cross-reference text.
89		−#add_function_parentheses = True
90	59
91		−# If true, the current module name will be prepended to all description
92		−# unit titles (such as .. function::).
93		−#add_module_names = True
	60	+# -- Options for HTML output -------------------------------------------------
94	61
95		−# If true, sectionauthor and moduleauthor directives will be shown in the
96		−# output. They are ignored by default.
97		−#show_authors = False
98		−
99		−# The name of the Pygments (syntax highlighting) style to use.
100		−pygments_style = 'sphinx'
101		−
102		−# A list of ignored prefixes for module index sorting.
103		−#modindex_common_prefix = []
104		−
105		−# If true, keep warnings as "system message" paragraphs in the built documents.
106		−#keep_warnings = False
107		−
108		−# If true, `todo` and `todoList` produce output, else they produce nothing.
109		−todo_include_todos = True
110		−
111		−
112		−# -- Options for HTML output ----------------------------------------------
	62	+# The master toctree document.
	63	+master_doc = 'index'
113	64
114	65	# The theme to use for HTML and HTML Help pages. See the documentation for
115	66	# a list of builtin themes.
116		−html_theme = "default"
117		−
118		−if not on_rtd: # only import and set the theme if we're building docs locally
119		− try:
120		− import sphinx_rtd_theme
121		− html_theme = 'sphinx_rtd_theme'
122		− html_theme_path = [sphinx_rtd_theme.get_html_theme_path()]
123		− except ImportError:
124		− html_theme = "default"
125		−
126		−# Theme options are theme-specific and customize the look and feel of a theme
127		−# further. For a list of options available for each theme, see the
128		−# documentation.
129		−#html_theme_options = {}
130		−
131		−# Add any paths that contain custom themes here, relative to this directory.
132		−#html_theme_path = []
133		−
134		−# The name for this set of Sphinx documents. If None, it defaults to
135		−# "<project> v<release> documentation".
136		−#html_title = None
	67	+# # Read The Docs Themes specific settings
	68	+html_theme = 'sphinx_rtd_theme'
	69	+html_theme_options = {
	70	+ 'display_version': True,
	71	+ 'prev_next_buttons_location': 'bottom'
	72	+}
137	73
138		−# A shorter title for the navigation bar. Default is the same as html_title.
139		−#html_short_title = None
140	74
141		−# The name of an image file (relative to this directory) to place at the top
142		−# of the sidebar.
143		−#html_logo = None
144	75
145		−# The name of an image file (within the static path) to use as favicon of the
146		−# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
147		−# pixels large.
148		−#html_favicon = None
149	76
150	77	# Add any paths that contain custom static files (such as style sheets) here,
151	78	# relative to this directory. They are copied after the builtin static files,
152	79	# so a file named "default.css" will overwrite the builtin "default.css".
153	80	html_static_path = ['_static']
154	81
155		−# Add any extra paths that contain custom files (such as robots.txt or
156		−# .htaccess) here, relative to this directory. These files are copied
157		−# directly to the root of the documentation.
158		−#html_extra_path = []
159		−
160		−# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
161		−# using the given strftime format.
162		−#html_last_updated_fmt = '%b %d, %Y'
163		−
164		−# If true, SmartyPants will be used to convert quotes and dashes to
165		−# typographically correct entities.
166		−#html_use_smartypants = True
167		−
168		−# Custom sidebar templates, maps document names to template names.
169		−#html_sidebars = {}
170		−
171		−# Additional templates that should be rendered to pages, maps page names to
172		−# template names.
173		−#html_additional_pages = {}
174		−
175		−# If false, no module index is generated.
176		−#html_domain_indices = True
177		−
178		−# If false, no index is generated.
179		−#html_use_index = True
180		−
181		−# If true, the index is split into individual pages for each letter.
182		−#html_split_index = False
183		−
184		−# If true, links to the reST sources are added to the pages.
185		−#html_show_sourcelink = True
186		−
187		−# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
188		−#html_show_sphinx = True
189		−
190		−# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
191		−#html_show_copyright = True
192		−
193		−# If true, an OpenSearch description file will be output, and all pages will
194		−# contain a <link> tag referring to it. The value of this option must be the
195		−# base URL from which the finished HTML is served.
196		−#html_use_opensearch = ''
197		−
198		−# This is the file name suffix for HTML files (e.g. ".xhtml").
199		−#html_file_suffix = None
200		−
201		−# Language to be used for generating the HTML full-text search index.
202		−# Sphinx supports the following languages:
203		−# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'
204		−# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'
205		−#html_search_language = 'en'
206		−
207		−# A dictionary with options for the search language support, empty by default.
208		−# Now only 'ja' uses this config value
209		−#html_search_options = {'type': 'default'}
210		−
211		−# The name of a javascript file (relative to the configuration directory) that
212		−# implements a search results scorer. If empty, the default will be used.
213		−#html_search_scorer = 'scorer.js'
214		−
215	82	# Output file base name for HTML help builder.
216	83	htmlhelp_basename = 'IdrisManualdoc'
217	84
@@ -305,7 +172,7 @@ latex_show_url = 'footnote' · 87 unmodified lines
305	172
306	173	# The name of an image file (relative to this directory) to place at the top of
307	174	# the title page.
308		−latex_logo = '../icons/idris-512x512.png'
	175	+latex_logo = '../../icons/idris-512x512.png'
309	176
310	177	# For "manual" documents, if this is true, then toplevel headings are parts,
311	178	# not chapters.

docs/source/faq/faq.rstrenamed from docs/faq/faq.rst+0−0

File renamed without changes.

docs/source/ffi/ffi.rstrenamed from docs/ffi/ffi.rst+0−0

File renamed without changes.

docs/source/ffi/index.rstrenamed from docs/ffi/index.rst+0−0

File renamed without changes.

docs/source/ffi/readline.rstrenamed from docs/ffi/readline.rst+0−0

File renamed without changes.

docs/source/index.rstrenamed from docs/index.rst+0−0

File renamed without changes.

docs/source/listing/idris-prompt-helloworld.txtrenamed from docs/listing/idris-prompt-helloworld.txt+0−0

File renamed without changes.

docs/source/listing/idris-prompt-interp.txtrenamed from docs/listing/idris-prompt-interp.txt+0−0

File renamed without changes.

docs/source/listing/idris-prompt-start.txtrenamed from docs/listing/idris-prompt-start.txt+0−0

File renamed without changes.

docs/source/proofs/definitional.rstrenamed from docs/proofs/definitional.rst+0−0

File renamed without changes.

docs/source/proofs/index.rstrenamed from docs/proofs/index.rst+0−0

File renamed without changes.

docs/source/proofs/inductive.rstrenamed from docs/proofs/inductive.rst+0−0

File renamed without changes.

docs/source/proofs/patterns.rstrenamed from docs/proofs/patterns.rst+0−0

File renamed without changes.

docs/source/proofs/pluscomm.rstrenamed from docs/proofs/pluscomm.rst+0−0

File renamed without changes.

docs/source/proofs/propositional.rstrenamed from docs/proofs/propositional.rst+0−0

File renamed without changes.

docs/source/reference/envvars.rstrenamed from docs/reference/envvars.rst+0−0

File renamed without changes.

docs/source/reference/index.rstrenamed from docs/reference/index.rst+0−0

File renamed without changes.

docs/source/reference/packages.rstrenamed from docs/reference/packages.rst+0−0

File renamed without changes.

docs/source/tutorial/conclusions.rstrenamed from docs/tutorial/conclusions.rst+16−14

@@ -7,33 +7,35 @@ Further Reading · 6 unmodified lines
7	7	Further information about Idris programming, and programming with
8	8	dependent types in general, can be obtained from various sources:
9	9
10		−- `Type-Driven Development with Idris <https://www.manning.com/books/type-driven-development-with-idris>`_
	10	+* `Type-Driven Development with Idris <https://www.manning.com/books/type-driven-development-with-idris>`_
11	11	by Edwin Brady, available from `Manning <https://www.manning.com>`_.
12	12
13		−- The Idris web site (http://www.idris-lang.org/) and by asking
	13	+* The Idris web site (http://www.idris-lang.org/) and by asking
14	14	questions on the mailing list.
15	15
16		−- The IRC channel ``#idris``, on
	16	+* The IRC channel ``#idris``, on
17	17	`webchat.freenode.net <https://webchat.freenode.net/>`__.
18	18
19		−- The wiki (https://github.com/idris-lang/Idris-dev/wiki/) has further
	19	+* The wiki (https://github.com/idris-lang/Idris-dev/wiki/) has further
20	20	user provided information, in particular:
21	21
22		− - https://github.com/idris-lang/Idris-dev/wiki/Manual
	22	+ * https://github.com/idris-lang/Idris-dev/wiki/Manual
23	23
24		− - https://github.com/idris-lang/Idris-dev/wiki/Language-Features
	24	+ * https://github.com/idris-lang/Idris-dev/wiki/Language-Features
25	25
26		−- Examining the prelude and exploring the ``samples`` in the
	26	+* Examining the prelude and exploring the ``samples`` in the
27	27	distribution. The Idris 2 source can be found online at:
28		− https://github.com/edwinb/Idris2.
	28	+
	29	+ * https://github.com/edwinb/Idris2.
29	30
30		−- Existing projects on the ``Idris Hackers`` web space:
31		− http://idris-hackers.github.io.
	31	+* Existing projects on the ``Idris Hackers`` web space:
	32	+
	33	+ * http://idris-hackers.github.io.
32	34
33		−- Various papers (e.g. [1]_, [2]_, and [3]_). Although these mostly
	35	+* Various papers (e.g. [#BradyHammond2012]_, [#Brady]_, and [#BradyHammond2010]_). Although these mostly
34	36	describe older versions of Idris.
35	37
36		−.. [1] Edwin Brady and Kevin Hammond. 2012. Resource-Safe systems
	38	+.. [#BradyHammond2012] Edwin Brady and Kevin Hammond. 2012. Resource-Safe systems
37	39	programming with embedded domain specific languages. In
38	40	Proceedings of the 14th international conference on Practical
39	41	Aspects of Declarative Languages (PADL'12), Claudio Russo and
@@ -41,14 +43,14 @@ dependent types in general, can be obtained from various sources: · 1 unmodified line
41	43	242-257. DOI=10.1007/978-3-642-27694-1_18
42	44	http://dx.doi.org/10.1007/978-3-642-27694-1_18
43	45
44		−.. [2] Edwin C. Brady. 2011. IDRIS ---: systems programming meets full
	46	+.. [#Brady] Edwin C. Brady. 2011. IDRIS ---: systems programming meets full
45	47	dependent types. In Proceedings of the 5th ACM workshop on
46	48	Programming languages meets program verification (PLPV
47	49	'11). ACM, New York, NY, USA,
48	50	43-54. DOI=10.1145/1929529.1929536
49	51	http://doi.acm.org/10.1145/1929529.1929536
50	52
51		−.. [3] Edwin C. Brady and Kevin Hammond. 2010. Scrapping your
	53	+.. [#BradyHammond2010] Edwin C. Brady and Kevin Hammond. 2010. Scrapping your
52	54	inefficient engine: using partial evaluation to improve
53	55	domain-specific language implementation. In Proceedings of the
54	56	15th ACM SIGPLAN international conference on Functional

docs/source/tutorial/index.rstrenamed from docs/tutorial/index.rst+0−0

File renamed without changes.

docs/source/tutorial/interactive.rstrenamed from docs/tutorial/interactive.rst+1−1

@@ -165,7 +165,7 @@ then ``:ps 96 vzipWith_rhs_1`` will give · 164 unmodified lines
165	165
166	166	.. code-block:: idris
167	167
168		− []
	168	+ []
169	169
170	170	This works because it is searching for a ``Vect`` of length 0, of
171	171	which the empty vector is the only possibility. Similarly, and perhaps

docs/source/tutorial/interfaces.rstrenamed from docs/tutorial/interfaces.rst+11−9

@@ -164,7 +164,7 @@ see this at the REPL: · 163 unmodified lines
164	164	Main> :t Ord
165	165	Prelude.Ord : Type -> Type
166	166
167		−So, ``(Ord a, Show a)`` is an ordinary pair of ``Type``s, with two constraints
	167	+So, ``(Ord a, Show a)`` is an ordinary pair of ``Types``, with two constraints
168	168	as the first and second element of the pair.
169	169
170	170	Note: Interfaces and ``mutual`` blocks
@@ -282,11 +282,13 @@ which reads a number from the console, returning a value of the form · 111 unmodified lines
282	282
283	283	.. code-block:: idris
284	284
	285	+ import Data.Strings
	286	+
285	287	readNumber : IO (Maybe Nat)
286	288	readNumber = do
287	289	input <- getLine
288	290	if all isDigit (unpack input)
289		− then pure (Just (cast input))
	291	+ then pure (Just (stringToNatOrZ input))
290	292	else pure Nothing
291	293
292	294	If we then use it to write a function to read two numbers, returning
@@ -325,9 +327,9 @@ case back as follows: · 32 unmodified lines
325	327
326	328	readNumbers : IO (Maybe (Nat, Nat))
327	329	readNumbers
328		− = do Just x_ok <- readNumber
	330	+ = do Just x_ok <- readNumber
329	331	\| Nothing => pure Nothing
330		− Just y_ok <- readNumber
	332	+ Just y_ok <- readNumber
331	333	\| Nothing => pure Nothing
332	334	pure (Just (x_ok, y_ok))
333	335
@@ -432,7 +434,7 @@ Idiom brackets · 98 unmodified lines
432	434	While ``do`` notation gives an alternative meaning to sequencing,
433	435	idioms give an alternative meaning to application. The notation and
434	436	larger example in this section is inspired by Conor McBride and Ross
435		−Paterson’s paper “Applicative Programming with Effects” [1]_.
	437	+Paterson’s paper “Applicative Programming with Effects” [#ConorRoss]_.
436	438
437	439	First, let us revisit ``m_add`` above. All it is really doing is
438	440	applying an operator to two values extracted from ``Maybe Int``. We
@@ -468,19 +470,19 @@ above (this is defined in the Idris library): · 29 unmodified lines
468	470	_ <*> _ = Nothing
469	471
470	472	Using ``<*>`` we can use this implementation as follows, where a function
471		−application ``[\| f a1 …an \|]`` is translated into ``pure f <> a1 <>
	473	+application ``[ f a1 …an \|]`` is translated into ``pure f <> a1 <>
472	474	… <*> an``:
473	475
474	476	.. code-block:: idris
475	477
476	478	m_add' : Maybe Int -> Maybe Int -> Maybe Int
477		− m_add' x y = [\| x + y \|]
	479	+ m_add' x y = [ x + y \|]
478	480
479	481	An error-handling interpreter
480	482	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
481	483
482	484	Idiom notation is commonly useful when defining evaluators. McBride
483		−and Paterson describe such an evaluator [1]_, for a language similar
	485	+and Paterson describe such an evaluator [#ConorRoss]_, for a language similar
484	486	to the following:
485	487
486	488	.. code-block:: idris
@@ -653,7 +655,7 @@ is declared with the ``\| m`` after the interface declaration. We call ``m`` a · 166 unmodified lines
653	655	parameter used to find an implementation.
654	656
655	657
656		−.. [1] Conor McBride and Ross Paterson. 2008. Applicative programming
	658	+.. [#ConorRoss] Conor McBride and Ross Paterson. 2008. Applicative programming
657	659	with effects. J. Funct. Program. 18, 1 (January 2008),
658	660	1-13. DOI=10.1017/S0956796807006326
659	661	http://dx.doi.org/10.1017/S0956796807006326

docs/source/tutorial/interp.rstrenamed from docs/tutorial/interp.rst+0−0

File renamed without changes.

docs/source/tutorial/introduction.rstrenamed from docs/tutorial/introduction.rst+5−4

@@ -21,7 +21,7 @@ In a language with dependent types, however, the distinction is less · 20 unmodified lines
21	21	clear. Dependent types allow types to “depend” on values — in other
22	22	words, types are a first class language construct and can be
23	23	manipulated like any other value. The standard example is the type of
24		−lists of a given length [1]_, ``Vect n a``, where ``a`` is the element
	24	+lists of a given length [#fn1]_, ``Vect n a``, where ``a`` is the element
25	25	type and ``n`` is the length of the list and can be an arbitrary term.
26	26
27	27	When types can contain values, and where those values describe
@@ -69,6 +69,7 @@ so that you can try them out easily. They can be found under · 41 unmodified lines
69	69	``samples``. It is, however, strongly recommended that you type
70	70	them in yourself, rather than simply loading and reading them.
71	71
72		−.. [1]
73		− Typically, and perhaps confusingly, referred to in the dependently
74		− typed programming literature as “vectors”
	72	+.. rubric:: Footnotes
	73	+
	74	+.. [#fn1] Typically, and perhaps confusingly, referred to in the dependently
	75	+ typed programming literature as "vectors".

docs/source/tutorial/miscellany.rstrenamed from docs/tutorial/miscellany.rst+3−3

@@ -14,7 +14,7 @@ Implicit arguments · 13 unmodified lines
14	14	==================
15	15
16	16	We have already seen implicit arguments, which allows arguments to be
17		−omitted when they can be inferred by the type checker, e.g.
	17	+omitted when they can be inferred by the type checker [#IdrisType]_, e.g.
18	18
19	19	.. code-block:: idris
20	20
@@ -101,6 +101,7 @@ literate programs, everything is assumed to be a comment unless the line · 80 unmodified lines
101	101	begins with a greater than sign ``>``, for example:
102	102
103	103	.. code-block:: literate-idris
	104	+ :force:
104	105
105	106	> module literate
106	107
@@ -161,5 +162,4 @@ The application of ``myid`` to itself leads to a cycle in the universe · 54 unmodified lines
161	162	hierarchy — ``myid``\ ’s first argument is a ``Type``, which cannot be
162	163	at a lower level than required if it is applied to itself.
163	164
164		−.. [1]
165		− https://github.com/david-christiansen/idris-type-providers
	165	+.. [#IdrisType] https://github.com/david-christiansen/idris-type-providers

docs/source/tutorial/modules.rstrenamed from docs/tutorial/modules.rst+1−0

@@ -148,6 +148,7 @@ Additionally, a module can re-export a module it has imported, by using · 147 unmodified lines
148	148	the ``public`` modifier on an ``import``. For example:
149	149
150	150	.. code-block:: idris
	151	+ :force:
151	152
152	153	module A
153	154

docs/source/tutorial/multiplicities.rstrenamed from docs/tutorial/multiplicities.rst+1−1

@@ -423,7 +423,7 @@ unrestricted multiplicity · 422 unmodified lines
423	423	.. code-block:: idris
424	424
425	425	sumLengths : {m, n : _} -> Vect m a -> Vect n a —> Nat
426		− sumLengths xs ys = vLen xs + vLen xs
	426	+ sumLengths xs ys = vlen xs + vlen xs
427	427
428	428	Remember that giving no multiplicity on a binder, as with ``m`` and ``n`` here,
429	429	means that the variable has unrestricted usage.

docs/source/tutorial/packages.rstrenamed from docs/tutorial/packages.rst+0−0

File renamed without changes.

docs/source/tutorial/starting.rstrenamed from docs/tutorial/starting.rst+0−0

File renamed without changes.

docs/source/tutorial/theorems.rstrenamed from docs/tutorial/theorems.rst+2−2

@@ -97,7 +97,7 @@ real distinction between proofs and programs. A proof, as far as we are · 96 unmodified lines
97	97	concerned here, is merely a program with a precise enough type to
98	98	guarantee a particular property of interest.
99	99
100		−We won’t go into details here, but the Curry-Howard correspondence [1]_
	100	+We won’t go into details here, but the Curry-Howard correspondence [#Timothy]_
101	101	explains this relationship. The proof itself is immediate, because
102	102	``plus Z n`` normalises to ``n`` by the definition of ``plus``:
103	103
@@ -450,7 +450,7 @@ example from a C library) where totality can be shown by an external · 346 unmodified lines
450	450	argument.
451	451
452	452
453		−.. [1] Timothy G. Griffin. 1989. A formulae-as-type notion of
	453	+.. [#Timothy] Timothy G. Griffin. 1989. A formulae-as-type notion of
454	454	control. In Proceedings of the 17th ACM SIGPLAN-SIGACT
455	455	symposium on Principles of programming languages (POPL
456	456	'90). ACM, New York, NY, USA, 47-58. DOI=10.1145/96709.96714

docs/source/tutorial/typesfuns.rstrenamed from docs/tutorial/typesfuns.rst+3−7

@@ -221,12 +221,12 @@ of how this works in practice: · 220 unmodified lines
221	221	odd : Nat -> Bool
222	222	odd Z = False
223	223	odd (S k) = even k
224		−
	224	+
225	225	test : List Nat
226	226	test = [c (S 1), c Z, d (S Z)]
227	227	where c : Nat -> Nat
228	228	c x = 42 + x
229		−
	229	+
230	230	d : Nat -> Nat
231	231	d y = c (y + 1 + z y)
232	232	where z : Nat -> Nat
@@ -753,12 +753,8 @@ For more details of the functions available on ``List`` and · 520 unmodified lines
753	753
754	754	- ``libs/base/Data/List.idr``
755	755
756		−- ``libs/base/Data/List.idr``
757		−
758	756	- ``libs/base/Data/Vect.idr``
759	757
760		−- ``libs/base/Data/VectType.idr``
761		−
762	758	Functions include filtering, appending, reversing, and so on.
763	759
764	760	Aside: Anonymous functions and operator sections
@@ -1052,7 +1048,7 @@ name. For example, a pair type could be defined as follows: · 287 unmodified lines
1052	1048	fst : a
1053	1049	snd : b
1054	1050
1055		−Using the ``class`` record from earlier, the size of the class can be
	1051	+Using the ``Class`` record from earlier, the size of the class can be
1056	1052	restricted using a ``Vect`` and the size included in the type by parameterising
1057	1053	the record with the size. For example:
1058	1054

docs/source/tutorial/views.rstrenamed from docs/tutorial/views.rst+2−2

@@ -31,7 +31,7 @@ The ``with`` rule — matching intermediate values · 30 unmodified lines
31	31
32	32	Very often, we need to match on the result of an intermediate
33	33	computation. Idris provides a construct for this, the ``with``
34		−rule, inspired by views in ``Epigram`` [1]_, which takes account of
	34	+rule, inspired by views in ``Epigram`` [#McBridgeMcKinna]_, which takes account of
35	35	the fact that matching on a value in a dependently typed language can
36	36	affect what we know about the forms of other values. In its simplest
37	37	form, the ``with`` rule adds another argument to the function being
@@ -151,6 +151,6 @@ it is: · 113 unmodified lines
151	151	For full details on ``rewrite`` in particular, please refer to the theorem
152	152	proving tutorial, in Section :ref:`proofs-index`.
153	153
154		−.. [1] Conor McBride and James McKinna. 2004. The view from the
	154	+.. [#McBridgeMcKinna] Conor McBride and James McKinna. 2004. The view from the
155	155	left. J. Funct. Program. 14, 1 (January 2004),
156	156	69-111. https://doi.org/10.1017/S0956796803004829

docs/source/typedd/typedd.rstrenamed from docs/typedd/typedd.rst+0−0

File renamed without changes.

docs/source/updates/updates.rstrenamed from docs/updates/updates.rst+2−2

@@ -140,7 +140,7 @@ unrestricted multiplicity · 139 unmodified lines
140	140	.. code-block:: idris
141	141
142	142	sumLengths : {m, n : _} -> Vect m a -> Vect n a —> Nat
143		− sumLengths xs ys = vLen xs + vLen xs
	143	+ sumLengths xs ys = vlen xs + vlen xs
144	144
145	145	Remember that giving no multiplicity on a binder, as with ``m`` and ``n`` here,
146	146	means that the variable has unrestricted usage.
@@ -263,7 +263,7 @@ Idris 1, it won't attempt significant backtracking. If you have deeply nested · 116 unmodified lines
263	263	ambiguous names (beyond a small threshold, default 3) Idris 2 will report an
264	264	error. You can change this threshold with a directive, for example:
265	265
266		−.. code_block:: idris
	266	+.. code-block:: idris
267	267
268	268	%ambiguity_depth 10
269	269

idris2.ipkg+1−0

@@ -4,6 +4,7 @@ modules = · 3 unmodified lines
4	4	Compiler.Common,
5	5	Compiler.CompileExpr,
6	6	Compiler.Inline,
	7	+ Compiler.LambdaLift,
7	8	Compiler.Scheme.Chez,
8	9	-- Compiler.Scheme.Chicken,
9	10	Compiler.Scheme.Racket,

libs/network/Network/Socket/Raw.idr+12−0

@@ -23,7 +23,18 @@ data SockaddrPtr = SAPtr AnyPtr · 22 unmodified lines
23	23
24	24	-- ---------------------------------------------------------- [ Socket Utilies ]
25	25
	26	+\|\|\| Put a value in a buffer
	27	+export
	28	+sock_poke : BufPtr -> Int -> Int -> IO ()
	29	+sock_poke (BPtr ptr) offset val = cCall () "idrnet_poke" [ptr, offset, val]
	30	+
	31	+\|\|\| Take a value from a buffer
	32	+export
	33	+sock_peek : BufPtr -> Int -> IO Int
	34	+sock_peek (BPtr ptr) offset = cCall Int "idrnet_peek" [ptr, offset]
	35	+
26	36	\|\|\| Frees a given pointer
	37	+export
27	38	sock_free : BufPtr -> IO ()
28	39	sock_free (BPtr ptr) = cCall () "idrnet_free" [ptr]
29	40
@@ -34,6 +45,7 @@ sockaddr_free (SAPtr ptr) = cCall () "idrnet_free" [ptr] · 4 unmodified lines
34	45	\|\|\| Allocates an amount of memory given by the ByteLength parameter.
35	46	\|\|\|
36	47	\|\|\| Used to allocate a mutable pointer to be given to the Recv functions.
	48	+export
37	49	sock_alloc : ByteLength -> IO BufPtr
38	50	sock_alloc bl = map BPtr $ cCall AnyPtr "idrnet_malloc" [bl]
39	51

libs/network/idris_net.c+10−0

@@ -56,6 +56,16 @@ void idrnet_free(void* ptr) { · 55 unmodified lines
56	56	free(ptr);
57	57	}
58	58
	59	+unsigned int idrnet_peek(void *ptr, unsigned int offset) {
	60	+ unsigned char buf_c = (unsigned char) ptr;
	61	+ return (unsigned int) buf_c[offset];
	62	+}
	63	+
	64	+void idrnet_poke(void *ptr, unsigned int offset, char val) {
	65	+ char buf_c = (char)ptr;
	66	+ buf_c[offset] = val;
	67	+}
	68	+
59	69
60	70	int idrnet_socket(int domain, int type, int protocol) {
61	71	#ifdef _WIN32

libs/network/idris_net.h+2−0

@@ -31,6 +31,8 @@ typedef struct idrnet_recvfrom_result { · 30 unmodified lines
31	31	// Memory management functions
32	32	void* idrnet_malloc(int size);
33	33	void idrnet_free(void* ptr);
	34	+unsigned int idrnet_peek(void *ptr, unsigned int offset);
	35	+void idrnet_poke(void *ptr, unsigned int offset, char val);
34	36
35	37	// Gets value of errno
36	38	int idrnet_errno();

libs/network/test.c+15−0

@@ -31,10 +31,25 @@ void test_sockaddr_port_returns_explicitly_assigned_port() { · 30 unmodified lines
31	31	close(sock);
32	32	}
33	33
	34	+void test_peek_and_poke_buffer() {
	35	+ void *buf = idrnet_malloc(100);
	36	+ assert(buf > 0);
	37	+
	38	+ for (int i = 0; i < 100; i++) {
	39	+ idrnet_poke(buf,i,7*i);
	40	+ }
	41	+
	42	+ for(int i = 0; i < 100; i++) {
	43	+ assert (idrnet_peek(buf,i) == (0xff & 7*i));
	44	+ }
	45	+ idrnet_free(buf);
	46	+}
	47	+
34	48
35	49	int main(int argc, char**argv) {
36	50	test_sockaddr_port_returns_explicitly_assigned_port();
37	51	test_sockaddr_port_returns_random_port_when_bind_port_is_0();
	52	+ test_peek_and_poke_buffer();
38	53
39	54	printf("network library tests SUCCESS\n");
40	55	return 0;

libs/prelude/Prelude.idr+1−0

@@ -364,6 +364,7 @@ Integral Integer where · 363 unmodified lines
364	364	-- all other possibilities fail. I don't plan to provide a nicer syntax for
365	365	-- this...
366	366	%defaulthint
	367	+%inline
367	368	public export
368	369	defaultInteger : Num Integer
369	370	defaultInteger = %search

src/Compiler/Common.idr+52−14

@@ -2,6 +2,7 @@ module Compiler.Common · 1 unmodified line
2	2
3	3	import Compiler.CompileExpr
4	4	import Compiler.Inline
	5	+import Compiler.LambdaLift
5	6
6	7	import Core.Context
7	8	import Core.Directory
@@ -101,12 +102,10 @@ fastAppend xs · 93 unmodified lines
101	102	build b (x :: xs) = do addToStringBuffer b x
102	103	build b xs
103	104
104		−dumpCases : {auto c : Ref Ctxt Defs} ->
105		− String -> List Name ->
	105	+dumpCases : Defs -> String -> List Name ->
106	106	Core ()
107		−dumpCases fn cns
108		− = do defs <- get Ctxt
109		− cstrs <- traverse (dumpCase defs) cns
	107	+dumpCases defs fn cns
	108	+ = do cstrs <- traverse dumpCase cns
110	109	Right () <- coreLift $ writeFile fn (fastAppend cstrs)
111	110	\| Left err => throw (FileErr fn err)
112	111	pure ()
@@ -115,21 +114,47 @@ dumpCases fn cns · 2 unmodified lines
115	114	fullShow (DN _ n) = show n
116	115	fullShow n = show n
117	116
118		− dumpCase : Defs -> Name -> Core String
119		− dumpCase defs n
	117	+ dumpCase : Name -> Core String
	118	+ dumpCase n
120	119	= case !(lookupCtxtExact n (gamma defs)) of
121	120	Nothing => pure ""
122	121	Just d =>
123		− case compexpr d of
	122	+ case namedcompexpr d of
124	123	Nothing => pure ""
125	124	Just def => pure (fullShow n ++ " = " ++ show def ++ "\n")
126	125
	126	+dumpLifted : String -> List (Name, LiftedDef) -> Core ()
	127	+dumpLifted fn lns
	128	+ = do let cstrs = map dumpDef lns
	129	+ Right () <- coreLift $ writeFile fn (fastAppend cstrs)
	130	+ \| Left err => throw (FileErr fn err)
	131	+ pure ()
	132	+ where
	133	+ fullShow : Name -> String
	134	+ fullShow (DN _ n) = show n
	135	+ fullShow n = show n
	136	+
	137	+ dumpDef : (Name, LiftedDef) -> String
	138	+ dumpDef (n, d) = fullShow n ++ " = " ++ show d ++ "\n"
	139	+
	140	+public export
	141	+record CompileData where
	142	+ constructor MkCompileData
	143	+ allNames : List Name -- names which need to be compiled
	144	+ nameTags : NameTags -- a mapping from type names to constructor tags
	145	+ mainExpr : CExp [] -- main expression to execute
	146	+ lambdaLifted : List (Name, LiftedDef)
	147	+ -- ^ lambda lifted definitions, if required. Only the top level names
	148	+ -- will be in the context, and (for the moment...) I don't expect to
	149	+ -- need to look anything up, so it's just an alist.
	150	+
127	151	-- Find all the names which need compiling, from a given expression, and compile
128		−-- them to CExp form (and update that in the Defs)
	152	+-- them to CExp form (and update that in the Defs).
	153	+-- Return the names, the type tags, and a compiled version of the expression
129	154	export
130		−findUsedNames : {auto c : Ref Ctxt Defs} ->
131		− Term vars -> Core (List Name, NameTags)
132		−findUsedNames tm
	155	+getCompileData : {auto c : Ref Ctxt Defs} ->
	156	+ ClosedTerm -> Core CompileData
	157	+getCompileData tm
133	158	= do defs <- get Ctxt
134	159	sopts <- getSession
135	160	let ns = getRefs (Resolved (-1)) tm
@@ -154,11 +179,24 @@ findUsedNames tm · 18 unmodified lines
154	179	logTime ("Compile defs " ++ show (length cns) ++ "/" ++ show asize) $
155	180	traverse_ (compileDef tycontags) cns
156	181	logTime "Inline" $ traverse_ inlineDef cns
	182	+ logTime "Merge lambda" $ traverse_ mergeLamDef cns
	183	+ logTime "Fix arity" $ traverse_ fixArityDef cns
	184	+ logTime "Forget names" $ traverse_ mkForgetDef cns
	185	+
	186	+ lifted <- logTime "Lambda lift" $ traverse lambdaLift cns
	187	+
	188	+ compiledtm <- fixArityExp !(compileExp tycontags tm)
	189	+
	190	+ defs <- get Ctxt
157	191	maybe (pure ())
158	192	(\f => do coreLift $ putStrLn $ "Dumping case trees to " ++ f
159		− dumpCases f cns)
	193	+ dumpCases defs f cns)
160	194	(dumpcases sopts)
161		− pure (cns, tycontags)
	195	+ maybe (pure ())
	196	+ (\f => do coreLift $ putStrLn $ "Dumping lambda lifted defs to " ++ f
	197	+ dumpLifted f (concat lifted))
	198	+ (dumplifted sopts)
	199	+ pure (MkCompileData cns tycontags compiledtm (concat lifted))
162	200	where
163	201	primTags : Int -> NameTags -> List Constant -> NameTags
164	202	primTags t tags [] = tags

src/Compiler/CompileExpr.idr+103−29

@@ -23,6 +23,7 @@ NameTags = NameMap Int · 22 unmodified lines
23	23
24	24	data Args
25	25	= NewTypeBy Nat Nat
	26	+ \| EraseArgs Nat (List Nat)
26	27	\| Arity Nat
27	28
28	29	\|\|\| Extract the number of arguments from a term, or return that it's
@@ -30,13 +31,15 @@ data Args · 1 unmodified line
30	31	numArgs : Defs -> Term vars -> Core Args
31	32	numArgs defs (Ref _ (TyCon tag arity) n) = pure (Arity arity)
32	33	numArgs defs (Ref _ _ n)
33		− = case !(lookupDefExact n (gamma defs)) of
34		− Just (DCon _ arity Nothing) => pure (Arity arity)
35		− Just (DCon _ arity (Just pos)) => pure (NewTypeBy arity pos)
36		− Just (PMDef _ args _ _ _) => pure (Arity (length args))
37		− Just (ExternDef arity) => pure (Arity arity)
38		− Just (ForeignDef arity _) => pure (Arity arity)
39		− Just (Builtin {arity} f) => pure (Arity arity)
	34	+ = do Just gdef <- lookupCtxtExact n (gamma defs)
	35	+ \| Nothing => pure (Arity 0)
	36	+ case definition gdef of
	37	+ DCon _ arity Nothing => pure (EraseArgs arity (eraseArgs gdef))
	38	+ DCon _ arity (Just (_, pos)) => pure (NewTypeBy arity pos)
	39	+ PMDef _ args _ _ _ => pure (Arity (length args))
	40	+ ExternDef arity => pure (Arity arity)
	41	+ ForeignDef arity _ => pure (Arity arity)
	42	+ Builtin {arity} f => pure (Arity arity)
40	43	_ => pure (Arity 0)
41	44	numArgs _ tm = pure (Arity 0)
42	45
@@ -60,6 +63,7 @@ etaExpand i (S k) exp args · 17 unmodified lines
60	63	(etaExpand (i + 1) k (weaken exp)
61	64	(MkVar First :: map weakenVar args))
62	65
	66	+export
63	67	expandToArity : Nat -> CExp vars -> List (CExp vars) -> CExp vars
64	68	-- No point in applying to anything
65	69	expandToArity _ (CErased fc) _ = CErased fc
@@ -96,6 +100,34 @@ applyNewType arity pos fn args · 30 unmodified lines
96	100	keepArg (CCon fc _ _ args) = keep 0 args
97	101	keepArg tm = CErased (getFC fn)
98	102
	103	+dropPos : List Nat -> CExp vs -> CExp vs
	104	+dropPos epos (CLam fc x sc) = CLam fc x (dropPos epos sc)
	105	+dropPos epos (CCon fc c a args) = CCon fc c a (drop 0 args)
	106	+ where
	107	+ drop : Nat -> List (CExp vs) -> List (CExp vs)
	108	+ drop i [] = []
	109	+ drop i (x :: xs)
	110	+ = if i `elem` epos
	111	+ then drop (1 + i) xs
	112	+ else x :: drop (1 + i) xs
	113	+dropPos epos tm = tm
	114	+
	115	+eraseConArgs : Nat -> List Nat -> CExp vars -> List (CExp vars) -> CExp vars
	116	+eraseConArgs arity epos fn args
	117	+ = let fn' = expandToArity arity fn args in
	118	+ dropPos epos fn' -- fn' might be lambdas, after eta expansion
	119	+
	120	+mkDropSubst : Nat -> List Nat ->
	121	+ (rest : List Name) ->
	122	+ (vars : List Name) ->
	123	+ (vars' ** SubVars (vars' ++ rest) (vars ++ rest))
	124	+mkDropSubst i es rest [] = ([] ** SubRefl)
	125	+mkDropSubst i es rest (x :: xs)
	126	+ = let (vs ** sub) = mkDropSubst (1 + i) es rest xs in
	127	+ if i `elem` es
	128	+ then (vs ** DropCons sub)
	129	+ else (x :: vs ** KeepCons sub)
	130	+
99	131	-- Rewrite applications of Nat constructors and functions to more optimal
100	132	-- versions using Integer
101	133
@@ -130,7 +162,7 @@ natBranch (MkConAlt n _ _ _) = isNatCon n · 28 unmodified lines
130	162	trySBranch : CExp vars -> CConAlt vars -> Maybe (CExp vars)
131	163	trySBranch n (MkConAlt (NS ["Prelude"] (UN "S")) _ [arg] sc)
132	164	= let fc = getFC n in
133		− Just (CLet fc arg (CApp fc (CRef fc (UN "prim__sub_Integer"))
	165	+ Just (CLet fc arg True (CApp fc (CRef fc (UN "prim__sub_Integer"))
134	166	[n, CPrimVal fc (BI 1)]) sc)
135	167	trySBranch _ _ = Nothing
136	168
@@ -184,7 +216,7 @@ mutual · 47 unmodified lines
184	216	toCExpTm tags n (Bind fc x (Let Rig0 val _) sc)
185	217	= pure $ shrinkCExp (DropCons SubRefl) !(toCExp tags n sc)
186	218	toCExpTm tags n (Bind fc x (Let _ val _) sc)
187		− = pure $ CLet fc x !(toCExp tags n val) !(toCExp tags n sc)
	219	+ = pure $ CLet fc x True !(toCExp tags n val) !(toCExp tags n sc)
188	220	toCExpTm tags n (Bind fc x (Pi c e ty) sc)
189	221	= pure $ CCon fc (UN "->") 1 [!(toCExp tags n ty),
190	222	CLam fc x !(toCExp tags n sc)]
@@ -219,25 +251,38 @@ mutual · 28 unmodified lines
219	251	\| NewTypeBy arity pos =>
220	252	do let res = applyNewType arity pos !(toCExpTm tags n f) args'
221	253	pure $ natHack res
	254	+ \| EraseArgs arity epos =>
	255	+ do let res = eraseConArgs arity epos !(toCExpTm tags n f) args'
	256	+ pure $ natHack res
222	257	let res = expandToArity a !(toCExpTm tags n f) args'
223	258	pure $ natHack res
224	259
225	260	mutual
226		− -- In the below, treat %World, and newtypes, as default cases
227	261	conCases : {auto c : Ref Ctxt Defs} ->
228	262	NameTags -> Name -> List (CaseAlt vars) ->
229	263	Core (List (CConAlt vars))
230	264	conCases tags n [] = pure []
231		− conCases tags n (ConCase x tag args sc :: ns)
	265	+ conCases {vars} tags n (ConCase x tag args sc :: ns)
232	266	= do defs <- get Ctxt
233		− case !(lookupDefExact x (gamma defs)) of
234		− Just (DCon _ arity (Just pos)) => conCases tags n ns -- skip it
235		− _ => do let tag' = case lookup x tags of
	267	+ Just gdef <- lookupCtxtExact x (gamma defs)
	268	+ \| Nothing => -- primitive type match
	269	+ do xn <- getFullName x
	270	+ let tag' = case lookup x tags of
236	271	Just t => t
237	272	_ => tag
238		− xn <- getFullName x
239	273	pure $ MkConAlt xn tag' args !(toCExpTree tags n sc)
240	274	:: !(conCases tags n ns)
	275	+ case (definition gdef) of
	276	+ DCon _ arity (Just pos) => conCases tags n ns -- skip it
	277	+ _ => do xn <- getFullName x
	278	+ let (args' ** sub)
	279	+ = mkDropSubst 0 (eraseArgs gdef) vars args
	280	+ let tag' = case lookup x tags of
	281	+ Just t => t
	282	+ _ => tag
	283	+ pure $ MkConAlt xn tag' args'
	284	+ (shrinkCExp sub !(toCExpTree tags n sc))
	285	+ :: !(conCases tags n ns)
241	286	conCases tags n (_ :: ns) = conCases tags n ns
242	287
243	288	constCases : {auto c : Ref Ctxt Defs} ->
@@ -254,18 +299,25 @@ mutual · 10 unmodified lines
254	299	getDef : {auto c : Ref Ctxt Defs} ->
255	300	FC -> CExp vars ->
256	301	NameTags -> Name -> List (CaseAlt vars) ->
257		− Core (Maybe (CExp vars))
258		− getDef fc scr tags n [] = pure Nothing
	302	+ Core (Bool, Maybe (CExp vars))
	303	+ getDef fc scr tags n [] = pure (False, Nothing)
259	304	getDef fc scr tags n (DefaultCase sc :: ns)
260		− = pure $ Just !(toCExpTree tags n sc)
	305	+ = pure $ (False, Just !(toCExpTree tags n sc))
261	306	getDef fc scr tags n (ConstCase WorldVal sc :: ns)
262		− = pure $ Just !(toCExpTree tags n sc)
	307	+ = pure $ (False, Just !(toCExpTree tags n sc))
263	308	getDef {vars} fc scr tags n (ConCase x tag args sc :: ns)
264	309	= do defs <- get Ctxt
265	310	case !(lookupDefExact x (gamma defs)) of
266		− Just (DCon _ arity (Just pos)) =>
	311	+ -- If the flag is False, we still take the
	312	+ -- default, but need to evaluate the scrutinee of the
	313	+ -- case anyway - if the data structure contains a %World,
	314	+ -- that we've erased, it means it has interacted with the
	315	+ -- outside world, so we need to evaluate to keep the
	316	+ -- side effect.
	317	+ Just (DCon _ arity (Just (noworld, pos))) =>
267	318	let env : SubstCEnv args vars = mkSubst 0 pos args in
268		− pure $ Just (substs env !(toCExpTree tags n sc))
	319	+ pure $ (not noworld,
	320	+ Just (substs env !(toCExpTree tags n sc)))
269	321	_ => getDef fc scr tags n ns
270	322	where
271	323	mkSubst : Nat -> Nat -> (args : List Name) -> SubstCEnv args vars
@@ -282,8 +334,8 @@ mutual · 10 unmodified lines
282	334	toCExpTree tags n alts@(Case _ x scTy (DelayCase ty arg sc :: rest))
283	335	= let fc = getLoc scTy in
284	336	pure $
285		− CLet fc arg (CForce fc (CLocal (getLoc scTy) x)) $
286		− CLet fc ty (CErased fc)
	337	+ CLet fc arg True (CForce fc (CLocal (getLoc scTy) x)) $
	338	+ CLet fc ty True (CErased fc)
287	339	!(toCExpTree tags n sc)
288	340	toCExpTree tags n alts = toCExpTree' tags n alts
289	341
@@ -294,9 +346,13 @@ mutual · 4 unmodified lines
294	346	= let fc = getLoc scTy in
295	347	do defs <- get Ctxt
296	348	cases <- conCases tags n alts
297		− def <- getDef fc (CLocal fc x) tags n alts
	349	+ (keepSc, def) <- getDef fc (CLocal fc x) tags n alts
298	350	if isNil cases
299		− then pure (fromMaybe (CErased fc) def)
	351	+ then (if keepSc
	352	+ then pure $ CLet fc (MN "eff" 0) False
	353	+ (CLocal fc x)
	354	+ (weaken (fromMaybe (CErased fc) def))
	355	+ else pure (fromMaybe (CErased fc) def))
300	356	else pure $ natHackTree $
301	357	CConCase fc (CLocal fc x) cases def
302	358	toCExpTree' tags n (Case _ x scTy alts@(DelayCase _ _ _ :: _))
@@ -304,9 +360,13 @@ mutual · 1 unmodified line
304	360	toCExpTree' tags n (Case fc x scTy alts@(ConstCase _ _ :: _))
305	361	= let fc = getLoc scTy in
306	362	do cases <- constCases tags n alts
307		− def <- getDef fc (CLocal fc x) tags n alts
	363	+ (keepSc, def) <- getDef fc (CLocal fc x) tags n alts
308	364	if isNil cases
309		− then pure (fromMaybe (CErased fc) def)
	365	+ then (if keepSc
	366	+ then pure $ CLet fc (MN "eff" 0) False
	367	+ (CLocal fc x)
	368	+ (weaken (fromMaybe (CErased fc) def))
	369	+ else pure (fromMaybe (CErased fc) def))
310	370	else pure $ CConstCase fc (CLocal fc x) cases def
311	371	toCExpTree' tags n (Case _ x scTy alts@(DefaultCase sc :: _))
312	372	= toCExpTree tags n sc
@@ -457,7 +517,8 @@ toCDef tags n ty (Builtin {arity} op) · 144 unmodified lines
457	517	getVars NoArgs = []
458	518	getVars (ConsArg a rest) = MkVar First :: map weakenVar (getVars rest)
459	519	toCDef tags n _ (DCon tag arity pos)
460		− = pure $ MkCon (fromMaybe tag $ lookup n tags) arity pos
	520	+ = let nt = maybe Nothing (Just . snd) pos in
	521	+ pure $ MkCon (fromMaybe tag $ lookup n tags) arity nt
461	522	toCDef tags n _ (TCon tag arity _ _ _ _ _ _)
462	523	= pure $ MkCon (fromMaybe tag $ lookup n tags) arity Nothing
463	524	-- We do want to be able to compile these, but also report an error at run time
@@ -479,7 +540,8 @@ export · 15 unmodified lines
479	540	compileExp : {auto c : Ref Ctxt Defs} ->
480	541	NameTags -> ClosedTerm -> Core (CExp [])
481	542	compileExp tags tm
482		− = toCExp tags (UN "main") tm
	543	+ = do exp <- toCExp tags (UN "main") tm
	544	+ pure exp
483	545
484	546	\|\|\| Given a name, look up an expression, and compile it to a CExp in the environment
485	547	export
@@ -491,3 +553,15 @@ compileDef tags n · 5 unmodified lines
491	553	ce <- toCDef tags n (type gdef)
492	554	!(toFullNames (definition gdef))
493	555	setCompiled n ce
	556	+
	557	+export
	558	+mkForgetDef : {auto c : Ref Ctxt Defs} ->
	559	+ Name -> Core ()
	560	+mkForgetDef n
	561	+ = do defs <- get Ctxt
	562	+ Just gdef <- lookupCtxtExact n (gamma defs)
	563	+ \| Nothing => throw (InternalError ("Trying to compile unknown name " ++ show n))
	564	+ case compexpr gdef of
	565	+ Nothing => pure ()
	566	+ Just cdef => do let ncdef = forgetDef cdef
	567	+ setNamedCompiled n ncdef

src/Compiler/Inline.idr+207−35

@@ -1,5 +1,7 @@
1	1	module Compiler.Inline
2	2
	3	+import Compiler.CompileExpr
	4	+
3	5	import Core.CompileExpr
4	6	import Core.Context
5	7	import Core.FC
@@ -14,26 +16,12 @@ data EEnv : List Name -> List Name -> Type where · 8 unmodified lines
14	16	Nil : EEnv free []
15	17	(::) : CExp free -> EEnv free vars -> EEnv free (x :: vars)
16	18
17		−weakenEnv : EEnv free vars -> EEnv (x :: free) vars
18		−weakenEnv [] = []
19		−weakenEnv (e :: env) = weaken e :: weakenEnv env
20		−
21		−weakenNsEnv : (xs : List Name) -> EEnv free vars -> EEnv (xs ++ free) vars
22		−weakenNsEnv [] env = env
23		−weakenNsEnv (x :: xs) env = weakenEnv (weakenNsEnv xs env)
24		−
25	19	extend : EEnv free vars -> (args : List (CExp free)) -> (args' : List Name) ->
26	20	LengthMatch args args' -> EEnv free (args' ++ vars)
27	21	extend env [] [] NilMatch = env
28	22	extend env (a :: xs) (n :: ns) (ConsMatch w)
29	23	= a :: extend env xs ns w
30	24
31		−extendLoc : FC -> EEnv free vars -> (args' : List Name) ->
32		− EEnv (args' ++ free) (args' ++ vars)
33		−extendLoc fc env [] = env
34		−extendLoc fc env (n :: ns)
35		− = CLocal fc First :: weakenEnv (extendLoc fc env ns)
36		−
37	25	Stack : List Name -> Type
38	26	Stack vars = List (CExp vars)
39	27
@@ -58,13 +46,46 @@ takeFromStack env (e :: es) (a :: as) · 18 unmodified lines
58	46	takeFromStack env stk [] = pure (env, stk)
59	47	takeFromStack env [] args = Nothing
60	48
61		−thinAll : (ns : List Name) -> CExp (outer ++ inner) -> CExp (outer ++ ns ++ inner)
62		−thinAll [] exp = exp
63		−thinAll {outer} {inner} (n :: ns) exp
64		− = thin {outer} {inner = ns ++ inner} n (thinAll ns exp)
	49	+data LVar : Type where
	50	+
	51	+genName : {auto l : Ref LVar Int} ->
	52	+ String -> Core Name
	53	+genName n
	54	+ = do i <- get LVar
	55	+ put LVar (i + 1)
	56	+ pure (MN n i)
	57	+
	58	+refToLocal : Name -> (x : Name) -> CExp vars -> CExp (x :: vars)
	59	+refToLocal x new tm = refsToLocals (Add new x None) tm
	60	+
	61	+mutual
	62	+ used : Name -> CExp free -> Bool
	63	+ used n (CRef _ n') = n == n'
	64	+ used n (CLam _ _ sc) = used n sc
	65	+ used n (CLet _ _ _ val sc) = used n val \|\| used n sc
	66	+ used n (CApp _ x args) = used n x \|\| or (map Delay (map (used n) args))
	67	+ used n (CCon _ _ _ args) = or (map Delay (map (used n) args))
	68	+ used n (COp _ _ args) = or (map Delay (map (used n) args))
	69	+ used n (CExtPrim _ _ args) = or (map Delay (map (used n) args))
	70	+ used n (CForce _ x) = used n x
	71	+ used n (CDelay _ x) = used n x
	72	+ used n (CConCase fc sc alts def)
	73	+ = used n sc \|\| or (map Delay (map (usedCon n) alts))
	74	+ \|\| maybe False (used n) def
	75	+ used n (CConstCase fc sc alts def)
	76	+ = used n sc \|\| or (map Delay (map (usedConst n) alts))
	77	+ \|\| maybe False (used n) def
	78	+ used _ tm = False
	79	+
	80	+ usedCon : Name -> CConAlt free -> Bool
	81	+ usedCon n (MkConAlt _ _ _ sc) = used n sc
	82	+
	83	+ usedConst : Name -> CConstAlt free -> Bool
	84	+ usedConst n (MkConstAlt _ sc) = used n sc
65	85
66	86	mutual
67	87	evalLocal : {auto c : Ref Ctxt Defs} ->
	88	+ {auto l : Ref LVar Int} ->
68	89	FC -> List Name -> Stack free ->
69	90	EEnv free vars ->
70	91	{idx : Nat} -> .(IsVar x idx (vars ++ free)) ->
@@ -72,11 +93,14 @@ mutual · 1 unmodified line
72	93	evalLocal {vars = []} fc rec stk env p
73	94	= pure $ unload stk (CLocal fc p)
74	95	evalLocal {vars = x :: xs} fc rec stk (v :: env) First
75		− = eval rec env stk (weakenNs xs v)
	96	+ = case stk of
	97	+ [] => pure v
	98	+ _ => eval rec env stk (weakenNs xs v)
76	99	evalLocal {vars = x :: xs} fc rec stk (_ :: env) (Later p)
77	100	= evalLocal fc rec stk env p
78	101
79	102	tryApply : {auto c : Ref Ctxt Defs} ->
	103	+ {auto l : Ref LVar Int} ->
80	104	List Name -> Stack free -> EEnv free vars -> CDef ->
81	105	Core (Maybe (CExp free))
82	106	tryApply {free} {vars} rec stk env (MkFun args exp)
@@ -89,6 +113,7 @@ mutual · 6 unmodified lines
89	113	tryApply rec stk env _ = pure Nothing
90	114
91	115	eval : {auto c : Ref Ctxt Defs} ->
	116	+ {auto l : Ref LVar Int} ->
92	117	List Name -> EEnv free vars -> Stack free -> CExp (vars ++ free) ->
93	118	Core (CExp free)
94	119	eval rec env stk (CLocal fc p) = evalLocal fc rec stk env p
@@ -100,18 +125,21 @@ mutual · 5 unmodified lines
100	125	\| Nothing => pure (unload stk (CRef fc n))
101	126	let arity = getArity def
102	127	if (Inline `elem` flags gdef) && (not (n `elem` rec))
103		− then do ap <- tryApply (n :: rec) stk env def
	128	+ then do ap <- tryApply (n :: rec) stk env def
104	129	pure $ maybe (unloadApp arity stk (CRef fc n)) id ap
105	130	else pure $ unloadApp arity stk (CRef fc n)
106	131	eval {vars} {free} rec env [] (CLam fc x sc)
107		− = do let thinsc = thin x {outer = x :: vars} {inner = free} sc
108		− sc' <- eval rec (CLocal fc First :: weakenEnv env) [] thinsc
109		− pure $ CLam fc x sc'
	132	+ = do xn <- genName "lamv"
	133	+ sc' <- eval rec (CRef fc xn :: env) [] sc
	134	+ pure $ CLam fc x (refToLocal xn x sc')
110	135	eval rec env (e :: stk) (CLam fc x sc) = eval rec (e :: env) stk sc
111		− eval {vars} {free} rec env stk (CLet fc x val sc)
112		− = do let thinsc = thin x {outer = x :: vars} {inner = free} sc
113		− sc' <- eval rec (CLocal fc First :: weakenEnv env) [] thinsc
114		− pure $ unload stk $ CLet fc x !(eval rec env [] val) sc'
	136	+ eval {vars} {free} rec env stk (CLet fc x inl val sc)
	137	+ = do xn <- genName "letv"
	138	+ sc' <- eval rec (CRef fc xn :: env) [] sc
	139	+ if inl && used xn sc'
	140	+ then do val' <- eval rec env [] val
	141	+ pure (unload stk $ CLet fc x inl val' (refToLocal xn x sc'))
	142	+ else pure sc'
115	143	eval rec env stk (CApp fc f args)
116	144	= eval rec env (!(traverse (eval rec env []) args) ++ stk) f
117	145	eval rec env stk (CCon fc n t args)
@@ -144,22 +172,34 @@ mutual · 26 unmodified lines
144	172	eval rec env stk (CErased fc) = pure $ unload stk $ CErased fc
145	173	eval rec env stk (CCrash fc str) = pure $ unload stk $ CCrash fc str
146	174
	175	+ extendLoc : {auto l : Ref LVar Int} ->
	176	+ FC -> EEnv free vars -> (args' : List Name) ->
	177	+ Core (Bounds args', EEnv free (args' ++ vars))
	178	+ extendLoc fc env [] = pure (None, env)
	179	+ extendLoc fc env (n :: ns)
	180	+ = do xn <- genName "cv"
	181	+ (bs', env') <- extendLoc fc env ns
	182	+ pure (Add n xn bs', CRef fc xn :: env')
	183	+
147	184	evalAlt : {auto c : Ref Ctxt Defs} ->
	185	+ {auto l : Ref LVar Int} ->
148	186	FC -> List Name -> EEnv free vars -> Stack free -> CConAlt (vars ++ free) ->
149	187	Core (CConAlt free)
150	188	evalAlt {free} {vars} fc rec env stk (MkConAlt n t args sc)
151		− = do let sc' = thinAll {outer=args ++ vars} {inner=free} args
152		− (rewrite sym (appendAssociative args vars free) in sc)
153		− scEval <- eval rec (extendLoc fc env args) (map (weakenNs args) stk) sc'
154		− pure $ MkConAlt n t args scEval
	189	+ = do (bs, env') <- extendLoc fc env args
	190	+ scEval <- eval rec env' stk
	191	+ (rewrite sym (appendAssociative args vars free) in sc)
	192	+ pure $ MkConAlt n t args (refsToLocals bs scEval)
155	193
156	194	evalConstAlt : {auto c : Ref Ctxt Defs} ->
	195	+ {auto l : Ref LVar Int} ->
157	196	List Name -> EEnv free vars -> Stack free -> CConstAlt (vars ++ free) ->
158	197	Core (CConstAlt free)
159	198	evalConstAlt rec env stk (MkConstAlt c sc)
160	199	= MkConstAlt c <$> eval rec env stk sc
161	200
162	201	pickAlt : {auto c : Ref Ctxt Defs} ->
	202	+ {auto l : Ref LVar Int} ->
163	203	List Name -> EEnv free vars -> Stack free ->
164	204	CExp free -> List (CConAlt (vars ++ free)) ->
165	205	Maybe (CExp (vars ++ free)) ->
@@ -180,6 +220,7 @@ mutual · 14 unmodified lines
180	220	pickAlt rec env stk _ _ _ = pure Nothing
181	221
182	222	pickConstAlt : {auto c : Ref Ctxt Defs} ->
	223	+ {auto l : Ref LVar Int} ->
183	224	List Name -> EEnv free vars -> Stack free ->
184	225	CExp free -> List (CConstAlt (vars ++ free)) ->
185	226	Maybe (CExp (vars ++ free)) ->
@@ -192,10 +233,124 @@ mutual · 6 unmodified lines
192	233	else pickConstAlt rec env stk (CPrimVal fc c) alts def
193	234	pickConstAlt rec env stk _ _ _ = pure Nothing
194	235
	236	+-- Inlining may have messed with function arity (e.g. by adding lambdas to
	237	+-- the LHS to avoid needlessly making a closure) so fix them up here. This
	238	+-- needs to be right because typically back ends need to know whether a
	239	+-- name is under- or over-applied
	240	+fixArityTm : {auto c : Ref Ctxt Defs} ->
	241	+ CExp vars -> List (CExp vars) -> Core (CExp vars)
	242	+fixArityTm (CRef fc n) args
	243	+ = do defs <- get Ctxt
	244	+ Just gdef <- lookupCtxtExact n (gamma defs)
	245	+ \| Nothing => pure (unload args (CRef fc n))
	246	+ let Just def = compexpr gdef
	247	+ \| Nothing => pure (unload args (CRef fc n))
	248	+ let arity = getArity def
	249	+ pure $ expandToArity arity (CApp fc (CRef fc n) []) args
	250	+fixArityTm (CLam fc x sc) args
	251	+ = pure $ expandToArity Z (CLam fc x !(fixArityTm sc [])) args
	252	+fixArityTm (CLet fc x inl val sc) args
	253	+ = pure $ expandToArity Z
	254	+ (CLet fc x inl !(fixArityTm val []) !(fixArityTm sc [])) args
	255	+fixArityTm (CApp fc f fargs) args
	256	+ = fixArityTm f (!(traverse (\tm => fixArityTm tm []) fargs) ++ args)
	257	+fixArityTm (CCon fc n t args) []
	258	+ = pure $ CCon fc n t !(traverse (\tm => fixArityTm tm []) args)
	259	+fixArityTm (COp fc op args) []
	260	+ = pure $ COp fc op !(traverseArgs args)
	261	+ where
	262	+ traverseArgs : Vect n (CExp vs) -> Core (Vect n (CExp vs))
	263	+ traverseArgs [] = pure []
	264	+ traverseArgs (a :: as) = pure $ !(fixArityTm a []) :: !(traverseArgs as)
	265	+fixArityTm (CExtPrim fc p args) []
	266	+ = pure $ CExtPrim fc p !(traverse (\tm => fixArityTm tm []) args)
	267	+fixArityTm (CForce fc tm) args
	268	+ = pure $ expandToArity Z (CForce fc !(fixArityTm tm [])) args
	269	+fixArityTm (CDelay fc tm) args
	270	+ = pure $ expandToArity Z (CDelay fc !(fixArityTm tm [])) args
	271	+fixArityTm (CConCase fc sc alts def) args
	272	+ = pure $ expandToArity Z
	273	+ (CConCase fc !(fixArityTm sc [])
	274	+ !(traverse fixArityAlt alts)
	275	+ !(traverseOpt (\tm => fixArityTm tm []) def)) args
	276	+ where
	277	+ fixArityAlt : CConAlt vars -> Core (CConAlt vars)
	278	+ fixArityAlt (MkConAlt n t a sc)
	279	+ = pure $ MkConAlt n t a !(fixArityTm sc [])
	280	+fixArityTm (CConstCase fc sc alts def) args
	281	+ = pure $ expandToArity Z
	282	+ (CConstCase fc !(fixArityTm sc [])
	283	+ !(traverse fixArityConstAlt alts)
	284	+ !(traverseOpt (\tm => fixArityTm tm []) def)) args
	285	+ where
	286	+ fixArityConstAlt : CConstAlt vars -> Core (CConstAlt vars)
	287	+ fixArityConstAlt (MkConstAlt c sc)
	288	+ = pure $ MkConstAlt c !(fixArityTm sc [])
	289	+fixArityTm t [] = pure t
	290	+fixArityTm t args = pure $ expandToArity Z t args
	291	+
	292	+export
	293	+fixArityExp : {auto c : Ref Ctxt Defs} ->
	294	+ CExp vars -> Core (CExp vars)
	295	+fixArityExp tm = fixArityTm tm []
	296	+
	297	+fixArity : {auto c : Ref Ctxt Defs} ->
	298	+ CDef -> Core CDef
	299	+fixArity (MkFun args exp) = pure $ MkFun args !(fixArityTm exp [])
	300	+fixArity (MkError exp) = pure $ MkError !(fixArityTm exp [])
	301	+fixArity d = pure d
	302	+
	303	+getLams : Int -> SubstCEnv done args -> CExp (done ++ args) ->
	304	+ (args' ** (SubstCEnv args' args, CExp (args' ++ args)))
	305	+getLams {done} i env (CLam fc x sc)
	306	+ = getLams {done = x :: done} (i + 1) (CRef fc (MN "ext" i) :: env) sc
	307	+getLams {done} i env sc = (done ** (env, sc))
	308	+
	309	+mkBounds : (xs : _) -> Bounds xs
	310	+mkBounds [] = None
	311	+mkBounds (x :: xs) = Add x x (mkBounds xs)
	312	+
	313	+getNewArgs : SubstCEnv done args -> List Name
	314	+getNewArgs [] = []
	315	+getNewArgs (CRef _ n :: xs) = n :: getNewArgs xs
	316	+getNewArgs {done = x :: xs} (_ :: sub) = x :: getNewArgs sub
	317	+
	318	+-- Move any lambdas in the body of the definition into the lhs list of vars.
	319	+-- Annoyingly, the indices will need fixing up because the order in the top
	320	+-- level definition goes left to right (i.e. first argument has lowest index,
	321	+-- not the highest, as you'd expect if they were all lambdas).
	322	+mergeLambdas : (args : List Name) -> CExp args -> (args' ** CExp args')
	323	+mergeLambdas args (CLam fc x sc)
	324	+ = let (args' ** (env, exp')) = getLams 0 [] (CLam fc x sc)
	325	+ expNs = substs env exp'
	326	+ newArgs = reverse $ getNewArgs env
	327	+ expLocs = mkLocals {later = args} {vars=[]} (mkBounds newArgs)
	328	+ (rewrite appendNilRightNeutral args in expNs) in
	329	+ (_ ** expLocs)
	330	+mergeLambdas args exp = (args ** exp)
	331	+
	332	+doEval : {auto c : Ref Ctxt Defs} ->
	333	+ Name -> CExp args -> Core (CExp args)
	334	+doEval n exp
	335	+ = do l <- newRef LVar (the Int 0)
	336	+ log 10 (show n ++ ": " ++ show exp)
	337	+ exp' <- eval [] [] [] exp
	338	+ log 10 ("Inlined: " ++ show exp')
	339	+ pure exp'
	340	+
195	341	inline : {auto c : Ref Ctxt Defs} ->
196		− CDef -> Core CDef
197		−inline (MkFun args exp) = MkFun args <$> eval [] [] [] exp
198		−inline d = pure d
	342	+ Name -> CDef -> Core CDef
	343	+inline n (MkFun args def)
	344	+ = pure $ MkFun args !(doEval n def)
	345	+inline n d = pure d
	346	+
	347	+-- merge lambdas from expression into top level arguments
	348	+mergeLam : {auto c : Ref Ctxt Defs} ->
	349	+ CDef -> Core CDef
	350	+mergeLam (MkFun args def)
	351	+ = do let (args' ** exp') = mergeLambdas args def
	352	+ pure $ MkFun args' exp'
	353	+mergeLam d = pure d
199	354
200	355	export
201	356	inlineDef : {auto c : Ref Ctxt Defs} ->
@@ -204,5 +359,22 @@ inlineDef n · 2 unmodified lines
204	359	= do defs <- get Ctxt
205	360	Just def <- lookupCtxtExact n (gamma defs) \| Nothing => pure ()
206	361	let Just cexpr = compexpr def \| Nothing => pure ()
207		− setCompiled n !(inline cexpr)
	362	+ setCompiled n !(inline n cexpr)
208	363
	364	+export
	365	+fixArityDef : {auto c : Ref Ctxt Defs} ->
	366	+ Name -> Core ()
	367	+fixArityDef n
	368	+ = do defs <- get Ctxt
	369	+ Just def <- lookupCtxtExact n (gamma defs) \| Nothing => pure ()
	370	+ let Just cexpr = compexpr def \| Nothing => pure ()
	371	+ setCompiled n !(fixArity cexpr)
	372	+
	373	+export
	374	+mergeLamDef : {auto c : Ref Ctxt Defs} ->
	375	+ Name -> Core ()
	376	+mergeLamDef n
	377	+ = do defs <- get Ctxt
	378	+ Just def <- lookupCtxtExact n (gamma defs) \| Nothing => pure ()
	379	+ let Just cexpr = compexpr def \| Nothing => pure ()
	380	+ setCompiled n !(mergeLam cexpr)

src/Compiler/LambdaLift.idr+237−0

@@ -0,0 +1,237 @@
	1	+module Compuler.LambdaLift
	2	+
	3	+import Core.CompileExpr
	4	+import Core.Context
	5	+import Core.Core
	6	+import Core.TT
	7	+
	8	+import Data.Vect
	9	+
	10	+%default covering
	11	+
	12	+mutual
	13	+ public export
	14	+ data Lifted : List Name -> Type where
	15	+ LLocal : {idx : Nat} -> FC -> .(IsVar x idx vars) -> Lifted vars
	16	+ -- A known function applied to exactly the right number of arguments,
	17	+ -- so the runtime can Just Go
	18	+ LAppName : FC -> Name -> List (Lifted vars) -> Lifted vars
	19	+ -- A known function applied to too few arguments, so the runtime should
	20	+ -- make a closure and wait for the remaining arguments
	21	+ LUnderApp : FC -> Name -> (missing : Nat) ->
	22	+ (args : List (Lifted vars)) -> Lifted vars
	23	+ -- A closure applied to one more argument (so, for example a closure
	24	+ -- which is waiting for another argument before it can run).
	25	+ -- The runtime should add the argument to the closure and run the result
	26	+ -- if it is now fully applied.
	27	+ LApp : FC -> (closure : Lifted vars) -> (arg : Lifted vars) -> Lifted vars
	28	+ LLet : FC -> (x : Name) -> Lifted vars ->
	29	+ Lifted (x :: var) -> Lifted vars
	30	+ LCon : FC -> Name -> (tag : Int) -> List (Lifted vars) -> Lifted vars
	31	+ LOp : FC -> PrimFn arity -> Vect arity (Lifted vars) -> Lifted vars
	32	+ LExtPrim : FC -> (p : Name) -> List (Lifted vars) -> Lifted vars
	33	+ LConCase : FC -> Lifted vars ->
	34	+ List (LiftedConAlt vars) ->
	35	+ Maybe (Lifted vars) -> Lifted vars
	36	+ LConstCase : FC -> Lifted vars ->
	37	+ List (LiftedConstAlt vars) ->
	38	+ Maybe (Lifted vars) -> Lifted vars
	39	+ LPrimVal : FC -> Constant -> Lifted vars
	40	+ LErased : FC -> Lifted vars
	41	+ LCrash : FC -> String -> Lifted vars
	42	+
	43	+ public export
	44	+ data LiftedConAlt : List Name -> Type where
	45	+ MkLConAlt : Name -> (tag : Int) -> (args : List Name) ->
	46	+ Lifted (args ++ vars) -> LiftedConAlt vars
	47	+
	48	+ public export
	49	+ data LiftedConstAlt : List Name -> Type where
	50	+ MkLConstAlt : Constant -> Lifted vars -> LiftedConstAlt vars
	51	+
	52	+public export
	53	+data LiftedDef : Type where
	54	+ -- We take the outer scope and the function arguments separately so that
	55	+ -- we don't have to reshuffle de Bruijn indices, which is expensive.
	56	+ -- This should be compiled as a function which takes 'args' first,
	57	+ -- then 'scope'.
	58	+ MkLFun : (args : List Name) -> -- function arguments
	59	+ (scope : List Name) -> -- outer scope
	60	+ Lifted (scope ++ args) -> LiftedDef
	61	+ MkLCon : (tag : Int) -> (arity : Nat) -> (nt : Maybe Nat) -> LiftedDef
	62	+ MkLForeign : (ccs : List String) ->
	63	+ (fargs : List CFType) ->
	64	+ CFType ->
	65	+ LiftedDef
	66	+ MkLError : Lifted [] -> LiftedDef
	67	+
	68	+mutual
	69	+ export
	70	+ Show (Lifted vs) where
	71	+ show (LLocal {x} _ _) = "!" ++ show x
	72	+ show (LAppName fc n args)
	73	+ = show n ++ "(" ++ showSep ", " (map show args) ++ ")"
	74	+ show (LUnderApp fc n m args)
	75	+ = "<" ++ show n ++ " underapp " ++ show m ++ ">(" ++
	76	+ showSep ", " (map show args) ++ ")"
	77	+ show (LApp fc c arg)
	78	+ = show c ++ " @ (" ++ show arg ++ ")"
	79	+ show (LLet fc x val sc)
	80	+ = "%let " ++ show x ++ " = " ++ show val ++ " in " ++ show sc
	81	+ show (LCon fc n t args)
	82	+ = "%con " ++ show n ++ "(" ++ showSep ", " (map show args) ++ ")"
	83	+ show (LOp fc op args)
	84	+ = "%op " ++ show op ++ "(" ++ showSep ", " (toList (map show args)) ++ ")"
	85	+ show (LExtPrim fc p args)
	86	+ = "%extprim " ++ show p ++ "(" ++ showSep ", " (map show args) ++ ")"
	87	+ show (LConCase fc sc alts def)
	88	+ = "%case " ++ show sc ++ " of { "
	89	+ ++ showSep "\| " (map show alts) ++ " " ++ show def
	90	+ show (LConstCase fc sc alts def)
	91	+ = "%case " ++ show sc ++ " of { "
	92	+ ++ showSep "\| " (map show alts) ++ " " ++ show def
	93	+ show (LPrimVal _ x) = show x
	94	+ show (LErased _) = "___"
	95	+ show (LCrash _ x) = "%CRASH(" ++ show x ++ ")"
	96	+
	97	+ export
	98	+ Show (LiftedConAlt vs) where
	99	+ show (MkLConAlt n t args sc)
	100	+ = "%conalt " ++ show n ++
	101	+ "(" ++ showSep ", " (map show args) ++ ") => " ++ show sc
	102	+
	103	+ export
	104	+ Show (LiftedConstAlt vs) where
	105	+ show (MkLConstAlt c sc)
	106	+ = "%constalt(" ++ show c ++ ") => " ++ show sc
	107	+
	108	+export
	109	+Show LiftedDef where
	110	+ show (MkLFun args scope exp) = show args ++ show scope ++ ": " ++ show exp
	111	+ show (MkLCon tag arity pos)
	112	+ = "Constructor tag " ++ show tag ++ " arity " ++ show arity ++
	113	+ maybe "" (\n => " (newtype by " ++ show n ++ ")") pos
	114	+ show (MkLForeign ccs args ret)
	115	+ = "Foreign call " ++ show ccs ++ " " ++
	116	+ show args ++ " -> " ++ show ret
	117	+ show (MkLError exp) = "Error: " ++ show exp
	118	+
	119	+
	120	+data Lifts : Type where
	121	+
	122	+record LDefs where
	123	+ constructor MkLDefs
	124	+ basename : Name -- top level name we're lifting from
	125	+ defs : List (Name, LiftedDef) -- new definitions we made
	126	+ nextName : Int -- name of next definition to lift
	127	+
	128	+genName : {auto l : Ref Lifts LDefs} ->
	129	+ Core Name
	130	+genName
	131	+ = do ldefs <- get Lifts
	132	+ let i = nextName ldefs
	133	+ put Lifts (record { nextName = i + 1 } ldefs)
	134	+ pure $ mkName (basename ldefs) i
	135	+ where
	136	+ mkName : Name -> Int -> Name
	137	+ mkName (NS ns b) i = NS ns (mkName b i)
	138	+ mkName (UN n) i = MN n i
	139	+ mkName n i = MN (show n) i
	140	+
	141	+unload : FC -> Lifted vars -> List (Lifted vars) -> Core (Lifted vars)
	142	+unload fc f [] = pure f
	143	+unload fc f (a :: as) = unload fc (LApp fc f a) as
	144	+
	145	+mutual
	146	+ makeLam : {auto l : Ref Lifts LDefs} ->
	147	+ {vars : _} ->
	148	+ FC -> (bound : List Name) ->
	149	+ CExp (bound ++ vars) -> Core (Lifted vars)
	150	+ makeLam fc bound (CLam _ x sc') = makeLam fc (x :: bound) sc'
	151	+ makeLam {vars} fc bound sc
	152	+ = do scl <- liftExp sc
	153	+ n <- genName
	154	+ ldefs <- get Lifts
	155	+ put Lifts (record { defs $= ((n, MkLFun vars bound scl) ::) } ldefs)
	156	+ -- TODO: an optimisation here would be to spot which variables
	157	+ -- aren't used in the new definition, and not abstract over them
	158	+ -- in the new definition. Given that we have to do some messing
	159	+ -- about with indices anyway, it's probably not costly to do.
	160	+ pure $ LUnderApp fc n (length bound) (allVars vars)
	161	+ where
	162	+ allPrfs : (vs : List Name) -> List (Var vs)
	163	+ allPrfs [] = []
	164	+ allPrfs (v :: vs) = MkVar First :: map weaken (allPrfs vs)
	165	+
	166	+ -- apply to all the variables. 'First' will be first in the last, which
	167	+ -- is good, because the most recently bound name is the first argument to
	168	+ -- the resulting function
	169	+ allVars : (vs : List Name) -> List (Lifted vs)
	170	+ allVars vs = map (\ (MkVar p) => LLocal fc p) (allPrfs vs)
	171	+
	172	+ liftExp : {auto l : Ref Lifts LDefs} ->
	173	+ CExp vars -> Core (Lifted vars)
	174	+ liftExp (CLocal fc prf) = pure $ LLocal fc prf
	175	+ liftExp (CRef fc n) = pure $ LAppName fc n [] -- probably shouldn't happen!
	176	+ liftExp (CLam fc x sc) = makeLam fc [x] sc
	177	+ liftExp (CLet fc x _ val sc) = pure $ LLet fc x !(liftExp val) !(liftExp sc)
	178	+ liftExp (CApp fc (CRef _ n) args) -- names are applied exactly in compileExp
	179	+ = pure $ LAppName fc n !(traverse liftExp args)
	180	+ liftExp (CApp fc f args)
	181	+ = unload fc !(liftExp f) !(traverse liftExp args)
	182	+ liftExp (CCon fc n t args) = pure $ LCon fc n t !(traverse liftExp args)
	183	+ liftExp (COp fc op args)
	184	+ = pure $ LOp fc op !(traverseArgs args)
	185	+ where
	186	+ traverseArgs : Vect n (CExp vars) -> Core (Vect n (Lifted vars))
	187	+ traverseArgs [] = pure []
	188	+ traverseArgs (a :: as) = pure $ !(liftExp a) :: !(traverseArgs as)
	189	+ liftExp (CExtPrim fc p args) = pure $ LExtPrim fc p !(traverse liftExp args)
	190	+ liftExp (CForce fc tm) = liftExp (CApp fc tm [CErased fc])
	191	+ liftExp (CDelay fc tm) = liftExp (CLam fc (MN "x" 0) (weaken tm))
	192	+ liftExp (CConCase fc sc alts def)
	193	+ = pure $ LConCase fc !(liftExp sc) !(traverse liftConAlt alts)
	194	+ !(traverseOpt liftExp def)
	195	+ where
	196	+ liftConAlt : CConAlt vars -> Core (LiftedConAlt vars)
	197	+ liftConAlt (MkConAlt n t args sc) = pure $ MkLConAlt n t args !(liftExp sc)
	198	+ liftExp (CConstCase fc sc alts def)
	199	+ = pure $ LConstCase fc !(liftExp sc) !(traverse liftConstAlt alts)
	200	+ !(traverseOpt liftExp def)
	201	+ where
	202	+ liftConstAlt : CConstAlt vars -> Core (LiftedConstAlt vars)
	203	+ liftConstAlt (MkConstAlt c sc) = pure $ MkLConstAlt c !(liftExp sc)
	204	+ liftExp (CPrimVal fc c) = pure $ LPrimVal fc c
	205	+ liftExp (CErased fc) = pure $ LErased fc
	206	+ liftExp (CCrash fc str) = pure $ LCrash fc str
	207	+
	208	+liftBody : Name -> CExp vars -> Core (Lifted vars, List (Name, LiftedDef))
	209	+liftBody n tm
	210	+ = do l <- newRef Lifts (MkLDefs n [] 0)
	211	+ tml <- liftExp {l} tm
	212	+ ldata <- get Lifts
	213	+ pure (tml, defs ldata)
	214	+
	215	+lambdaLiftDef : Name -> CDef -> Core (List (Name, LiftedDef))
	216	+lambdaLiftDef n (MkFun args exp)
	217	+ = do (expl, defs) <- liftBody n exp
	218	+ pure ((n, MkLFun args [] expl) :: defs)
	219	+lambdaLiftDef n (MkCon t a nt) = pure [(n, MkLCon t a nt)]
	220	+lambdaLiftDef n (MkForeign ccs fargs ty) = pure [(n, MkLForeign ccs fargs ty)]
	221	+lambdaLiftDef n (MkError exp)
	222	+ = do (expl, defs) <- liftBody n exp
	223	+ pure ((n, MkLError expl) :: defs)
	224	+
	225	+-- Return the lambda lifted definitions required for the given name.
	226	+-- If the name hasn't been compiled yet (via CompileExpr.compileDef) then
	227	+-- this will return an empty list
	228	+-- An empty list an error, because on success you will always get at least
	229	+-- one definition, the lifted definition for the given name.
	230	+export
	231	+lambdaLift : {auto c : Ref Ctxt Defs} ->
	232	+ Name -> Core (List (Name, LiftedDef))
	233	+lambdaLift n
	234	+ = do defs <- get Ctxt
	235	+ Just def <- lookupCtxtExact n (gamma defs) \| Nothing => pure []
	236	+ let Just cexpr = compexpr def \| Nothing => pure []
	237	+ lambdaLiftDef n cexpr

src/Compiler/Scheme/Chez.idr+38−31

@@ -90,17 +90,17 @@ chezString : String -> String · 89 unmodified lines
90	90	chezString cs = strCons '"' (showChezString (unpack cs) "\"")
91	91
92	92	mutual
93		− tySpec : CExp vars -> Core String
	93	+ tySpec : NamedCExp -> Core String
94	94	-- Primitive types have been converted to names for the purpose of matching
95	95	-- on types
96		− tySpec (CCon fc (UN "Int") _ []) = pure "int"
97		− tySpec (CCon fc (UN "String") _ []) = pure "string"
98		− tySpec (CCon fc (UN "Double") _ []) = pure "double"
99		− tySpec (CCon fc (UN "Char") _ []) = pure "char"
100		− tySpec (CCon fc (NS _ n) _ [_])
	96	+ tySpec (NmCon fc (UN "Int") _ []) = pure "int"
	97	+ tySpec (NmCon fc (UN "String") _ []) = pure "string"
	98	+ tySpec (NmCon fc (UN "Double") _ []) = pure "double"
	99	+ tySpec (NmCon fc (UN "Char") _ []) = pure "char"
	100	+ tySpec (NmCon fc (NS _ n) _ [_])
101	101	= cond [(n == UN "Ptr", pure "void*")]
102	102	(throw (GenericMsg fc ("Can't pass argument of type " ++ show n ++ " to foreign function")))
103		− tySpec (CCon fc (NS _ n) _ [])
	103	+ tySpec (NmCon fc (NS _ n) _ [])
104	104	= cond [(n == UN "Unit", pure "void"),
105	105	(n == UN "AnyPtr", pure "void*")]
106	106	(throw (GenericMsg fc ("Can't pass argument of type " ++ show n ++ " to foreign function")))
@@ -110,44 +110,44 @@ mutual · 3 unmodified lines
110	110	handleRet "void" op = op ++ " " ++ mkWorld (schConstructor 0 [])
111	111	handleRet _ op = mkWorld op
112	112
113		− getFArgs : CExp vars -> Core (List (CExp vars, CExp vars))
114		− getFArgs (CCon fc _ 0 _) = pure []
115		− getFArgs (CCon fc _ 1 [ty, val, rest]) = pure $ (ty, val) :: !(getFArgs rest)
	113	+ getFArgs : NamedCExp -> Core (List (NamedCExp, NamedCExp))
	114	+ getFArgs (NmCon fc _ 0 _) = pure []
	115	+ getFArgs (NmCon fc _ 1 [ty, val, rest]) = pure $ (ty, val) :: !(getFArgs rest)
116	116	getFArgs arg = throw (GenericMsg (getFC arg) ("Badly formed c call argument list " ++ show arg))
117	117
118		− chezExtPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String
119		− chezExtPrim i vs CCall [ret, CPrimVal fc (Str fn), fargs, world]
	118	+ chezExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String
	119	+ chezExtPrim i CCall [ret, NmPrimVal fc (Str fn), fargs, world]
120	120	= do args <- getFArgs fargs
121	121	argTypes <- traverse tySpec (map fst args)
122	122	retType <- tySpec ret
123		− argsc <- traverse (schExp chezExtPrim chezString 0 vs) (map snd args)
	123	+ argsc <- traverse (schExp chezExtPrim chezString 0) (map snd args)
124	124	pure $ handleRet retType ("((foreign-procedure #f " ++ show fn ++ " ("
125	125	++ showSep " " argTypes ++ ") " ++ retType ++ ") "
126	126	++ showSep " " argsc ++ ")")
127		− chezExtPrim i vs CCall [ret, fn, args, world]
	127	+ chezExtPrim i CCall [ret, fn, args, world]
128	128	= pure "(error \"bad ffi call\")"
129	129	-- throw (InternalError ("C FFI calls must be to statically known functions (" ++ show fn ++ ")"))
130		− chezExtPrim i vs GetStr [world]
	130	+ chezExtPrim i GetStr [world]
131	131	= pure $ mkWorld "(get-line (current-input-port))"
132		− chezExtPrim i vs GetField [CPrimVal _ (Str s), _, _, struct,
133		− CPrimVal _ (Str fld), _]
134		− = do structsc <- schExp chezExtPrim chezString 0 vs struct
	132	+ chezExtPrim i GetField [NmPrimVal _ (Str s), _, _, struct,
	133	+ NmPrimVal _ (Str fld), _]
	134	+ = do structsc <- schExp chezExtPrim chezString 0 struct
135	135	pure $ "(ftype-ref " ++ s ++ " (" ++ fld ++ ") " ++ structsc ++ ")"
136		− chezExtPrim i vs GetField [_,_,_,_,_,_]
	136	+ chezExtPrim i GetField [_,_,_,_,_,_]
137	137	= pure "(error \"bad setField\")"
138		− chezExtPrim i vs SetField [CPrimVal _ (Str s), _, _, struct,
139		− CPrimVal _ (Str fld), _, val, world]
140		− = do structsc <- schExp chezExtPrim chezString 0 vs struct
141		− valsc <- schExp chezExtPrim chezString 0 vs val
	138	+ chezExtPrim i SetField [NmPrimVal _ (Str s), _, _, struct,
	139	+ NmPrimVal _ (Str fld), _, val, world]
	140	+ = do structsc <- schExp chezExtPrim chezString 0 struct
	141	+ valsc <- schExp chezExtPrim chezString 0 val
142	142	pure $ mkWorld $
143	143	"(ftype-set! " ++ s ++ " (" ++ fld ++ ") " ++ structsc ++
144	144	" " ++ valsc ++ ")"
145		− chezExtPrim i vs SetField [_,_,_,_,_,_,_,_]
	145	+ chezExtPrim i SetField [_,_,_,_,_,_,_,_]
146	146	= pure "(error \"bad setField\")"
147		− chezExtPrim i vs SysCodegen []
	147	+ chezExtPrim i SysCodegen []
148	148	= pure $ "\"chez\""
149		− chezExtPrim i vs prim args
150		− = schExtCommon chezExtPrim chezString i vs prim args
	149	+ chezExtPrim i prim args
	150	+ = schExtCommon chezExtPrim chezString i prim args
151	151
152	152	-- Reference label for keeping track of loaded external libraries
153	153	data Loaded : Type where
@@ -202,6 +202,9 @@ cCall fc cfn clib args ret · 48 unmodified lines
202	202	applyLams n (Nothing :: as) = applyLams ("(" ++ n ++ " #f)") as
203	203	applyLams n (Just a :: as) = applyLams ("(" ++ n ++ " " ++ a ++ ")") as
204	204
	205	+ getVal : String -> String
	206	+ getVal str = "(vector-ref " ++ str ++ "1)"
	207	+
205	208	mkFun : List CFType -> CFType -> String -> String
206	209	mkFun args ret n
207	210	= let argns = mkNs 0 args in
@@ -314,8 +317,8 @@ startChez : String -> String · 106 unmodified lines
314	317	startChez target = unlines
315	318	[ "#!/bin/sh"
316	319	, ""
317		− , "export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`dirname " ++ target ++ "`"
318		− , target ++ " \"$@\""
	320	+ , "export LD_LIBRARY_PATH=\"$LD_LIBRARY_PATH:$(dirname \"" ++ target ++ "\")\""
	321	+ , "\"" ++ target ++ "\" \"$@\""
319	322	]
320	323
321	324	\|\|\| Compile a TT expression to Chez Scheme
@@ -325,14 +328,18 @@ compileToSS c tm outfile · 3 unmodified lines
325	328	= do ds <- getDirectives Chez
326	329	libs <- findLibs ds
327	330	traverse_ copyLib libs
328		− (ns, tags) <- findUsedNames tm
	331	+ cdata <- getCompileData tm
	332	+ let ns = allNames cdata
	333	+ let tags = nameTags cdata
	334	+ let ctm = forget (mainExpr cdata)
	335	+
329	336	defs <- get Ctxt
330	337	l <- newRef {t = List String} Loaded ["libc", "libc 6"]
331	338	s <- newRef {t = List String} Structs []
332	339	fgndefs <- traverse getFgnCall ns
333	340	compdefs <- traverse (getScheme chezExtPrim chezString defs) ns
334	341	let code = fastAppend (map snd fgndefs ++ compdefs)
335		− main <- schExp chezExtPrim chezString 0 [] !(compileExp tags tm)
	342	+ main <- schExp chezExtPrim chezString 0 ctm
336	343	chez <- coreLift findChez
337	344	support <- readDataFile "chez/support.ss"
338	345	let scm = schHeader chez (map snd libs) ++

src/Compiler/Scheme/Common.idr+119−122

@@ -85,6 +85,7 @@ schOp (Div IntType) [x, y] = op "b/" [x, y, "63"] · 84 unmodified lines
85	85	schOp (Add ty) [x, y] = op "+" [x, y]
86	86	schOp (Sub ty) [x, y] = op "-" [x, y]
87	87	schOp (Mul ty) [x, y] = op "*" [x, y]
	88	+schOp (Div IntegerType) [x, y] = op "quotient" [x, y]
88	89	schOp (Div ty) [x, y] = op "/" [x, y]
89	90	schOp (Mod ty) [x, y] = op "remainder" [x, y]
90	91	schOp (Neg ty) [x] = op "-" [x]
@@ -136,12 +137,12 @@ schOp (Cast DoubleType StringType) [x] = op "number->string" [x] · 45 unmodified lines
136	137	schOp (Cast CharType StringType) [x] = op "string" [x]
137	138
138	139	schOp (Cast IntType IntegerType) [x] = x
139		−schOp (Cast DoubleType IntegerType) [x] = op "floor" [x]
	140	+schOp (Cast DoubleType IntegerType) [x] = op "exact-floor" [x]
140	141	schOp (Cast CharType IntegerType) [x] = op "char->integer" [x]
141	142	schOp (Cast StringType IntegerType) [x] = op "cast-string-int" [x]
142	143
143	144	schOp (Cast IntegerType IntType) [x] = x
144		−schOp (Cast DoubleType IntType) [x] = op "floor" [x]
	145	+schOp (Cast DoubleType IntType) [x] = op "exact-floor" [x]
145	146	schOp (Cast StringType IntType) [x] = op "cast-string-int" [x]
146	147	schOp (Cast CharType IntType) [x] = op "char->integer" [x]
147	148
@@ -234,7 +235,7 @@ toPrim pn = Unknown pn · 86 unmodified lines
234	235
235	236	export
236	237	mkWorld : String -> String
237		−mkWorld res = res -- MkIORes is a newtype now! schConstructor 0 ["#f", res, "#f"] -- MkIORes
	238	+mkWorld res = res -- MkIORes is a newtype now! schConstructor 0 [res, "#f"] -- MkIORes
238	239
239	240	schConstant : (String -> String) -> Constant -> String
240	241	schConstant _ (I x) = show x
@@ -258,82 +259,79 @@ schCaseDef Nothing = "" · 17 unmodified lines
258	259	schCaseDef (Just tm) = "(else " ++ tm ++ ")"
259	260
260	261	export
261		−schArglist : SVars ns -> String
	262	+schArglist : List Name -> String
262	263	schArglist [] = ""
263		−schArglist [x] = x
264		−schArglist (x :: xs) = x ++ " " ++ schArglist xs
	264	+schArglist [x] = schName x
	265	+schArglist (x :: xs) = schName x ++ " " ++ schArglist xs
265	266
266		−parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String,
	267	+parameters (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String,
267	268	schString : String -> String)
268	269	mutual
269		− schConAlt : Int -> SVars vars -> String -> CConAlt vars -> Core String
270		− schConAlt {vars} i vs target (MkConAlt n tag args sc)
271		− = let vs' = extendSVars args vs in
272		− pure $ "((" ++ show tag ++ ") "
273		− ++ bindArgs 1 args vs' !(schExp i vs' sc) ++ ")"
	270	+ schConAlt : Int -> String -> NamedConAlt -> Core String
	271	+ schConAlt i target (MkNConAlt n tag args sc)
	272	+ = pure $ "((" ++ show tag ++ ") "
	273	+ ++ bindArgs 1 args !(schExp i sc) ++ ")"
274	274	where
275		− bindArgs : Int -> (ns : List Name) -> SVars (ns ++ vars) -> String -> String
276		− bindArgs i [] vs body = body
277		− bindArgs i (n :: ns) (v :: vs) body
278		− = "(let ((" ++ v ++ " " ++ "(vector-ref " ++ target ++ " " ++ show i ++ "))) "
279		− ++ bindArgs (i + 1) ns vs body ++ ")"
	275	+ bindArgs : Int -> (ns : List Name) -> String -> String
	276	+ bindArgs i [] body = body
	277	+ bindArgs i (n :: ns) body
	278	+ = "(let ((" ++ schName n ++ " " ++ "(vector-ref " ++ target ++ " " ++ show i ++ "))) "
	279	+ ++ bindArgs (i + 1) ns body ++ ")"
280	280
281		− schConstAlt : Int -> SVars vars -> String -> CConstAlt vars -> Core String
282		− schConstAlt i vs target (MkConstAlt c exp)
283		− = pure $ "((equal? " ++ target ++ " " ++ schConstant schString c ++ ") " ++ !(schExp i vs exp) ++ ")"
	281	+ schConstAlt : Int -> String -> NamedConstAlt -> Core String
	282	+ schConstAlt i target (MkNConstAlt c exp)
	283	+ = pure $ "((equal? " ++ target ++ " " ++ schConstant schString c ++ ") " ++ !(schExp i exp) ++ ")"
284	284
285	285	-- oops, no traverse for Vect in Core
286		− schArgs : Int -> SVars vars -> Vect n (CExp vars) -> Core (Vect n String)
287		− schArgs i vs [] = pure []
288		− schArgs i vs (arg :: args) = pure $ !(schExp i vs arg) :: !(schArgs i vs args)
	286	+ schArgs : Int -> Vect n NamedCExp -> Core (Vect n String)
	287	+ schArgs i [] = pure []
	288	+ schArgs i (arg :: args) = pure $ !(schExp i arg) :: !(schArgs i args)
289	289
290	290	export
291		− schExp : Int -> SVars vars -> CExp vars -> Core String
292		− schExp i vs (CLocal fc el) = pure $ lookupSVar el vs
293		− schExp i vs (CRef fc n) = pure $ schName n
294		− schExp i vs (CLam fc x sc)
295		− = do let vs' = extendSVars [x] vs
296		− sc' <- schExp i vs' sc
297		− pure $ "(lambda (" ++ lookupSVar First vs' ++ ") " ++ sc' ++ ")"
298		− schExp i vs (CLet fc x val sc)
299		− = do let vs' = extendSVars [x] vs
300		− val' <- schExp i vs val
301		− sc' <- schExp i vs' sc
302		− pure $ "(let ((" ++ lookupSVar First vs' ++ " " ++ val' ++ ")) " ++ sc' ++ ")"
303		− schExp i vs (CApp fc x [])
304		− = pure $ "(" ++ !(schExp i vs x) ++ ")"
305		− schExp i vs (CApp fc x args)
306		− = pure $ "(" ++ !(schExp i vs x) ++ " " ++ showSep " " !(traverse (schExp i vs) args) ++ ")"
307		− schExp i vs (CCon fc x tag args)
308		− = pure $ schConstructor tag !(traverse (schExp i vs) args)
309		− schExp i vs (COp fc op args)
310		− = pure $ schOp op !(schArgs i vs args)
311		− schExp i vs (CExtPrim fc p args)
312		− = schExtPrim i vs (toPrim p) args
313		− schExp i vs (CForce fc t) = pure $ "(" ++ !(schExp i vs t) ++ ")"
314		− schExp i vs (CDelay fc t) = pure $ "(lambda () " ++ !(schExp i vs t) ++ ")"
315		− schExp i vs (CConCase fc sc alts def)
316		− = do tcode <- schExp (i+1) vs sc
317		− defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i vs v))) def
	291	+ schExp : Int -> NamedCExp -> Core String
	292	+ schExp i (NmLocal fc n) = pure $ schName n
	293	+ schExp i (NmRef fc n) = pure $ schName n
	294	+ schExp i (NmLam fc x sc)
	295	+ = do sc' <- schExp i sc
	296	+ pure $ "(lambda (" ++ schName x ++ ") " ++ sc' ++ ")"
	297	+ schExp i (NmLet fc x val sc)
	298	+ = do val' <- schExp i val
	299	+ sc' <- schExp i sc
	300	+ pure $ "(let ((" ++ schName x ++ " " ++ val' ++ ")) " ++ sc' ++ ")"
	301	+ schExp i (NmApp fc x [])
	302	+ = pure $ "(" ++ !(schExp i x) ++ ")"
	303	+ schExp i (NmApp fc x args)
	304	+ = pure $ "(" ++ !(schExp i x) ++ " " ++ showSep " " !(traverse (schExp i) args) ++ ")"
	305	+ schExp i (NmCon fc x tag args)
	306	+ = pure $ schConstructor tag !(traverse (schExp i) args)
	307	+ schExp i (NmOp fc op args)
	308	+ = pure $ schOp op !(schArgs i args)
	309	+ schExp i (NmExtPrim fc p args)
	310	+ = schExtPrim i (toPrim p) args
	311	+ schExp i (NmForce fc t) = pure $ "(" ++ !(schExp i t) ++ ")"
	312	+ schExp i (NmDelay fc t) = pure $ "(lambda () " ++ !(schExp i t) ++ ")"
	313	+ schExp i (NmConCase fc sc alts def)
	314	+ = do tcode <- schExp (i+1) sc
	315	+ defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def
318	316	let n = "sc" ++ show i
319	317	pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (get-tag " ++ n ++ ") "
320		− ++ showSep " " !(traverse (schConAlt (i+1) vs n) alts)
	318	+ ++ showSep " " !(traverse (schConAlt (i+1) n) alts)
321	319	++ schCaseDef defc ++ "))"
322		− schExp i vs (CConstCase fc sc alts def)
323		− = do defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i vs v))) def
324		− tcode <- schExp (i+1) vs sc
	320	+ schExp i (NmConstCase fc sc alts def)
	321	+ = do defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def
	322	+ tcode <- schExp (i+1) sc
325	323	let n = "sc" ++ show i
326	324	pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (cond "
327		− ++ showSep " " !(traverse (schConstAlt (i+1) vs n) alts)
	325	+ ++ showSep " " !(traverse (schConstAlt (i+1) n) alts)
328	326	++ schCaseDef defc ++ "))"
329		− schExp i vs (CPrimVal fc c) = pure $ schConstant schString c
330		− schExp i vs (CErased fc) = pure "'erased"
331		− schExp i vs (CCrash fc msg) = pure $ "(blodwen-error-quit " ++ show msg ++ ")"
	327	+ schExp i (NmPrimVal fc c) = pure $ schConstant schString c
	328	+ schExp i (NmErased fc) = pure "'erased"
	329	+ schExp i (NmCrash fc msg) = pure $ "(blodwen-error-quit " ++ show msg ++ ")"
332	330
333	331	-- Need to convert the argument (a list of scheme arguments that may
334	332	-- have been constructed at run time) to a scheme list to be passed to apply
335		− readArgs : Int -> SVars vars -> CExp vars -> Core String
336		− readArgs i vs tm = pure $ "(blodwen-read-args " ++ !(schExp i vs tm) ++ ")"
	333	+ readArgs : Int -> NamedCExp -> Core String
	334	+ readArgs i tm = pure $ "(blodwen-read-args " ++ !(schExp i tm) ++ ")"
337	335
338	336	fileOp : String -> String
339	337	fileOp op = "(blodwen-file-op (lambda () " ++ op ++ "))"
@@ -341,92 +339,91 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx · 1 unmodified line
341	339	-- External primitives which are common to the scheme codegens (they can be
342	340	-- overridden)
343	341	export
344		− schExtCommon : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String
345		− schExtCommon i vs SchemeCall [ret, CPrimVal fc (Str fn), args, world]
	342	+ schExtCommon : Int -> ExtPrim -> List NamedCExp -> Core String
	343	+ schExtCommon i SchemeCall [ret, NmPrimVal fc (Str fn), args, world]
346	344	= pure $ mkWorld ("(apply " ++ fn ++" "
347		− ++ !(readArgs i vs args) ++ ")")
348		− schExtCommon i vs SchemeCall [ret, fn, args, world]
349		− = pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i vs fn) ++")) "
350		− ++ !(readArgs i vs args) ++ ")")
351		− schExtCommon i vs PutStr [arg, world]
352		− = pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
353		− schExtCommon i vs GetStr [world]
	345	+ ++ !(readArgs i args) ++ ")")
	346	+ schExtCommon i SchemeCall [ret, fn, args, world]
	347	+ = pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i fn) ++")) "
	348	+ ++ !(readArgs i args) ++ ")")
	349	+ schExtCommon i PutStr [arg, world]
	350	+ = pure $ "(begin (display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) ++ ")" -- code for MkUnit
	351	+ schExtCommon i GetStr [world]
354	352	= pure $ mkWorld "(blodwen-get-line (current-input-port))"
355		− schExtCommon i vs PutChar [arg, world]
356		− = pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
357		− schExtCommon i vs GetChar [world]
	353	+ schExtCommon i PutChar [arg, world]
	354	+ = pure $ "(begin (display " ++ !(schExp i arg) ++ ") " ++ mkWorld (schConstructor 0 []) ++ ")" -- code for MkUnit
	355	+ schExtCommon i GetChar [world]
358	356	= pure $ mkWorld "(blodwen-get-char (current-input-port))"
359		− schExtCommon i vs FileOpen [file, mode, bin, world]
	357	+ schExtCommon i FileOpen [file, mode, bin, world]
360	358	= pure $ mkWorld $ fileOp $ "(blodwen-open "
361		− ++ !(schExp i vs file) ++ " "
362		− ++ !(schExp i vs mode) ++ " "
363		− ++ !(schExp i vs bin) ++ ")"
364		− schExtCommon i vs FileClose [file, world]
365		− = pure $ "(blodwen-close-port " ++ !(schExp i vs file) ++ ") " ++ mkWorld (schConstructor 0 [])
366		− schExtCommon i vs FileReadLine [file, world]
367		− = pure $ mkWorld $ fileOp $ "(blodwen-get-line " ++ !(schExp i vs file) ++ ")"
368		− schExtCommon i vs FileWriteLine [file, str, world]
	359	+ ++ !(schExp i file) ++ " "
	360	+ ++ !(schExp i mode) ++ " "
	361	+ ++ !(schExp i bin) ++ ")"
	362	+ schExtCommon i FileClose [file, world]
	363	+ = pure $ "(blodwen-close-port " ++ !(schExp i file) ++ ") " ++ mkWorld (schConstructor 0 [])
	364	+ schExtCommon i FileReadLine [file, world]
	365	+ = pure $ mkWorld $ fileOp $ "(blodwen-get-line " ++ !(schExp i file) ++ ")"
	366	+ schExtCommon i FileWriteLine [file, str, world]
369	367	= pure $ mkWorld $ fileOp $ "(blodwen-putstring "
370		− ++ !(schExp i vs file) ++ " "
371		− ++ !(schExp i vs str) ++ ")"
372		− schExtCommon i vs FileEOF [file, world]
373		− = pure $ mkWorld $ "(blodwen-eof " ++ !(schExp i vs file) ++ ")"
374		− schExtCommon i vs FileModifiedTime [file, world]
	368	+ ++ !(schExp i file) ++ " "
	369	+ ++ !(schExp i str) ++ ")"
	370	+ schExtCommon i FileEOF [file, world]
	371	+ = pure $ mkWorld $ "(blodwen-eof " ++ !(schExp i file) ++ ")"
	372	+ schExtCommon i FileModifiedTime [file, world]
375	373	= pure $ mkWorld $ fileOp $ "(blodwen-file-modified-time "
376		− ++ !(schExp i vs file) ++ ")"
377		− schExtCommon i vs NewIORef [_, val, world]
378		− = pure $ mkWorld $ "(box " ++ !(schExp i vs val) ++ ")"
379		− schExtCommon i vs ReadIORef [_, ref, world]
380		− = pure $ mkWorld $ "(unbox " ++ !(schExp i vs ref) ++ ")"
381		− schExtCommon i vs WriteIORef [_, ref, val, world]
	374	+ ++ !(schExp i file) ++ ")"
	375	+ schExtCommon i NewIORef [_, val, world]
	376	+ = pure $ mkWorld $ "(box " ++ !(schExp i val) ++ ")"
	377	+ schExtCommon i ReadIORef [_, ref, world]
	378	+ = pure $ mkWorld $ "(unbox " ++ !(schExp i ref) ++ ")"
	379	+ schExtCommon i WriteIORef [_, ref, val, world]
382	380	= pure $ mkWorld $ "(set-box! "
383		− ++ !(schExp i vs ref) ++ " "
384		− ++ !(schExp i vs val) ++ ")"
385		− schExtCommon i vs NewArray [_, size, val, world]
386		− = pure $ mkWorld $ "(make-vector " ++ !(schExp i vs size) ++ " "
387		− ++ !(schExp i vs val) ++ ")"
388		− schExtCommon i vs ArrayGet [_, arr, pos, world]
389		− = pure $ mkWorld $ "(vector-ref " ++ !(schExp i vs arr) ++ " "
390		− ++ !(schExp i vs pos) ++ ")"
391		− schExtCommon i vs ArraySet [_, arr, pos, val, world]
392		− = pure $ mkWorld $ "(vector-set! " ++ !(schExp i vs arr) ++ " "
393		− ++ !(schExp i vs pos) ++ " "
394		− ++ !(schExp i vs val) ++ ")"
395		− schExtCommon i vs VoidElim [_, _]
	381	+ ++ !(schExp i ref) ++ " "
	382	+ ++ !(schExp i val) ++ ")"
	383	+ schExtCommon i NewArray [_, size, val, world]
	384	+ = pure $ mkWorld $ "(make-vector " ++ !(schExp i size) ++ " "
	385	+ ++ !(schExp i val) ++ ")"
	386	+ schExtCommon i ArrayGet [_, arr, pos, world]
	387	+ = pure $ mkWorld $ "(vector-ref " ++ !(schExp i arr) ++ " "
	388	+ ++ !(schExp i pos) ++ ")"
	389	+ schExtCommon i ArraySet [_, arr, pos, val, world]
	390	+ = pure $ mkWorld $ "(vector-set! " ++ !(schExp i arr) ++ " "
	391	+ ++ !(schExp i pos) ++ " "
	392	+ ++ !(schExp i val) ++ ")"
	393	+ schExtCommon i VoidElim [_, _]
396	394	= pure "(display \"Error: Executed 'void'\")"
397		− schExtCommon i vs SysOS []
	395	+ schExtCommon i SysOS []
398	396	= pure $ show os
399		− schExtCommon i vs (Unknown n) args
	397	+ schExtCommon i (Unknown n) args
400	398	= throw (InternalError ("Can't compile unknown external primitive " ++ show n))
401		− schExtCommon i vs Stdin [] = pure "(current-input-port)"
402		− schExtCommon i vs Stdout [] = pure "(current-output-port)"
403		− schExtCommon i vs Stderr [] = pure "(current-error-port)"
404		− schExtCommon i vs prim args
	399	+ schExtCommon i Stdin [] = pure "(current-input-port)"
	400	+ schExtCommon i Stdout [] = pure "(current-output-port)"
	401	+ schExtCommon i Stderr [] = pure "(current-error-port)"
	402	+ schExtCommon i prim args
405	403	= throw (InternalError ("Badly formed external primitive " ++ show prim
406	404	++ " " ++ show args))
407	405
408	406	schDef : {auto c : Ref Ctxt Defs} ->
409		− Name -> CDef -> Core String
410		− schDef n (MkFun args exp)
411		− = let vs = initSVars args in
412		− pure $ "(define " ++ schName !(getFullName n) ++ " (lambda (" ++ schArglist vs ++ ") "
413		− ++ !(schExp 0 vs exp) ++ "))\n"
414		− schDef n (MkError exp)
415		− = pure $ "(define (" ++ schName !(getFullName n) ++ " . any-args) " ++ !(schExp 0 [] exp) ++ ")\n"
416		− schDef n (MkForeign _ _ _) = pure "" -- compiled by specific back end
417		− schDef n (MkCon t a _) = pure "" -- Nothing to compile here
	407	+ Name -> NamedDef -> Core String
	408	+ schDef n (MkNmFun args exp)
	409	+ = pure $ "(define " ++ schName !(getFullName n) ++ " (lambda (" ++ schArglist args ++ ") "
	410	+ ++ !(schExp 0 exp) ++ "))\n"
	411	+ schDef n (MkNmError exp)
	412	+ = pure $ "(define (" ++ schName !(getFullName n) ++ " . any-args) " ++ !(schExp 0 exp) ++ ")\n"
	413	+ schDef n (MkNmForeign _ _ _) = pure "" -- compiled by specific back end
	414	+ schDef n (MkNmCon t a _) = pure "" -- Nothing to compile here
418	415
419	416	-- Convert the name to scheme code
420	417	-- (There may be no code generated, for example if it's a constructor)
421	418	export
422	419	getScheme : {auto c : Ref Ctxt Defs} ->
423		− (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String) ->
	420	+ (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String) ->
424	421	(schString : String -> String) ->
425	422	Defs -> Name -> Core String
426	423	getScheme schExtPrim schString defs n
427	424	= case !(lookupCtxtExact n (gamma defs)) of
428	425	Nothing => throw (InternalError ("Compiling undefined name " ++ show n))
429		− Just d => case compexpr d of
	426	+ Just d => case namedcompexpr d of
430	427	Nothing =>
431	428	throw (InternalError ("No compiled definition for " ++ show n))
432	429	Just d => schDef schExtPrim schString n d

src/Compiler/Scheme/Racket.idr+20−16

@@ -66,27 +66,27 @@ racketString : String -> String · 65 unmodified lines
66	66	racketString cs = strCons '"' (showRacketString (unpack cs) "\"")
67	67
68	68	mutual
69		− racketPrim : Int -> SVars vars -> ExtPrim -> List (CExp vars) -> Core String
70		− racketPrim i vs CCall [ret, fn, args, world]
	69	+ racketPrim : Int -> ExtPrim -> List NamedCExp -> Core String
	70	+ racketPrim i CCall [ret, fn, args, world]
71	71	= throw (InternalError ("Can't compile C FFI calls to Racket yet"))
72		− racketPrim i vs GetField [CPrimVal _ (Str s), _, _, struct,
73		− CPrimVal _ (Str fld), _]
74		− = do structsc <- schExp racketPrim racketString 0 vs struct
	72	+ racketPrim i GetField [NmPrimVal _ (Str s), _, _, struct,
	73	+ NmPrimVal _ (Str fld), _]
	74	+ = do structsc <- schExp racketPrim racketString 0 struct
75	75	pure $ "(" ++ s ++ "-" ++ fld ++ " " ++ structsc ++ ")"
76		− racketPrim i vs GetField [_,_,_,_,_,_]
	76	+ racketPrim i GetField [_,_,_,_,_,_]
77	77	= pure "(error \"bad setField\")"
78		− racketPrim i vs SetField [CPrimVal _ (Str s), _, _, struct,
79		− CPrimVal _ (Str fld), _, val, world]
80		− = do structsc <- schExp racketPrim racketString 0 vs struct
81		− valsc <- schExp racketPrim racketString 0 vs val
	78	+ racketPrim i SetField [NmPrimVal _ (Str s), _, _, struct,
	79	+ NmPrimVal _ (Str fld), _, val, world]
	80	+ = do structsc <- schExp racketPrim racketString 0 struct
	81	+ valsc <- schExp racketPrim racketString 0 val
82	82	pure $ mkWorld $
83	83	"(set-" ++ s ++ "-" ++ fld ++ "! " ++ structsc ++ " " ++ valsc ++ ")"
84		− racketPrim i vs SetField [_,_,_,_,_,_,_,_]
	84	+ racketPrim i SetField [_,_,_,_,_,_,_,_]
85	85	= pure "(error \"bad setField\")"
86		− racketPrim i vs SysCodegen []
	86	+ racketPrim i SysCodegen []
87	87	= pure $ "\"racket\""
88		− racketPrim i vs prim args
89		− = schExtCommon racketPrim racketString i vs prim args
	88	+ racketPrim i prim args
	89	+ = schExtCommon racketPrim racketString i prim args
90	90
91	91	-- Reference label for keeping track of loaded external libraries
92	92	data Loaded : Type where
@@ -287,14 +287,18 @@ getFgnCall n · 194 unmodified lines
287	287	compileToRKT : Ref Ctxt Defs ->
288	288	ClosedTerm -> (outfile : String) -> Core ()
289	289	compileToRKT c tm outfile
290		− = do (ns, tags) <- findUsedNames tm
	290	+ = do cdata <- getCompileData tm
	291	+ let ns = allNames cdata
	292	+ let tags = nameTags cdata
	293	+ let ctm = forget (mainExpr cdata)
	294	+
291	295	defs <- get Ctxt
292	296	l <- newRef {t = List String} Loaded []
293	297	s <- newRef {t = List String} Structs []
294	298	fgndefs <- traverse getFgnCall ns
295	299	compdefs <- traverse (getScheme racketPrim racketString defs) ns
296	300	let code = fastAppend (map snd fgndefs ++ compdefs)
297		− main <- schExp racketPrim racketString 0 [] !(compileExp tags tm)
	301	+ main <- schExp racketPrim racketString 0 ctm
298	302	support <- readDataFile "racket/support.rkt"
299	303	let scm = schHeader (concat (map fst fgndefs)) ++
300	304	support ++ code ++

src/Core/Binary.idr+1−1

@@ -27,7 +27,7 @@ import Data.Buffer · 26 unmodified lines
27	27	-- TTC files can only be compatible if the version number is the same
28	28	export
29	29	ttcVersion : Int
30		−ttcVersion = 20
	30	+ttcVersion = 22
31	31
32	32	export
33	33	checkTTCVersion : String -> Int -> Int -> Core ()

src/Core/CaseTree.idr+15−1

@@ -6,24 +6,36 @@ import Data.NameMap · 5 unmodified lines
6	6	%default covering
7	7
8	8	mutual
	9	+ \|\|\| Case trees in A-normal forms
	10	+ \|\|\| i.e. we may only dispatch on variables, not expressions
9	11	public export
10	12	data CaseTree : List Name -> Type where
	13	+ \|\|\| case x return scTy of { p1 => e1 ; ... }
11	14	Case : {name : _} ->
12	15	(idx : Nat) ->
13	16	IsVar name idx vars ->
14	17	(scTy : Term vars) -> List (CaseAlt vars) ->
15	18	CaseTree vars
	19	+ \|\|\| RHS: no need for further inspection
16	20	STerm : Term vars -> CaseTree vars
	21	+ \|\|\| error from a partial match
17	22	Unmatched : (msg : String) -> CaseTree vars
	23	+ \|\|\| Absurd context
18	24	Impossible : CaseTree vars
19	25
	26	+ \|\|\| Case alternatives. Unlike arbitrary patterns, they can be at most
	27	+ \|\|\| one constructor deep.
20	28	public export
21	29	data CaseAlt : List Name -> Type where
	30	+ \|\|\| Constructor for a data type; bind the arguments and subterms.
22	31	ConCase : Name -> (tag : Int) -> (args : List Name) ->
23	32	CaseTree (args ++ vars) -> CaseAlt vars
	33	+ \|\|\| Lazy match for the Delay type use for codata types
24	34	DelayCase : (ty : Name) -> (arg : Name) ->
25	35	CaseTree (ty :: arg :: vars) -> CaseAlt vars
	36	+ \|\|\| Match against a literal
26	37	ConstCase : Constant -> CaseTree vars -> CaseAlt vars
	38	+ \|\|\| Catch-all case
27	39	DefaultCase : CaseTree vars -> CaseAlt vars
28	40
29	41	public export
@@ -65,7 +77,9 @@ mutual · 35 unmodified lines
65	77	export
66	78	eqTree : CaseTree vs -> CaseTree vs' -> Bool
67	79	eqTree (Case i _ _ alts) (Case i' _ _ alts')
68		− = i == i && and (map Delay (zipWith eqAlt alts alts'))
	80	+ = i == i
	81	+ && length alts == length alts
	82	+ && and (zipWith (\ a, b => Delay (eqAlt a b)) alts alts')
69	83	eqTree (STerm t) (STerm t') = eqTerm t t'
70	84	eqTree (Unmatched _) (Unmatched _) = True
71	85	eqTree Impossible Impossible = True

src/Core/CompileExpr.idr+300−38

@@ -19,7 +19,8 @@ mutual · 18 unmodified lines
19	19	-- Lambda expression
20	20	CLam : FC -> (x : Name) -> CExp (x :: vars) -> CExp vars
21	21	-- Let bindings
22		− CLet : FC -> (x : Name) -> CExp vars -> CExp (x :: vars) -> CExp vars
	22	+ CLet : FC -> (x : Name) -> (inlineOK : Bool) -> -- Don't inline if set
	23	+ CExp vars -> CExp (x :: vars) -> CExp vars
23	24	-- Application of a defined function. The length of the argument list is
24	25	-- exactly the same length as expected by its definition (so saturate with
25	26	-- lambdas if necessary, or overapply with additional CApps)
@@ -53,6 +54,53 @@ mutual · 27 unmodified lines
53	54	data CConstAlt : List Name -> Type where
54	55	MkConstAlt : Constant -> CExp vars -> CConstAlt vars
55	56
	57	+mutual
	58	+ \|\|\| NamedCExp - as above, but without the name index, so with explicit
	59	+ \|\|\| names, which are faster (but less safe) to manipulate in the inliner.
	60	+ \|\|\| You can, howeveer, assume that name bindings are unique - translation
	61	+ \|\|\| to this form (and the liner) ensure that, even if the type doesn't
	62	+ \|\|\| guarantee it!
	63	+ public export
	64	+ data NamedCExp : Type where
	65	+ NmLocal : FC -> Name -> NamedCExp
	66	+ NmRef : FC -> Name -> NamedCExp
	67	+ -- Lambda expression
	68	+ NmLam : FC -> (x : Name) -> NamedCExp -> NamedCExp
	69	+ -- Let bindings
	70	+ NmLet : FC -> (x : Name) -> NamedCExp -> NamedCExp -> NamedCExp
	71	+ -- Application of a defined function. The length of the argument list is
	72	+ -- exactly the same length as expected by its definition (so saturate with
	73	+ -- lambdas if necessary, or overapply with additional CApps)
	74	+ NmApp : FC -> NamedCExp -> List NamedCExp -> NamedCExp
	75	+ -- A saturated constructor application
	76	+ NmCon : FC -> Name -> (tag : Int) -> List NamedCExp -> NamedCExp
	77	+ -- Internally defined primitive operations
	78	+ NmOp : FC -> PrimFn arity -> Vect arity NamedCExp -> NamedCExp
	79	+ -- Externally defined primitive operations
	80	+ NmExtPrim : FC -> (p : Name) -> List NamedCExp -> NamedCExp
	81	+ -- A forced (evaluated) value
	82	+ NmForce : FC -> NamedCExp -> NamedCExp
	83	+ -- A delayed value
	84	+ NmDelay : FC -> NamedCExp -> NamedCExp
	85	+ -- A case match statement
	86	+ NmConCase : FC -> (sc : NamedCExp) -> List NamedConAlt -> Maybe NamedCExp -> NamedCExp
	87	+ NmConstCase : FC -> (sc : NamedCExp) -> List NamedConstAlt -> Maybe NamedCExp -> NamedCExp
	88	+ -- A primitive value
	89	+ NmPrimVal : FC -> Constant -> NamedCExp
	90	+ -- An erased value
	91	+ NmErased : FC -> NamedCExp
	92	+ -- Some sort of crash?
	93	+ NmCrash : FC -> String -> NamedCExp
	94	+
	95	+ public export
	96	+ data NamedConAlt : Type where
	97	+ MkNConAlt : Name -> (tag : Int) -> (args : List Name) ->
	98	+ NamedCExp -> NamedConAlt
	99	+
	100	+ public export
	101	+ data NamedConstAlt : Type where
	102	+ MkNConstAlt : Constant -> NamedCExp -> NamedConstAlt
	103	+
56	104	-- Argument type descriptors for foreign function calls
57	105	public export
58	106	data CFType : Type where
@@ -83,42 +131,156 @@ data CDef : Type where · 24 unmodified lines
83	131	-- to run, discarding arguments, no matter how many arguments are passed
84	132	MkError : CExp [] -> CDef
85	133
	134	+public export
	135	+data NamedDef : Type where
	136	+ -- Normal function definition
	137	+ MkNmFun : (args : List Name) -> NamedCExp -> NamedDef
	138	+ -- Constructor
	139	+ MkNmCon : (tag : Int) -> (arity : Nat) -> (nt : Maybe Nat) -> NamedDef
	140	+ -- Foreign definition
	141	+ MkNmForeign : (ccs : List String) ->
	142	+ (fargs : List CFType) ->
	143	+ CFType ->
	144	+ NamedDef
	145	+ -- A function which will fail at runtime (usually due to being a hole) so needs
	146	+ -- to run, discarding arguments, no matter how many arguments are passed
	147	+ MkNmError : NamedCExp -> NamedDef
	148	+
86	149	mutual
87	150	export
88		− Show (CExp vars) where
89		− show (CLocal {x} _ y) = "!" ++ show x
90		− show (CRef _ x) = show x
91		− show (CLam _ x y) = "(%lam " ++ show x ++ " " ++ show y ++ ")"
92		− show (CLet _ x y z) = "(%let " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
93		− show (CApp _ x xs)
	151	+ Show NamedCExp where
	152	+ show (NmLocal _ x) = "!" ++ show x
	153	+ show (NmRef _ x) = show x
	154	+ show (NmLam _ x y) = "(%lam " ++ show x ++ " " ++ show y ++ ")"
	155	+ show (NmLet _ x y z) = "(%let " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
	156	+ show (NmApp _ x xs)
94	157	= assert_total $ "(" ++ show x ++ " " ++ show xs ++ ")"
95		− show (CCon _ x tag xs)
	158	+ show (NmCon _ x tag xs)
96	159	= assert_total $ "(%con " ++ show x ++ " " ++ show tag ++ " " ++ show xs ++ ")"
97		− show (COp _ op xs)
	160	+ show (NmOp _ op xs)
98	161	= assert_total $ "(" ++ show op ++ " " ++ show xs ++ ")"
99		− show (CExtPrim _ p xs)
	162	+ show (NmExtPrim _ p xs)
100	163	= assert_total $ "(%extern " ++ show p ++ " " ++ show xs ++ ")"
101		− show (CForce _ x) = "(%force " ++ show x ++ ")"
102		− show (CDelay _ x) = "(%delay " ++ show x ++ ")"
103		− show (CConCase _ sc xs def)
	164	+ show (NmForce _ x) = "(%force " ++ show x ++ ")"
	165	+ show (NmDelay _ x) = "(%delay " ++ show x ++ ")"
	166	+ show (NmConCase _ sc xs def)
104	167	= assert_total $ "(%case " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")"
105		− show (CConstCase _ sc xs def)
	168	+ show (NmConstCase _ sc xs def)
106	169	= assert_total $ "(%case " ++ show sc ++ " " ++ show xs ++ " " ++ show def ++ ")"
107		− show (CPrimVal _ x) = show x
108		− show (CErased _) = "___"
109		− show (CCrash _ x) = "(CRASH " ++ show x ++ ")"
	170	+ show (NmPrimVal _ x) = show x
	171	+ show (NmErased _) = "___"
	172	+ show (NmCrash _ x) = "(CRASH " ++ show x ++ ")"
110	173
111	174	export
112		− Show (CConAlt vars) where
113		− show (MkConAlt x tag args exp)
	175	+ Show NamedConAlt where
	176	+ show (MkNConAlt x tag args exp)
114	177	= "(%concase " ++ show x ++ " " ++ show tag ++ " " ++
115	178	show args ++ " " ++ show exp ++ ")"
116	179
117	180	export
118		− Show (CConstAlt vars) where
119		− show (MkConstAlt x exp)
	181	+ Show NamedConstAlt where
	182	+ show (MkNConstAlt x exp)
120	183	= "(%constcase " ++ show x ++ " " ++ show exp ++ ")"
121	184
	185	+export
	186	+data Names : List Name -> Type where
	187	+ Nil : Names []
	188	+ (::) : Name -> Names xs -> Names (x :: xs)
	189	+
	190	+elem : Name -> Names xs -> Bool
	191	+elem n [] = False
	192	+elem n (x :: xs) = if n == x then True else elem n xs
	193	+
	194	+tryNext : Name -> Name
	195	+tryNext (UN n) = MN n 0
	196	+tryNext (MN n i) = MN n (1 + i)
	197	+tryNext n = MN (nameRoot n) 0
	198	+
	199	+uniqueName : Name -> Names vs -> Name
	200	+uniqueName s ns =
	201	+ if s `elem` ns
	202	+ then uniqueName (tryNext s) ns
	203	+ else s
	204	+
	205	+export
	206	+getLocName : (idx : Nat) -> Names vars -> .(IsVar name idx vars) -> Name
	207	+getLocName Z (x :: xs) First = x
	208	+getLocName (S k) (x :: xs) (Later p) = getLocName k xs p
	209	+
	210	+export
	211	+addLocs : (args : List Name) -> Names vars -> Names (args ++ vars)
	212	+addLocs [] ns = ns
	213	+addLocs (x :: xs) ns
	214	+ = let rec = addLocs xs ns in
	215	+ uniqueName x rec :: rec
	216	+
	217	+conArgs : (args : List Name) -> Names (args ++ vars) -> List Name
	218	+conArgs [] ns = []
	219	+conArgs (a :: as) (n :: ns) = n :: conArgs as ns
	220	+
	221	+mutual
	222	+ forgetExp : Names vars -> CExp vars -> NamedCExp
	223	+ forgetExp locs (CLocal fc p) = NmLocal fc (getLocName _ locs p)
	224	+ forgetExp locs (CRef fc n) = NmRef fc n
	225	+ forgetExp locs (CLam fc x sc)
	226	+ = let locs' = addLocs [x] locs in
	227	+ NmLam fc (getLocName _ locs' First) (forgetExp locs' sc)
	228	+ forgetExp locs (CLet fc x _ val sc)
	229	+ = let locs' = addLocs [x] locs in
	230	+ NmLet fc (getLocName _ locs' First)
	231	+ (forgetExp locs val)
	232	+ (forgetExp locs' sc)
	233	+ forgetExp locs (CApp fc f args)
	234	+ = NmApp fc (forgetExp locs f) (map (forgetExp locs) args)
	235	+ forgetExp locs (CCon fc n t args)
	236	+ = NmCon fc n t (map (forgetExp locs) args)
	237	+ forgetExp locs (COp fc op args)
	238	+ = NmOp fc op (map (forgetExp locs) args)
	239	+ forgetExp locs (CExtPrim fc p args)
	240	+ = NmExtPrim fc p (map (forgetExp locs) args)
	241	+ forgetExp locs (CForce fc f)
	242	+ = NmForce fc (forgetExp locs f)
	243	+ forgetExp locs (CDelay fc f)
	244	+ = NmDelay fc (forgetExp locs f)
	245	+ forgetExp locs (CConCase fc sc alts def)
	246	+ = NmConCase fc (forgetExp locs sc) (map (forgetConAlt locs) alts)
	247	+ (map (forgetExp locs) def)
	248	+ forgetExp locs (CConstCase fc sc alts def)
	249	+ = NmConstCase fc (forgetExp locs sc) (map (forgetConstAlt locs) alts)
	250	+ (map (forgetExp locs) def)
	251	+ forgetExp locs (CPrimVal fc c) = NmPrimVal fc c
	252	+ forgetExp locs (CErased fc) = NmErased fc
	253	+ forgetExp locs (CCrash fc msg) = NmCrash fc msg
	254	+
	255	+ forgetConAlt : Names vars -> CConAlt vars -> NamedConAlt
	256	+ forgetConAlt locs (MkConAlt n t args exp)
	257	+ = let args' = addLocs args locs in
	258	+ MkNConAlt n t (conArgs args args') (forgetExp args' exp)
	259	+
	260	+ forgetConstAlt : Names vars -> CConstAlt vars -> NamedConstAlt
	261	+ forgetConstAlt locs (MkConstAlt c exp)
	262	+ = MkNConstAlt c (forgetExp locs exp)
	263	+
	264	+export
	265	+forget : {vars : _} -> CExp vars -> NamedCExp
	266	+forget {vars} exp
	267	+ = forgetExp (addLocs vars [])
	268	+ (rewrite appendNilRightNeutral vars in exp)
	269	+
	270	+export
	271	+forgetDef : CDef -> NamedDef
	272	+forgetDef (MkFun args def)
	273	+ = let ns = addLocs args []
	274	+ args' = conArgs args ns in
	275	+ MkNmFun args' (forget def)
	276	+forgetDef (MkCon t a nt) = MkNmCon t a nt
	277	+forgetDef (MkForeign ccs fargs ty) = MkNmForeign ccs fargs ty
	278	+forgetDef (MkError err) = MkNmError (forget err)
	279	+
	280	+export
	281	+Show (CExp vars) where
	282	+ show exp = show (forget exp)
	283	+
122	284	export
123	285	Show CFType where
124	286	show CFUnit = "Unit"
@@ -144,19 +306,30 @@ Show CDef where · 19 unmodified lines
144	306	show args ++ " -> " ++ show ret
145	307	show (MkError exp) = "Error: " ++ show exp
146	308
	309	+export
	310	+Show NamedDef where
	311	+ show (MkNmFun args exp) = show args ++ ": " ++ show exp
	312	+ show (MkNmCon tag arity pos)
	313	+ = "Constructor tag " ++ show tag ++ " arity " ++ show arity ++
	314	+ maybe "" (\n => " (newtype by " ++ show n ++ ")") pos
	315	+ show (MkNmForeign ccs args ret)
	316	+ = "Foreign call " ++ show ccs ++ " " ++
	317	+ show args ++ " -> " ++ show ret
	318	+ show (MkNmError exp) = "Error: " ++ show exp
	319	+
147	320	mutual
148	321	export
149	322	thin : (n : Name) -> CExp (outer ++ inner) -> CExp (outer ++ n :: inner)
150	323	thin n (CLocal fc prf)
151		− = let MkVar var' = insertVar {n} _ prf in
	324	+ = let MkNVar var' = insertNVar {n} _ prf in
152	325	CLocal fc var'
153	326	thin _ (CRef fc x) = CRef fc x
154	327	thin {outer} {inner} n (CLam fc x sc)
155	328	= let sc' = thin {outer = x :: outer} {inner} n sc in
156	329	CLam fc x sc'
157		− thin {outer} {inner} n (CLet fc x val sc)
	330	+ thin {outer} {inner} n (CLet fc x inl val sc)
158	331	= let sc' = thin {outer = x :: outer} {inner} n sc in
159		− CLet fc x (thin n val) sc'
	332	+ CLet fc x inl (thin n val) sc'
160	333	thin n (CApp fc x xs)
161	334	= CApp fc (thin n x) (assert_total (map (thin n) xs))
162	335	thin n (CCon fc x tag xs)
@@ -194,15 +367,15 @@ mutual · 31 unmodified lines
194	367	(ns : List Name) -> CExp (outer ++ inner) ->
195	368	CExp (outer ++ (ns ++ inner))
196	369	insertNames ns (CLocal fc prf)
197		− = let MkVar var' = insertVarNames {ns} _ prf in
	370	+ = let MkNVar var' = insertNVarNames {ns} _ prf in
198	371	CLocal fc var'
199	372	insertNames _ (CRef fc x) = CRef fc x
200	373	insertNames {outer} {inner} ns (CLam fc x sc)
201	374	= let sc' = insertNames {outer = x :: outer} {inner} ns sc in
202	375	CLam fc x sc'
203		− insertNames {outer} {inner} ns (CLet fc x val sc)
	376	+ insertNames {outer} {inner} ns (CLet fc x inl val sc)
204	377	= let sc' = insertNames {outer = x :: outer} {inner} ns sc in
205		− CLet fc x (insertNames ns val) sc'
	378	+ CLet fc x inl (insertNames ns val) sc'
206	379	insertNames ns (CApp fc x xs)
207	380	= CApp fc (insertNames ns x) (assert_total (map (insertNames ns) xs))
208	381	insertNames ns (CCon fc x tag xs)
@@ -244,7 +417,7 @@ mutual · 35 unmodified lines
244	417	embed (CLocal fc prf) = CLocal fc (varExtend prf)
245	418	embed (CRef fc n) = CRef fc n
246	419	embed (CLam fc x sc) = CLam fc x (embed sc)
247		− embed (CLet fc x val sc) = CLet fc x (embed val) (embed sc)
	420	+ embed (CLet fc x inl val sc) = CLet fc x inl (embed val) (embed sc)
248	421	embed (CApp fc f args) = CApp fc (embed f) (assert_total (map embed args))
249	422	embed (CCon fc n t args) = CCon fc n t (assert_total (map embed args))
250	423	embed (COp fc p args) = COp fc p (assert_total (map embed args))
@@ -282,9 +455,9 @@ mutual · 31 unmodified lines
282	455	shrinkCExp sub (CLam fc x sc)
283	456	= let sc' = shrinkCExp (KeepCons sub) sc in
284	457	CLam fc x sc'
285		− shrinkCExp sub (CLet fc x val sc)
	458	+ shrinkCExp sub (CLet fc x inl val sc)
286	459	= let sc' = shrinkCExp (KeepCons sub) sc in
287		− CLet fc x (shrinkCExp sub val) sc'
	460	+ CLet fc x inl (shrinkCExp sub val) sc'
288	461	shrinkCExp sub (CApp fc x xs)
289	462	= CApp fc (shrinkCExp sub x) (assert_total (map (shrinkCExp sub) xs))
290	463	shrinkCExp sub (CCon fc x tag xs)
@@ -321,11 +494,12 @@ Weaken CExp where · 30 unmodified lines
321	494
322	495	-- Substitute some explicit terms for names in a term, and remove those
323	496	-- names from the scope
324		−public export
325		−data SubstCEnv : List Name -> List Name -> Type where
326		− Nil : SubstCEnv [] vars
327		− (::) : CExp vars ->
328		− SubstCEnv ds vars -> SubstCEnv (d :: ds) vars
	497	+namespace SubstCEnv
	498	+ public export
	499	+ data SubstCEnv : List Name -> List Name -> Type where
	500	+ Nil : SubstCEnv [] vars
	501	+ (::) : CExp vars ->
	502	+ SubstCEnv ds vars -> SubstCEnv (d :: ds) vars
329	503
330	504	findDrop : {drop : _} -> {idx : Nat} ->
331	505	FC -> .(IsVar name idx (drop ++ vars)) ->
@@ -352,9 +526,9 @@ mutual · 20 unmodified lines
352	526	substEnv {outer} env (CLam fc x sc)
353	527	= let sc' = substEnv {outer = x :: outer} env sc in
354	528	CLam fc x sc'
355		− substEnv {outer} env (CLet fc x val sc)
	529	+ substEnv {outer} env (CLet fc x inl val sc)
356	530	= let sc' = substEnv {outer = x :: outer} env sc in
357		− CLet fc x (substEnv env val) sc'
	531	+ CLet fc x inl (substEnv env val) sc'
358	532	substEnv env (CApp fc x xs)
359	533	= CApp fc (substEnv env x) (assert_total (map (substEnv env) xs))
360	534	substEnv env (CCon fc x tag xs)
@@ -394,12 +568,81 @@ export · 33 unmodified lines
394	568	substs : SubstCEnv drop vars -> CExp (drop ++ vars) -> CExp vars
395	569	substs env tm = substEnv {outer = []} env tm
396	570
	571	+resolveRef : (done : List Name) -> Bounds bound -> FC -> Name ->
	572	+ Maybe (CExp (later ++ (done ++ bound ++ vars)))
	573	+resolveRef done None fc n = Nothing
	574	+resolveRef {later} {vars} done (Add {xs} new old bs) fc n
	575	+ = if n == old
	576	+ then rewrite appendAssociative later done (new :: xs ++ vars) in
	577	+ let MkNVar p = weakenNVar {inner = new :: xs ++ vars}
	578	+ (later ++ done) First in
	579	+ Just (CLocal fc p)
	580	+ else rewrite appendAssociative done [new] (xs ++ vars)
	581	+ in resolveRef (done ++ [new]) bs fc n
	582	+
	583	+mutual
	584	+ export
	585	+ mkLocals : {later, vars : _} ->
	586	+ Bounds bound ->
	587	+ CExp (later ++ vars) -> CExp (later ++ (bound ++ vars))
	588	+ mkLocals bs (CLocal {idx} {x} fc p)
	589	+ = let MkNVar p' = addVars bs p in CLocal {x} fc p'
	590	+ mkLocals {later} {vars} bs (CRef fc var)
	591	+ = maybe (CRef fc var) id (resolveRef [] bs fc var)
	592	+ mkLocals {later} {vars} bs (CLam fc x sc)
	593	+ = let sc' = mkLocals bs {later = x :: later} {vars} sc in
	594	+ CLam fc x sc'
	595	+ mkLocals {later} {vars} bs (CLet fc x inl val sc)
	596	+ = let sc' = mkLocals bs {later = x :: later} {vars} sc in
	597	+ CLet fc x inl (mkLocals bs val) sc'
	598	+ mkLocals bs (CApp fc f xs)
	599	+ = CApp fc (mkLocals bs f) (assert_total (map (mkLocals bs) xs))
	600	+ mkLocals bs (CCon fc x tag xs)
	601	+ = CCon fc x tag (assert_total (map (mkLocals bs) xs))
	602	+ mkLocals bs (COp fc x xs)
	603	+ = COp fc x (assert_total (map (mkLocals bs) xs))
	604	+ mkLocals bs (CExtPrim fc x xs)
	605	+ = CExtPrim fc x (assert_total (map (mkLocals bs) xs))
	606	+ mkLocals bs (CForce fc x)
	607	+ = CForce fc (mkLocals bs x)
	608	+ mkLocals bs (CDelay fc x)
	609	+ = CDelay fc (mkLocals bs x)
	610	+ mkLocals bs (CConCase fc sc xs def)
	611	+ = CConCase fc (mkLocals bs sc)
	612	+ (assert_total (map (mkLocalsConAlt bs) xs))
	613	+ (assert_total (map (mkLocals bs) def))
	614	+ mkLocals bs (CConstCase fc sc xs def)
	615	+ = CConstCase fc (mkLocals bs sc)
	616	+ (assert_total (map (mkLocalsConstAlt bs) xs))
	617	+ (assert_total (map (mkLocals bs) def))
	618	+ mkLocals bs (CPrimVal fc x) = CPrimVal fc x
	619	+ mkLocals bs (CErased fc) = CErased fc
	620	+ mkLocals bs (CCrash fc x) = CCrash fc x
	621	+
	622	+ mkLocalsConAlt : Bounds bound ->
	623	+ CConAlt (later ++ vars) -> CConAlt (later ++ (bound ++ vars))
	624	+ mkLocalsConAlt {bound} {later} {vars} bs (MkConAlt x tag args sc)
	625	+ = let sc' : CExp ((args ++ later) ++ vars)
	626	+ = rewrite sym (appendAssociative args later vars) in sc in
	627	+ MkConAlt x tag args
	628	+ (rewrite appendAssociative args later (bound ++ vars) in
	629	+ mkLocals bs sc')
	630	+
	631	+ mkLocalsConstAlt : Bounds bound ->
	632	+ CConstAlt (later ++ vars) -> CConstAlt (later ++ (bound ++ vars))
	633	+ mkLocalsConstAlt bs (MkConstAlt x sc) = MkConstAlt x (mkLocals bs sc)
	634	+
	635	+export
	636	+refsToLocals : Bounds bound -> CExp vars -> CExp (bound ++ vars)
	637	+refsToLocals None tm = tm
	638	+refsToLocals bs y = mkLocals {later = []} bs y
	639	+
397	640	export
398	641	getFC : CExp args -> FC
399	642	getFC (CLocal fc _) = fc
400	643	getFC (CRef fc _) = fc
401	644	getFC (CLam fc _ _) = fc
402		−getFC (CLet fc _ _ _) = fc
	645	+getFC (CLet fc _ _ _ _) = fc
403	646	getFC (CApp fc _ _) = fc
404	647	getFC (CCon fc _ _ _) = fc
405	648	getFC (COp fc _ _) = fc
@@ -411,3 +654,22 @@ getFC (CConstCase fc _ _ _) = fc · 5 unmodified lines
411	654	getFC (CPrimVal fc _) = fc
412	655	getFC (CErased fc) = fc
413	656	getFC (CCrash fc _) = fc
	657	+
	658	+namespace NamedCExp
	659	+ export
	660	+ getFC : NamedCExp -> FC
	661	+ getFC (NmLocal fc _) = fc
	662	+ getFC (NmRef fc _) = fc
	663	+ getFC (NmLam fc _ _) = fc
	664	+ getFC (NmLet fc _ _ _) = fc
	665	+ getFC (NmApp fc _ _) = fc
	666	+ getFC (NmCon fc _ _ _) = fc
	667	+ getFC (NmOp fc _ _) = fc
	668	+ getFC (NmExtPrim fc _ _) = fc
	669	+ getFC (NmForce fc _) = fc
	670	+ getFC (NmDelay fc _) = fc
	671	+ getFC (NmConCase fc _ _ _) = fc
	672	+ getFC (NmConstCase fc _ _ _) = fc
	673	+ getFC (NmPrimVal fc _) = fc
	674	+ getFC (NmErased fc) = fc
	675	+ getFC (NmCrash fc _) = fc

src/Core/Context.idr+21−4

@@ -65,8 +65,14 @@ data Def : Type where · 64 unmodified lines
65	65	Def
66	66	Builtin : {arity : Nat} -> PrimFn arity -> Def
67	67	DCon : (tag : Int) -> (arity : Nat) ->
68		− (newtypeArg : Maybe Nat) -> -- if only constructor, and only one
69		− -- argument is non-Rig0, flag it here,
	68	+ (newtypeArg : Maybe (Bool, Nat)) ->
	69	+ -- if only constructor, and only one argument is non-Rig0,
	70	+ -- flag it here. The Nat is the unerased argument position.
	71	+ -- The Bool is 'True' if there is no %World token in the
	72	+ -- structure, which means it is safe to completely erase
	73	+ -- when pattern matching (otherwise we still have to ensure
	74	+ -- that the value is inspected, to make sure external effects
	75	+ -- happen)
70	76	Def -- data constructor
71	77	TCon : (tag : Int) -> (arity : Nat) ->
72	78	(parampos : List Nat) -> -- parameters
@@ -215,6 +221,7 @@ record GlobalDef where · 142 unmodified lines
215	221	linearChecked : Bool -- Flag whether we've already checked its linearity
216	222	definition : Def
217	223	compexpr : Maybe CDef
	224	+ namedcompexpr : Maybe NamedDef
218	225	sizeChange : List SCCall
219	226
220	227	export
@@ -485,7 +492,7 @@ newDef : FC -> Name -> RigCount -> List Name -> · 264 unmodified lines
485	492	newDef fc n rig vars ty vis def
486	493	= MkGlobalDef fc n ty [] [] []
487	494	rig vars vis unchecked [] Nothing Nothing False False False def
488		− Nothing []
	495	+ Nothing Nothing []
489	496
490	497	-- Rewrite rules, applied after type checking, for runtime code only
491	498	-- LHS and RHS must have the same type, but we don't (currently) require that
@@ -919,7 +926,7 @@ addBuiltin n ty tot op · 427 unmodified lines
919	926	= do addDef n (MkGlobalDef emptyFC n ty [] [] [] RigW [] Public tot
920	927	[Inline] Nothing Nothing
921	928	False False True (Builtin op)
922		− Nothing [])
	929	+ Nothing Nothing [])
923	930	pure ()
924	931
925	932	export
@@ -954,6 +961,16 @@ setCompiled n cexp · 28 unmodified lines
954	961	addDef n (record { compexpr = Just cexp } gdef)
955	962	pure ()
956	963
	964	+export
	965	+setNamedCompiled : {auto c : Ref Ctxt Defs} ->
	966	+ Name -> NamedDef -> Core ()
	967	+setNamedCompiled n cexp
	968	+ = do defs <- get Ctxt
	969	+ Just gdef <- lookupCtxtExact n (gamma defs)
	970	+ \| Nothing => pure ()
	971	+ addDef n (record { namedcompexpr = Just cexp } gdef)
	972	+ pure ()
	973	+
957	974	-- Record that the name has been linearity checked so we don't need to do
958	975	-- it again
959	976	export

src/Core/Env.idr+3−7

@@ -75,15 +75,11 @@ getBinderUnder : Weaken tm => · 74 unmodified lines
75	75	{idx : Nat} ->
76	76	(ns : List Name) ->
77	77	.(IsVar x idx vars) -> Env tm vars ->
78		− Binder (tm (reverse ns ++ vars))
	78	+ Binder (tm (reverseOnto vars ns))
79	79	getBinderUnder {idx = Z} {vars = v :: vs} ns First (b :: env)
80		− = rewrite appendAssociative (reverse ns) [v] vs in
81		− rewrite revNs [v] ns in
82		− map (weakenNs (reverse (v :: ns))) b
	80	+ = rewrite revOnto vs (v :: ns) in map (weakenNs (reverse (v :: ns))) b
83	81	getBinderUnder {idx = S k} {vars = v :: vs} ns (Later lp) (b :: env)
84		− = rewrite appendAssociative (reverse ns) [v] vs in
85		− rewrite revNs [v] ns in
86		− getBinderUnder (v :: ns) lp env
	82	+ = getBinderUnder (v :: ns) lp env
87	83
88	84	export
89	85	getBinder : Weaken tm =>

src/Core/LinearCheck.idr+3−3

@@ -188,9 +188,9 @@ mutual · 187 unmodified lines
188	188	getName (x :: xs) (Later p) = getName xs p
189	189
190	190	rigSafe : RigCount -> RigCount -> Core ()
191		− rigSafe Rig1 RigW = throw (LinearMisuse fc (getName vars prf) Rig1 RigW)
192		− rigSafe Rig0 RigW = throw (LinearMisuse fc (getName vars prf) Rig0 RigW)
193		− rigSafe Rig0 Rig1 = throw (LinearMisuse fc (getName vars prf) Rig0 Rig1)
	191	+ rigSafe Rig1 RigW = throw (LinearMisuse fc name Rig1 RigW)
	192	+ rigSafe Rig0 RigW = throw (LinearMisuse fc name Rig0 RigW)
	193	+ rigSafe Rig0 Rig1 = throw (LinearMisuse fc name Rig0 Rig1)
194	194	rigSafe _ _ = pure ()
195	195
196	196	-- count the usage if we're in a linear context. If not, the usage doesn't

src/Core/Name.idr+1−1

@@ -56,7 +56,7 @@ showSep sep (x :: xs) = x ++ sep ++ showSep sep xs · 55 unmodified lines
56	56	\|\|\| Check whether a given character is a valid identifier character
57	57	export
58	58	identChar : Char -> Bool
59		−identChar x = isAlphaNum x \|\| x == '_' \|\| x == '\''
	59	+identChar x = isAlphaNum x \|\| x == '_' \|\| x == '\'' \|\| x > chr 127
60	60
61	61	export Show Name where
62	62	show (NS ns n) = showSep "." (reverse ns) ++ "." ++ show n

src/Core/Normalise.idr+75−92

@@ -72,9 +72,9 @@ parameters (defs : Defs, topopts : EvalOpts) · 71 unmodified lines
72	72	eval env locs (Local fc mrig idx prf) stk
73	73	= evalLocal env fc mrig idx prf stk locs
74	74	eval env locs (Ref fc nt fn) stk
75		− = evalRef env locs False fc nt fn stk (NApp fc (NRef nt fn) stk)
	75	+ = evalRef env False fc nt fn stk (NApp fc (NRef nt fn) stk)
76	76	eval {vars} {free} env locs (Meta fc name idx args) stk
77		− = evalMeta env locs fc name idx (closeArgs args) stk
	77	+ = evalMeta env fc name idx (closeArgs args) stk
78	78	where
79	79	-- Yes, it's just a map, but specialising it by hand since we
80	80	-- use this a lot and it saves the run time overhead of making
@@ -120,34 +120,14 @@ parameters (defs : Defs, topopts : EvalOpts) · 39 unmodified lines
120	120	eval env locs (Erased fc i) stk = pure $ NErased fc i
121	121	eval env locs (TType fc) stk = pure $ NType fc
122	122
123		− evalLocal : {vars : _} ->
124		− Env Term free ->
125		− FC -> Maybe Bool ->
126		− (idx : Nat) -> .(IsVar name idx (vars ++ free)) ->
127		− Stack free ->
128		− LocalEnv free vars ->
129		− Core (NF free)
130		− evalLocal {vars = []} env fc mrig idx prf stk locs
131		− = if not (holesOnly topopts \|\| argHolesOnly topopts) && isLet mrig idx env
132		− then
133		− case getBinder prf env of
134		− Let _ val _ => eval env [] val stk
135		− _ => pure $ NApp fc (NLocal mrig idx prf) stk
136		− else pure $ NApp fc (NLocal mrig idx prf) stk
137		− where
138		− isLet' : Nat -> Env tm vars -> Bool
139		− isLet' Z (Let _ _ _ :: env) = True
140		− isLet' Z _ = False
141		− isLet' (S k) (b :: env) = isLet' k env
142		− isLet' (S k) [] = False
143		−
144		− isLet : Maybe Bool -> Nat -> Env tm vars -> Bool
145		− isLet (Just t) _ _ = t
146		− isLet _ n env = isLet' n env
147		− evalLocal env fc mrig Z First stk (MkClosure opts locs' env' tm' :: locs)
	123	+ evalLocClosure : Env Term free ->
	124	+ FC -> Maybe Bool ->
	125	+ Stack free ->
	126	+ Closure free ->
	127	+ Core (NF free)
	128	+ evalLocClosure env fc mrig stk (MkClosure opts locs' env' tm')
148	129	= evalWithOpts defs opts env' locs' tm' stk
149		− evalLocal {free} {vars = x :: xs}
150		− env fc mrig Z First stk (MkNFClosure nf :: locs)
	130	+ evalLocClosure {free} env fc mrig stk (MkNFClosure nf)
151	131	= applyToStack nf stk
152	132	where
153	133	applyToStack : NF free -> Stack free -> Core (NF free)
@@ -155,41 +135,58 @@ parameters (defs : Defs, topopts : EvalOpts) · 1 unmodified line
155	135	= do arg' <- sc defs arg
156	136	applyToStack arg' stk
157	137	applyToStack (NApp fc (NRef nt fn) args) stk
158		− = evalRef {vars = xs} env locs False fc nt fn (args ++ stk)
	138	+ = evalRef env False fc nt fn (args ++ stk)
159	139	(NApp fc (NRef nt fn) args)
160	140	applyToStack (NApp fc (NLocal mrig idx p) args) stk
161		− = let MkVar p' = insertVarNames {outer=[]} {ns = xs} idx p in
162		− evalLocal env fc mrig _ p' (args ++ stk) locs
	141	+ = evalLocal env fc mrig _ p (args ++ stk) []
163	142	applyToStack (NDCon fc n t a args) stk
164	143	= pure $ NDCon fc n t a (args ++ stk)
165	144	applyToStack (NTCon fc n t a args) stk
166	145	= pure $ NTCon fc n t a (args ++ stk)
167	146	applyToStack nf _ = pure nf
168	147
	148	+ evalLocal : {vars : _} ->
	149	+ Env Term free ->
	150	+ FC -> Maybe Bool ->
	151	+ (idx : Nat) -> .(IsVar name idx (vars ++ free)) ->
	152	+ Stack free ->
	153	+ LocalEnv free vars ->
	154	+ Core (NF free)
	155	+ -- If it's one of the free variables, we are done unless the free
	156	+ -- variable maps to a let-binding
	157	+ evalLocal {vars = []} env fc mrig idx prf stk locs
	158	+ = if not (holesOnly topopts \|\| argHolesOnly topopts)
	159	+ -- if we know it's not a let, no point in even running `getBinder`
	160	+ && fromMaybe True mrig
	161	+ then
	162	+ case getBinder prf env of
	163	+ Let _ val _ => eval env [] val stk
	164	+ _ => pure $ NApp fc (NLocal mrig idx prf) stk
	165	+ else pure $ NApp fc (NLocal mrig idx prf) stk
	166	+ evalLocal env fc mrig Z First stk (x :: locs)
	167	+ = evalLocClosure env fc mrig stk x
169	168	evalLocal {vars = x :: xs} {free}
170	169	env fc mrig (S idx) (Later p) stk (_ :: locs)
171	170	= evalLocal {vars = xs} env fc mrig idx p stk locs
172	171
173		− evalMeta : {vars : _} ->
174		− Env Term free -> LocalEnv free vars ->
	172	+ evalMeta : Env Term free ->
175	173	FC -> Name -> Int -> List (Closure free) ->
176	174	Stack free -> Core (NF free)
177		− evalMeta {vars} env locs fc nm i args stk
178		− = evalRef env locs True fc Func (Resolved i) (args ++ stk)
	175	+ evalMeta env fc nm i args stk
	176	+ = evalRef env True fc Func (Resolved i) (args ++ stk)
179	177	(NApp fc (NMeta nm i args) stk)
180	178
181		− evalRef : {vars : _} ->
182		− Env Term free -> LocalEnv free vars ->
	179	+ evalRef : Env Term free ->
183	180	(isMeta : Bool) ->
184	181	FC -> NameType -> Name -> Stack free -> (def : Lazy (NF free)) ->
185	182	Core (NF free)
186		− evalRef env locs meta fc (DataCon tag arity) fn stk def
	183	+ evalRef env meta fc (DataCon tag arity) fn stk def
187	184	= pure $ NDCon fc fn tag arity stk
188		− evalRef env locs meta fc (TyCon tag arity) fn stk def
	185	+ evalRef env meta fc (TyCon tag arity) fn stk def
189	186	= pure $ NTCon fc fn tag arity stk
190		− evalRef env locs meta fc Bound fn stk def
	187	+ evalRef env meta fc Bound fn stk def
191	188	= pure def
192		− evalRef env locs meta fc nt n stk def
	189	+ evalRef env meta fc nt n stk def
193	190	= do Just res <- lookupCtxtExact n (gamma defs)
194	191	\| Nothing => pure def
195	192	let redok = evalAll topopts \|\|
@@ -201,48 +198,42 @@ parameters (defs : Defs, topopts : EvalOpts) · 5 unmodified lines
201	198	opts' <- if noCycles res
202	199	then useMeta fc n defs topopts
203	200	else pure topopts
204		− evalDef env locs opts' meta fc
	201	+ evalDef env opts' meta fc
205	202	(multiplicity res) (definition res) (flags res) stk def
206	203	else pure def
207	204
208	205	getCaseBound : List (Closure free) ->
209	206	(args : List Name) ->
210		− LocalEnv free vars ->
211		− Maybe (LocalEnv free (args ++ vars))
212		− getCaseBound [] [] loc = Just loc
213		− getCaseBound [] (x :: xs) loc = Nothing -- mismatched arg length
214		− getCaseBound (arg :: args) [] loc = Nothing -- mismatched arg length
215		− getCaseBound (arg :: args) (n :: ns) loc
216		− = do loc' <- getCaseBound args ns loc
217		− pure (arg :: loc')
	207	+ LocalEnv free more ->
	208	+ Maybe (LocalEnv free (args ++ more))
	209	+ getCaseBound [] [] loc = Just loc
	210	+ getCaseBound [] (_ :: _) loc = Nothing -- mismatched arg length
	211	+ getCaseBound (arg :: args) [] loc = Nothing -- mismatched arg length
	212	+ getCaseBound (arg :: args) (n :: ns) loc = (arg ::) <$> getCaseBound args ns loc
218	213
219	214	evalConAlt : Env Term free ->
220		− LocalEnv free (more ++ vars) -> EvalOpts -> FC ->
	215	+ LocalEnv free more -> EvalOpts -> FC ->
221	216	Stack free ->
222	217	(args : List Name) ->
223	218	List (Closure free) ->
224	219	CaseTree (args ++ more) ->
225	220	(default : Core (NF free)) ->
226	221	Core (NF free)
227		− evalConAlt {more} {vars} env loc opts fc stk args args' sc def
228		− = maybe def (\bound =>
229		− let loc' : LocalEnv _ ((args ++ more) ++ vars)
230		− = rewrite sym (appendAssociative args more vars) in
231		− bound in
232		− evalTree env loc' opts fc stk sc def)
	222	+ evalConAlt env loc opts fc stk args args' sc def
	223	+ = maybe def (\bound => evalTree env bound opts fc stk sc def)
233	224	(getCaseBound args' args loc)
234	225
235	226	tryAlt : Env Term free ->
236		− LocalEnv free (more ++ vars) -> EvalOpts -> FC ->
	227	+ LocalEnv free more -> EvalOpts -> FC ->
237	228	Stack free -> NF free -> CaseAlt more ->
238	229	(default : Core (NF free)) -> Core (NF free)
239	230	-- Ordinary constructor matching
240		− tryAlt {more} {vars} env loc opts fc stk (NDCon _ nm tag' arity args') (ConCase x tag args sc) def
	231	+ tryAlt {more} env loc opts fc stk (NDCon _ nm tag' arity args') (ConCase x tag args sc) def
241	232	= if tag == tag'
242	233	then evalConAlt env loc opts fc stk args args' sc def
243	234	else def
244	235	-- Type constructor matching, in typecase
245		− tryAlt {more} {vars} env loc opts fc stk (NTCon _ nm tag' arity args') (ConCase nm' tag args sc) def
	236	+ tryAlt {more} env loc opts fc stk (NTCon _ nm tag' arity args') (ConCase nm' tag args sc) def
246	237	= if nm == nm'
247	238	then evalConAlt env loc opts fc stk args args' sc def
248	239	else def
@@ -255,9 +246,9 @@ parameters (defs : Defs, topopts : EvalOpts) · 6 unmodified lines
255	246	tryAlt env loc opts fc stk (NType _) (ConCase (UN "Type") tag [] sc) def
256	247	= evalTree env loc opts fc stk sc def
257	248	-- Arrow matching, in typecase
258		− tryAlt {more} {vars}
	249	+ tryAlt {more}
259	250	env loc opts fc stk (NBind pfc x (Pi r e aty) scty) (ConCase (UN "->") tag [s,t] sc) def
260		− = evalConAlt {more} {vars} env loc opts fc stk [s,t]
	251	+ = evalConAlt {more} env loc opts fc stk [s,t]
261	252	[MkNFClosure aty,
262	253	MkNFClosure (NBind pfc x (Lam r e aty) scty)]
263	254	sc def
@@ -284,34 +275,27 @@ parameters (defs : Defs, topopts : EvalOpts) · 20 unmodified lines
284	275	tryAlt _ _ _ _ _ _ _ def = def
285	276
286	277	findAlt : Env Term free ->
287		− LocalEnv free (args ++ vars) -> EvalOpts -> FC ->
	278	+ LocalEnv free args -> EvalOpts -> FC ->
288	279	Stack free -> NF free -> List (CaseAlt args) ->
289	280	(default : Core (NF free)) -> Core (NF free)
290	281	findAlt env loc opts fc stk val [] def = def
291	282	findAlt env loc opts fc stk val (x :: xs) def
292	283	= tryAlt env loc opts fc stk val x (findAlt env loc opts fc stk val xs def)
293	284
294		− evalTree : {vars : _} ->
295		− Env Term free -> LocalEnv free (args ++ vars) ->
	285	+ evalTree : Env Term free -> LocalEnv free args ->
296	286	EvalOpts -> FC ->
297	287	Stack free -> CaseTree args ->
298	288	(default : Core (NF free)) -> Core (NF free)
299		− evalTree {args} {vars} {free} env loc opts fc stk (Case idx x _ alts) def
300		− = do let x' : IsVar _ _ ((args ++ vars) ++ free)
301		− = rewrite sym (appendAssociative args vars free) in
302		− varExtend x
303		− xval <- evalLocal env fc Nothing idx x' [] loc
	289	+ evalTree env loc opts fc stk (Case idx x _ alts) def
	290	+ = do xval <- evalLocal env fc Nothing idx (varExtend x) [] loc
304	291	findAlt env loc opts fc stk xval alts def
305		− evalTree {args} {vars} {free} env loc opts fc stk (STerm tm) def
306		− = do let tm' : Term ((args ++ vars) ++ free)
307		− = rewrite sym (appendAssociative args vars free) in
308		− embed tm
309		− case fuel opts of
310		− Nothing => evalWithOpts defs opts env loc tm' stk
	292	+ evalTree env loc opts fc stk (STerm tm) def
	293	+ = do case fuel opts of
	294	+ Nothing => evalWithOpts defs opts env loc (embed tm) stk
311	295	Just Z => def
312	296	Just (S k) =>
313	297	do let opts' = record { fuel = Just k } opts
314		− evalWithOpts defs opts' env loc tm' stk
	298	+ evalWithOpts defs opts' env loc (embed tm) stk
315	299	evalTree env loc opts fc stk _ def = def
316	300
317	301	-- Take arguments from the stack, as long as there's enough.
@@ -330,13 +314,13 @@ parameters (defs : Defs, topopts : EvalOpts) · 12 unmodified lines
330	314	= rewrite sym (plusSuccRightSucc got k) in
331	315	takeStk k stk (arg :: acc)
332	316
333		− extendFromStack : (args : List Name) ->
334		− LocalEnv free vars -> Stack free ->
335		− Maybe (LocalEnv free (args ++ vars), Stack free)
336		− extendFromStack [] loc stk = Just (loc, stk)
337		− extendFromStack (n :: ns) loc [] = Nothing
338		− extendFromStack (n :: ns) loc (arg :: args)
339		− = do (loc', stk') <- extendFromStack ns loc args
	317	+ argsFromStack : (args : List Name) ->
	318	+ Stack free ->
	319	+ Maybe (LocalEnv free args, Stack free)
	320	+ argsFromStack [] stk = Just ([], stk)
	321	+ argsFromStack (n :: ns) [] = Nothing
	322	+ argsFromStack (n :: ns) (arg :: args)
	323	+ = do (loc', stk') <- argsFromStack ns args
340	324	pure (arg :: loc', stk')
341	325
342	326	evalOp : (Vect arity (NF free) -> Maybe (NF free)) ->
@@ -357,13 +341,12 @@ parameters (defs : Defs, topopts : EvalOpts) · 14 unmodified lines
357	341	evalAll [] = pure []
358	342	evalAll (c :: cs) = pure $ !(evalClosure defs c) :: !(evalAll cs)
359	343
360		− evalDef : {vars : _} ->
361		− Env Term free -> LocalEnv free vars -> EvalOpts ->
	344	+ evalDef : Env Term free -> EvalOpts ->
362	345	(isMeta : Bool) -> FC ->
363	346	RigCount -> Def -> List DefFlag ->
364	347	Stack free -> (def : Lazy (NF free)) ->
365	348	Core (NF free)
366		− evalDef {vars} env locs opts meta fc rigd (PMDef r args tree _ _) flags stk def
	349	+ evalDef env opts meta fc rigd (PMDef r args tree _ _) flags stk def
367	350	-- If evaluating the definition fails (e.g. due to a case being
368	351	-- stuck) return the default.
369	352	-- We can use the definition if one of the following is true:
@@ -374,20 +357,20 @@ parameters (defs : Defs, topopts : EvalOpts) · 4 unmodified lines
374	357	-- + It's a metavariable and we're not in 'argHolesOnly'
375	358	-- + It's inlinable and we're in 'tcInline'
376	359	= if alwaysReduce r
377		− \|\| (not (holesOnly opts) && not (argHolesOnly opts) && not (tcInline opts))
	360	+ \|\| (not (holesOnly opts \|\| argHolesOnly opts \|\| tcInline opts))
378	361	\|\| (meta && rigd /= Rig0)
379	362	\|\| (meta && holesOnly opts)
380	363	\|\| (tcInline opts && elem TCInline flags)
381		− then case extendFromStack args locs stk of
	364	+ then case argsFromStack args stk of
382	365	Nothing => pure def
383	366	Just (locs', stk') =>
384	367	evalTree env locs' opts fc stk' tree (pure def)
385	368	else pure def
386		− evalDef {vars} env locs opts meta fc rigd (Builtin op) flags stk def
	369	+ evalDef env opts meta fc rigd (Builtin op) flags stk def
387	370	= evalOp (getOp op) stk def
388	371	-- All other cases, use the default value, which is already applied to
389	372	-- the stack
390		− evalDef env locs opts _ _ _ _ _ stk def = pure def
	373	+ evalDef env opts _ _ _ _ _ stk def = pure def
391	374
392	375	-- Make sure implicit argument order is right... 'vars' is used so we'll
393	376	-- write it explicitly, but it does appear after the parameters in 'eval'!

src/Core/Options.idr+3−1

@@ -99,6 +99,7 @@ record Session where · 98 unmodified lines
99	99	logTimings : Bool
100	100	debugElabCheck : Bool -- do conversion check to verify results of elaborator
101	101	dumpcases : Maybe String -- file to output compiled case trees
	102	+ dumplifted : Maybe String -- file to output lambda lifted definitions
102	103
103	104	public export
104	105	record PPrinter where
@@ -143,7 +144,8 @@ defaultPPrint : PPrinter · 38 unmodified lines
143	144	defaultPPrint = MkPPOpts False True False
144	145
145	146	defaultSession : Session
146		−defaultSession = MkSessionOpts False False False Chez 0 False False Nothing
	147	+defaultSession = MkSessionOpts False False False Chez 0 False False
	148	+ Nothing Nothing
147	149
148	150	defaultElab : ElabDirectives
149	151	defaultElab = MkElabDirectives True True PartialOK 3

src/Core/TT.idr+47−12

@@ -405,7 +405,7 @@ data UseSide = UseLeft \| UseRight · 404 unmodified lines
405	405	public export
406	406	data Term : List Name -> Type where
407	407	Local : {name : _} ->
408		− FC -> Maybe Bool ->
	408	+ FC -> (isLet : Maybe Bool) ->
409	409	(idx : Nat) -> .(IsVar name idx vars) -> Term vars
410	410	Ref : FC -> NameType -> (name : Name) -> Term vars
411	411	-- Metavariables and the scope they are applied to
@@ -654,6 +654,21 @@ export · 242 unmodified lines
654	654	notCovering : Totality
655	655	notCovering = MkTotality Unchecked (MissingCases [])
656	656
	657	+public export
	658	+data NVar : Name -> List Name -> Type where
	659	+ MkNVar : {i : Nat} -> .(IsVar n i vars) -> NVar n vars
	660	+
	661	+export
	662	+insertNVar : {outer : List Name} ->
	663	+ (idx : Nat) ->
	664	+ .(IsVar name idx (outer ++ inner)) ->
	665	+ NVar name (outer ++ n :: inner)
	666	+insertNVar {outer = []} idx x = MkNVar (Later x)
	667	+insertNVar {outer = (name :: xs)} Z First = MkNVar First
	668	+insertNVar {n} {outer = (x :: xs)} (S i) (Later y)
	669	+ = let MkNVar prf = insertNVar {n} i y in
	670	+ MkNVar (Later prf)
	671	+
657	672	export
658	673	insertVar : {outer : _} ->
659	674	(idx : Nat) ->
@@ -673,6 +688,14 @@ weakenVar (y :: xs) x · 13 unmodified lines
673	688	= let MkVar x' = weakenVar xs x in
674	689	MkVar (Later x')
675	690
	691	+export
	692	+weakenNVar : (ns : List Name) -> {idx : Nat} -> .(IsVar name idx inner) ->
	693	+ NVar name (ns ++ inner)
	694	+weakenNVar [] x = MkNVar x
	695	+weakenNVar (y :: xs) x
	696	+ = let MkNVar x' = weakenNVar xs x in
	697	+ MkNVar (Later x')
	698	+
676	699	export
677	700	insertVarNames : {outer, ns : _} ->
678	701	(idx : Nat) ->
@@ -684,11 +707,22 @@ insertVarNames {ns} {outer = (y :: xs)} (S i) (Later x) · 5 unmodified lines
684	707	= let MkVar prf = insertVarNames {ns} i x in
685	708	MkVar (Later prf)
686	709
	710	+export
	711	+insertNVarNames : {outer, ns : _} ->
	712	+ (idx : Nat) ->
	713	+ .(IsVar name idx (outer ++ inner)) ->
	714	+ NVar name (outer ++ (ns ++ inner))
	715	+insertNVarNames {ns} {outer = []} idx prf = weakenNVar ns prf
	716	+insertNVarNames {outer = (y :: xs)} Z First = MkNVar First
	717	+insertNVarNames {ns} {outer = (y :: xs)} (S i) (Later x)
	718	+ = let MkNVar prf = insertNVarNames {ns} i x in
	719	+ MkNVar (Later prf)
	720	+
687	721	export
688	722	thin : {outer, inner : _} ->
689	723	(n : Name) -> Term (outer ++ inner) -> Term (outer ++ n :: inner)
690	724	thin n (Local fc r idx prf)
691		− = let MkVar var' = insertVar {n} idx prf in
	725	+ = let MkNVar var' = insertNVar {n} idx prf in
692	726	Local fc r _ var'
693	727	thin n (Ref fc nt name) = Ref fc nt name
694	728	thin n (Meta fc name idx args) = Meta fc name idx (map (thin n) args)
@@ -725,7 +759,7 @@ insertNames : {outer, inner : _} -> · 30 unmodified lines
725	759	(ns : List Name) -> Term (outer ++ inner) ->
726	760	Term (outer ++ (ns ++ inner))
727	761	insertNames ns (Local fc r idx prf)
728		− = let MkVar prf' = insertVarNames {ns} idx prf in
	762	+ = let MkNVar prf' = insertNVarNames {ns} idx prf in
729	763	Local fc r _ prf'
730	764	insertNames ns (Ref fc nt name) = Ref fc nt name
731	765	insertNames ns (Meta fc name idx args)
@@ -988,15 +1022,16 @@ namespace Bounds · 256 unmodified lines
988	1022	None : Bounds []
989	1023	Add : (x : Name) -> Name -> Bounds xs -> Bounds (x :: xs)
990	1024
	1025	+export
991	1026	addVars : {later, bound : _} ->
992	1027	{idx : Nat} ->
993	1028	Bounds bound -> .(IsVar name idx (later ++ vars)) ->
994		− Var (later ++ (bound ++ vars))
995		−addVars {later = []} {bound} bs p = weakenVar bound p
996		−addVars {later = (x :: xs)} bs First = MkVar First
	1029	+ NVar name (later ++ (bound ++ vars))
	1030	+addVars {later = []} {bound} bs p = weakenNVar bound p
	1031	+addVars {later = (x :: xs)} bs First = MkNVar First
997	1032	addVars {later = (x :: xs)} bs (Later p)
998		− = let MkVar p' = addVars {later = xs} bs p in
999		− MkVar (Later p')
	1033	+ = let MkNVar p' = addVars {later = xs} bs p in
	1034	+ MkNVar (Later p')
1000	1035
1001	1036	resolveRef : (done : List Name) -> Bounds bound -> FC -> Name ->
1002	1037	Maybe (Term (later ++ (done ++ bound ++ vars)))
@@ -1004,9 +1039,9 @@ resolveRef done None fc n = Nothing · 1 unmodified line
1004	1039	resolveRef {later} {vars} done (Add {xs} new old bs) fc n
1005	1040	= if n == old
1006	1041	then rewrite appendAssociative later done (new :: xs ++ vars) in
1007		− let MkVar p = weakenVar {inner = new :: xs ++ vars}
1008		− (later ++ done) First in
1009		− Just (Local fc Nothing _ p)
	1042	+ let MkNVar p = weakenNVar {inner = new :: xs ++ vars}
	1043	+ (later ++ done) First in
	1044	+ Just (Local fc Nothing _ p)
1010	1045	else rewrite appendAssociative done [new] (xs ++ vars)
1011	1046	in resolveRef (done ++ [new]) bs fc n
1012	1047
@@ -1014,7 +1049,7 @@ mkLocals : {later, bound : _} -> · 1 unmodified line
1014	1049	Bounds bound ->
1015	1050	Term (later ++ vars) -> Term (later ++ (bound ++ vars))
1016	1051	mkLocals bs (Local fc r idx p)
1017		− = let MkVar p' = addVars bs p in Local fc r _ p'
	1052	+ = let MkNVar p' = addVars bs p in Local fc r _ p'
1018	1053	mkLocals bs (Ref fc Bound name)
1019	1054	= maybe (Ref fc Bound name) id (resolveRef [] bs fc name)
1020	1055	mkLocals bs (Ref fc nt name)

src/Core/TTC.idr+5−6

@@ -583,7 +583,7 @@ mutual · 582 unmodified lines
583	583	toBuf b (CLocal fc {x} {idx} h) = do tag 0; toBuf b fc; toBuf b x; toBuf b idx
584	584	toBuf b (CRef fc n) = do tag 1; toBuf b fc; toBuf b n
585	585	toBuf b (CLam fc x sc) = do tag 2; toBuf b fc; toBuf b x; toBuf b sc
586		− toBuf b (CLet fc x val sc) = do tag 3; toBuf b fc; toBuf b x; toBuf b val; toBuf b sc
	586	+ toBuf b (CLet fc x inl val sc) = do tag 3; toBuf b fc; toBuf b x; toBuf b inl; toBuf b val; toBuf b sc
587	587	toBuf b (CApp fc f as) = assert_total $ do tag 4; toBuf b fc; toBuf b f; toBuf b as
588	588	toBuf b (CCon fc t n as) = assert_total $ do tag 5; toBuf b fc; toBuf b t; toBuf b n; toBuf b as
589	589	toBuf b (COp {arity} fc op as) = assert_total $ do tag 6; toBuf b fc; toBuf b arity; toBuf b op; toBuf b as
@@ -608,8 +608,8 @@ mutual · 18 unmodified lines
608	608	x <- fromBuf b; sc <- fromBuf b
609	609	pure (CLam fc x sc)
610	610	3 => do fc <- fromBuf b
611		− x <- fromBuf b; val <- fromBuf b; sc <- fromBuf b
612		− pure (CLet fc x val sc)
	611	+ x <- fromBuf b; inl <- fromBuf b; val <- fromBuf b; sc <- fromBuf b
	612	+ pure (CLet fc x inl val sc)
613	613	4 => do fc <- fromBuf b
614	614	f <- fromBuf b; as <- fromBuf b
615	615	pure (CApp fc f as)
@@ -944,10 +944,10 @@ TTC GlobalDef where · 328 unmodified lines
944	944	sc <- fromBuf b
945	945	pure (MkGlobalDef loc name ty eargs seargs specargs
946	946	mul vars vis
947		− tot fl refs refsR inv c True def cdef sc)
	947	+ tot fl refs refsR inv c True def cdef Nothing sc)
948	948	else pure (MkGlobalDef loc name (Erased loc False) [] [] []
949	949	RigW [] Public unchecked [] refs refsR
950		− False False True def cdef [])
	950	+ False False True def cdef Nothing [])
951	951
952	952	TTC Transform where
953	953	toBuf b (MkTransform {vars} env lhs rhs)
@@ -973,4 +973,3 @@ Core.Context.decode gam idx update (Coded bin) · 19 unmodified lines
973	973	when update $ coreLift $ writeArray arr idx (Decoded def')
974	974	pure def'
975	975	Core.Context.decode gam idx update (Decoded def) = pure def
976		−

src/Core/Unify.idr+12−17

@@ -218,16 +218,8 @@ unifyArgs : (Unify tm, Quote tm) => · 217 unmodified lines
218	218	unifyArgs mode loc env [] [] = pure success
219	219	unifyArgs mode loc env (cx :: cxs) (cy :: cys)
220	220	= do res <- unify (lower mode) loc env cx cy
221		− case constraints res of
222		− [] => do cs <- unifyArgs mode loc env cxs cys
223		− pure (union res cs)
224		− _ => do cs <- unifyArgs mode loc env cxs cys
225		− -- TODO: Fix this bit! See p59 Ulf's thesis
226		−-- c <- addConstraint
227		−-- (MkSeqConstraint loc env
228		−-- (map (quote gam env) (cx :: cxs))
229		−-- (map (quote gam env) (cy :: cys)))
230		− pure (union res cs) -- [c]
	221	+ cs <- unifyArgs mode loc env cxs cys
	222	+ pure (union res cs)
231	223	unifyArgs mode loc env _ _ = ufail loc ""
232	224
233	225	-- Get the variables in an application argument list; fail if any arguments
@@ -1120,11 +1112,8 @@ mutual · 886 unmodified lines
1120	1112	Unify Term where
1121	1113	unifyD _ _ mode loc env x y
1122	1114	= do defs <- get Ctxt
1123		− ust <- get UST
1124		− when (logging ust) $
1125		− do logTerm 0 "TOP LEVEL Unifying: " x
1126		− logTerm 0 " with: " y
1127		− if x == y
	1115	+ empty <- clearDefs defs
	1116	+ if !(convert empty env x y)
1128	1117	then do log 10 $ "Skipped unification (equal already): "
1129	1118	++ show x ++ " and " ++ show y
1130	1119	pure success
@@ -1133,7 +1122,8 @@ mutual · 2 unmodified lines
1133	1122	unify mode loc env xnf ynf
1134	1123	unifyWithLazyD _ _ mode loc env x y
1135	1124	= do defs <- get Ctxt
1136		− if x == y
	1125	+ empty <- clearDefs defs
	1126	+ if !(convert empty env x y)
1137	1127	then do log 10 $ "Skipped unification (equal already): "
1138	1128	++ show x ++ " and " ++ show y
1139	1129	pure success
@@ -1145,7 +1135,12 @@ mutual · 5 unmodified lines
1145	1135	Unify Closure where
1146	1136	unifyD _ _ mode loc env x y
1147	1137	= do defs <- get Ctxt
1148		− unify mode loc env !(evalClosure defs x) !(evalClosure defs y)
	1138	+ empty <- clearDefs defs
	1139	+ if !(convert empty env x y)
	1140	+ then pure success
	1141	+ else do xnf <- evalClosure defs x
	1142	+ ynf <- evalClosure defs y
	1143	+ unify mode loc env xnf ynf
1149	1144
1150	1145	export
1151	1146	setInvertible : {auto c : Ref Ctxt Defs} ->

src/Idris/CommandLine.idr+4−0

@@ -71,6 +71,8 @@ data CLOpt · 70 unmodified lines
71	71	Metadata String \|
72	72	\|\|\| Dump cases before compiling
73	73	DumpCases String \|
	74	+ \|\|\| Dump lambda lifted defs before compiling
	75	+ DumpLifted String \|
74	76	\|\|\| Run a REPL command then exit immediately
75	77	RunREPL String \|
76	78	FindIPKG \|
@@ -147,6 +149,8 @@ options = [MkOpt ["--check", "-c"] [] [CheckOnly] · 70 unmodified lines
147	149	Nothing, -- dump metadata information from the given ttm file
148	150	MkOpt ["--dumpcases"] ["output file"] (\f => [DumpCases f])
149	151	Nothing, -- dump case trees to the given file
	152	+ MkOpt ["--dumplifted"] ["output file"] (\f => [DumpLifted f])
	153	+ Nothing, -- dump case trees to the given file
150	154	MkOpt ["--debug-elab-check"] [] [DebugElabCheck]
151	155	Nothing -- do more elaborator checks (currently conversion in LinearCheck)
152	156	]

src/Idris/Desugar.idr+43−17

@@ -72,11 +72,10 @@ toTokList (POp fc opn l r) · 71 unmodified lines
72	72	let op = nameRoot opn
73	73	case lookup op (infixes syn) of
74	74	Nothing =>
75		− let ops = unpack opChars in
76		− if any (\x => x `elem` ops) (unpack op)
77		− then throw (GenericMsg fc $ "Unknown operator '" ++ op ++ "'")
78		− else do rtoks <- toTokList r
79		− pure (Expr l :: Op fc opn backtickPrec :: rtoks)
	75	+ if any isOpChar (unpack op)
	76	+ then throw (GenericMsg fc $ "Unknown operator '" ++ op ++ "'")
	77	+ else do rtoks <- toTokList r
	78	+ pure (Expr l :: Op fc opn backtickPrec :: rtoks)
80	79	Just (Prefix, _) =>
81	80	throw (GenericMsg fc $ "'" ++ op ++ "' is a prefix operator")
82	81	Just (fix, prec) =>
@@ -547,9 +546,9 @@ mutual · 464 unmodified lines
547	546	getDecl AsType d@(PRecord fc vis n ps _ _)
548	547	= Just (PData fc vis (MkPLater fc n (mkRecType ps)))
549	548	where
550		− mkRecType : List (Name, PTerm) -> PTerm
	549	+ mkRecType : List (Name, RigCount, PiInfo PTerm, PTerm) -> PTerm
551	550	mkRecType [] = PType fc
552		− mkRecType ((n, t) :: ts) = PPi fc RigW Explicit (Just n) t (mkRecType ts)
	551	+ mkRecType ((n, c, p, t) :: ts) = PPi fc c p (Just n) t (mkRecType ts)
553	552	getDecl AsType d@(PFixity _ _ _ _) = Just d
554	553	getDecl AsType d@(PDirective _ _) = Just d
555	554	getDecl AsType d = Nothing
@@ -691,20 +690,26 @@ mutual · 135 unmodified lines
691	690	= map (\x => (Nothing, x)) (pairToCons p)
692	691
693	692	desugarDecl ps (PImplementation fc vis pass is cons tn params impname nusing body)
694		− = do is' <- traverse (\ ntm => do tm' <- desugar AnyExpr ps (snd (snd ntm))
695		− pure (fst ntm, fst (snd ntm), tm')) is
696		− cons' <- traverse (\ ntm => do tm' <- desugar AnyExpr ps (snd ntm)
697		− pure (fst ntm, tm')) cons
	693	+ = do is' <- traverse (\ (n,c,tm) => do tm' <- desugar AnyExpr ps tm
	694	+ pure (n, c, tm')) is
	695	+ let _ = the (List (Name, RigCount, RawImp)) is'
	696	+ cons' <- traverse (\ (n, tm) => do tm' <- desugar AnyExpr ps tm
	697	+ pure (n, tm')) cons
	698	+ let _ = the (List (Maybe Name, RawImp)) cons'
698	699	params' <- traverse (desugar AnyExpr ps) params
	700	+ let _ = the (List RawImp) params'
699	701	-- Look for bindable names in all the constraints and parameters
700	702	let bnames = if !isUnboundImplicits
701	703	then
702	704	concatMap (findBindableNames True ps []) (map snd cons') ++
703	705	concatMap (findBindableNames True ps []) params'
704	706	else []
	707	+
705	708	let paramsb = map (doBind bnames) params'
706	709	let isb = map (\ (n, r, tm) => (n, r, doBind bnames tm)) is'
707		− let consb = map (\ (n, tm) => (n, doBind bnames tm)) cons'
	710	+ let _ = the (List (Name, RigCount, RawImp)) isb
	711	+ let consb = map (\(n, tm) => (n, doBind bnames tm)) cons'
	712	+ let _ = the (List (Maybe Name, RawImp)) consb
708	713
709	714	body' <- maybe (pure Nothing)
710	715	(\b => do b' <- traverse (desugarDecl ps) b
@@ -713,21 +718,32 @@ mutual · 2 unmodified lines
713	718	elabImplementation fc vis pass env nest isb consb
714	719	tn paramsb impname nusing
715	720	body')]
	721	+
716	722	desugarDecl ps (PRecord fc vis tn params conname_in fields)
717		− = do params' <- traverse (\ ntm => do tm' <- desugar AnyExpr ps (snd ntm)
718		− pure (fst ntm, tm')) params
	723	+ = do params' <- traverse (\ (n,c,p,tm) =>
	724	+ do tm' <- desugar AnyExpr ps tm
	725	+ p' <- mapDesugarPiInfo ps p
	726	+ pure (n, c, p', tm'))
	727	+ params
	728	+ let _ = the (List (Name, RigCount, PiInfo RawImp, RawImp)) params'
719	729	let fnames = map fname fields
	730	+ let _ = the (List Name) fnames
720	731	-- Look for bindable names in the parameters
721		−
	732	+
722	733	let bnames = if !isUnboundImplicits
723	734	then concatMap (findBindableNames True
724	735	(ps ++ fnames ++ map fst params) [])
725		− (map snd params')
	736	+ (map (\(_,_,_,d) => d) params')
726	737	else []
727		− let paramsb = map (\ (n, tm) => (n, doBind bnames tm)) params'
	738	+ let _ = the (List (String, String)) bnames
	739	+
	740	+ let paramsb = map (\ (n, c, p, tm) => (n, c, p, doBind bnames tm)) params'
	741	+ let _ = the (List (Name, RigCount, PiInfo RawImp, RawImp)) paramsb
728	742	fields' <- traverse (desugarField (ps ++ map fname fields ++
729	743	map fst params)) fields
	744	+ let _ = the (List IField) fields'
730	745	let conname = maybe (mkConName tn) id conname_in
	746	+ let _ = the Name conname
731	747	-- True flag set so that the parent namespace can look inside the
732	748	-- record definition
733	749	pure [IRecord fc (Just (nameRoot tn))
@@ -739,6 +755,16 @@ mutual · 5 unmodified lines
739	755	mkConName : Name -> Name
740	756	mkConName (NS ns (UN n)) = NS ns (DN n (MN ("__mk" ++ n) 0))
741	757	mkConName n = DN (show n) (MN ("__mk" ++ show n) 0)
	758	+
	759	+ mapDesugarPiInfo : {auto s : Ref Syn SyntaxInfo} -> {auto c : Ref Ctxt Defs}
	760	+ -> {auto u : Ref UST UState} -> {auto m : Ref MD Metadata}
	761	+ -> List Name -> PiInfo PTerm -> Core (PiInfo RawImp)
	762	+ mapDesugarPiInfo ps Implicit = pure Implicit
	763	+ mapDesugarPiInfo ps Explicit = pure Explicit
	764	+ mapDesugarPiInfo ps AutoImplicit = pure AutoImplicit
	765	+ mapDesugarPiInfo ps (DefImplicit tm) = pure $ DefImplicit
	766	+ !(desugar AnyExpr ps tm)
	767	+
742	768
743	769	desugarDecl ps (PFixity fc Prefix prec (UN n))
744	770	= do syn <- get Syn

src/Idris/Elab/Implementation.idr+5−5

@@ -169,6 +169,11 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln nusing mbo · 168 unmodified lines
169	169	log 5 $ "Added defaults: body is " ++ show body
170	170	log 5 $ "Missing methods: " ++ show missing
171	171
	172	+ -- Add the 'using' hints
	173	+ log 10 $ "Open hints: " ++ (show (impName :: nusing))
	174	+ traverse_ (\n => do n' <- checkUnambig fc n
	175	+ addOpenHint n') nusing
	176	+
172	177	-- 2. Elaborate top level function types for this interface
173	178	defs <- get Ctxt
174	179	fns <- topMethTypes [] impName methImps impsp (params cdata)
@@ -199,11 +204,6 @@ elabImplementation {vars} fc vis pass env nest is cons iname ps impln nusing mbo · 24 unmodified lines
199	204	let hs = openHints defs
200	205	maybe (pure ()) (\x => addOpenHint impName) impln
201	206
202		− -- Also add the 'using' hints
203		− log 10 $ "Open hints: " ++ (show (impName :: nusing))
204		− traverse_ (\n => do n' <- checkUnambig fc n
205		− addOpenHint n') nusing
206		−
207	207	-- Make sure we don't use this name to solve parent constraints
208	208	-- when elaborating the record, or we'll end up in a cycle!
209	209	setFlag fc impName BlockedHint

src/Idris/IDEMode/MakeClause.idr+1−1

@@ -9,7 +9,7 @@ import Parser.Unlit · 8 unmodified lines
9	9	showRHSName : Name -> String
10	10	showRHSName n
11	11	= let fn = show (dropNS n) in
12		− if any (flip elem (unpack opChars)) (unpack fn)
	12	+ if any isOpChar (unpack fn)
13	13	then "op"
14	14	else fn
15	15

src/Idris/IDEMode/Parser.idr+4−18

@@ -1,3 +1,6 @@
	1	+\|\|\| Slightly different lexer than the source language because we are more free
	2	+\|\|\| as to what can be identifiers, and fewer tokens are supported. But otherwise,
	3	+\|\|\| we can reuse the standard stuff
1	4	module Idris.IDEMode.Parser
2	5
3	6	import Idris.IDEMode.Commands
@@ -7,34 +10,17 @@ import Parser.Lexer · 3 unmodified lines
7	10	import Parser.Support
8	11	import Text.Lexer
9	12
10		−-- Slightly different lexer than the source language because we are more free
11		−-- as to what can be identifiers, and fewer tokens are supported. But otherwise,
12		−-- we can reuse the standard stuff
13		−
14	13	%hide Lexer.symbols
15	14
16	15	symbols : List String
17	16	symbols = ["(", ":", ")"]
18	17
19		−ident : Lexer
20		−ident = pred startIdent <+> many (pred validIdent)
21		− where
22		− startIdent : Char -> Bool
23		− startIdent '_' = True
24		− startIdent x = isAlpha x
25		−
26		− validIdent : Char -> Bool
27		− validIdent '_' = True
28		− validIdent '-' = True
29		− validIdent '\'' = True
30		− validIdent x = isAlphaNum x
31		−
32	18	ideTokens : TokenMap Token
33	19	ideTokens =
34	20	map (\x => (exact x, Symbol)) symbols ++
35	21	[(digits, \x => Literal (cast x)),
36	22	(stringLit, \x => StrLit (stripQuotes x)),
37		− (ident, Ident),
	23	+ (identRelaxed, Ident),
38	24	(space, Comment)]
39	25	where
40	26	stripQuotes : String -> String

src/Idris/IDEMode/TokenLine.idr+4−17

@@ -1,7 +1,7 @@
	1	+\|\|\| Tokenise a source line for easier processing
1	2	module Idris.IDEMode.TokenLine
2	3
3		−-- Tokenise a source line for easier processing
4		−
	4	+import Parser.Lexer
5	5	import Text.Lexer
6	6
7	7	public export
@@ -14,24 +14,12 @@ data SourcePart · 6 unmodified lines
14	14	\| Equal
15	15	\| Other String
16	16
17		−ident : Lexer
18		−ident = pred startIdent <+> many (pred validIdent)
19		− where
20		− startIdent : Char -> Bool
21		− startIdent '_' = True
22		− startIdent x = isAlpha x
23		−
24		− validIdent : Char -> Bool
25		− validIdent '_' = True
26		− validIdent '\'' = True
27		− validIdent x = isAlphaNum x
28		−
29	17	holeIdent : Lexer
30		−holeIdent = is '?' <+> ident
	18	+holeIdent = is '?' <+> identStrict
31	19
32	20	srcTokens : TokenMap SourcePart
33	21	srcTokens =
34		− [(ident, Name),
	22	+ [(identStrict, Name),
35	23	(holeIdent, \x => HoleName (assert_total (strTail x))),
36	24	(space, Whitespace),
37	25	(is '{', const LBrace),
@@ -47,4 +35,3 @@ tokens str · 9 unmodified lines
47	35	-- number to read when storing spans in the file
48	36	(srctoks, (l, c, rest)) =>
49	37	map tok srctoks ++ (if rest == "" then [] else [Other rest])
50		−

src/Idris/Parser.idr+38−8

@@ -398,23 +398,29 @@ mutual · 397 unmodified lines
398	398	rig <- getMult rigc
399	399	pure (rig, pat, ty))
400	400
401		− pibindList : FileName -> FilePos -> IndentInfo ->
402		− Rule (List (RigCount, Maybe Name, PTerm))
403		− pibindList fname start indents
	401	+ pibindListName : FileName -> FilePos -> IndentInfo ->
	402	+ Rule (List (RigCount, Name, PTerm))
	403	+ pibindListName fname start indents
404	404	= do rigc <- multiplicity
405	405	ns <- sepBy1 (symbol ",") unqualifiedName
406	406	symbol ":"
407	407	ty <- expr pdef fname indents
408	408	atEnd indents
409	409	rig <- getMult rigc
410		− pure (map (\n => (rig, Just (UN n), ty)) ns)
	410	+ pure (map (\n => (rig, UN n, ty)) ns)
411	411	<\|> sepBy1 (symbol ",")
412	412	(do rigc <- multiplicity
413	413	n <- name
414	414	symbol ":"
415	415	ty <- expr pdef fname indents
416	416	rig <- getMult rigc
417		− pure (rig, Just n, ty))
	417	+ pure (rig, n, ty))
	418	+
	419	+ pibindList : FileName -> FilePos -> IndentInfo ->
	420	+ Rule (List (RigCount, Maybe Name, PTerm))
	421	+ pibindList fname start indents
	422	+ = do params <- pibindListName fname start indents
	423	+ pure $ map (\(rig, n, ty) => (rig, Just n, ty)) params
418	424
419	425	bindSymbol : Rule (PiInfo PTerm)
420	426	bindSymbol
@@ -624,8 +630,8 @@ mutual · 203 unmodified lines
624	630	record_ fname indents
625	631	= do start <- location
626	632	keyword "record"
627		− commit
628	633	symbol "{"
	634	+ commit
629	635	fs <- sepBy1 (symbol ",") (field fname indents)
630	636	symbol "}"
631	637	end <- location
@@ -1263,6 +1269,30 @@ fieldDecl fname indents · 631 unmodified lines
1263	1269	end <- location
1264	1270	pure (map (\n => MkField (MkFC fname start end)
1265	1271	rig p n ty) ns)
	1272	+recordParam : FileName -> IndentInfo -> Rule (List (Name, RigCount, PiInfo PTerm, PTerm))
	1273	+recordParam fname indents
	1274	+ = do symbol "("
	1275	+ start <- location
	1276	+ params <- pibindListName fname start indents
	1277	+ symbol ")"
	1278	+ pure $ map (\(c, n, tm) => (n, c, Explicit, tm)) params
	1279	+ <\|> do symbol "{"
	1280	+ commit
	1281	+ info <- the (EmptyRule (PiInfo PTerm))
	1282	+ (pure AutoImplicit <* keyword "auto"
	1283	+ <\|>(do
	1284	+ keyword "default"
	1285	+ t <- simpleExpr fname indents
	1286	+ pure $ DefImplicit t)
	1287	+ <\|> pure Implicit)
	1288	+ start <- location
	1289	+ params <- pibindListName fname start indents
	1290	+ symbol "}"
	1291	+ pure $ map (\(c, n, tm) => (n, c, info, tm)) params
	1292	+ <\|> do start <- location
	1293	+ n <- name
	1294	+ end <- location
	1295	+ pure [(n, RigW, Explicit, PInfer (MkFC fname start end))]
1266	1296
1267	1297	recordDecl : FileName -> IndentInfo -> Rule PDecl
1268	1298	recordDecl fname indents
@@ -1270,9 +1300,9 @@ recordDecl fname indents · 1 unmodified line
1270	1300	vis <- visibility
1271	1301	col <- column
1272	1302	keyword "record"
1273		− commit
1274	1303	n <- name
1275		− params <- many (ifaceParam fname indents)
	1304	+ paramss <- many (recordParam fname indents)
	1305	+ let params = concat paramss
1276	1306	keyword "where"
1277	1307	dcflds <- blockWithOptHeaderAfter col ctor (fieldDecl fname)
1278	1308	end <- location

src/Idris/Resugar.idr+13−4

@@ -340,14 +340,23 @@ mutual · 339 unmodified lines
340	340	toPRecord : {auto c : Ref Ctxt Defs} ->
341	341	{auto s : Ref Syn SyntaxInfo} ->
342	342	ImpRecord ->
343		− Core (Name, List (Name, PTerm), Maybe Name, List PField)
	343	+ Core (Name, List (Name, RigCount, PiInfo PTerm, PTerm), Maybe Name, List PField)
344	344	toPRecord (MkImpRecord fc n ps con fs)
345		− = do ps' <- traverse (\ (n, ty) =>
	345	+ = do ps' <- traverse (\ (n, c, p, ty) =>
346	346	do ty' <- toPTerm startPrec ty
347		− pure (n, ty')) ps
	347	+ p' <- mapPiInfo p
	348	+ pure (n, c, p', ty')) ps
348	349	fs' <- traverse toPField fs
349	350	pure (n, ps', Just con, fs')
350		−
	351	+ where
	352	+ mapPiInfo : {auto c : Ref Ctxt Defs} ->
	353	+ {auto s : Ref Syn SyntaxInfo} ->
	354	+ PiInfo RawImp -> Core (PiInfo PTerm)
	355	+ mapPiInfo Explicit = pure Explicit
	356	+ mapPiInfo Implicit = pure Implicit
	357	+ mapPiInfo AutoImplicit = pure AutoImplicit
	358	+ mapPiInfo (DefImplicit p) = pure $ DefImplicit !(toPTerm startPrec p)
	359	+
351	360	toPFnOpt : {auto c : Ref Ctxt Defs} ->
352	361	{auto s : Ref Syn SyntaxInfo} ->
353	362	FnOpt -> Core PFnOpt

src/Idris/SetOptions.idr+3−0

@@ -89,6 +89,9 @@ preOptions (FindIPKG :: opts) · 88 unmodified lines
89	89	preOptions (DumpCases f :: opts)
90	90	= do setSession (record { dumpcases = Just f } !getSession)
91	91	preOptions opts
	92	+preOptions (DumpLifted f :: opts)
	93	+ = do setSession (record { dumplifted = Just f } !getSession)
	94	+ preOptions opts
92	95	preOptions (_ :: opts) = preOptions opts
93	96
94	97	-- Options to be processed after type checking. Returns whether execution

src/Idris/Syntax.idr+9−2

@@ -223,7 +223,7 @@ mutual · 222 unmodified lines
223	223	PRecord : FC ->
224	224	Visibility ->
225	225	Name ->
226		− (params : List (Name, PTerm)) ->
	226	+ (params : List (Name, RigCount, PiInfo PTerm, PTerm)) ->
227	227	(conName : Maybe Name) ->
228	228	List PField ->
229	229	PDecl
@@ -828,7 +828,7 @@ mapPTermM f = goPTerm where · 598 unmodified lines
828	828	<*> pure ns
829	829	<*> goMPDecls mps
830	830	goPDecl (PRecord fc v n nts mn fs) =
831		− PRecord fc v n <$> goPairedPTerms nts
	831	+ PRecord fc v n <$> go4TupledPTerms nts
832	832	<*> pure mn
833	833	<*> goPFields fs
834	834	goPDecl (PMutual fc ps) = PMutual fc <$> goPDecls ps
@@ -884,6 +884,13 @@ mapPTermM f = goPTerm where · 49 unmodified lines
884	884	(::) . (\ c => (a, b, c)) <$> goPTerm t
885	885	<*> go3TupledPTerms ts
886	886
	887	+ go4TupledPTerms : List (a, b, PiInfo PTerm, PTerm) -> Core (List (a, b, PiInfo PTerm, PTerm))
	888	+ go4TupledPTerms [] = pure []
	889	+ go4TupledPTerms ((a, b, p, t) :: ts) =
	890	+ (\ p, d, ts => (a, b, p, d) :: ts) <$> goPiInfo p
	891	+ <*> goPTerm t
	892	+ <*> go4TupledPTerms ts
	893	+
887	894	goPDos : List PDo -> Core (List PDo)
888	895	goPDos [] = pure []
889	896	goPDos (d :: ds) = (::) <$> goPDo d <*> goPDos ds

src/Parser/Lexer.idr+87−31

@@ -40,20 +40,58 @@ export · 39 unmodified lines
40	40	Show (TokenData Token) where
41	41	show t = show (line t, col t, tok t)
42	42
	43	+\|\|\| In `comment` we are careful not to parse closing delimiters as
	44	+\|\|\| valid comments. i.e. you may not write many dashes followed by
	45	+\|\|\| a closing brace and call it a valid comment.
43	46	comment : Lexer
44		−comment = is '-' <+> is '-' <+> many (isNot '\n')
45		−
46		−toEndComment : (k : Nat) -> Recognise (k /= 0)
47		−toEndComment Z = empty
48		−toEndComment (S k)
49		− = some (pred (\c => c /= '-' && c /= '{' && c /= '"'))
50		− <+> toEndComment (S k)
51		− <\|> is '{' <+> is '-' <+> toEndComment (S (S k))
52		− <\|> is '-' <+> is '}' <+> toEndComment k
53		− <\|> comment <+> toEndComment (S k)
54		− <\|> stringLit <+> toEndComment (S k)
55		− <\|> is '{' <+> toEndComment (S k)
56		− <\|> is '-' <+> toEndComment (S k)
	47	+comment
	48	+ = is '-' <+> is '-' -- comment opener
	49	+ <+> many (is '-') <+> reject (is '}') -- not a closing delimiter
	50	+ <+> many (isNot '\n') -- till the end of line
	51	+
	52	+mutual
	53	+
	54	+ \|\|\| The mutually defined functions represent different states in a
	55	+ \|\|\| small automaton.
	56	+ \|\|\| `toEndComment` is the default state and it will munch through
	57	+ \|\|\| the input until we detect a special character (a dash, an
	58	+ \|\|\| opening brace, or a double quote) and then switch to the
	59	+ \|\|\| appropriate state.
	60	+ toEndComment : (k : Nat) -> Recognise (k /= 0)
	61	+ toEndComment Z = empty
	62	+ toEndComment (S k)
	63	+ = some (pred (\c => c /= '-' && c /= '{' && c /= '"'))
	64	+ <+> toEndComment (S k)
	65	+ <\|> is '{' <+> singleBrace k
	66	+ <\|> is '-' <+> singleDash k
	67	+ <\|> stringLit <+> toEndComment (S k)
	68	+
	69	+ \|\|\| After reading a single brace, we may either finish reading an
	70	+ \|\|\| opening delimiter or ignore it (e.g. it could be an implicit
	71	+ \|\|\| binder).
	72	+ singleBrace : (k : Nat) -> Lexer
	73	+ singleBrace k
	74	+ = is '-' <+> many (is '-') -- opening delimiter
	75	+ <+> singleDash (S k) -- handles the {----} special case
	76	+ <\|> toEndComment (S k) -- not a valid comment
	77	+
	78	+ \|\|\| After reading a single dash, we may either find another one,
	79	+ \|\|\| meaning we may have started reading a line comment, or find
	80	+ \|\|\| a closing brace meaning we have found a closing delimiter.
	81	+ singleDash : (k : Nat) -> Lexer
	82	+ singleDash k
	83	+ = is '-' <+> doubleDash k -- comment or closing delimiter
	84	+ <\|> is '}' <+> toEndComment k -- closing delimiter
	85	+ <\|> toEndComment (S k) -- not a valid comment
	86	+
	87	+ \|\|\| After reading a double dash, we are potentially reading a line
	88	+ \|\|\| comment unless the series of uninterrupted dashes is ended with
	89	+ \|\|\| a closing brace in which case it is a closing delimiter.
	90	+ doubleDash : (k : Nat) -> Lexer
	91	+ doubleDash k = many (is '-') <+> choice -- absorb all dashes
	92	+ [ is '}' <+> toEndComment k -- closing delimiter
	93	+ , many (isNot '\n') <+> toEndComment (S k) -- line comment
	94	+ ]
57	95
58	96	blockComment : Lexer
59	97	blockComment = is '{' <+> is '-' <+> toEndComment 1
@@ -61,20 +99,40 @@ blockComment = is '{' <+> is '-' <+> toEndComment 1 · 1 unmodified line
61	99	docComment : Lexer
62	100	docComment = is '\|' <+> is '\|' <+> is '\|' <+> many (isNot '\n')
63	101
64		−ident : Lexer
65		−ident = pred startIdent <+> many (pred validIdent)
66		− where
67		− startIdent : Char -> Bool
68		− startIdent '_' = True
69		− startIdent x = isAlpha x \|\| x > chr 127
	102	+-- Identifier Lexer
	103	+--
	104	+-- There are two variants, a strict ident and a relaxed ident.
	105	+-- Prime definitions recieve a boolean determining if it is relaxed.
	106	+
	107	+startIdent : Char -> Bool
	108	+startIdent '_' = True
	109	+startIdent x = isAlpha x \|\| x > chr 127
	110	+
	111	+%inline
	112	+validIdent' : Bool -> Char -> Bool
	113	+validIdent' _ '_' = True
	114	+validIdent' r '-' = r
	115	+validIdent' _ '\'' = True
	116	+validIdent' _ x = isAlphaNum x \|\| x > chr 127
	117	+
	118	+%inline
	119	+ident' : Bool -> Lexer
	120	+ident' relaxed =
	121	+ (pred $ startIdent) <+>
	122	+ (many . pred $ validIdent' relaxed)
	123	+
	124	+-- This are the two identifier lexer specializations
70	125
71		− validIdent : Char -> Bool
72		− validIdent '_' = True
73		− validIdent '\'' = True
74		− validIdent x = isAlphaNum x \|\| x > chr 127
	126	+export
	127	+identStrict : Lexer
	128	+identStrict = ident' False
	129	+
	130	+export
	131	+identRelaxed : Lexer
	132	+identRelaxed = ident' True
75	133
76	134	holeIdent : Lexer
77		−holeIdent = is '?' <+> ident
	135	+holeIdent = is '?' <+> identStrict
78	136
79	137	doubleLit : Lexer
80	138	doubleLit
@@ -121,12 +179,13 @@ symbols · 40 unmodified lines
121	179	"(", ")", "{", "}", "[", "]", ",", ";", "_",
122	180	"`(", "`"]
123	181
	182	+
124	183	export
125		−opChars : String
126		−opChars = ":!#$%&*+./<=>?@\\^\|-~"
	184	+isOpChar : Char -> Bool
	185	+isOpChar c = c `elem` (unpack ":!#$%&*+./<=>?@\\^\|-~")
127	186
128	187	validSymbol : Lexer
129		−validSymbol = some (oneOf opChars)
	188	+validSymbol = some (pred isOpChar)
130	189
131	190	-- Valid symbols which have a special meaning so can't be operators
132	191	export
@@ -136,9 +195,6 @@ reservedSymbols · 3 unmodified lines
136	195	["%", "\\", ":", "=", "\|", "\|\|\|", "<-", "->", "=>", "?", "!",
137	196	"&", "**", ".."]
138	197
139		−symbolChar : Char -> Bool
140		−symbolChar c = c `elem` unpack opChars
141		−
142	198	fromHexLit : String -> Integer
143	199	fromHexLit str
144	200	= if length str <= 2
@@ -161,7 +217,7 @@ rawTokens = · 16 unmodified lines
161	217	(digits, \x => Literal (cast x)),
162	218	(stringLit, \x => StrLit (stripQuotes x)),
163	219	(charLit, \x => CharLit (stripQuotes x)),
164		− (ident, \x => if x `elem` keywords then Keyword x else Ident x),
	220	+ (identStrict, \x => if x `elem` keywords then Keyword x else Ident x),
165	221	(space, Comment),
166	222	(validSymbol, Symbol),
167	223	(symbol, Unrecognised)]

src/TTImp/Elab/Case.idr+6−7

@@ -249,23 +249,22 @@ caseBlock {vars} rigc elabinfo fc nest env scr scrtm scrty caseRig alts expected · 248 unmodified lines
249	249	-- Replace a variable in the argument list; if the reference is to
250	250	-- a variable kept in the outer environment (therefore not an argument
251	251	-- in the list) don't consume it
252		− replace : {idx : Nat} -> .(IsVar name idx vs) ->
253		− RawImp -> List RawImp -> List RawImp
254		− replace First lhs (old :: xs)
	252	+ replace : (idx : Nat) -> RawImp -> List RawImp -> List RawImp
	253	+ replace Z lhs (old :: xs)
255	254	= let lhs' = case old of
256	255	IAs loc' side n _ => IAs loc' side n lhs
257	256	_ => lhs in
258	257	lhs' :: xs
259		− replace (Later p) lhs (x :: xs)
260		− = x :: replace p lhs xs
	258	+ replace (S k) lhs (x :: xs)
	259	+ = x :: replace k lhs xs
261	260	replace _ _ xs = xs
262	261
263	262	mkSplit : Maybe (Var vs) ->
264	263	RawImp -> List RawImp ->
265	264	List RawImp
266	265	mkSplit Nothing lhs args = reverse (lhs :: args)
267		− mkSplit (Just (MkVar prf)) lhs args
268		− = reverse (replace prf lhs args)
	266	+ mkSplit (Just (MkVar {i} prf)) lhs args
	267	+ = reverse (replace i lhs args)
269	268
270	269	-- Names used in the pattern we're matching on, so don't bind them
271	270	-- in the generated case block

src/TTImp/Elab/Check.idr+8−3

@@ -191,6 +191,11 @@ strengthenedEState {n} {vars} c e fc env · 190 unmodified lines
191	191	dropSub (DropCons sub) = pure sub
192	192	dropSub _ = throw (InternalError "Badly formed weakened environment")
193	193
	194	+ -- This helps persuade the erasure checker that it can erase IsVar,
	195	+ -- because there's no matching on it in removeArgVars below.
	196	+ dropLater : IsVar name (S idx) (v :: vs) -> IsVar name idx vs
	197	+ dropLater (Later p) = p
	198	+
194	199	-- Remove any instance of the top level local variable from an
195	200	-- application. Fail if it turns out to be necessary.
196	201	-- NOTE: While this isn't strictly correct given the type of the hole
@@ -200,10 +205,10 @@ strengthenedEState {n} {vars} c e fc env · 3 unmodified lines
200	205	-- in scope.
201	206	removeArgVars : List (Term (n :: vs)) -> Maybe (List (Term vs))
202	207	removeArgVars [] = pure []
203		− removeArgVars (Local fc r _ (Later p) :: args)
	208	+ removeArgVars (Local fc r (S k) p :: args)
204	209	= do args' <- removeArgVars args
205		− pure (Local fc r _ p :: args')
206		− removeArgVars (Local fc r _ First :: args)
	210	+ pure (Local fc r _ (dropLater p) :: args')
	211	+ removeArgVars (Local fc r Z p :: args)
207	212	= removeArgVars args
208	213	removeArgVars (a :: args)
209	214	= do a' <- shrinkTerm a (DropCons SubRefl)

src/TTImp/Parser.idr+34−14

@@ -226,23 +226,30 @@ mutual · 225 unmodified lines
226	226	pure (rig, UN n, ty))
227	227
228	228
229		− pibindList : FileName -> FilePos -> IndentInfo ->
230		− Rule (List (RigCount, Maybe Name, RawImp))
231		− pibindList fname start indents
	229	+ pibindListName : FileName -> FilePos -> IndentInfo ->
	230	+ Rule (List (RigCount, Name, RawImp))
	231	+ pibindListName fname start indents
232	232	= do rigc <- multiplicity
233	233	ns <- sepBy1 (symbol ",") unqualifiedName
234	234	symbol ":"
235	235	ty <- expr fname indents
236	236	atEnd indents
237	237	rig <- getMult rigc
238		− pure (map (\n => (rig, Just (UN n), ty)) ns)
	238	+ pure (map (\n => (rig, UN n, ty)) ns)
239	239	<\|> sepBy1 (symbol ",")
240	240	(do rigc <- multiplicity
241	241	n <- name
242	242	symbol ":"
243	243	ty <- expr fname indents
244	244	rig <- getMult rigc
245		− pure (rig, Just n, ty))
	245	+ pure (rig, n, ty))
	246	+
	247	+ pibindList : FileName -> FilePos -> IndentInfo ->
	248	+ Rule (List (RigCount, Maybe Name, RawImp))
	249	+ pibindList fname start indents
	250	+ = do params <- pibindListName fname start indents
	251	+ pure $ map (\(rig, n, ty) => (rig, Just n, ty)) params
	252	+
246	253
247	254	autoImplicitPi : FileName -> IndentInfo -> Rule RawImp
248	255	autoImplicitPi fname indents
@@ -370,8 +377,8 @@ mutual · 121 unmodified lines
370	377	record_ fname indents
371	378	= do start <- location
372	379	keyword "record"
373		− commit
374	380	symbol "{"
	381	+ commit
375	382	fs <- sepBy1 (symbol ",") (field fname indents)
376	383	symbol "}"
377	384	sc <- expr fname indents
@@ -550,18 +557,30 @@ dataDecl fname indents · 172 unmodified lines
550	557	end <- location
551	558	pure (MkImpData (MkFC fname start end) n ty opts cs)
552	559
553		−ifaceParam : FileName -> IndentInfo -> Rule (Name, RawImp)
554		−ifaceParam fname indents
	560	+recordParam : FileName -> IndentInfo -> Rule (List (Name, RigCount, PiInfo RawImp, RawImp))
	561	+recordParam fname indents
555	562	= do symbol "("
556		− n <- name
557		− symbol ":"
558		− tm <- expr fname indents
	563	+ start <- location
	564	+ params <- pibindListName fname start indents
559	565	symbol ")"
560		− pure (n, tm)
	566	+ pure $ map (\(c, n, tm) => (n, c, Explicit, tm)) params
	567	+ <\|> do symbol "{"
	568	+ commit
	569	+ start <- location
	570	+ info <- the (EmptyRule (PiInfo RawImp))
	571	+ (pure AutoImplicit <* keyword "auto"
	572	+ <\|>(do
	573	+ keyword "default"
	574	+ t <- simpleExpr fname indents
	575	+ pure $ DefImplicit t)
	576	+ <\|> pure Implicit)
	577	+ params <- pibindListName fname start indents
	578	+ symbol "}"
	579	+ pure $ map (\(c, n, tm) => (n, c, info, tm)) params
561	580	<\|> do start <- location
562	581	n <- name
563	582	end <- location
564		− pure (n, Implicit (MkFC fname start end) False)
	583	+ pure [(n, RigW, Explicit, Implicit (MkFC fname start end) False)]
565	584
566	585	fieldDecl : FileName -> IndentInfo -> Rule (List IField)
567	586	fieldDecl fname indents
@@ -593,7 +612,8 @@ recordDecl fname indents · 25 unmodified lines
593	612	keyword "record"
594	613	commit
595	614	n <- name
596		− params <- many (ifaceParam fname indents)
	615	+ paramss <- many (recordParam fname indents)
	616	+ let params = concat paramss
597	617	keyword "where"
598	618	exactIdent "constructor"
599	619	dc <- name

src/TTImp/ProcessData.idr+15−11

@@ -195,20 +195,24 @@ getDetags fc tys · 194 unmodified lines
195	195	else pure rest
196	196
197	197	-- If exactly one argument is unerased, return its position
198		−getRelevantArg : Defs -> Nat -> Maybe Nat -> NF [] -> Core (Maybe Nat)
199		−getRelevantArg defs i rel (NBind fc _ (Pi Rig0 _ _) sc)
200		− = getRelevantArg defs (1 + i) rel
	198	+getRelevantArg : Defs -> Nat -> Maybe Nat -> Bool -> NF [] ->
	199	+ Core (Maybe (Bool, Nat))
	200	+getRelevantArg defs i rel world (NBind fc _ (Pi Rig0 _ _) sc)
	201	+ = getRelevantArg defs (1 + i) rel world
201	202	!(sc defs (toClosure defaultOpts [] (Erased fc False)))
202		−-- %World is never inspected, so might as well be deleted from data types
203		−getRelevantArg defs i rel (NBind fc _ (Pi _ _ (NPrimVal _ WorldType)) sc)
204		− = getRelevantArg defs (1 + i) rel
	203	+-- %World is never inspected, so might as well be deleted from data types,
	204	+-- although it needs care when compiling to ensure that the function that
	205	+-- returns the IO/%World type isn't erased
	206	+getRelevantArg defs i rel world (NBind fc _ (Pi _ _ (NPrimVal _ WorldType)) sc)
	207	+ = getRelevantArg defs (1 + i) rel False
205	208	!(sc defs (toClosure defaultOpts [] (Erased fc False)))
206		−getRelevantArg defs i Nothing (NBind fc _ (Pi _ _ _) sc) -- found a relevant arg
207		− = getRelevantArg defs (1 + i) (Just i)
	209	+getRelevantArg defs i Nothing world (NBind fc _ (Pi _ _ _) sc) -- found a relevant arg
	210	+ = getRelevantArg defs (1 + i) (Just i) world
208	211	!(sc defs (toClosure defaultOpts [] (Erased fc False)))
209		−getRelevantArg defs i (Just _) (NBind _ _ (Pi _ _ _) sc) -- more than one relevant
	212	+getRelevantArg defs i (Just _) world (NBind _ _ (Pi _ _ _) sc) -- more than one relevant
210	213	= pure Nothing
211		−getRelevantArg defs i rel tm = pure rel
	214	+getRelevantArg defs i rel world tm
	215	+ = pure (maybe Nothing (\r => Just (world, r)) rel)
212	216
213	217	-- If there's one constructor with only one non-Rig0 argument, flag it as
214	218	-- a newtype for optimisation
@@ -217,7 +221,7 @@ findNewtype : {auto c : Ref Ctxt Defs} -> · 2 unmodified lines
217	221	List Constructor -> Core ()
218	222	findNewtype [con]
219	223	= do defs <- get Ctxt
220		− Just arg <- getRelevantArg defs 0 Nothing !(nf defs [] (type con))
	224	+ Just arg <- getRelevantArg defs 0 Nothing True !(nf defs [] (type con))
221	225	\| Nothing => pure ()
222	226	updateDef (name con)
223	227	(\d => case d of

src/TTImp/ProcessRecord.idr+32−19

@@ -15,10 +15,10 @@ import TTImp.TTImp · 14 unmodified lines
15	15	import TTImp.Unelab
16	16	import TTImp.Utils
17	17
18		−mkDataTy : FC -> List (Name, RawImp) -> RawImp
	18	+mkDataTy : FC -> List (Name, RigCount, PiInfo RawImp, RawImp) -> RawImp
19	19	mkDataTy fc [] = IType fc
20		−mkDataTy fc ((n, ty) :: ps)
21		− = IPi fc RigW Explicit (Just n) ty (mkDataTy fc ps)
	20	+mkDataTy fc ((n, c, p, ty) :: ps)
	21	+ = IPi fc c p (Just n) ty (mkDataTy fc ps)
22	22
23	23	elabRecord : {vars : _} ->
24	24	{auto c : Ref Ctxt Defs} ->
@@ -27,7 +27,7 @@ elabRecord : {vars : _} -> · 2 unmodified lines
27	27	List ElabOpt -> FC -> Env Term vars ->
28	28	NestedNames vars -> Maybe String ->
29	29	Visibility -> Name ->
30		− (params : List (Name, RawImp)) ->
	30	+ (params : List (Name, RigCount, PiInfo RawImp, RawImp)) ->
31	31	(conName : Name) ->
32	32	List IField ->
33	33	Core ()
@@ -37,24 +37,29 @@ elabRecord {vars} eopts fc env nest newns vis tn params conName_in fields · 3 unmodified lines
37	37	defs <- get Ctxt
38	38	Just conty <- lookupTyExact conName (gamma defs)
39	39	\| Nothing => throw (InternalError ("Adding " ++ show tn ++ "failed"))
40		− let recTy = apply (IVar fc tn) (map (IVar fc) (map fst params))
41	40	-- Go into new namespace, if there is one, for getters
42	41	case newns of
43		− Nothing => elabGetters conName recTy 0 [] [] conty
	42	+ Nothing => elabGetters conName 0 [] [] conty
44	43	Just ns =>
45	44	do let cns = currentNS defs
46	45	let nns = nestedNS defs
47	46	extendNS [ns]
48	47	newns <- getNS
49		− elabGetters conName recTy 0 [] [] conty
	48	+ elabGetters conName 0 [] [] conty
50	49	defs <- get Ctxt
51	50	-- Record that the current namespace is allowed to look
52	51	-- at private names in the nested namespace
53	52	put Ctxt (record { currentNS = cns,
54	53	nestedNS = newns :: nns } defs)
55		− where
56		− jname : (Name, RawImp) -> (Maybe Name, RigCount, PiInfo RawImp, RawImp)
57		− jname (n, t) = (Just n, Rig0, Implicit, t)
	54	+ where
	55	+ paramTelescope : List (Maybe Name, RigCount, PiInfo RawImp, RawImp)
	56	+ paramTelescope = map jname params
	57	+ where
	58	+ jname : (Name, RigCount, PiInfo RawImp, RawImp)
	59	+ -> (Maybe Name, RigCount, PiInfo RawImp, RawImp)
	60	+ -- Record type parameters are implicit in the constructor
	61	+ -- and projections
	62	+ jname (n, _, _, t) = (Just n, Rig0, Implicit, t)
58	63
59	64	fname : IField -> Name
60	65	fname (MkIField fc c p n ty) = n
@@ -69,11 +74,19 @@ elabRecord {vars} eopts fc env nest newns vis tn params conName_in fields · 8 unmodified lines
69	74	mkTy ((n, c, imp, argty) :: args) ret
70	75	= IPi fc c imp n argty (mkTy args ret)
71	76
	77	+ recTy : RawImp
	78	+ recTy = apply (IVar fc tn) (map (\(n, c, p, tm) => (n, IVar fc n, p)) params)
	79	+ where
	80	+ \|\|\| Apply argument to list of explicit or implicit named arguments
	81	+ apply : RawImp -> List (Name, RawImp, PiInfo RawImp) -> RawImp
	82	+ apply f [] = f
	83	+ apply f ((n, arg, Explicit) :: xs) = apply (IApp (getFC f) f arg) xs
	84	+ apply f ((n, arg, _ ) :: xs) = apply (IImplicitApp (getFC f) f (Just n) arg) xs
	85	+
72	86	elabAsData : Name -> Core ()
73	87	elabAsData cname
74		− = do let retty = apply (IVar fc tn) (map (IVar fc) (map fst params))
75		− let conty = mkTy (map jname params) $
76		− mkTy (map farg fields) retty
	88	+ = do let conty = mkTy paramTelescope $
	89	+ mkTy (map farg fields) recTy
77	90	let con = MkImpTy fc cname !(bindTypeNames [] (map fst params ++
78	91	map fname fields ++ vars) conty)
79	92	let dt = MkImpData fc tn !(bindTypeNames [] (map fst params ++
@@ -89,16 +102,16 @@ elabRecord {vars} eopts fc env nest newns vis tn params conName_in fields · 9 unmodified lines
89	102
90	103	-- Generate getters from the elaborated record constructor type
91	104	elabGetters : {vs : _} ->
92		− Name -> RawImp ->
	105	+ Name ->
93	106	(done : Nat) -> -- number of explicit fields processed
94	107	List (Name, RawImp) -> -- names to update in types
95	108	-- (for dependent records, where a field's type may depend
96	109	-- on an earlier projection)
97	110	Env Term vs -> Term vs ->
98	111	Core ()
99		− elabGetters con recTy done upds tyenv (Bind bfc n b@(Pi rc imp ty_chk) sc)
	112	+ elabGetters con done upds tyenv (Bind bfc n b@(Pi rc imp ty_chk) sc)
100	113	= if (n `elem` map fst params) \|\| (n `elem` vars)
101		− then elabGetters con recTy
	114	+ then elabGetters con
102	115	(if imp == Explicit && not (n `elem` vars)
103	116	then S done else done)
104	117	upds (b :: tyenv) sc
@@ -111,7 +124,7 @@ elabRecord {vars} eopts fc env nest newns vis tn params conName_in fields · 6 unmodified lines
111	124	let rname = MN "rec" 0
112	125	gty <- bindTypeNames []
113	126	(map fst params ++ map fname fields ++ vars) $
114		− mkTy (map jname params) $
	127	+ mkTy paramTelescope $
115	128	IPi fc RigW Explicit (Just rname) recTy ty'
116	129	log 5 $ "Projection " ++ show gname ++ " : " ++ show gty
117	130	let lhs_exp
@@ -134,11 +147,11 @@ elabRecord {vars} eopts fc env nest newns vis tn params conName_in fields · 16 unmodified lines
134	147	processDecl [] nest env
135	148	(IDef fc gname [PatClause fc lhs (IVar fc fldName)])
136	149	let upds' = (n, IApp fc (IVar fc gname) (IVar fc rname)) :: upds
137		− elabGetters con recTy
	150	+ elabGetters con
138	151	(if imp == Explicit
139	152	then S done else done)
140	153	upds' (b :: tyenv) sc
141		− elabGetters con recTy done upds _ _ = pure ()
	154	+ elabGetters con done upds _ _ = pure ()
142	155
143	156	export
144	157	processRecord : {auto c : Ref Ctxt Defs} ->

src/TTImp/TTImp.idr+1−1

@@ -264,7 +264,7 @@ mutual · 263 unmodified lines
264	264	public export
265	265	data ImpRecord : Type where
266	266	MkImpRecord : FC -> (n : Name) ->
267		− (params : List (Name, RawImp)) ->
	267	+ (params : List (Name, RigCount, PiInfo RawImp, RawImp)) ->
268	268	(conName : Name) ->
269	269	(fields : List IField) ->
270	270	ImpRecord

src/Utils/Binary.idr+1−1

@@ -114,7 +114,7 @@ initBinaryS s · 113 unmodified lines
114	114	extendBinary : Int -> Binary -> Core Binary
115	115	extendBinary need (MkBin buf l s u)
116	116	= do let newsize = s * 2
117		− let s' = if newsize < need
	117	+ let s' = if (newsize - l) < need
118	118	then newsize + need
119	119	else newsize
120	120	Just buf' <- coreLift $ resizeBuffer buf s'

support/chez/support.ss+8−5

@@ -6,7 +6,7 @@ · 5 unmodified lines
6	6	(define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
7	7	(define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
8	8	(define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
9		−(define b/ (lambda (x y bits) (remainder (floor (/ x y)) (expt 2 bits))))
	9	+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
10	10
11	11	(define blodwen-shl (lambda (x y) (ash x y)))
12	12	(define blodwen-shr (lambda (x y) (ash x (- y))))
@@ -26,6 +26,9 @@ · 13 unmodified lines
26	26	(define cast-string-int
27	27	(lambda (x)
28	28	(floor (cast-num (string->number (destroy-prefix x))))))
	29	+(define exact-floor
	30	+ (lambda (x)
	31	+ (inexact->exact (floor x))))
29	32	(define cast-string-double
30	33	(lambda (x)
31	34	(cast-num (string->number (destroy-prefix x)))))
@@ -42,11 +45,11 @@ · 10 unmodified lines
42	45
43	46	(define either-left
44	47	(lambda (x)
45		− (vector 0 #f #f x)))
	48	+ (vector 0 x)))
46	49
47	50	(define either-right
48	51	(lambda (x)
49		− (vector 1 #f #f x)))
	52	+ (vector 1 x)))
50	53
51	54	(define blodwen-error-quit
52	55	(lambda (msg)
@@ -237,8 +240,8 @@ · 184 unmodified lines
237	240	(define (blodwen-args)
238	241	(define (blodwen-build-args args)
239	242	(if (null? args)
240		− (vector 0 '())
241		− (vector 1 '() (car args) (blodwen-build-args (cdr args)))))
	243	+ (vector 0) ; Prelude.List
	244	+ (vector 1 (car args) (blodwen-build-args (cdr args)))))
242	245	(blodwen-build-args (command-line)))
243	246
244	247	(define (blodwen-hasenv var)

support/chicken/support.scm+4−1

@@ -6,7 +6,7 @@ · 5 unmodified lines
6	6	(define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
7	7	(define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
8	8	(define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
9		−(define b/ (lambda (x y bits) (remainder (/ x y) (expt 2 bits))))
	9	+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
10	10
11	11	(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
12	12	(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
@@ -26,6 +26,9 @@ · 13 unmodified lines
26	26	(define cast-string-int
27	27	(lambda (x)
28	28	(floor (cast-num (string->number (destroy-prefix x))))))
	29	+(define exact-floor
	30	+ (lambda (x)
	31	+ (inexact->exact (floor x))))
29	32	(define cast-string-double
30	33	(lambda (x)
31	34	(cast-num (string->number (destroy-prefix x)))))

support/racket/support.rkt+5−5

@@ -6,7 +6,7 @@ · 5 unmodified lines
6	6	(define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
7	7	(define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
8	8	(define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
9		−(define b/ (lambda (x y bits) (remainder (/ x y) (expt 2 bits))))
	9	+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
10	10
11	11	(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
12	12	(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
@@ -42,11 +42,11 @@ · 29 unmodified lines
42	42
43	43	(define either-left
44	44	(lambda (x)
45		− (vector 0 #f #f x)))
	45	+ (vector 0 x)))
46	46
47	47	(define either-right
48	48	(lambda (x)
49		− (vector 1 #f #f x)))
	49	+ (vector 1 x)))
50	50
51	51	(define blodwen-error-quit
52	52	(lambda (msg)
@@ -244,8 +244,8 @@ · 191 unmodified lines
244	244	(define (blodwen-args)
245	245	(define (blodwen-build-args args)
246	246	(if (null? args)
247		− (vector 0 '())
248		− (vector 1 '() (car args) (blodwen-build-args (cdr args)))))
	247	+ (vector 0) ; Prelude.List
	248	+ (vector 1 (car args) (blodwen-build-args (cdr args)))))
249	249	(blodwen-build-args
250	250	(cons (path->string (find-system-path 'run-file))
251	251	(vector->list (current-command-line-arguments)))))

tests/Main.idr+6−5

@@ -17,7 +17,7 @@ ttimpTests · 16 unmodified lines
17	17	"lazy001",
18	18	"nest001", "nest002",
19	19	"perf001", "perf002", "perf003",
20		− "record001", "record002",
	20	+ "record001", "record002", "record003",
21	21	"rewrite001",
22	22	"qtt001", "qtt002", "qtt003",
23	23	"search001", "search002", "search003", "search004", "search005",
@@ -67,7 +67,7 @@ idrisTests · 43 unmodified lines
67	67	"params001",
68	68	-- Performance: things which have been slow in the past, or which
69	69	-- pose interesting challenges for the elaborator
70		− "perf001", "perf002", "perf003",
	70	+ "perf001", "perf002", "perf003", "perf004",
71	71	-- Parse errors
72	72	"perror001", "perror002", "perror003", "perror004", "perror005",
73	73	"perror006",
@@ -77,11 +77,11 @@ idrisTests · 3 unmodified lines
77	77	-- interesting interactions between features
78	78	"real001", "real002",
79	79	-- Records, access and dependent update
80		− "record001", "record002",
	80	+ "record001", "record002", "record003",
81	81	-- Miscellaneous regressions
82	82	"reg001", "reg002", "reg003", "reg004", "reg005", "reg006", "reg007",
83	83	"reg008", "reg009", "reg010", "reg011", "reg012", "reg013", "reg014",
84		− "reg015",
	84	+ "reg015", "reg016",
85	85	-- Totality checking
86	86	"total001", "total002", "total003", "total004", "total005",
87	87	"total006",
@@ -98,7 +98,8 @@ chezTests : List String · 10 unmodified lines
98	98	chezTests
99	99	= ["chez001", "chez002", "chez003", "chez004", "chez005", "chez006",
100	100	"chez007", "chez008", "chez009", "chez010", "chez011", "chez012",
101		− "chez013", "chez014"]
	101	+ "chez013", "chez014", "chez015", "chez016",
	102	+ "reg001"]
102	103
103	104	ideModeTests : List String
104	105	ideModeTests

tests/chez/chez015/Numbers.idr+34−0

@@ -0,0 +1,34 @@
	1	+module Main
	2	+
	3	+import Data.List
	4	+
	5	+large : (a: Type) -> a
	6	+-- integer larger than 64 bits
	7	+large Integer = 3518437212345678901234567890123
	8	+-- int close to 2ˆ63
	9	+-- we expect some operations will overflow
	10	+large Int = 3518437212345678901234567890
	11	+
	12	+small : (a: Type) -> a
	13	+small Integer = 437
	14	+small Int = 377
	15	+
	16	+numOps : (Num a) => List ( a -> a -> a )
	17	+numOps = [ (+), (*) ]
	18	+
	19	+negOps : (Neg a) => List (a -> a -> a)
	20	+negOps = [ (-) ]
	21	+
	22	+integralOps : (Integral a) => List (a -> a -> a)
	23	+integralOps = [ div, mod ]
	24	+
	25	+binOps : (Num a, Neg a, Integral a) => List (a -> a -> a)
	26	+binOps = numOps ++ negOps ++ integralOps
	27	+
	28	+main : IO ()
	29	+main = do
	30	+ putStrLn $ show (results Integer)
	31	+ putStrLn $ show (results Int)
	32	+ where
	33	+ results : (a:Type) -> (Num a, Neg a, Integral a) => List a
	34	+ results a = map (\ op => large a `op` small a) binOps

tests/chez/chez015/expected+4−0

@@ -0,0 +1,4 @@
	1	+[3518437212327232157160858338944, 1537557061787000452679295093927559, 3518437212327232157160858338070, 8051343735302590748651849744, 379]
	2	+[8650625671965379659, 5435549321212129090, 8650625671965378905, 365458446121836181, 357]
	3	+1/1: Building Numbers (Numbers.idr)
	4	+Main> Main> Bye for now!

tests/chez/chez015/input+2−0

@@ -0,0 +1,2 @@
	1	+:exec main
	2	+:q

tests/chez/chez015/run+3−0

@@ -0,0 +1,3 @@
	1	+$1 --no-banner Numbers.idr < input
	2	+
	3	+rm -rf build

tests/chez/chez016/expected+3−0

@@ -0,0 +1,3 @@
	1	+Running Chez program located in folder with spaces
	2	+1/1: Building Main (Main.idr)
	3	+Main> Main> Bye for now!

tests/chez/chez016/folder with spaces/Main.idr+2−0

@@ -0,0 +1,2 @@
	1	+main : IO ()
	2	+main = putStrLn "Running Chez program located in folder with spaces"

tests/chez/chez016/input+2−0

@@ -0,0 +1,2 @@
	1	+:exec main
	2	+:q

tests/chez/chez016/run+7−0

@@ -0,0 +1,7 @@
	1	+# Get the absolute path to idris2 because we run idris2 from another folder than the current
	2	+IDRIS2_EXEC="$(realpath "$1")"
	3	+
	4	+cd "folder with spaces" \|\| exit
	5	+
	6	+"$IDRIS2_EXEC" --no-banner Main.idr < ../input
	7	+rm -rf build

tests/chez/reg001/expected+10−0

@@ -0,0 +1,10 @@
	1	+3
	2	+4.2
	3	+"1.2"
	4	+4
	5	+1
	6	+"2.7"
	7	+5.9
	8	+2
	9	+2
	10	+2

tests/chez/reg001/numbers.idr+21−0

@@ -0,0 +1,21 @@
	1	+-- the commented-out cases are still wrong,
	2	+-- but fixing them as well would make other tests fail for mysterious reasons
	3	+-- see https://github.com/edwinb/Idris2/pull/281
	4	+main : IO ()
	5	+main = do
	6	+ printLn $ 3
	7	+ printLn $ 4.2
	8	+ printLn $ "1.2"
	9	+
	10	+ printLn $ cast {to = Int} 4.8
	11	+ printLn $ cast {to = Integer} 1.2
	12	+ printLn $ cast {to = String} 2.7
	13	+
	14	+ -- printLn $ cast {to = Int} "1.2"
	15	+ -- printLn $ cast {to = Integer} "2.7"
	16	+ printLn $ cast {to = Double} "5.9"
	17	+
	18	+ printLn $ (the Int 6 `div` the Int 3)
	19	+ printLn $ (the Integer 6 `div` the Integer 3)
	20	+ printLn $ (cast {to = Int} "6.6" `div` cast "3.9")
	21	+ -- printLn $ (cast {to = Integer} "6.6" `div` cast "3.9")

tests/chez/reg001/run+3−0

@@ -0,0 +1,3 @@
	1	+$1 numbers.idr -x main
	2	+
	3	+rm -rf build

tests/ideMode/ideMode001/expected+1−1

@@ -8,7 +8,7 @@ · 7 unmodified lines
8	8	0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:192}_[] ?{_:191}_[])")))))) 1)
9	9	0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
10	10	0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:182}_[] ?{_:181}_[])")))))) 1)
11		−0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:172} : (Main.Vect n[0] a[1])) -> (({arg:173} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:630:1--637:1 n[2] m[4]) a[3])))")))))) 1)
	11	+0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:172} : (Main.Vect n[0] a[1])) -> (({arg:173} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:631:1--638:1 n[2] m[4]) a[3])))")))))) 1)
12	12	0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
13	13	0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
14	14	0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)

tests/ideMode/ideMode003/expected+1−1

@@ -8,7 +8,7 @@ · 7 unmodified lines
8	8	0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 7 18) (:end 7 21)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:192}_[] ?{_:191}_[])")))))) 1)
9	9	0000d8(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 16) (:end 7 1)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect m a)")))))) 1)
10	10	0000ed(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 6 11) (:end 6 14)) ((:name "ys") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "(Main.Vect ?{_:182}_[] ?{_:181}_[])")))))) 1)
11		−0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:172} : (Main.Vect n[0] a[1])) -> (({arg:173} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:630:1--637:1 n[2] m[4]) a[3])))")))))) 1)
	11	+0001ca(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 1) (:end 6 1)) ((:name "Main.append") (:namespace "") (:decor :bound) (:implicit :False) (:key "") (:doc-overview "") (:type "{0 m : Prelude.Nat} -> {0 a : Type} -> {0 n : Prelude.Nat} -> (({arg:172} : (Main.Vect n[0] a[1])) -> (({arg:173} : (Main.Vect m[3] a[2])) -> (Main.Vect (Prelude.+ Prelude.Nat Prelude.Num implementation at Prelude.idr:631:1--638:1 n[2] m[4]) a[3])))")))))) 1)
12	12	0000cb(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 47) (:end 6 1)) ((:name "a") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Type")))))) 1)
13	13	0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 44) (:end 5 45)) ((:name "m") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)
14	14	0000d3(:output (:ok (:highlight-source ((((:filename "LocType.idr") (:start 5 40) (:end 5 42)) ((:name "n") (:namespace "") (:decor :type) (:implicit :False) (:key "") (:doc-overview "") (:type "Prelude.Nat")))))) 1)

tests/idris2/basic037/Comments.idr+16−0

@@ -1,3 +1,11 @@
	1	+{-------------------------}
	2	+-- These should be
	3	+-- ignored
	4	+{- {---------------} -}
	5	+
	6	+-- Comments should have the right to be empty:
	7	+--
	8	+
1	9	-- This is a valid comment {-
2	10	-- It should not lead to a parse error if nested in a
3	11	-- multiline comment
@@ -21,3 +29,11 @@ myString = "Similarly, this is a valid string literal {- " · 17 unmodified lines
21	29	-- So we should be able to put it in a multiline comment
22	30
23	31	-}
	32	+
	33	+
	34	+{------------- Some people {---- like ---}
	35	+ {- comments with
	36	+ weird
	37	+ ----------}
	38	+ closing delimiters
	39	+ --}

tests/idris2/basic037/Issue279.idr+12−0

@@ -0,0 +1,12 @@
	1	+module Main
	2	+
	3	+{-- comment 1 --}
	4	+
	5	+someFunction : IO ()
	6	+
	7	+{-- comment 2 --}
	8	+
	9	+main : IO ()
	10	+main = do
	11	+ someFunction
	12	+ pure ()

tests/idris2/basic037/expected+2−0

@@ -1,2 +1,4 @@
1	1	1/1: Building Comments (Comments.idr)
2	2	Main> Bye for now!
	3	+1/1: Building Issue279 (Issue279.idr)
	4	+Main> Bye for now!

tests/idris2/basic037/run+1−0

@@ -1,3 +1,4 @@
1	1	echo ':q' \| $1 --no-banner --no-prelude Comments.idr
	2	+echo ':q' \| $1 --no-banner Issue279.idr
2	3
3	4	rm -rf build

tests/idris2/perf004/bigdpair.idr+30−0

@@ -0,0 +1,30 @@
	1	+import Data.Vect
	2	+
	3	+MkBig : Nat -> Type
	4	+MkBig Z = Int
	5	+MkBig (S k) = ((n ** Vect n Int), MkBig k)
	6	+
	7	+bigEx : (n : Nat) -> MkBig n
	8	+bigEx Z = 94
	9	+bigEx (S k) = ((2 ** [0,0]), bigEx k)
	10	+
	11	+data VWrap : Type -> Type where
	12	+ MkVWrap : (0 n : Nat) -> Vect n a -> VWrap a
	13	+
	14	+MkBig' : Nat -> Type
	15	+MkBig' Z = Int
	16	+MkBig' (S k) = (VWrap Int, MkBig' k)
	17	+
	18	+namespace Foo
	19	+ public
	20	+ export
	21	+ bigEx' : (n : Nat) -> MkBig' n
	22	+ bigEx' Z = 94
	23	+ bigEx' (S k) = (MkVWrap 1 [0], bigEx' k)
	24	+
	25	+eqBigs : bigEx 1000000 = bigEx 1000000
	26	+eqBigs = Refl
	27	+
	28	+eqBigs' : bigEx' 800000 = bigEx' 800000
	29	+eqBigs' = Refl
	30	+

tests/idris2/perf004/expected+1−0

@@ -0,0 +1 @@
	1	+1/1: Building bigdpair (bigdpair.idr)

tests/idris2/perf004/run+3−0

@@ -0,0 +1,3 @@
	1	+$1 --check bigdpair.idr
	2	+
	3	+rm -rf build

tests/idris2/record003/Record.idr+33−0

@@ -0,0 +1,33 @@
	1	+\|\|\| Test extended record syntax
	2	+data NotZero : Nat -> Type where
	3	+ Is : {n : Nat} -> NotZero (S n)
	4	+
	5	+record Positive (n : Nat) {auto 0 pos : NotZero n} where
	6	+ constructor Check
	7	+
	8	+a : Positive 1
	9	+a = Check
	10	+
	11	+b : Positive 2
	12	+b = Check
	13	+
	14	+{- Will not type-check
	15	+c : Positive 0
	16	+-}
	17	+
	18	+data KindOfString = ASCII \| UTF
	19	+
	20	+UTForASCII : KindOfString -> Type
	21	+UTForASCII UTF = String
	22	+UTForASCII ASCII = List Char --- Just to demonstrate
	23	+
	24	+record FlexiString { default UTF k : KindOfString} where
	25	+ constructor MkFlexiString
	26	+ val : UTForASCII k
	27	+
	28	+c : FlexiString
	29	+c = MkFlexiString "hello"
	30	+
	31	+d : FlexiString {k = ASCII}
	32	+d = MkFlexiString ['h', 'i']
	33	+

tests/idris2/record003/expected+1−0

@@ -0,0 +1 @@
	1	+1/1: Building Record (Record.idr)

tests/idris2/record003/run+3−0

@@ -0,0 +1,3 @@
	1	+$1 -c --no-banner Record.idr
	2	+
	3	+rm -rf build

tests/idris2/reg016/Using.idr+14−0

@@ -0,0 +1,14 @@
	1	+module Using
	2	+
	3	+interface MagmaT a where
	4	+ op: a -> a -> a
	5	+
	6	+interface MagmaT a => SemigroupT a where
	7	+ assoc: (x, y, z: a) -> (x `op` y) `op` z = x `op` (y `op` z)
	8	+
	9	+[NamedMagma] MagmaT Bool where
	10	+ False `op` False = False
	11	+ _ `op` _ = True
	12	+
	13	+[NamedSemigroup] SemigroupT Bool using NamedMagma where
	14	+ assoc = ?hole

tests/idris2/reg016/expected+1−0

@@ -0,0 +1 @@
	1	+1/1: Building Using (Using.idr)

tests/idris2/reg016/run+3−0

@@ -0,0 +1,3 @@
	1	+$1 Using.idr --check
	2	+
	3	+rm -rf build

tests/idris2/total006/expected+1−1

@@ -1,6 +1,6 @@
1	1	1/1: Building Total (Total.idr)
2	2	Main> Main.count is total
3		−Main> Main.badCount is possibly not terminating due to recursive path Main.badCount -> Prelude.Functor implementation at Prelude.idr:873:1--877:1 -> Prelude.map
	3	+Main> Main.badCount is possibly not terminating due to recursive path Main.badCount -> Prelude.Functor implementation at Prelude.idr:874:1--878:1 -> Prelude.map
4	4	Main> Main.process is total
5	5	Main> Main.badProcess is possibly not terminating due to recursive path Main.badProcess -> Main.badProcess -> Main.badProcess
6	6	Main> Main.doubleInt is total

tests/ttimp/record003/Record.yaff+35−0

@@ -0,0 +1,35 @@
	1	+data Nat : Type where
	2	+ Z : Nat
	3	+ S : Nat -> Nat
	4	+
	5	+data NotZero : Nat -> Type where
	6	+ Is : {n : Nat} -> NotZero (S n)
	7	+
	8	+record Positive (n : Nat) {auto 0 pos : NotZero n} where
	9	+ constructor Check
	10	+
	11	+a : Positive (S Z)
	12	+a = Check
	13	+
	14	+b : Positive (S (S Z))
	15	+b = Check
	16	+
	17	+
	18	+data KindOfString : Type where
	19	+ ASCII : KindOfString
	20	+ UTF : KindOfString
	21	+
	22	+UTForASCII : KindOfString -> Type
	23	+UTForASCII UTF = String
	24	+UTForASCII ASCII = Nat -- Just as demonstration
	25	+
	26	+record FlexiString { default UTF k : KindOfString} where
	27	+ constructor MkFlexiString
	28	+ val : UTForASCII k
	29	+
	30	+c : FlexiString
	31	+c = MkFlexiString "hello"
	32	+
	33	+d : FlexiString {k = ASCII}
	34	+d = MkFlexiString Z
	35	+

tests/ttimp/record003/expected+6−0

@@ -0,0 +1,6 @@
	1	+Processing as TTImp
	2	+Written TTC
	3	+Yaffle> Bye for now!
	4	+Processing as TTC
	5	+Read TTC
	6	+Yaffle> Bye for now!

tests/ttimp/record003/input+2−0

@@ -0,0 +1,2 @@
	1	+:q
	2	+

tests/ttimp/record003/run+4−0

@@ -0,0 +1,4 @@
	1	+$1 --yaffle Record.yaff < input
	2	+$1 --yaffle build/ttc/Record.ttc < input
	3	+
	4	+rm -rf build

Merge remote-tracking branch 'upstream'

Keyboard shortcuts

General

Issues and pull requests

Issues, pull requests and Inbox

Repository code