git.iko.soy/Idris-dev
on master help sign in
Merge upstream
865343dKyarigwo
.travis.yml+9−3
compare with master
unifiedsplit
@@ -35,6 +35,11 @@ matrix:
35 - env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"
35 - env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"
36 compiler: ": #GHC 8.0.1"
36 compiler: ": #GHC 8.0.1"
37 addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,cppcheck,hscolour], sources: [hvr-ghc]}}
37 addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,cppcheck,hscolour], sources: [hvr-ghc]}}
38+ allow_failures:
39+ - os: osx
40+ env: CABALVER="1.24" GHCVER="8.0.1" TESTS="test_c"
41+ compiler: ": #GHC 8.0.1"
42+ fast-finish: true
38
43
39cache:
44cache:
40 directories:
45 directories:
@@ -56,9 +61,8 @@ before_install:
56 - env
61 - env
57 - if [[ $TRAVIS_OS_NAME == 'osx' ]];
62 - if [[ $TRAVIS_OS_NAME == 'osx' ]];
58 then
63 then
59− brew update; brew install ghc; brew install cabal-install;
64+ brew outdated pkgconfig || brew install pkgconfig;
60− brew install libffi; brew install pkg-config; brew install cppcheck;
65+ brew install ghc cabal-install libffi cppcheck gnu-sed;
61− brew install gnu-sed;
62 export PATH=$HOME/.cabal/bin:$PATH;
66 export PATH=$HOME/.cabal/bin:$PATH;
63 export SED=gsed;
67 export SED=gsed;
64 export ZCAT=gzcat;
68 export ZCAT=gzcat;
@@ -66,6 +70,8 @@ before_install:
66 fi
70 fi
67
71
68install:
72install:
73+ - which cabal
74+ - which ghc
69 - cabal --version
75 - cabal --version
70 - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
76 - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
71 - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
77 - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
CHANGELOG.md+40−1
@@ -1,4 +1,42 @@
1−# New in 0.13:
1+# New in 0.99.1:
2+
3+## Language updates
4+
5+* Language pragmas now required for the less stable existing features, in
6+ addition to the existing `TypeProviders` and `ErrorReflection`:
7+ + `ElabReflection`, which must be enabled to use `%runElab`
8+ + `UniquenessTypes`, which must be enabled to use `UniqueType`
9+ + `DSLNotation`, which must be enabled to define a `dsl` block
10+ + `FirstClassReflection`, which must be enabled to define a `%reflection`
11+ function
12+
13+* New language extension `LinearTypes`:
14+ + This allows adding a /multiplicity/ to a binder which says how often it
15+ is allowed to be used; either 0 or 1 (if unstated, multiplicity is "many")
16+ + The typing rules follow Conor McBride's paper "I Got Plenty o' Nuttin'"
17+ + This is highly experimental, unfinished, not at all polished. and there
18+ are still lots of details to sort out. Some features don't quite work
19+ properly yet. But it is there to play with for the brave!
20+
21+## Tool Updates
22+
23++ Idris' output has been updated to more accurately reflect its
24+ progress through the compiler i.e. Type Checking; Totality Checking;
25+ IBC Generation; Compiling; and Code Generation. To control the
26+ loudness of the reporting three verbosity levels are introduced:
27+ `--V0`, `--V1`, and `--V2`. The old aliases of `-V` and `--verbose`
28+ persist.
29+
30+## Library Updates
31+
32++ Terminating programs has been improved with more appropriate
33+ functions (`exitWith`, `exitFailure`, and `exitSuccess`) and a data
34+ structure (`ExitCode`) to capture a program's return code.
35+
36++ Casting a `String` to an `Int`, `Integer` or a `Double` now ignores leading
37+ and trailing whitespace. Previously only leading whitespace was ignored.
38+
39+# New in 0.99:
2
40
3## Language updates
41## Language updates
4
42
@@ -62,6 +100,7 @@
62
100
63## Miscellaneous updates
101## Miscellaneous updates
64
102
103+* New, faster, better, implementation of the coverage checker
65* The test suite now uses [tasty-golden](https://hackage.haskell.org/package/tasty-golden). New tests must be registered in `test/TestData.hs`, as explained in the relevant `README.md`.
104* The test suite now uses [tasty-golden](https://hackage.haskell.org/package/tasty-golden). New tests must be registered in `test/TestData.hs`, as explained in the relevant `README.md`.
66* Added OSX and Windows continous integration with Travis and Appveyor.
105* Added OSX and Windows continous integration with Travis and Appveyor.
67
106
CONTRIBUTORS+200−40
@@ -1,56 +1,216 @@
1Thanks to the following for their help and contributions:
1Thanks to the following for their help and contributions:
2
2
3−Ozgur Akgun
3+a3gis
4+Aaron Craelius
5+Adam Sandberg Eriksson
6+Adam Schønemann
7+Adolfo Ochagavía
4Ahmad Salim Al-Sibahi
8Ahmad Salim Al-Sibahi
5−Edward Chadwick Amsden
9+Aistis Raulinaitis
6−Michael R. Bernstein
10+Alex Feldman-Crough
7−Jan Bessai
11+Alexander Berntsen
8−Nicola Botta
12+Alexander Shabalin
9−Edwin Brady
10−Vitaly Bragilevsky
11−Jakob Brünker
12Alyssa Carter
13Alyssa Carter
14+Andreas Bogk
15+Andreas Reuleaux
16+Andrei Dziahel
17+Andrew Cann
18+Andrew Stewart Gibson
19+Andy Morris
20+Anthony Cantor
21+Anthony---faineance
22+Apostolis Xekoukoulotakis
23+Athan Clark
24+Bartosz Przygoda
25+Ben Gamari
26+Ben Sherman
27+ben-schulz
28+Benjamin Hodgson
29+Benjamin Saunders
30+Björn Aili
31+bmastenbrook
32+Brent Yorgey
33+Brian Koropoff
34+Brian McKenna
35+Bryn Keller
36+Calvin Beck
37+Carsten König
13Carter Charbonneau
38Carter Charbonneau
39+Casper M. H. Holmgreen
40+cchantep
41+Cezar Ionescu
42+Chao-Hong Chen
43+Chetan Taralekar
44+Chris Allen
45+Christopher Schwaab
46+Cliff Harvey
47+Cliff L. Biffle
48+Colin Adams
49+comco
50+Craig McLaughlin
51+cswords
52+Daniel Waterworth
53+Daniël Heres
54+Darin Morrison
55+David Feuer
56+David Kraeutmann
14David Raymond Christiansen
57David Raymond Christiansen
15−Aaron Craelius
58+defanor
16−Jason Dagit
59+Dennis Griffith
17−Adam Sandberg Eriksson
60+Dirk Ullrich
18−Guglielmo Fachini
61+Dmitry Bushev
19−Simon Fowler
62+Dmitry Tsygankov
63+Dominic Mulligan
64+Dominik Peteler
65+Echo Nolan
66+Eduard Nicodei
67+Edward Amsden
68+Edward O'Callaghan
69+Edwin Brady
70+Eric Casteleijn
71+Eric Mertens
72+Eric Walkingshaw
73+Eric Weinstein
74+Erkin Batu Altunbaş
75+Ertugrul Söylemez
76+EvanR
77+Fabian Thorand
78+fiendfan1
79+Franklin Chen
80+Frederic Koehler
81+Friedrich von Never
82+Gabe McArthur
83+Gabor Greif
84+Gabriel Garcia
85+George Leontiev
86+Gleb Alexeyev
20Google
87Google
21−Zack Grannan
88+Greg Anderson
22−Sean Hunt
89+Greg Pfeil
23−Cezar Ionescu
90+Guglielmo Fachini
91+Hannes Mehnert
24Heath Johns
92Heath Johns
93+Heather
94+Hector A. Escobedo IV
95+identical snowflake
96+Ignas Vyšniauskas
97+Ilan Godik
98+Imuli
25Irene Knapp
99Irene Knapp
26−Paul Koerbitz
100+Jack Henahan
27−Niklas Larsson
101+Jacob Mitchell
28−Shea Levy
102+Jakob Brünker
103+Jan Bessai
104+Jan de Muijnck-Hughes
105+Jan Doms
106+Jan Stolarek
107+Jason Dagit
108+Jason Gross
109+Jean-Remi Desjardins
110+Jeff Hemphill
111+Jefferson Carpenter
112+Jens Petersen
113+Jeremy W. Sherman
114+jhegedus42
115+joe9
116+Johannes Griebler
117+John Connor
118+John Dobronszki
119+John Wiegley
120+Jon Atack
121+Jonas Westerlund
122+Jonathan Sterling
123+Joseph Huang
124+Josh Vera
125+JP Smith
126+Juliusz Chroboczek
127+Jurriën Stutterheim
128+Jürgen Peters
129+Karlos Kaeeikaas
130+Kester Tong
131+lambdadomain
132+Langston Barrett
133+Leif Warner
134+Leon Schoorl
135+Luke Palmer
136+Mark Farrell
137+Markus Klink
138+Markus Pfeiffer
29Mathnerd314
139Mathnerd314
30−Hannes Mehnert
140+Mattias Lundell
141+Matvey B. Aksenov
142+Matúš Tejiščák
143+Maxim Ivanov
31Mekeor Melire
144Mekeor Melire
32Melissa Mozifian
145Melissa Mozifian
33−Jan de Muijnck-Hughes
146+Melvar Chen
34−Dominic Mulligan
147+Michael A. Smith
35−Echo Nolan
148+Michael Bernstein
36−Tom Prince
149+Michael Gilliland
37−raichoo
150+Michael Hensler
151+Michael Maloney
152+Michael McGirr
153+Michael Thompson
154+Michael Weiss
155+Miikka Koskinen
156+Mitchell Rosen
157+Miëtek Bak
158+Mort Yao
159+Nathan Dinsmore
160+Nicola Botta
161+Niklas Larsson
162+Norbert Melzer
163+Oskar Wickström
164+Ozgur Akgun
165+Patrik Jansson
166+Paul Koerbitz
167+Per Fredelius
168+Peter Minten
38Philip Rasmussen
169Philip Rasmussen
39−Aistis Raulinaitis
170+PoroCYon
171+raichoo
40Reynir Reynisson
172Reynir Reynisson
173+Ricky Elrod
174+Robert Clipsham
175+Robert Edström
176+Ross Meikleham
177+Ryan Scott
178+Sam Elliott
179+Sam T
180+Saurabh Rawat
181+Sean Hunt
182+Sebastian de Bellefon
183+Sebastian Dröge
41Seo Sanghyeon
184Seo Sanghyeon
42−Benjamin Saunders
185+Sergei Trofimovich
43−Alexander Shabalin
186+Shane Pearman
44−Jeremy W. Sherman
187+Shea Levy
45−Timo Petteri Sinnemäki
188+Simon Fowler
46−JP Smith
47startling
189startling
48−Chetan T
190+Stefan Bleibinhaus
49−Matúš Tejiščák
191+stepcut
50−Dirk Ullrich
192+Stephen Drodge
51−Leif Warner
193+Steven Shaw
52−Daniel Waterworth
194+Stuart Gale
53−Eric Weinstein
195+suhorng
54−Jonas Westerlund
196+Sune Alkærsig
55−Björn Aili
197+Sven Koschnicke
198+tdidriksen
199+Tenor Biel
200+Thomas Cooper
201+Tim Dysinger
202+Tim McGilchrist
203+Timo Petteri Sinnemäki
204+Tom Prince
205+TorosFanny
206+Trevor Elliott
207+uwap
208+Vitaly Bragilevsky
209+Vyacheslav Shebanov
210+xged
211+XIE Yuheng
212+Yacine Hmito
213+Zack Grannan
56−Zheng Jihui
214+Zheng Jihui
215+zjhmale
216+Сухарик
docs/conf.py+3−3
@@ -33,7 +33,7 @@ on_rtd = os.environ.get('READTHEDOCS', None) == 'True'
33# ones.
33# ones.
34extensions = [
34extensions = [
35 'sphinx.ext.todo',
35 'sphinx.ext.todo',
36− 'sphinx.ext.pngmath',
36+ 'sphinx.ext.pngmath', # imgmath is not supported on readthedocs.
37 'sphinx.ext.ifconfig',
37 'sphinx.ext.ifconfig',
38]
38]
39
39
@@ -59,9 +59,9 @@ author = u'The Idris Community'
59# built documents.
59# built documents.
60#
60#
61# The short X.Y version.
61# The short X.Y version.
62−version = '0.12.3'
62+version = '0.99'
63# The full version, including alpha/beta/rc tags.
63# The full version, including alpha/beta/rc tags.
64−release = '0.12.3'
64+release = '0.99'
65
65
66# The language for content autogenerated by Sphinx. Refer to documentation
66# The language for content autogenerated by Sphinx. Refer to documentation
67# for a list of supported languages.
67# for a list of supported languages.
docs/listing/idris-prompt-helloworld.txt+1−1
@@ -1,7 +1,7 @@
1$ idris hello.idr
1$ idris hello.idr
2 ____ __ _
2 ____ __ _
3 / _/___/ /____(_)____
3 / _/___/ /____(_)____
4− / // __ / ___/ / ___/ Version 0.12.3
4+ / // __ / ___/ / ___/ Version 0.99
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
6 /___/\__,_/_/ /_/____/ Type :? for help
6 /___/\__,_/_/ /_/____/ Type :? for help
7
7
docs/listing/idris-prompt-interp.txt+1−1
@@ -1,7 +1,7 @@
1$ idris interp.idr
1$ idris interp.idr
2 ____ __ _
2 ____ __ _
3 / _/___/ /____(_)____
3 / _/___/ /____(_)____
4− / // __ / ___/ / ___/ Version 0.12.3
4+ / // __ / ___/ / ___/ Version 0.99
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
6 /___/\__,_/_/ /_/____/ Type :? for help
6 /___/\__,_/_/ /_/____/ Type :? for help
7
7
docs/listing/idris-prompt-start.txt+1−1
@@ -1,7 +1,7 @@
1$ idris
1$ idris
2 ____ __ _
2 ____ __ _
3 / _/___/ /____(_)____
3 / _/___/ /____(_)____
4− / // __ / ___/ / ___/ Version 0.12.3
4+ / // __ / ___/ / ___/ Version 0.99
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
5 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
6/___/\__,_/_/ /_/____/ Type :? for help
6/___/\__,_/_/ /_/____/ Type :? for help
7
7
docs/reference/compilation.rst+23−7
@@ -1,6 +1,6 @@
1−***********************
1+************************************
2−Compilation and Logging
2+Compilation, Logging, and Reporting
3−***********************
3+************************************
4
4
5This section provides information about the Idris compilation process, and
5This section provides information about the Idris compilation process, and
6provides details over how you can follow the process through logging.
6provides details over how you can follow the process through logging.
@@ -41,11 +41,27 @@ With Idris you can ask it to terminate the compilation process after type checki
41
41
42Use of this option will still result in the generation of the Idris binary ``.ibc`` files, and is suitable if you do not wish to generate code from one of the supported backends.
42Use of this option will still result in the generation of the Idris binary ``.ibc`` files, and is suitable if you do not wish to generate code from one of the supported backends.
43
43
44−Logging Output
44+Reporting Compilation Process
45−==============
45+=============================
46
46
47+During compilation the reporting of Idris' progress can be controlled
48+by setting a verbosity level.
49+
50++ ``-V``, or alternatively ``--verbose`` and ``--V0``, will report which file Idris is currently type checking.
51++ ``--V1`` will additionally report: Parsing, IBC Generation, and Code
52+ Generation.
53++ ``--V2`` will additionally report: Totality Checking, Universe
54+ Checking, and the individual steps prior to code generation.
55+
56+
57+By default Idris' progress reporting is set to quiet-``-q``, or ``--quiet``.
58+
59+Logging Internal Operation
60+===========================
61+
62+For those that develop on the Idris compiler, the internal operation
47−The internal operation of Idris is captured using a category based logger.
63+of Idris is captured using a category based logger. Currently, the
48−Currently, the logging infrastructure has support for the following categories:
64+logging infrastructure has support for the following categories:
49
65
50+ Parser
66+ Parser
51+ Elaborator
67+ Elaborator
docs/reference/documenting.rst+8−1
@@ -61,7 +61,14 @@ italics correctly). A comprehensive set of examples is given below.
61 ||| Add some numbers.
61 ||| Add some numbers.
62 |||
62 |||
63 ||| Addition is really great. This paragraph is not part of the overview.
63 ||| Addition is really great. This paragraph is not part of the overview.
64− ||| Still the same paragraph. Lists are also nifty:
64+ ||| Still the same paragraph.
65+ |||
66+ ||| You can even provide examples which are inlined in the documentation:
67+ ||| ```idris example
68+ ||| add 4 5
69+ ||| ```
70+ |||
71+ ||| Lists are also nifty:
65 ||| * Really nifty!
72 ||| * Really nifty!
66 ||| * Yep!
73 ||| * Yep!
67 ||| * The name `add` is a **bold** choice
74 ||| * The name `add` is a **bold** choice
docs/reference/misc.rst+1−1
@@ -273,7 +273,7 @@ That is, ``{x}`` behaves like ``{x=x}``.
273
273
274
274
275Existence of an implementation
275Existence of an implementation
276−========================
276+==============================
277
277
278In order to show that an implementation of some interface is defined for some
278In order to show that an implementation of some interface is defined for some
279type, one could use the ``%implementation`` keyword:
279type, one could use the ``%implementation`` keyword:
docs/reference/packages.rst+8−1
@@ -97,7 +97,7 @@ external ``C`` libraries, the following options are available:
97 which must be present for the package to be usable.
97 which must be present for the package to be usable.
98
98
99+ ``objs = <objs>``, which takes a comma separated list of additional
99+ ``objs = <objs>``, which takes a comma separated list of additional
100− files to be installed (object files, headers), perhaps generated
100+ files to be installed (object files, headers), perhaps generated
101 by the ``Makefile``.
101 by the ``Makefile``.
102
102
103Testing
103Testing
@@ -112,6 +112,11 @@ The following option is available:
112.. IMPORTANT::
112.. IMPORTANT::
113 The modules containing the test functions must also be added to the list of modules.
113 The modules containing the test functions must also be added to the list of modules.
114
114
115+Comments
116+---------
117+
118+Package files support comments using the standard Idris singleline ``--`` and multiline ``{- -}`` format.
119+
115Using Package files
120Using Package files
116===================
121===================
117
122
@@ -127,6 +132,8 @@ Given an Idris package file ``text.ipkg`` it can be used with the Idris compiler
127
132
128+ ``idris --mkdoc test.ipkg`` will build HTML documentation for your package in the folder ``test_doc`` in your project's root directory.
133+ ``idris --mkdoc test.ipkg`` will build HTML documentation for your package in the folder ``test_doc`` in your project's root directory.
129
134
135++ ``idris --installdoc test.ipkg`` will install the packages documentation into Idris' central documentation folder located at ``idris --docdir``.
136+
130+ ``idris --checkpkg test.ipkg`` will type check all modules in the package only. This differs from build that type checks **and** generates code.
137+ ``idris --checkpkg test.ipkg`` will type check all modules in the package only. This differs from build that type checks **and** generates code.
131
138
132+ ``idris --testpkg test.ipkg`` will compile and run any embedded tests you have specified in the ``tests`` parameter.
139+ ``idris --testpkg test.ipkg`` will compile and run any embedded tests you have specified in the ``tests`` parameter.
docs/tutorial/index.rst−1
@@ -24,7 +24,6 @@ This is the Idris Tutorial. It will teach you about programming in the Idris Lan
24 interfaces
24 interfaces
25 modules
25 modules
26 packages
26 packages
27− testing
28 interp
27 interp
29 views
28 views
30 theorems
29 theorems
docs/tutorial/packages.rst+101−15
@@ -31,14 +31,18 @@ package file would be::
31
31
32
32
33Other examples of package files can be found in the ``libs`` directory
33Other examples of package files can be found in the ``libs`` directory
34−of the main Idris repository, and in `third-party libraries <https://github.com/idris-lang/Idris-dev/wiki/Libraries>`_.
34+of the main Idris repository, and in `third-party libraries
35−More details including a complete listing of available fields can be found in :ref:`ref-sect-packages`.
35+<https://github.com/idris-lang/Idris-dev/wiki/Libraries>`_.
36
36
37
37
38Using Package files
38Using Package files
39===================
39===================
40
40
41−Given an Idris package file ``maths.ipkg`` it can be used with the Idris compiler as follows:
41+
42+Idris itself is aware about packages, and special commands are
43+available to help with, for example, building packages, installing
44+packages, and cleaning packages. For instance, given the ``maths``
45+package from earlier we can use Idris as follows:
42
46
43+ ``idris --build maths.ipkg`` will build all modules in the package
47+ ``idris --build maths.ipkg`` will build all modules in the package
44
48
@@ -48,20 +52,102 @@ Given an Idris package file ``maths.ipkg`` it can be used with the Idris compile
48+ ``idris --clean maths.ipkg`` will delete all intermediate code and
52+ ``idris --clean maths.ipkg`` will delete all intermediate code and
49 executable files generated when building.
53 executable files generated when building.
50
54
51−+ ``idris --mkdoc maths.ipkg`` will build HTML documentation for your
52− package in the folder ``maths_doc`` in your project's root
53− directory.
54−
55−+ ``idris --checkpkg maths.ipkg`` will type check all modules in the
56− package only. This differs from build that type checks **and**
57− generates code.
58−
59−+ ``idris --testpkg maths.ipkg`` will compile and run any embedded
60− tests you have specified in the ``tests`` parameter. More
61− information about testing is given in the next section.
62−
63Once the maths package has been installed, the command line option
55Once the maths package has been installed, the command line option
64``--package maths`` makes it accessible (abbreviated to ``-p maths``).
56``--package maths`` makes it accessible (abbreviated to ``-p maths``).
65For example::
57For example::
66
58
67 idris -p maths Main.idr
59 idris -p maths Main.idr
60+
61+
62+Testing Idris Packages
63+======================
64+
65+The integrated build system includes a simple testing framework.
66+This framework collects functions listed in the ``ipkg`` file under ``tests``.
67+All test functions must return ``IO ()``.
68+
69+
70+When you enter ``idris --testpkg yourmodule.ipkg``,
71+the build system creates a temporary file in a fresh environment on your machine
72+by listing the ``tests`` functions under a single ``main`` function.
73+It compiles this temporary file to an executable and then executes it.
74+
75+
76+The tests themselves are responsible for reporting their success or failure.
77+Test functions commonly use ``putStrLn`` to report test results.
78+The test framework does not impose any standards for reporting and consequently
79+does not aggregate test results.
80+
81+
82+For example, lets take the following list of functions that are defined in a module called ``NumOps`` for a sample package ``maths``.
83+
84+.. name: Math/NumOps.idr
85+.. code-block:: idris
86+
87+ module Maths.NumOps
88+
89+ %access export -- to make functions under test visible
90+
91+ double : Num a => a -> a
92+ double a = a + a
93+
94+ triple : Num a => a -> a
95+ triple a = a + double a
96+
97+A simple test module, with a qualified name of ``Test.NumOps`` can be declared as
98+
99+.. name: Math/TestOps.idr
100+.. code-block:: idris
101+
102+ module Test.NumOps
103+
104+ import Maths.NumOps
105+
106+ %access export -- to make the test functions visible
107+
108+ assertEq : Eq a => (given : a) -> (expected : a) -> IO ()
109+ assertEq g e = if g == e
110+ then putStrLn "Test Passed"
111+ else putStrLn "Test Failed"
112+
113+ assertNotEq : Eq a => (given : a) -> (expected : a) -> IO ()
114+ assertNotEq g e = if not (g == e)
115+ then putStrLn "Test Passed"
116+ else putStrLn "Test Failed"
117+
118+ testDouble : IO ()
119+ testDouble = assertEq (double 2) 4
120+
121+ testTriple : IO ()
122+ testTriple = assertNotEq (triple 2) 5
123+
124+
125+The functions ``assertEq`` and ``assertNotEq`` are used to run expected passing, and failing, equality tests.
126+The actual tests are ``testDouble`` and ``testTriple``, and are declared in the ``maths.ipkg`` file as follows::
127+
128+ package maths
129+
130+ modules = Maths.NumOps
131+ , Test.NumOps
132+
133+ tests = Test.NumOps.testDouble
134+ , Test.NumOps.testTriple
135+
136+
137+The testing framework can then be invoked using ``idris --testpkg maths.ipkg``::
138+
139+ > idris --testpkg maths.ipkg
140+ Type checking ./Maths/NumOps.idr
141+ Type checking ./Test/NumOps.idr
142+ Type checking /var/folders/63/np5g0d5j54x1s0z12rf41wxm0000gp/T/idristests144128232716531729.idr
143+ Test Passed
144+ Test Passed
145+
146+Note how both tests have reported success by printing ``Test Passed``
147+as we arranged for with the ``assertEq`` and ``assertNoEq`` functions.
148+
149+More information
150+================
151+
152+More details, including a complete listing of available fields, can be
153+found in the reference manual in :ref:`ref-sect-packages`.
docs/tutorial/syntax.rst+1−1
@@ -92,7 +92,7 @@ forms. For example, a ``for`` loop binds a variable on each iteration:
92
92
93.. code-block:: idris
93.. code-block:: idris
94
94
95− syntax for {x} in [xs] ":" [body] = forLoop xs (\x => body)
95+ syntax for {x} "in" [xs] ":" [body] = forLoop xs (\x => body)
96
96
97 main : IO ()
97 main : IO ()
98 main = do for x in [1..10]:
98 main = do for x in [1..10]:
docs/tutorial/testing.rstdeleted−85
@@ -1,85 +0,0 @@
1−.. _tut-sect-testing:
2−
3−**********************
4−Testing Idris Packages
5−**********************
6−
7−The integrated build system includes a simple testing framework.
8−This framework collects functions listed in the ``ipkg`` file under ``tests``.
9−All test functions must return ``IO ()``.
10−
11−
12−When you enter ``idris --testpkg yourmodule.ipkg``,
13−the build system creates a temporary file in a fresh environment on your machine
14−by listing the ``tests`` functions under a single ``main`` function.
15−It compiles this temporary file to an executable and then executes it.
16−
17−
18−The tests themselves are responsible for reporting their success or failure.
19−Test functions commonly use ``putStrLn`` to report test results.
20−The test framework does not impose any standards for reporting and consequently
21−does not aggregate test results.
22−
23−
24−For example, lets take the following list of functions that are defined in a module called ``NumOps`` for a sample package ``maths``.
25−
26−.. name: Math/NumOps.idr
27−.. code-block:: idris
28−
29− module Maths.NumOps
30−
31− double : Num a => a -> a
32− double a = a + a
33−
34− triple : Num a => a -> a
35− triple a = a + double a
36−
37−A simple test module, with a qualified name of ``Test.NumOps`` can be declared as
38−
39−.. name: Math/TestOps.idr
40−.. code-block:: idris
41−
42− module Test.NumOps
43−
44− import Maths.NumOps
45−
46− assertEq : Eq a => (given : a) -> (expected : a) -> IO ()
47− assertEq g e = if g == e
48− then putStrLn "Test Passed"
49− else putStrLn "Test Failed"
50−
51− assertNotEq : Eq a => (given : a) -> (expected : a) -> IO ()
52− assertNotEq g e = if not (g == e)
53− then putStrLn "Test Passed"
54− else putStrLn "Test Failed"
55−
56− testDouble : IO ()
57− testDouble = assertEq (double 2) 4
58−
59− testTriple : IO ()
60− testTriple = assertNotEq (triple 2) 5
61−
62−
63−The functions ``assertEq`` and ``assertNotEq`` are used to run expected passing, and failing, equality tests.
64−The actual tests are ``testDouble`` and ``testTriple``, and are declared in the ``maths.ipkg`` file as follows::
65−
66− package maths
67−
68− modules = Maths.NumOps
69− , Test.NumOps
70−
71− tests = Test.NumOps.testDouble
72− , Test.NumOps.testTriple
73−
74−
75−The testing framework can then be invoked using ``idris --testpkg maths.ipkg``::
76−
77− > idris --testpkg maths.ipkg
78− Type checking ./Maths/NumOps.idr
79− Type checking ./Test/NumOps.idr
80− Type checking /var/folders/63/np5g0d5j54x1s0z12rf41wxm0000gp/T/idristests144128232716531729.idr
81− Test Passed
82− Test Passed
83−
84−Note how both tests have reported success by printing ``Test Passed``
85−as we arranged for with the ``assertEq`` and ``assertNoEq`` functions.
idris.cabal+9−2
@@ -1,5 +1,5 @@
1Name: idris
1Name: idris
2−Version: 0.12.3
2+Version: 0.99
3License: BSD3
3License: BSD3
4License-file: LICENSE
4License-file: LICENSE
5Author: Edwin Brady
5Author: Edwin Brady
@@ -289,7 +289,6 @@ Library
289 , vector < 0.12
289 , vector < 0.12
290 , vector-binary-instances < 0.3
290 , vector-binary-instances < 0.3
291 , zip-archive > 0.2.3.5 && < 0.4
291 , zip-archive > 0.2.3.5 && < 0.4
292− , safe == 0.3.9
293 , fsnotify >= 0.2 && < 2.2
292 , fsnotify >= 0.2 && < 2.2
294 , async < 2.2
293 , async < 2.2
295
294
@@ -302,6 +301,14 @@ Library
302 else
301 else
303 build-depends: process < 1.5
302 build-depends: process < 1.5
304
303
304+ -- safe 0.3.10 is having issues with cabal 1.20 and ghc 7.6.3, the
305+ -- hvr ghc ppa doesn't provide a new enough cabal library. Temporary
306+ -- fix until hvr ghc ppa is fixed or we deprecate support for 7.6.3.
307+ if impl(ghc < 7.8.4)
308+ build-depends: safe == 0.3.9
309+ else
310+ build-depends: safe >= 0.3.9
311+
305 Extensions: MultiParamTypeClasses
312 Extensions: MultiParamTypeClasses
306 , DeriveFoldable
313 , DeriveFoldable
307 , DeriveTraversable
314 , DeriveTraversable
libs/base/Control/Isomorphism.idr+5
@@ -2,6 +2,7 @@ module Control.Isomorphism
2
2
3import Syntax.PreorderReasoning
3import Syntax.PreorderReasoning
4import Data.Fin
4import Data.Fin
5+import Control.Category
5
6
6%default total
7%default total
7%access public export
8%access public export
@@ -32,6 +33,10 @@ isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') =
32 (from (to x)) ={ fromTo x }=
33 (from (to x)) ={ fromTo x }=
33 x QED)
34 x QED)
34
35
36+Category Iso where
37+ id = isoRefl
38+ (.) = flip isoTrans
39+
35||| Isomorphism is symmetric
40||| Isomorphism is symmetric
36isoSym : Iso a b -> Iso b a
41isoSym : Iso a b -> Iso b a
37isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom
42isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom
libs/base/Data/Complex.idr+11−3
@@ -63,15 +63,23 @@ conjugate (r:+i) = (r :+ (0-i))
63implementation Functor Complex where
63implementation Functor Complex where
64 map f (r :+ i) = f r :+ f i
64 map f (r :+ i) = f r :+ f i
65
65
66−-- We can't do "implementation Num a => Num (Complex a)" because
66+-- We can do "implementation Neg a => Num (Complex a)" because
67−-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double
67+-- we don't need "abs", only (-)
68−implementation Num (Complex Double) where
68+implementation Neg a => Num (Complex a) where
69 (+) (a:+b) (c:+d) = ((a+c):+(b+d))
69 (+) (a:+b) (c:+d) = ((a+c):+(b+d))
70 (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))
70 (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))
71 fromInteger x = (fromInteger x:+0)
71 fromInteger x = (fromInteger x:+0)
72
72
73+-- We can't do "implementation Neg a => Neg (Complex a)" because
74+-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double
73implementation Neg (Complex Double) where
75implementation Neg (Complex Double) where
74 negate = map negate
76 negate = map negate
75 (-) (a:+b) (c:+d) = ((a-c):+(b-d))
77 (-) (a:+b) (c:+d) = ((a-c):+(b-d))
76 abs (a:+b) = (magnitude (a:+b):+0)
78 abs (a:+b) = (magnitude (a:+b):+0)
77
79
80+-- As soon as abs moves out of Neg (issue #3500), the following would become a
81+-- valid instance:
82+
83+-- implementation Neg a => Neg (Complex a) where
84+-- negate = map negate
85+-- (-) (a:+b) (c:+d) = ((a-c):+(b-d))
libs/base/Data/List/Views.idr+1−3
@@ -187,7 +187,7 @@ public export
187data VList : List a -> Type where
187data VList : List a -> Type where
188 VNil : VList []
188 VNil : VList []
189 VOne : VList [x]
189 VOne : VList [x]
190− VCons : {x : a} -> {y : a} -> {xs : List a} ->
190+ VCons : {x : a} -> {y : a} -> .{xs : List a} ->
191 (rec : VList xs) -> VList (x :: xs ++ [y])
191 (rec : VList xs) -> VList (x :: xs ++ [y])
192
192
193total
193total
@@ -225,5 +225,3 @@ vList xs with (splitBalanced xs)
225 vList (ys ++ zs) | (MkSplitBal prf)
225 vList (ys ++ zs) | (MkSplitBal prf)
226 = toVList ys (snocList zs) prf
226 = toVList ys (snocList zs) prf
227
227
228−
229−
libs/base/Data/String/Views.idr+2
@@ -1,5 +1,7 @@
1module Data.String.Views
1module Data.String.Views
2
2
3+%access public export
4+
3||| View for traversing a String one character at a time
5||| View for traversing a String one character at a time
4data StrList : String -> Type where
6data StrList : String -> Type where
5 SNil : StrList ""
7 SNil : StrList ""
libs/base/Debug/Error.idr+3−6
@@ -12,9 +12,6 @@ error : {default (%runElab sourceLocation) loc : SourceLocation} ->
12 (message : String) ->
12 (message : String) ->
13 a
13 a
14error {loc = FileLoc filename (line, col) _} message =
14error {loc = FileLoc filename (line, col) _} message =
15− believe_me . unsafePerformIO $
16− do let place = filename ++ " line " ++ show line ++ " column " ++ show col
15+ let place = filename ++ " line " ++ show line ++ " column " ++ show col
17− let message' = place ++ ": " ++ message
16+ message' = place ++ ": " ++ message in
18− putStrLn message'
17+ idris_crash message'
19− exit 1
20−
libs/base/System.idr+35−4
@@ -1,5 +1,7 @@
1module System
1module System
2
2
3+import Data.So
4+
3%include C "unistd.h"
5%include C "unistd.h"
4%default partial
6%default partial
5%access public export
7%access public export
@@ -52,11 +54,41 @@ getEnvironment = getAllPairs 0 []
52 then pure $ reverse $ map splitEq acc
54 then pure $ reverse $ map splitEq acc
53 else getAllPairs (n + 1) (envPair :: acc)
55 else getAllPairs (n + 1) (envPair :: acc)
54
56
57+||| Programs can either terminate successfully, or end in a caught
58+||| failure.
59+data ExitCode : Type where
60+ ||| Terminate successfully.
61+ ExitSuccess : ExitCode
62+ ||| Program terminated for some prescribed reason.
63+ |||
64+ ||| @errNo A non-zero numerical value indicating failure.
65+ ||| @prf Proof that the int value is non-zero.
66+ ExitFailure : (errNo : Int)
67+ -> {auto prf : So (not $ errNo == 0)}
68+ -> ExitCode
69+
55||| Quit with a particular exit code
70||| Quit with a particular exit code
56−exit : Int -> IO ()
71+exit : Int -> IO a
57−exit code = foreign FFI_C "exit" (Int -> IO ()) code
72+exit code = believe_me $ foreign FFI_C "exit" (Int -> IO ()) code
73+
74+||| Terminate the program with an `ExitCode`. This code indicates the
75+||| success of the program's execution, and returns the success code
76+||| to the program's caller.
77+|||
78+||| @code The `ExitCode` for program.
79+exitWith : (code : ExitCode) -> IO a
80+exitWith ExitSuccess = exit 0
81+exitWith (ExitFailure errNo) = exit errNo
58
82
83+||| Exit the program indicating failure.
84+exitFailure : IO a
85+exitFailure = exitWith (ExitFailure 1)
86+
87+||| Exit the program after a successful run.
88+exitSuccess : IO a
89+exitSuccess = exitWith ExitSuccess
90+
59−||| Get the numbers of seconds since 1st January 1970, 00:00 UTC
91+||| Get the numbers of seconds since 1st January 1970, 00:00 UTC
60time : IO Integer
92time : IO Integer
61time = do MkRaw t <- foreign FFI_C "idris_time" (IO (Raw Integer))
93time = do MkRaw t <- foreign FFI_C "idris_time" (IO (Raw Integer))
62 pure t
94 pure t
@@ -66,4 +98,3 @@ usleep i = foreign FFI_C "usleep" (Int -> IO ()) i
66
98
67system : String -> IO Int
99system : String -> IO Int
68system cmd = foreign FFI_C "system" (String -> IO Int) cmd
100system cmd = foreign FFI_C "system" (String -> IO Int) cmd
69−
libs/contrib/CFFI/Types.idr+3−1
@@ -126,13 +126,15 @@ offsetsPacked xs = offsets' xs [] 0
126 offsets' [] acc _ = reverse acc
126 offsets' [] acc _ = reverse acc
127 offsets' (x::xs) acc pos = offsets' xs (pos::acc) (sizeOf x)
127 offsets' (x::xs) acc pos = offsets' xs (pos::acc) (sizeOf x)
128
128
129+%language ElabReflection -- needed for 'error', which finds a line number
130+
129private
131private
130indexOrFail : Nat -> List a -> a
132indexOrFail : Nat -> List a -> a
131indexOrFail i xs = case index' i xs of
133indexOrFail i xs = case index' i xs of
132 Just x => x
134 Just x => x
133 Nothing => error "Out of bounds access"
135 Nothing => error "Out of bounds access"
134
136
135−||| The offset of a firld in a composite type
137+||| The offset of a field in a composite type
136export
138export
137offset : Composite -> Nat -> Int
139offset : Composite -> Nat -> Int
138offset (STRUCT xs) i = indexOrFail i (offsetsStruct xs)
140offset (STRUCT xs) i = indexOrFail i (offsetsStruct xs)
libs/effects/Effect/Exception.idr+1−2
@@ -17,7 +17,7 @@ implementation Handler (Exception a) List where
17
17
18implementation Show a => Handler (Exception a) IO where
18implementation Show a => Handler (Exception a) IO where
19 handle _ (Raise e) k = do printLn e
19 handle _ (Raise e) k = do printLn e
20− believe_me (exit 1)
20+ (exit 1)
21
21
22implementation Handler (Exception a) (IOExcept a) where
22implementation Handler (Exception a) (IOExcept a) where
23 handle _ (Raise e) k = ioe_fail e
23 handle _ (Raise e) k = ioe_fail e
@@ -30,4 +30,3 @@ EXCEPTION t = MkEff () (Exception t)
30
30
31raise : a -> Eff b [EXCEPTION a]
31raise : a -> Eff b [EXCEPTION a]
32raise err = call $ Raise err
32raise err = call $ Raise err
33−
libs/prelude/Builtins.idr+7
@@ -2,6 +2,7 @@
2
2
3%access public export
3%access public export
4%default total
4%default total
5+%language UniquenessTypes
5
6
6||| The canonical single-element type, also known as the trivially
7||| The canonical single-element type, also known as the trivially
7||| true proposition.
8||| true proposition.
@@ -177,6 +178,12 @@ assert_total x = x
177assert_unreachable : a
178assert_unreachable : a
178-- compiled as primitive
179-- compiled as primitive
179
180
181+||| Abort immediately with an error message
182+idris_crash : (msg : String) -> a
183+-- compiled as primitive
184+
185+%used idris_crash msg
186+
180||| Subvert the type checker. This function is abstract, so it will not reduce in
187||| Subvert the type checker. This function is abstract, so it will not reduce in
181||| the type checker. Use it with care - it can result in segfaults or worse!
188||| the type checker. Use it with care - it can result in segfaults or worse!
182export
189export
libs/prelude/Prelude.idr+11−3
@@ -37,6 +37,8 @@ import public Language.Reflection.Errors
37%access public export
37%access public export
38%default total
38%default total
39
39
40+%language ElabReflection
41+
40-- Things that can't be elsewhere for import cycle reasons
42-- Things that can't be elsewhere for import cycle reasons
41-- See comment after declaration of void in Builtins.idr
43-- See comment after declaration of void in Builtins.idr
42-- for explanation of this definition's location
44-- for explanation of this definition's location
@@ -144,9 +146,14 @@ natRange n = List.reverse (go n)
144 where go Z = []
146 where go Z = []
145 go (S n) = n :: go n
147 go (S n) = n :: go n
146
148
149+
147-- predefine Nat versions of Enum, so we can use them in the default impls
150-- predefine Nat versions of Enum, so we can use them in the default impls
151+countFrom : Num n => n -> n -> Stream n
152+countFrom start diff = start :: countFrom (start + diff) diff
153+
148total natEnumFromThen : Nat -> Nat -> Stream Nat
154total natEnumFromThen : Nat -> Nat -> Stream Nat
149−natEnumFromThen n next = n :: natEnumFromThen next (minus next n)
155+natEnumFromThen n next = countFrom n (minus next n)
156+
150total natEnumFromTo : Nat -> Nat -> List Nat
157total natEnumFromTo : Nat -> Nat -> List Nat
151natEnumFromTo n m = if n <= m
158natEnumFromTo n m = if n <= m
152 then go n m
159 then go n m
@@ -195,7 +202,7 @@ Enum Integer where
195 succ n = n + 1
202 succ n = n + 1
196 toNat n = cast n
203 toNat n = cast n
197 fromNat n = cast n
204 fromNat n = cast n
198− enumFromThen n inc = n :: enumFromThen (inc + n) inc
205+ enumFromThen n inc = countFrom n (inc - n)
199 enumFromTo n m = if n <= m
206 enumFromTo n m = if n <= m
200 then go n m
207 then go n m
201 else List.reverse $ go m n
208 else List.reverse $ go m n
@@ -224,7 +231,8 @@ Enum Int where
224 go' acc (S k) m = go' (m :: acc) k (m - 1)
231 go' acc (S k) m = go' (m :: acc) k (m - 1)
225 go : Int -> Int -> List Int
232 go : Int -> Int -> List Int
226 go n m = go' [] (cast {to = Nat} (m - n)) m
233 go n m = go' [] (cast {to = Nat} (m - n)) m
227− enumFromThen n inc = n :: enumFromThen (inc + n) inc
234+ enumFromThen n inc = countFrom n (inc - n)
235+
228 enumFromThenTo n next m = if n == m then [n]
236 enumFromThenTo n next m = if n == m then [n]
229 else if next - n == 0 || next - n < 0 /= m - n < 0 then []
237 else if next - n == 0 || next - n < 0 /= m - n < 0 then []
230 else go (natRange (S (divNatNZ (cast {to=Nat} (abs (m - n))) (S (cast {to=Nat} ((abs (next - n)) - 1))) SIsNotZ)))
238 else go (natRange (S (divNatNZ (cast {to=Nat} (abs (m - n))) (S (cast {to=Nat} ((abs (next - n)) - 1))) SIsNotZ)))
libs/prelude/Prelude/Nat.idr+13−8
@@ -91,6 +91,12 @@ hyper (S pn) a (S pb) = hyper pn a (hyper (S pn) a pb)
91-- Comparisons
91-- Comparisons
92--------------------------------------------------------------------------------
92--------------------------------------------------------------------------------
93
93
94+||| Proofs that `n` or `m` is not equal to Z
95+data NotBothZero : (n, m : Nat) -> Type where
96+ LeftIsNotZero : NotBothZero (S n) m
97+ RightIsNotZero : NotBothZero n (S m)
98+
99+
94||| Proofs that `n` is less than or equal to `m`
100||| Proofs that `n` is less than or equal to `m`
95||| @ n the smaller number
101||| @ n the smaller number
96||| @ m the larger number
102||| @ m the larger number
@@ -386,16 +392,15 @@ log2 (S n) = log2NZ (S n) SIsNotZ
386--------------------------------------------------------------------------------
392--------------------------------------------------------------------------------
387-- GCD and LCM
393-- GCD and LCM
388--------------------------------------------------------------------------------
394--------------------------------------------------------------------------------
389−partial
390−gcd : Nat -> Nat -> Nat
395+gcd : (a: Nat) -> (b: Nat) -> .{auto ok: NotBothZero a b} -> Nat
391−gcd a Z = a
396+gcd a Z = a
397+gcd Z b = b
392−gcd a b = assert_total (gcd b (a `modNat` b))
398+gcd a (S b) = assert_total $ gcd (S b) (modNatNZ a (S b) SIsNotZ)
393
399
394−partial
395lcm : Nat -> Nat -> Nat
400lcm : Nat -> Nat -> Nat
396−lcm _ Z = Z
401+lcm _ Z = Z
397−lcm Z _ = Z
402+lcm Z _ = Z
398−lcm x y = divNat (x * y) (gcd x y)
403+lcm a (S b) = assert_total $ divNat (a * (S b)) (gcd a (S b))
399
404
400
405
401--------------------------------------------------------------------------------
406--------------------------------------------------------------------------------
libs/prelude/Prelude/Strings.idr+19−14
@@ -45,7 +45,8 @@ foldl1 f (x::xs) = foldl f x xs
45||| ```
45||| ```
46partial
46partial
47strHead : String -> Char
47strHead : String -> Char
48+strHead "" = idris_crash "Prelude.Strings: attempt to take the head of an empty string"
48−strHead = prim__strHead
49+strHead x = prim__strHead x
49
50
50||| Returns the characters specified after the head of the string.
51||| Returns the characters specified after the head of the string.
51|||
52|||
@@ -59,7 +60,8 @@ strHead = prim__strHead
59||| ```
60||| ```
60partial
61partial
61strTail : String -> String
62strTail : String -> String
63+strTail "" = idris_crash "Prelude.Strings: attempt to take the tail of an empty string"
62−strTail = prim__strTail
64+strTail xs = prim__strTail xs
63
65
64||| Adds a character to the front of the specified string.
66||| Adds a character to the front of the specified string.
65|||
67|||
@@ -72,6 +74,18 @@ strTail = prim__strTail
72strCons : Char -> String -> String
74strCons : Char -> String -> String
73strCons = prim__strCons
75strCons = prim__strCons
74
76
77+||| Returns the length of the string.
78+|||
79+||| ```idris example
80+||| length ""
81+||| ```
82+||| ```idris example
83+||| length "ABC"
84+||| ```
85+length : String -> Nat
86+length = fromInteger . prim__zextInt_BigInt . prim_lenString
87+
88+
75||| Returns the nth character (starting from 0) of the specified string.
89||| Returns the nth character (starting from 0) of the specified string.
76|||
90|||
77||| Precondition: '0 < i < length s' for 'strIndex s i'.
91||| Precondition: '0 < i < length s' for 'strIndex s i'.
@@ -81,7 +95,9 @@ strCons = prim__strCons
81||| ```
95||| ```
82partial
96partial
83strIndex : String -> Int -> Char
97strIndex : String -> Int -> Char
98+strIndex x i = if (i < 0 || i >= cast (length x))
99+ then idris_crash "Prelude.Strings: String index out of bounds"
84−strIndex = prim__strIndex
100+ else prim__strIndex x i
85
101
86||| Reverses the elements within a String.
102||| Reverses the elements within a String.
87|||
103|||
@@ -297,17 +313,6 @@ unlines' (l::ls) = l ++ '\n' :: unlines' ls
297unlines : List String -> String
313unlines : List String -> String
298unlines = pack . unlines' . map unpack
314unlines = pack . unlines' . map unpack
299
315
300−||| Returns the length of the string.
301−|||
302−||| ```idris example
303−||| length ""
304−||| ```
305−||| ```idris example
306−||| length "ABC"
307−||| ```
308−length : String -> Nat
309−length = fromInteger . prim__zextInt_BigInt . prim_lenString
310−
311||| Returns a substring of a given string
316||| Returns a substring of a given string
312|||
317|||
313||| @ index The (zero based) index of the string to extract. If this is
318||| @ index The (zero based) index of the string to extract. If this is
libs/pruviloj/Pruviloj/Induction.idr+3−1
@@ -132,7 +132,9 @@ induction subj =
132 (_, ty) <- check !getEnv subj
132 (_, ty) <- check !getEnv subj
133 ty' <- forget ty
133 ty' <- forget ty
134 case headName ty' of
134 case headName ty' of
135+ Nothing =>
135− Nothing => fail [TermPart ty, TextPart "is not an inductive family"]
136+ fail [TermPart ty,
137+ TextPart "is not a datatype declared with the data keyword"]
136 Just fam =>
138 Just fam =>
137 do let elim = elimN fam
139 do let elim = elimN fam
138 (_,_,elimTy) <- (lookupTyExact elim) <|> (do deriveElim fam elim
140 (_,_,elimTy) <- (lookupTyExact elim) <|> (do deriveElim fam elim
main/Main.hs+16−4
@@ -1,5 +1,11 @@
1module Main where
1module Main where
2
2
3+import System.Exit ( ExitCode(..), exitWith, exitSuccess )
4+
5+import Control.Monad ( unless, when, (>=>) )
6+import Data.Maybe ( fromMaybe )
7+import Data.Foldable ( foldrM )
8+
3import Idris.AbsSyntax
9import Idris.AbsSyntax
4import Idris.CmdOptions
10import Idris.CmdOptions
5import Idris.Error
11import Idris.Error
@@ -9,8 +15,8 @@ import Idris.Package
9
15
10import Util.System (setupBundledCC)
16import Util.System (setupBundledCC)
11
17
12−import Control.Monad (when)
18+import Util.System ( setupBundledCC )
13−import System.Exit (exitSuccess)
19+import System.Exit ( ExitCode(..), exitWith)
14
20
15processShowOptions :: [Opt] -> Idris ()
21processShowOptions :: [Opt] -> Idris ()
16processShowOptions opts = runIO $ do
22processShowOptions opts = runIO $ do
@@ -33,7 +39,7 @@ processClientOptions :: [Opt] -> Idris ()
33processClientOptions opts = check opts getClient $ \fs -> case fs of
39processClientOptions opts = check opts getClient $ \fs -> case fs of
34 [] -> ifail "No --client argument. This indicates a bug. Please report."
40 [] -> ifail "No --client argument. This indicates a bug. Please report."
35 (c : _) -> do
41 (c : _) -> do
36− setVerbose False
42+ setVerbose 0
37 setQuiet True
43 setQuiet True
38 case getPort opts of
44 case getPort opts of
39 Just DontListen -> ifail "\"--client\" and \"--port none\" are incompatible"
45 Just DontListen -> ifail "\"--client\" and \"--port none\" are incompatible"
@@ -49,7 +55,13 @@ processPackageOptions opts = do
49 check opts getPkgMkDoc $ \fs -> runIO $ do
55 check opts getPkgMkDoc $ \fs -> runIO $ do
50 mapM_ (documentPkg opts) fs
56 mapM_ (documentPkg opts) fs
51 check opts getPkgTest $ \fs -> runIO $ do
57 check opts getPkgTest $ \fs -> runIO $ do
58+
52− mapM_ (testPkg opts) fs
59+ codes <- mapM (testPkg opts) fs
60+ -- check if any of the tests exited with an exit code other
61+ -- than zero; if they did, exit with exit code 1
62+ unless (null $ filter (/= ExitSuccess) codes) $
63+ exitWith (ExitFailure 1)
64+
53 check opts getPkg $ \fs -> runIO $ do
65 check opts getPkg $ \fs -> runIO $ do
54 mapM_ (buildPkg opts (WarnOnly `elem` opts)) fs
66 mapM_ (buildPkg opts (WarnOnly `elem` opts)) fs
55 check opts getPkgREPL $ \fs -> case fs of
67 check opts getPkgREPL $ \fs -> case fs of
man/idris.1+16−2
@@ -1,6 +1,6 @@
1.\" Manpage for Idris.
1.\" Manpage for Idris.
2.\" Contact <> to correct errors or typos.
2.\" Contact <> to correct errors or typos.
3−.TH man 1 "25 March 2016" "0.12.3" "Idris man page"
3+.TH man 1 "28 November 2016" "0.99" "Idris man page"
4.SH NAME
4.SH NAME
5idris -\ a general purpose pure functional programming language with dependent types.
5idris -\ a general purpose pure functional programming language with dependent types.
6.SH SYNOPSIS
6.SH SYNOPSIS
@@ -13,17 +13,29 @@ specified precisely in the type. It is compiled, with eager
13evaluation. Its features are influenced by Haskell and ML.
13evaluation. Its features are influenced by Haskell and ML.
14
14
15+ Full dependent types with dependent pattern matching
15+ Full dependent types with dependent pattern matching
16+
16+ Simple case expressions, where-clauses, with-rule
17+ Simple case expressions, where-clauses, with-rule
18+
17+ Pattern matching let- and lambda-bindings
19+ Pattern matching let- and lambda-bindings
20+
18+ Overloading via Interfaces (Type class-like), Monad comprehensions
21+ Overloading via Interfaces (Type class-like), Monad comprehensions
22+
19+ do-notation, idiom brackets
23+ do-notation, idiom brackets
24+
20+ Syntactic conveniences for lists, tuples, dependent pairs
25+ Syntactic conveniences for lists, tuples, dependent pairs
26+
21+ Totality checking
27+ Totality checking
28+
22+ Coinductive types
29+ Coinductive types
30+
23+ Indentation significant syntax, Extensible syntax
31+ Indentation significant syntax, Extensible syntax
32+
24+ Tactic based theorem proving (influenced by Coq)
33+ Tactic based theorem proving (influenced by Coq)
34+
25+ Cumulative universes
35+ Cumulative universes
36+
26+ Simple Foreign Function Interface
37+ Simple Foreign Function Interface
38+
27+ Hugs style interactive environment
39+ Hugs style interactive environment
28
40
29It is important to note that Idris is first and foremost a research tool
41It is important to note that Idris is first and foremost a research tool
@@ -56,7 +68,9 @@ should not necessarily be seen as production ready nor for industrial use.
56 --listlibs Display installed libraries
68 --listlibs Display installed libraries
57 --libdir Display library directory
69 --libdir Display library directory
58 --include Display the includes flags
70 --include Display the includes flags
71+ --V2 Loudest verbosity
72+ --V1 Louder verbosity
59− -V,--verbose Loud verbosity
73+ -V, --V0, --verbose Loud verbosity
60 --ibcsubdir FILE Write IBC files into sub directory
74 --ibcsubdir FILE Write IBC files into sub directory
61 -i,--idrispath ARG Add directory to the list of import paths
75 -i,--idrispath ARG Add directory to the list of import paths
62 --sourcepath ARG Add directory to the list of source search paths
76 --sourcepath ARG Add directory to the list of source search paths
mkpkg.sh+44−6
@@ -1,26 +1,64 @@
1#!/bin/sh
1#!/bin/sh
2
2
3−VERSION=$1
3+set -euo pipefail
4
4
5+if [ "$#" -lt 1 ]; then
6+ echo "Usage $0 [version number] ?[idris bin location]"
7+ echo ""
8+ echo "The first argument is the version number"
9+ echo ""
10+ echo "The second argument is optional, and used to point to a"
11+ echo "custom location in which idris was recently built i.e."
12+ echo "withing .stack-work or .cabal-sandbox. The location must"
13+ echo "be given relative to the project root of a package in the "
14+ echo "libs/ directory."
15+ exit 1
16+fi
17+
18+VERSION=${1:-}
19+
5−echo "Building version-$VERSION\n\n"
20+echo "==> Building version-$VERSION"
21+echo ""
6−echo "Have you: set the release flag, checked the demos and the tutorial?"
22+echo "Q: Have you: (a) set the release flag & (b) checked the demos and the tutorial?"
7−read $foo
23+read ${FOO:-}
8
24
9git tag v$VERSION -a
25git tag v$VERSION -a
10
26
27+echo "==> Building Source Distribution"
11cabal sdist
28cabal sdist
12
29
13# Generate Idris library docs and put them in lib_docs.tar.gz in the root
30# Generate Idris library docs and put them in lib_docs.tar.gz in the root
31+echo "==> Generating API Documentation."
32+echo "==> Determining version of Idris to use."
33+if [ -z ${2+x} ];
34+then
35+ echo "==> Using default location.";
14−make lib_doc
36+ make lib_doc
37+else
38+ echo "==> Using custom location.";
39+ make -C libs IDRIS=$2 doc
40+fi
41+
15DOCDIR=`mktemp -d /tmp/docsXXXXX`
42DOCDIR=`mktemp -d /tmp/docsXXXXX`
43+
16cp -r libs/base/base_doc "$DOCDIR"
44cp -r libs/base/base_doc "$DOCDIR"
17cp -r libs/prelude/prelude_doc "$DOCDIR"
45cp -r libs/prelude/prelude_doc "$DOCDIR"
18cp -r libs/effects/effects_doc "$DOCDIR"
46cp -r libs/effects/effects_doc "$DOCDIR"
19cp -r libs/contrib/contrib_doc "$DOCDIR"
47cp -r libs/contrib/contrib_doc "$DOCDIR"
48+
20tar -czvf lib_docs.tar.gz -C "$DOCDIR" prelude_doc base_doc effects_doc contrib_doc
49tar -czvf lib_docs.tar.gz -C "$DOCDIR" prelude_doc base_doc effects_doc contrib_doc
21
50
51+echo "==> Building Binaries"
22cabal configure --prefix=/usr/local
52cabal configure --prefix=/usr/local
53+
23cabal build
54cabal build
55+
56+echo "==> Creating Package"
57+mkdir -p /tmp/idris-pkg/
58+
24cabal copy --destdir=/tmp/idris-pkg/
59cabal copy --destdir=/tmp/idris-pkg/
25−pkgbuild --id org.idris-lang --root /tmp/idris-pkg/ idris-$VERSION.pkg
26
60
61+pkgbuild --identifier org.idris-lang \
62+ --version "v$VERSION" \
63+ --root /tmp/idris-pkg/ \
64+ idris-$VERSION.pkg
rts/idris_bitstring.c+8−8
@@ -823,37 +823,37 @@ VAL idris_b64T32(VM *vm, VAL a) {
823}
823}
824
824
825VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {
825VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {
826− return MKB8(vm, *(uint8_t*)(GETPTR(ptr) + GETINT(offset)));
826+ return MKB8(vm, *(uint8_t*)((char *)GETPTR(ptr) + GETINT(offset)));
827}
827}
828
828
829VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {
829VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {
830− *(uint8_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);
830+ *(uint8_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);
831 return MKINT(0);
831 return MKINT(0);
832}
832}
833
833
834VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {
834VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {
835− return MKB16(vm, *(uint16_t*)(GETPTR(ptr) + GETINT(offset)));
835+ return MKB16(vm, *(uint16_t*)((char *)GETPTR(ptr) + GETINT(offset)));
836}
836}
837
837
838VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {
838VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {
839− *(uint16_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);
839+ *(uint16_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);
840 return MKINT(0);
840 return MKINT(0);
841}
841}
842
842
843VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {
843VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {
844− return MKB32(vm, *(uint32_t*)(GETPTR(ptr) + GETINT(offset)));
844+ return MKB32(vm, *(uint32_t*)((char *)GETPTR(ptr) + GETINT(offset)));
845}
845}
846
846
847VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {
847VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {
848− *(uint32_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);
848+ *(uint32_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);
849 return MKINT(0);
849 return MKINT(0);
850}
850}
851
851
852VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {
852VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {
853− return MKB64(vm, *(uint64_t*)(GETPTR(ptr) + GETINT(offset)));
853+ return MKB64(vm, *(uint64_t*)((char *)GETPTR(ptr) + GETINT(offset)));
854}
854}
855
855
856VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {
856VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {
857− *(uint64_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);
857+ *(uint64_t*)((char *)GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);
858 return MKINT(0);
858 return MKINT(0);
859}
859}
rts/idris_gmp.c+1−1
@@ -14,7 +14,7 @@
14// much space is needed (or find another way of preventing copying)
14// much space is needed (or find another way of preventing copying)
15#define IDRIS_MAXGMP 65536
15#define IDRIS_MAXGMP 65536
16
16
17−void init_gmpalloc() {
17+void init_gmpalloc(void) {
18 mp_set_memory_functions(idris_alloc, idris_realloc, idris_free);
18 mp_set_memory_functions(idris_alloc, idris_realloc, idris_free);
19}
19}
20
20
rts/idris_gmp.h+1−1
@@ -8,7 +8,7 @@
8#endif
8#endif
9
9
10// Set memory allocation functions
10// Set memory allocation functions
11−void init_gmpalloc();
11+void init_gmpalloc(void);
12
12
13VAL MKBIGI(int val);
13VAL MKBIGI(int val);
14VAL MKBIGC(VM* vm, char* bigint);
14VAL MKBIGC(VM* vm, char* bigint);
rts/idris_rts.c+24−19
@@ -70,7 +70,7 @@ VM* init_vm(int stack_size, size_t heap_size,
70 return vm;
70 return vm;
71}
71}
72
72
73−VM* idris_vm() {
73+VM* idris_vm(void) {
74 VM* vm = init_vm(4096000, 4096000, 1);
74 VM* vm = init_vm(4096000, 4096000, 1);
75 init_threadkeys();
75 init_threadkeys();
76 init_threaddata(vm);
76 init_threaddata(vm);
@@ -95,12 +95,12 @@ void close_vm(VM* vm) {
95}
95}
96
96
97#ifdef HAS_PTHREAD
97#ifdef HAS_PTHREAD
98−void create_key() {
98+void create_key(void) {
99 pthread_key_create(&vm_key, (void*)free_key);
99 pthread_key_create(&vm_key, (void*)free_key);
100}
100}
101#endif
101#endif
102
102
103−void init_threadkeys() {
103+void init_threadkeys(void) {
104#ifdef HAS_PTHREAD
104#ifdef HAS_PTHREAD
105 static pthread_once_t key_once = PTHREAD_ONCE_INIT;
105 static pthread_once_t key_once = PTHREAD_ONCE_INIT;
106 pthread_once(&key_once, create_key);
106 pthread_once(&key_once, create_key);
@@ -113,7 +113,7 @@ void init_threaddata(VM *vm) {
113#endif
113#endif
114}
114}
115
115
116−void init_signals() {
116+void init_signals(void) {
117#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__)
117#if (__linux__ || __APPLE__ || __FreeBSD__ || __DragonFly__)
118 signal(SIGPIPE, SIG_IGN);
118 signal(SIGPIPE, SIG_IGN);
119#endif
119#endif
@@ -173,7 +173,7 @@ void idris_requireAlloc(size_t size) {
173#endif
173#endif
174}
174}
175
175
176−void idris_doneAlloc() {
176+void idris_doneAlloc(void) {
177#ifdef HAS_PTHREAD
177#ifdef HAS_PTHREAD
178 VM* vm = pthread_getspecific(vm_key);
178 VM* vm = pthread_getspecific(vm_key);
179 int lock = vm->processes > 0;
179 int lock = vm->processes > 0;
@@ -191,7 +191,7 @@ void* idris_alloc(size_t size) {
191 Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);
191 Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);
192 SETTY(cl, CT_RAWDATA);
192 SETTY(cl, CT_RAWDATA);
193 cl->info.size = size;
193 cl->info.size = size;
194− return (void*)cl+sizeof(Closure);
194+ return (void*)((char *)cl+sizeof(Closure));
195}
195}
196
196
197void* idris_realloc(void* old, size_t old_size, size_t size) {
197void* idris_realloc(void* old, size_t old_size, size_t size) {
@@ -449,36 +449,36 @@ void idris_poke(void* ptr, i_int offset, uint8_t data) {
449
449
450
450
451VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {
451VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {
452− void** addr = GETPTR(ptr) + GETINT(offset);
452+ void** addr = (void **)((char *)GETPTR(ptr) + GETINT(offset));
453 return MKPTR(vm, *addr);
453 return MKPTR(vm, *addr);
454}
454}
455
455
456VAL idris_pokePtr(VAL ptr, VAL offset, VAL data) {
456VAL idris_pokePtr(VAL ptr, VAL offset, VAL data) {
457− void** addr = GETPTR(ptr) + GETINT(offset);
457+ void** addr = (void **)((char *)GETPTR(ptr) + GETINT(offset));
458 *addr = GETPTR(data);
458 *addr = GETPTR(data);
459 return MKINT(0);
459 return MKINT(0);
460}
460}
461
461
462VAL idris_peekDouble(VM* vm, VAL ptr, VAL offset) {
462VAL idris_peekDouble(VM* vm, VAL ptr, VAL offset) {
463− return MKFLOAT(vm, *(double*)(GETPTR(ptr) + GETINT(offset)));
463+ return MKFLOAT(vm, *(double*)((char *)GETPTR(ptr) + GETINT(offset)));
464}
464}
465
465
466VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data) {
466VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data) {
467− *(double*)(GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);
467+ *(double*)((char *)GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);
468 return MKINT(0);
468 return MKINT(0);
469}
469}
470
470
471VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset) {
471VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset) {
472− return MKFLOAT(vm, *(float*)(GETPTR(ptr) + GETINT(offset)));
472+ return MKFLOAT(vm, *(float*)((char *)GETPTR(ptr) + GETINT(offset)));
473}
473}
474
474
475VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data) {
475VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data) {
476− *(float*)(GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);
476+ *(float*)((char *)GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);
477 return MKINT(0);
477 return MKINT(0);
478}
478}
479
479
480void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {
480void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {
481− memmove(dest + dest_offset, src + src_offset, size);
481+ memmove((char *)dest + dest_offset, (char *)src + src_offset, size);
482}
482}
483
483
484VAL idris_castIntStr(VM* vm, VAL i) {
484VAL idris_castIntStr(VM* vm, VAL i) {
@@ -595,6 +595,11 @@ VAL idris_readStr(VM* vm, FILE* h) {
595 return ret;
595 return ret;
596}
596}
597
597
598+void idris_crash(char* msg) {
599+ fprintf(stderr, "%s\n", msg);
600+ exit(1);
601+}
602+
598VAL idris_strHead(VM* vm, VAL str) {
603VAL idris_strHead(VM* vm, VAL str) {
599 return idris_strIndex(vm, str, 0);
604 return idris_strIndex(vm, str, 0);
600}
605}
@@ -1041,7 +1046,7 @@ void idris_freeMsg(Msg* msg) {
1041 free(msg);
1046 free(msg);
1042}
1047}
1043
1048
1044−int idris_errno() {
1049+int idris_errno(void) {
1045 return errno;
1050 return errno;
1046}
1051}
1047
1052
@@ -1051,7 +1056,7 @@ char* idris_showerror(int err) {
1051
1056
1052VAL* nullary_cons;
1057VAL* nullary_cons;
1053
1058
1054−void init_nullaries() {
1059+void init_nullaries(void) {
1055 int i;
1060 int i;
1056 VAL cl;
1061 VAL cl;
1057 nullary_cons = malloc(256 * sizeof(VAL));
1062 nullary_cons = malloc(256 * sizeof(VAL));
@@ -1063,7 +1068,7 @@ void init_nullaries() {
1063 }
1068 }
1064}
1069}
1065
1070
1066−void free_nullaries() {
1071+void free_nullaries(void) {
1067 int i;
1072 int i;
1068 for(i = 0; i < 256; ++i) {
1073 for(i = 0; i < 256; ++i) {
1069 free(nullary_cons[i]);
1074 free(nullary_cons[i]);
@@ -1074,7 +1079,7 @@ void free_nullaries() {
1074int __idris_argc;
1079int __idris_argc;
1075char **__idris_argv;
1080char **__idris_argv;
1076
1081
1077−int idris_numArgs() {
1082+int idris_numArgs(void) {
1078 return __idris_argc;
1083 return __idris_argc;
1079}
1084}
1080
1085
@@ -1082,12 +1087,12 @@ const char* idris_getArg(int i) {
1082 return __idris_argv[i];
1087 return __idris_argv[i];
1083}
1088}
1084
1089
1085−void idris_disableBuffering() {
1090+void idris_disableBuffering(void) {
1086 setvbuf(stdin, NULL, _IONBF, 0);
1091 setvbuf(stdin, NULL, _IONBF, 0);
1087 setvbuf(stdout, NULL, _IONBF, 0);
1092 setvbuf(stdout, NULL, _IONBF, 0);
1088}
1093}
1089
1094
1090−void stackOverflow() {
1095+void stackOverflow(void) {
1091 fprintf(stderr, "Stack overflow");
1096 fprintf(stderr, "Stack overflow");
1092 exit(-1);
1097 exit(-1);
1093}
1098}
rts/idris_rts.h+13−10
@@ -161,11 +161,11 @@ Stats terminate(VM* vm);
161
161
162// Create a new VM, set up everything with sensible defaults (use when
162// Create a new VM, set up everything with sensible defaults (use when
163// calling Idris from C)
163// calling Idris from C)
164−VM* idris_vm();
164+VM* idris_vm(void);
165void close_vm(VM* vm);
165void close_vm(VM* vm);
166
166
167// Set up key for thread-local data - called once from idris_main
167// Set up key for thread-local data - called once from idris_main
168−void init_threadkeys();
168+void init_threadkeys(void);
169
169
170// Functions all take a pointer to their VM, and previous stack base,
170// Functions all take a pointer to their VM, and previous stack base,
171// and return nothing.
171// and return nothing.
@@ -278,7 +278,7 @@ void* allocate(size_t size, int outerlock);
278// may take a lock if other threads are running).
278// may take a lock if other threads are running).
279
279
280void idris_requireAlloc(size_t size);
280void idris_requireAlloc(size_t size);
281−void idris_doneAlloc();
281+void idris_doneAlloc(void);
282
282
283// public interface to allocation (note that this may move other pointers
283// public interface to allocation (note that this may move other pointers
284// if allocating beyond the limits given by idris_requireAlloc!)
284// if allocating beyond the limits given by idris_requireAlloc!)
@@ -299,14 +299,14 @@ void idris_free(void* ptr, size_t size);
299
299
300#define NULL_CON(x) nullary_cons[x]
300#define NULL_CON(x) nullary_cons[x]
301
301
302−int idris_errno();
302+int idris_errno(void);
303char* idris_showerror(int err);
303char* idris_showerror(int err);
304
304
305extern VAL* nullary_cons;
305extern VAL* nullary_cons;
306−void init_nullaries();
306+void init_nullaries(void);
307−void free_nullaries();
307+void free_nullaries(void);
308
308
309−void init_signals();
309+void init_signals(void);
310
310
311void* vmThread(VM* callvm, func f, VAL arg);
311void* vmThread(VM* callvm, func f, VAL arg);
312void* idris_stopThread(VM* vm);
312void* idris_stopThread(VM* vm);
@@ -364,6 +364,9 @@ VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data);
364VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset);
364VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset);
365VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data);
365VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data);
366
366
367+// Crash with a message (used for partial primitives)
368+void idris_crash(char* msg);
369+
367// String primitives
370// String primitives
368VAL idris_concat(VM* vm, VAL l, VAL r);
371VAL idris_concat(VM* vm, VAL l, VAL r);
369VAL idris_strlt(VM* vm, VAL l, VAL r);
372VAL idris_strlt(VM* vm, VAL l, VAL r);
@@ -391,16 +394,16 @@ VAL idris_systemInfo(VM* vm, VAL index);
391extern int __idris_argc;
394extern int __idris_argc;
392extern char **__idris_argv;
395extern char **__idris_argv;
393
396
394−int idris_numArgs();
397+int idris_numArgs(void);
395const char *idris_getArg(int i);
398const char *idris_getArg(int i);
396
399
397// disable stdin/stdout buffering
400// disable stdin/stdout buffering
398−void idris_disableBuffering();
401+void idris_disableBuffering(void);
399
402
400// Handle stack overflow.
403// Handle stack overflow.
401// Just reports an error and exits.
404// Just reports an error and exits.
402
405
403−void stackOverflow();
406+void stackOverflow(void);
404
407
405// I think these names are nicer for an API...
408// I think these names are nicer for an API...
406
409
src/IRTS/CodegenC.hs+2−1
@@ -617,6 +617,7 @@ doOp v (LIntCh ITNative) args = v ++ creg (last args)
617doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
617doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args
618
618
619doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
619doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"
620+doOp v LCrash [x] = "idris_crash(GETSTR(" ++ creg x ++ "))"
620doOp v LNoOp args = v ++ creg (last args)
621doOp v LNoOp args = v ++ creg (last args)
621
622
622-- Pointer primitives (declared as %extern in Builtins.idr)
623-- Pointer primitives (declared as %extern in Builtins.idr)
@@ -673,7 +674,7 @@ doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"
673doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
674doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"
674 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
675 = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"
675doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
676doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"
676− = v ++ "MKPTR(vm, GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ "))"
677+ = v ++ "MKPTR(vm, (void *)((char *)GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ ")))"
677doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
678doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"
678
679
679
680
src/IRTS/Compiler.hs+15−5
@@ -52,8 +52,10 @@ import System.Process
52
52
53-- | Compile to simplified forms and return CodegenInfo
53-- | Compile to simplified forms and return CodegenInfo
54compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo
54compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo
55−compile codegen f mtm
55+compile codegen f mtm = do
56+ logCodeGen 1 "Compiling Output."
57+ iReport 2 "Compiling Output."
56− = do checkMVs -- check for undefined metavariables
58+ checkMVs -- check for undefined metavariables
57 checkTotality -- refuse to compile if there are totality problems
59 checkTotality -- refuse to compile if there are totality problems
58 exports <- findExports
60 exports <- findExports
59 let rootNames = case mtm of
61 let rootNames = case mtm of
@@ -89,9 +91,11 @@ compile codegen f mtm
89 let ctxtIn = addAlist tagged emptyContext
91 let ctxtIn = addAlist tagged emptyContext
90
92
91 logCodeGen 1 "Defunctionalising"
93 logCodeGen 1 "Defunctionalising"
94+ iReport 3 "Defunctionalising"
92 let defuns_in = defunctionalise nexttag ctxtIn
95 let defuns_in = defunctionalise nexttag ctxtIn
93 logCodeGen 5 $ show defuns_in
96 logCodeGen 5 $ show defuns_in
94 logCodeGen 1 "Inlining"
97 logCodeGen 1 "Inlining"
98+ iReport 3 "Inlining"
95 let defuns = inline defuns_in
99 let defuns = inline defuns_in
96 logCodeGen 5 $ show defuns
100 logCodeGen 5 $ show defuns
97 logCodeGen 1 "Resolving variables for CG"
101 logCodeGen 1 "Resolving variables for CG"
@@ -108,7 +112,8 @@ compile codegen f mtm
108 Just f -> runIO $ writeFile f (dumpDefuns defuns)
112 Just f -> runIO $ writeFile f (dumpDefuns defuns)
109 triple <- Idris.AbsSyntax.targetTriple
113 triple <- Idris.AbsSyntax.targetTriple
110 cpu <- Idris.AbsSyntax.targetCPU
114 cpu <- Idris.AbsSyntax.targetCPU
111− logCodeGen 1 "Building output"
115+ logCodeGen 1 "Generating Code."
116+ iReport 2 "Generating Code."
112 case checked of
117 case checked of
113 OK c -> do return $ CodegenInfo f outty triple cpu
118 OK c -> do return $ CodegenInfo f outty triple cpu
114 hdrs impdirs objs libs flags
119 hdrs impdirs objs libs flags
@@ -258,6 +263,11 @@ irTerm top vs env tm@(App _ f a) = do
258 | u == txt "assert_unreachable"
263 | u == txt "assert_unreachable"
259 -> return $ LError $ "ABORT: Reached an unreachable case in " ++ show top
264 -> return $ LError $ "ABORT: Reached an unreachable case in " ++ show top
260
265
266+ (P _ (UN u) _, [_, msg])
267+ | u == txt "idris_crash"
268+ -> do msg' <- irTerm top vs env msg
269+ return $ LOp LCrash [msg']
270+
261 -- TMP HACK - until we get inlining.
271 -- TMP HACK - until we get inlining.
262 (P _ (UN r) _, [_, _, _, _, _, arg])
272 (P _ (UN r) _, [_, _, _, _, _, arg])
263 | r == txt "replace"
273 | r == txt "replace"
@@ -456,14 +466,14 @@ irTerm top vs env tm@(App _ f a) = do
456 | otherwise = n
466 | otherwise = n
457
467
458 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
468 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
459− fst4 (x,_,_,_,_) = x
469+ fst4 (x,_,_,_,_,_) = x
460
470
461irTerm top vs env (P _ n _) = return $ LV (Glob n)
471irTerm top vs env (P _ n _) = return $ LV (Glob n)
462irTerm top vs env (V i)
472irTerm top vs env (V i)
463 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
473 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
464 | otherwise = ifail $ "bad de bruijn index: " ++ show i
474 | otherwise = ifail $ "bad de bruijn index: " ++ show i
465
475
466−irTerm top vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc
476+irTerm top vs env (Bind n (Lam _ _) sc) = LLam [n'] <$> irTerm top vs (n':env) sc
467 where
477 where
468 n' = uniqueName n env
478 n' = uniqueName n env
469
479
src/IRTS/Lang.hs+2
@@ -92,6 +92,8 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
92 | LPar -- evaluate argument anywhere, possibly on another
92 | LPar -- evaluate argument anywhere, possibly on another
93 -- core or another machine. 'id' is a valid implementation
93 -- core or another machine. 'id' is a valid implementation
94 | LExternal Name
94 | LExternal Name
95+ | LCrash
96+
95 | LNoOp
97 | LNoOp
96 deriving (Show, Eq, Generic)
98 deriving (Show, Eq, Generic)
97
99
src/IRTS/Portable.hs+4−4
@@ -29,7 +29,7 @@ data CodegenFile = CGFile {
29
29
30-- Update the version when the format changes
30-- Update the version when the format changes
31formatVersion :: Int
31formatVersion :: Int
32−formatVersion = 1
32+formatVersion = 2
33
33
34writePortable :: Handle -> CodegenInfo -> IO ()
34writePortable :: Handle -> CodegenInfo -> IO ()
35writePortable file ci = do
35writePortable file ci = do
@@ -236,13 +236,13 @@ instance ToJSON SExp where
236 toJSON (SApp tail name exps) = object ["SApp" .= (tail, name, exps)]
236 toJSON (SApp tail name exps) = object ["SApp" .= (tail, name, exps)]
237 toJSON (SLet lv a b) = object ["SLet" .= (lv, a, b)]
237 toJSON (SLet lv a b) = object ["SLet" .= (lv, a, b)]
238 toJSON (SUpdate lv exp) = object ["SUpdate" .= (lv, exp)]
238 toJSON (SUpdate lv exp) = object ["SUpdate" .= (lv, exp)]
239− toJSON (SProj lv i) = object ["DProj" .= (lv, i)]
239+ toJSON (SProj lv i) = object ["SProj" .= (lv, i)]
240 toJSON (SCon lv i name vars) = object ["SCon" .= (lv, i, name, vars)]
240 toJSON (SCon lv i name vars) = object ["SCon" .= (lv, i, name, vars)]
241 toJSON (SCase ct lv alts) = object ["SCase" .= (ct, lv, alts)]
241 toJSON (SCase ct lv alts) = object ["SCase" .= (ct, lv, alts)]
242− toJSON (SChkCase lv alts) = object ["DChkCase" .= (lv, alts)]
242+ toJSON (SChkCase lv alts) = object ["SChkCase" .= (lv, alts)]
243 toJSON (SConst c) = object ["SConst" .= c]
243 toJSON (SConst c) = object ["SConst" .= c]
244 toJSON (SForeign fd ret exps) = object ["SForeign" .= (fd, ret, exps)]
244 toJSON (SForeign fd ret exps) = object ["SForeign" .= (fd, ret, exps)]
245− toJSON (SOp prim vars) = object ["DOp" .= (prim, vars)]
245+ toJSON (SOp prim vars) = object ["SOp" .= (prim, vars)]
246 toJSON SNothing = object ["SNothing" .= Null]
246 toJSON SNothing = object ["SNothing" .= Null]
247 toJSON (SError s) = object ["SError" .= s]
247 toJSON (SError s) = object ["SError" .= s]
248
248
src/IRTS/System.hs+6−1
@@ -6,7 +6,7 @@ License : BSD3
6Maintainer : The Idris Community.
6Maintainer : The Idris Community.
7-}
7-}
8{-# LANGUAGE CPP #-}
8{-# LANGUAGE CPP #-}
9−module IRTS.System( getDataFileName
9+module IRTS.System( getIdrisDataFileByName
10 , getCC
10 , getCC
11 , getLibFlags
11 , getLibFlags
12 , getIdrisDataDir
12 , getIdrisDataDir
@@ -42,6 +42,11 @@ getIdrisDataDir = do
42 return ddir
42 return ddir
43 Just ddir -> return ddir
43 Just ddir -> return ddir
44
44
45+getIdrisDataFileByName :: String -> IO FilePath
46+getIdrisDataFileByName fn = do
47+ dir <- getIdrisDataDir
48+ return $ dir </> fn
49+
45overrideIdrisSubDirWith :: String -- ^ Sub directory in `getDataDir` location.
50overrideIdrisSubDirWith :: String -- ^ Sub directory in `getDataDir` location.
46 -> String -- ^ Environment variable to get new location from.
51 -> String -- ^ Environment variable to get new location from.
47 -> IO FilePath
52 -> IO FilePath
src/Idris/ASTUtils.hs+1−1
@@ -148,7 +148,7 @@ opts_idrisCmdline =
148--
148--
149-- This has a terrible name, but I'm not sure of a better one that
149-- This has a terrible name, but I'm not sure of a better one that
150-- isn't confusingly close to tt_ctxt
150-- isn't confusingly close to tt_ctxt
151−known_terms :: Field IState (Ctxt (Def, Injectivity, Accessibility, Totality, MetaInformation))
151+known_terms :: Field IState (Ctxt (Def, RigCount, Injectivity, Accessibility, Totality, MetaInformation))
152known_terms = Field (definitions . tt_ctxt)
152known_terms = Field (definitions . tt_ctxt)
153 (\v state -> state {tt_ctxt = (tt_ctxt state) {definitions = v}})
153 (\v state -> state {tt_ctxt = (tt_ctxt state) {definitions = v}})
154
154
src/Idris/AbsSyntax.hs+54−44
@@ -142,14 +142,10 @@ addImported pub f
142 putIState $ i { idris_imported = nub $ (f, pub) : idris_imported i }
142 putIState $ i { idris_imported = nub $ (f, pub) : idris_imported i }
143
143
144addLangExt :: LanguageExt -> Idris ()
144addLangExt :: LanguageExt -> Idris ()
145−addLangExt TypeProviders = do i <- getIState
146− putIState $ i {
147− idris_language_extensions = TypeProviders : idris_language_extensions i
148− }
149−addLangExt ErrorReflection = do i <- getIState
145+addLangExt e = do i <- getIState
150− putIState $ i {
146+ putIState $ i {
151− idris_language_extensions = ErrorReflection : idris_language_extensions i
147+ idris_language_extensions = e : idris_language_extensions i
152− }
148+ }
153
149
154-- | Transforms are organised by the function being applied on the lhs
150-- | Transforms are organised by the function being applied on the lhs
155-- of the transform, to make looking up appropriate transforms quicker
151-- of the transform, to make looking up appropriate transforms quicker
@@ -389,7 +385,7 @@ allNames ns n = do i <- getIState
389 case getCGAllNames i n of
385 case getCGAllNames i n of
390 Just ns -> return ns
386 Just ns -> return ns
391 Nothing -> case lookupCtxtExact n (idris_callgraph i) of
387 Nothing -> case lookupCtxtExact n (idris_callgraph i) of
392− Just ci ->
388+ Just ci ->
393 do more <- mapM (allNames (n:ns)) (calls ci)
389 do more <- mapM (allNames (n:ns)) (calls ci)
394 let ns' = nub (n : concat more)
390 let ns' = nub (n : concat more)
395 addCGAllNames i n ns'
391 addCGAllNames i n ns'
@@ -1028,17 +1024,31 @@ targetCPU :: Idris String
1028targetCPU = do i <- getIState
1024targetCPU = do i <- getIState
1029 return (opt_cpu (idris_options i))
1025 return (opt_cpu (idris_options i))
1030
1026
1031−verbose :: Idris Bool
1027+verbose :: Idris Int
1028+verbose = do
1032−verbose = do i <- getIState
1029+ i <- getIState
1033− -- Quietness overrides verbosity
1030+ -- Quietness overrides verbosity
1031+ let quiet = opt_quiet $ idris_options i
1032+ if quiet
1033+ then return $ 0
1034− return (not (opt_quiet (idris_options i)) &&
1034+ else return $ (opt_verbose $ idris_options i)
1035+
1036+setVerbose :: Int -> Idris ()
1037+setVerbose t = do
1038+ i <- getIState
1039+ let opts = idris_options i
1035− opt_verbose (idris_options i))
1040+ let opt' = opts { opt_verbose = t }
1041+ putIState $ i { idris_options = opt' }
1036
1042
1037−setVerbose :: Bool -> Idris ()
1043+iReport :: Int -> String -> Idris ()
1044+iReport level msg = do
1045+ verbosity <- verbose
1038−setVerbose t = do i <- getIState
1046+ i <- getIState
1039− let opts = idris_options i
1047+ when (level <= verbosity) $
1040− let opt' = opts { opt_verbose = t }
1048+ case idris_outputmode i of
1041− putIState $ i { idris_options = opt' }
1049+ RawOutput h -> runIO $ hPutStrLn h msg
1050+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "write-string" msg n
1051+ return ()
1042
1052
1043typeInType :: Idris Bool
1053typeInType :: Idris Bool
1044typeInType = do i <- getIState
1054typeInType = do i <- getIState
@@ -1296,8 +1306,8 @@ expandParams dec ps ns infs tm = en 0 tm
1296
1306
1297 nseq x y = nsroot x == nsroot y
1307 nseq x y = nsroot x == nsroot y
1298
1308
1299− enTacImp ql (TacImp aos st scr) = TacImp aos st (en ql scr)
1309+ enTacImp ql (TacImp aos st scr rig) = TacImp aos st (en ql scr) rig
1300− enTacImp ql other = other
1310+ enTacImp ql other = other
1301
1311
1302expandParamsD :: Bool -> -- True = RHS only
1312expandParamsD :: Bool -> -- True = RHS only
1303 IState ->
1313 IState ->
@@ -1465,10 +1475,10 @@ addStatics n tm ptm =
1465 putIState $ i { idris_statics = addDef n stpos (idris_statics i) }
1475 putIState $ i { idris_statics = addDef n stpos (idris_statics i) }
1466 addIBC (IBCStatic n)
1476 addIBC (IBCStatic n)
1467 where
1477 where
1468− initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc t s)
1478+ initStatics (Bind n (Pi _ _ ty _) sc) (PPi p n' fc t s)
1469 | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' fc t s) in
1479 | n /= n' = let (static, dynamic) = initStatics sc (PPi p n' fc t s) in
1470 (static, (n, ty) : dynamic)
1480 (static, (n, ty) : dynamic)
1471− initStatics (Bind n (Pi _ ty _) sc) (PPi p n' fc _ s)
1481+ initStatics (Bind n (Pi _ _ ty _) sc) (PPi p n' fc _ s)
1472 = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in
1482 = let (static, dynamic) = initStatics (instantiate (P Bound n ty) sc) s in
1473 if pstatic p == Static then ((n, ty) : static, dynamic)
1483 if pstatic p == Static then ((n, ty) : static, dynamic)
1474 else if (not (searchArg p))
1484 else if (not (searchArg p))
@@ -1484,16 +1494,16 @@ addStatics n tm ptm =
1484 getNamePos i ps (P _ n _ : as)
1494 getNamePos i ps (P _ n _ : as)
1485 | i `elem` ps = n : getNamePos (i + 1) ps as
1495 | i `elem` ps = n : getNamePos (i + 1) ps as
1486 getNamePos i ps (_ : as) = getNamePos (i + 1) ps as
1496 getNamePos i ps (_ : as) = getNamePos (i + 1) ps as
1487− getParamNames ist (Bind t (Pi _ (P _ n _) _) sc)
1497+ getParamNames ist (Bind t (Pi _ _ (P _ n _) _) sc)
1488 = n : getParamNames ist sc
1498 = n : getParamNames ist sc
1489 getParamNames ist _ = []
1499 getParamNames ist _ = []
1490
1500
1491− getNamesFrom i ps (Bind n (Pi _ _ _) sc)
1501+ getNamesFrom i ps (Bind n (Pi _ _ _ _) sc)
1492 | i `elem` ps = n : getNamesFrom (i + 1) ps sc
1502 | i `elem` ps = n : getNamesFrom (i + 1) ps sc
1493 | otherwise = getNamesFrom (i + 1) ps sc
1503 | otherwise = getNamesFrom (i + 1) ps sc
1494 getNamesFrom i ps sc = []
1504 getNamesFrom i ps sc = []
1495
1505
1496− freeArgNames (Bind n (Pi _ ty _) sc)
1506+ freeArgNames (Bind n (Pi _ _ ty _) sc)
1497 = nub $ freeNames ty ++ freeNames sc -- treat '->' as fn here
1507 = nub $ freeNames ty ++ freeNames sc -- treat '->' as fn here
1498 freeArgNames tm = let (_, args) = unApply tm in
1508 freeArgNames tm = let (_, args) = unApply tm in
1499 concatMap freeNames args
1509 concatMap freeNames args
@@ -1501,11 +1511,11 @@ addStatics n tm ptm =
1501 -- if a name appears in an interface or tactic implicit index, it doesn't
1511 -- if a name appears in an interface or tactic implicit index, it doesn't
1502 -- affect its 'uniquely inferrable' from a static status since these are
1512 -- affect its 'uniquely inferrable' from a static status since these are
1503 -- resolved by searching.
1513 -- resolved by searching.
1504− searchArg (Constraint _ _) = True
1514+ searchArg (Constraint _ _ _) = True
1505− searchArg (TacImp _ _ _) = True
1515+ searchArg (TacImp _ _ _ _) = True
1506 searchArg _ = False
1516 searchArg _ = False
1507
1517
1508− staticList sts (Bind n (Pi _ _ _) sc) = (n `elem` sts) : staticList sts sc
1518+ staticList sts (Bind n (Pi _ _ _ _) sc) = (n `elem` sts) : staticList sts sc
1509 staticList _ _ = []
1519 staticList _ _ = []
1510
1520
1511-- Dealing with implicit arguments
1521-- Dealing with implicit arguments
@@ -1537,14 +1547,14 @@ addUsingConstraints syn fc t
1537 -- if all of args in ns, then add it
1547 -- if all of args in ns, then add it
1538 doAdd (UConstraint c args : cs) ns t
1548 doAdd (UConstraint c args : cs) ns t
1539 | all (\n -> elem n ns) args
1549 | all (\n -> elem n ns) args
1540− = PPi (Constraint [] Dynamic) (sMN 0 "cu") NoFC
1550+ = PPi (Constraint [] Dynamic RigW) (sMN 0 "cu") NoFC
1541 (mkConst c args) (doAdd cs ns t)
1551 (mkConst c args) (doAdd cs ns t)
1542 | otherwise = doAdd cs ns t
1552 | otherwise = doAdd cs ns t
1543
1553
1544 mkConst c args = PApp fc (PRef fc [] c)
1554 mkConst c args = PApp fc (PRef fc [] c)
1545 (map (PExp 0 [] (sMN 0 "carg") . PRef fc []) args)
1555 (map (PExp 0 [] (sMN 0 "carg") . PRef fc []) args)
1546
1556
1547− getConstraints (PPi (Constraint _ _) _ _ c sc)
1557+ getConstraints (PPi (Constraint _ _ _) _ _ c sc)
1548 = getcapp c ++ getConstraints sc
1558 = getcapp c ++ getConstraints sc
1549 getConstraints (PPi _ _ _ c sc) = getConstraints sc
1559 getConstraints (PPi _ _ _ c sc) = getConstraints sc
1550 getConstraints _ = []
1560 getConstraints _ = []
@@ -1613,25 +1623,25 @@ getUnboundImplicits i t tm = getImps t (collectImps tm)
1613 scopedimpl (Just i) = not (toplevel_imp i)
1623 scopedimpl (Just i) = not (toplevel_imp i)
1614 scopedimpl _ = False
1624 scopedimpl _ = False
1615
1625
1616− getImps (Bind n (Pi i _ _) sc) imps
1626+ getImps (Bind n (Pi _ i _ _) sc) imps
1617 | scopedimpl i = getImps sc imps
1627 | scopedimpl i = getImps sc imps
1618− getImps (Bind n (Pi _ t _) sc) imps
1628+ getImps (Bind n (Pi _ _ t _) sc) imps
1619 | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps
1629 | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps
1620 where
1630 where
1621− argInfo n (Imp opt _ _ _ _) Placeholder
1631+ argInfo n (Imp opt _ _ _ _ _) Placeholder
1622 = (True, PImp 0 True opt n Placeholder)
1632 = (True, PImp 0 True opt n Placeholder)
1623− argInfo n (Imp opt _ _ _ _) t'
1633+ argInfo n (Imp opt _ _ _ _ _) t'
1624 = (False, PImp (getPriority i t') True opt n t')
1634 = (False, PImp (getPriority i t') True opt n t')
1625− argInfo n (Exp opt _ _) t'
1635+ argInfo n (Exp opt _ _ _) t'
1626 = (InaccessibleArg `elem` opt,
1636 = (InaccessibleArg `elem` opt,
1627 PExp (getPriority i t') opt n t')
1637 PExp (getPriority i t') opt n t')
1628− argInfo n (Constraint opt _) t'
1638+ argInfo n (Constraint opt _ _) t'
1629 = (InaccessibleArg `elem` opt,
1639 = (InaccessibleArg `elem` opt,
1630 PConstraint 10 opt n t')
1640 PConstraint 10 opt n t')
1631− argInfo n (TacImp opt _ scr) t'
1641+ argInfo n (TacImp opt _ scr _) t'
1632 = (InaccessibleArg `elem` opt,
1642 = (InaccessibleArg `elem` opt,
1633 PTacImplicit 10 opt n scr t')
1643 PTacImplicit 10 opt n scr t')
1634− getImps (Bind n (Pi _ t _) sc) imps = impBind n t : getImps sc imps
1644+ getImps (Bind n (Pi _ _ t _) sc) imps = impBind n t : getImps sc imps
1635 where impBind n t = (True, PImp 1 True [] n Placeholder)
1645 where impBind n t = (True, PImp 1 True [] n Placeholder)
1636 getImps sc tm = []
1646 getImps sc tm = []
1637
1647
@@ -1714,13 +1724,13 @@ implicitise auto syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $
1714 = do (decls, ns) <- get
1724 = do (decls, ns) <- get
1715 let isn = nub (implNamesIn uvars ty)
1725 let isn = nub (implNamesIn uvars ty)
1716 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1726 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1717− imps top env (PPi (Imp l _ _ _ _) n _ ty sc)
1727+ imps top env (PPi (Imp l _ _ _ _ _) n _ ty sc)
1718 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]
1728 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]
1719 (decls , ns) <- get
1729 (decls , ns) <- get
1720 put (PImp (getPriority ist ty) True l n Placeholder : decls,
1730 put (PImp (getPriority ist ty) True l n Placeholder : decls,
1721 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1731 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1722 imps True (n:env) sc
1732 imps True (n:env) sc
1723− imps top env (PPi (Exp l _ _) n _ ty sc)
1733+ imps top env (PPi (Exp l _ _ _) n _ ty sc)
1724 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1734 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1725 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1735 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1726 _ -> [])
1736 _ -> [])
@@ -1728,7 +1738,7 @@ implicitise auto syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $
1728 put (PExp (getPriority ist ty) l n Placeholder : decls,
1738 put (PExp (getPriority ist ty) l n Placeholder : decls,
1729 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1739 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1730 imps True (n:env) sc
1740 imps True (n:env) sc
1731− imps top env (PPi (Constraint l _) n _ ty sc)
1741+ imps top env (PPi (Constraint l _ _) n _ ty sc)
1732 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1742 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1733 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1743 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1734 _ -> [])
1744 _ -> [])
@@ -1736,7 +1746,7 @@ implicitise auto syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $
1736 put (PConstraint 10 l n Placeholder : decls,
1746 put (PConstraint 10 l n Placeholder : decls,
1737 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1747 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))
1738 imps True (n:env) sc
1748 imps True (n:env) sc
1739− imps top env (PPi (TacImp l _ scr) n _ ty sc)
1749+ imps top env (PPi (TacImp l _ scr _) n _ ty sc)
1740 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1750 = do let isn = nub (implNamesIn uvars ty ++ case sc of
1741 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1751 (PRef _ _ x) -> namesIn uvars ist sc `dropAll` [n]
1742 _ -> [])
1752 _ -> [])
@@ -2136,7 +2146,7 @@ stripUnmatchable :: IState -> PTerm -> PTerm
2136stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where
2146stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where
2137 su :: PTerm -> PTerm
2147 su :: PTerm -> PTerm
2138 su tm@(PRef fc hl f)
2148 su tm@(PRef fc hl f)
2139− | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)
2149+ | (Bind n (Pi _ _ t _) sc :_) <- lookupTy f (tt_ctxt i)
2140 = Placeholder
2150 = Placeholder
2141 | (TType _ : _) <- lookupTy f (tt_ctxt i),
2151 | (TType _ : _) <- lookupTy f (tt_ctxt i),
2142 not (implicitable f)
2152 not (implicitable f)
src/Idris/AbsSyntaxTree.hs+48−27
@@ -91,7 +91,7 @@ data IOption = IOption {
91 , opt_showimp :: Bool -- ^ show implicits
91 , opt_showimp :: Bool -- ^ show implicits
92 , opt_errContext :: Bool
92 , opt_errContext :: Bool
93 , opt_repl :: Bool
93 , opt_repl :: Bool
94− , opt_verbose :: Bool
94+ , opt_verbose :: Int
95 , opt_nobanner :: Bool
95 , opt_nobanner :: Bool
96 , opt_quiet :: Bool
96 , opt_quiet :: Bool
97 , opt_codegen :: Codegen
97 , opt_codegen :: Codegen
@@ -120,7 +120,7 @@ defaultOpts = IOption { opt_logLevel = 0
120 , opt_showimp = False
120 , opt_showimp = False
121 , opt_errContext = False
121 , opt_errContext = False
122 , opt_repl = True
122 , opt_repl = True
123− , opt_verbose = True
123+ , opt_verbose = 0
124 , opt_nobanner = False
124 , opt_nobanner = False
125 , opt_quiet = False
125 , opt_quiet = False
126 , opt_codegen = Via IBCFormat "c"
126 , opt_codegen = Via IBCFormat "c"
@@ -184,7 +184,9 @@ ppOption opt = PPOption {
184ppOptionIst :: IState -> PPOption
184ppOptionIst :: IState -> PPOption
185ppOptionIst = ppOption . idris_options
185ppOptionIst = ppOption . idris_options
186
186
187−data LanguageExt = TypeProviders | ErrorReflection
187+data LanguageExt = TypeProviders | ErrorReflection | UniquenessTypes
188+ | DSLNotation | ElabReflection | FCReflection
189+ | LinearTypes
188 deriving (Show, Eq, Read, Ord, Generic)
190 deriving (Show, Eq, Read, Ord, Generic)
189
191
190-- | The output mode in use
192-- | The output mode in use
@@ -335,6 +337,7 @@ primDefs = [ sUN "unsafePerformPrimIO"
335 , sUN "mkForeignPrim"
337 , sUN "mkForeignPrim"
336 , sUN "void"
338 , sUN "void"
337 , sUN "assert_unreachable"
339 , sUN "assert_unreachable"
340+ , sUN "idris_crash"
338 ]
341 ]
339
342
340-- information that needs writing for the current module's .ibc file
343-- information that needs writing for the current module's .ibc file
@@ -510,7 +513,7 @@ data Opt = Filename String
510 | NoCoverage
513 | NoCoverage
511 | ErrContext
514 | ErrContext
512 | ShowImpl
515 | ShowImpl
513− | Verbose
516+ | Verbose Int
514 | Port REPLPort -- ^ REPL TCP port
517 | Port REPLPort -- ^ REPL TCP port
515 | IBCSubDir String
518 | IBCSubDir String
516 | ImportDir String
519 | ImportDir String
@@ -597,17 +600,21 @@ data Plicity = Imp { pargopts :: [ArgOpt]
597 , pparam :: Bool
600 , pparam :: Bool
598 , pscoped :: Maybe ImplicitInfo -- ^ Nothing, if top level
601 , pscoped :: Maybe ImplicitInfo -- ^ Nothing, if top level
599 , pinsource :: Bool -- ^ Explicitly written in source
602 , pinsource :: Bool -- ^ Explicitly written in source
603+ , pcount :: RigCount
600 }
604 }
601 | Exp { pargopts :: [ArgOpt]
605 | Exp { pargopts :: [ArgOpt]
602 , pstatic :: Static
606 , pstatic :: Static
603 , pparam :: Bool -- ^ this is a param (rather than index)
607 , pparam :: Bool -- ^ this is a param (rather than index)
608+ , pcount :: RigCount
604 }
609 }
605 | Constraint { pargopts :: [ArgOpt]
610 | Constraint { pargopts :: [ArgOpt]
606− , pstatic :: Static
611+ , pstatic :: Static
612+ , pcount :: RigCount
607 }
613 }
608 | TacImp { pargopts :: [ArgOpt]
614 | TacImp { pargopts :: [ArgOpt]
609 , pstatic :: Static
615 , pstatic :: Static
610 , pscript :: PTerm
616 , pscript :: PTerm
617+ , pcount :: RigCount
611 }
618 }
612 deriving (Show, Eq, Ord, Data, Generic, Typeable)
619 deriving (Show, Eq, Ord, Data, Generic, Typeable)
613
620
@@ -616,24 +623,24 @@ deriving instance Binary Plicity
616!-}
623!-}
617
624
618is_scoped :: Plicity -> Maybe ImplicitInfo
625is_scoped :: Plicity -> Maybe ImplicitInfo
619−is_scoped (Imp _ _ _ s _) = s
626+is_scoped (Imp _ _ _ s _ _) = s
620−is_scoped _ = Nothing
627+is_scoped _ = Nothing
621
628
622-- Top level implicit
629-- Top level implicit
623−impl = Imp [] Dynamic False (Just (Impl False True False)) False
630+impl = Imp [] Dynamic False (Just (Impl False True False)) False RigW
624-- Machine generated top level implicit
631-- Machine generated top level implicit
625−impl_gen = Imp [] Dynamic False (Just (Impl False True True)) False
632+impl_gen = Imp [] Dynamic False (Just (Impl False True True)) False RigW
626
633
627-- Scoped implicits
634-- Scoped implicits
628−forall_imp = Imp [] Dynamic False (Just (Impl False False True)) False
635+forall_imp = Imp [] Dynamic False (Just (Impl False False True)) False RigW
629−forall_constraint = Imp [] Dynamic False (Just (Impl True False True)) False
636+forall_constraint = Imp [] Dynamic False (Just (Impl True False True)) False RigW
630
637
631−expl = Exp [] Dynamic False
638+expl = Exp [] Dynamic False RigW
632−expl_param = Exp [] Dynamic True
639+expl_param = Exp [] Dynamic True RigW
633
640
634−constraint = Constraint [] Static
641+constraint = Constraint [] Static RigW
635
642
636−tacimpl t = TacImp [] Dynamic t
643+tacimpl t = TacImp [] Dynamic t RigW
637
644
638data FnOpt = Inlinable -- ^ always evaluate when simplifying
645data FnOpt = Inlinable -- ^ always evaluate when simplifying
639 | TotalFn | PartialFn | CoveringFn
646 | TotalFn | PartialFn | CoveringFn
@@ -1617,8 +1624,8 @@ getInferTerm (App _ (App _ _ _) tm) = tm
1617getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)
1624getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)
1618
1625
1619getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc
1626getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc
1620− where toTy (Lam t) = Pi Nothing t (TType (UVar [] 0))
1627+ where toTy (Lam r t) = Pi r Nothing t (TType (UVar [] 0))
1621− toTy (PVar t) = PVTy t
1628+ toTy (PVar _ t) = PVTy t
1622 toTy b = b
1629 toTy b = b
1623getInferType (App _ (App _ _ ty) _) = ty
1630getInferType (App _ (App _ _ ty) _) = ty
1624
1631
@@ -1813,7 +1820,15 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd
1813 depth d . bracket p startPrec . group . align $
1820 depth d . bracket p startPrec . group . align $
1814 kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe (decD d) startPrec bnd v) </>
1821 kwd "let" <+> (group . align . hang 2 $ prettyBindingOf n False <+> text "=" <$> prettySe (decD d) startPrec bnd v) </>
1815 kwd "in" <+> (group . align . hang 2 $ prettySe (decD d) startPrec ((n, False):bnd) sc)
1822 kwd "in" <+> (group . align . hang 2 $ prettySe (decD d) startPrec ((n, False):bnd) sc)
1816− prettySe d p bnd (PPi (Exp l s _) n _ ty sc)
1823+ prettySe d p bnd (PPi (Exp l s _ rig) n _ ty sc)
1824+ | Rig0 <- rig =
1825+ depth d . bracket p startPrec . group $
1826+ enclose lparen rparen (group . align $ text "0" <+> prettyBindingOf n False <+> colon <+> prettySe (decD d) startPrec bnd ty) <+>
1827+ st <> text "->" <$> prettySe (decD d) startPrec ((n, False):bnd) sc
1828+ | Rig1 <- rig =
1829+ depth d . bracket p startPrec . group $
1830+ enclose lparen rparen (group . align $ text "1" <+> prettyBindingOf n False <+> colon <+> prettySe (decD d) startPrec bnd ty) <+>
1831+ st <> text "->" <$> prettySe (decD d) startPrec ((n, False):bnd) sc
1817 | n `elem` allNamesIn sc || ppopt_impl ppo && uname n || n `elem` docArgs
1832 | n `elem` allNamesIn sc || ppopt_impl ppo && uname n || n `elem` docArgs
1818 || ppopt_pinames ppo && uname n =
1833 || ppopt_pinames ppo && uname n =
1819 depth d . bracket p startPrec . group $
1834 depth d . bracket p startPrec . group $
@@ -1833,24 +1848,28 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd
1833 case s of
1848 case s of
1834 Static -> text "%static" <> space
1849 Static -> text "%static" <> space
1835 _ -> empty
1850 _ -> empty
1836− prettySe d p bnd (PPi (Imp l s _ fa _) n _ ty sc)
1851+ prettySe d p bnd (PPi (Imp l s _ fa _ rig) n _ ty sc)
1837 | ppopt_impl ppo =
1852 | ppopt_impl ppo =
1838 depth d . bracket p startPrec $
1853 depth d . bracket p startPrec $
1839− lbrace <> prettyBindingOf n True <+> colon <+> prettySe (decD d) startPrec bnd ty <> rbrace <+>
1854+ lbrace <> showRig rig n <+> colon <+> prettySe (decD d) startPrec bnd ty <> rbrace <+>
1840 st <> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1855 st <> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1841 | otherwise = depth d $ prettySe (decD d) startPrec ((n, True):bnd) sc
1856 | otherwise = depth d $ prettySe (decD d) startPrec ((n, True):bnd) sc
1842 where
1857 where
1858+ showRig Rig0 n = text "0" <+> prettyBindingOf n True
1859+ showRig Rig1 n = text "1" <+> prettyBindingOf n True
1860+ showRig _ n = prettyBindingOf n True
1861+
1843 st =
1862 st =
1844 case s of
1863 case s of
1845 Static -> text "%static" <> space
1864 Static -> text "%static" <> space
1846 _ -> empty
1865 _ -> empty
1847− prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =
1866+ prettySe d p bnd (PPi (Constraint _ _ rig) n _ ty sc) =
1848 depth d . bracket p startPrec $
1867 depth d . bracket p startPrec $
1849 prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1868 prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1850− prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch{}])) n _ ty sc) =
1869+ prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch{}]) rig) n _ ty sc) =
1851 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>
1870 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>
1852 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1871 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1853− prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =
1872+ prettySe d p bnd (PPi (TacImp _ _ s rig) n _ ty sc) =
1854 depth d . bracket p startPrec $
1873 depth d . bracket p startPrec $
1855 lbrace <> kwd "default" <+> prettySe (decD d) (funcAppPrec + 1) bnd s <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>
1874 lbrace <> kwd "default" <+> prettySe (decD d) (funcAppPrec + 1) bnd s <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>
1856 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
1875 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc
@@ -2378,7 +2397,7 @@ allNamesIn tm = nub $ ni 0 [] tm
2378 ni i env (PUnquote tm) = ni (i - 1) env tm
2397 ni i env (PUnquote tm) = ni (i - 1) env tm
2379 ni i env tm = concatMap (ni i env) (children tm)
2398 ni i env tm = concatMap (ni i env) (children tm)
2380
2399
2381− niTacImp i env (TacImp _ _ scr) = ni i env scr
2400+ niTacImp i env (TacImp _ _ scr _) = ni i env scr
2382 niTacImp _ _ _ = []
2401 niTacImp _ _ _ = []
2383
2402
2384
2403
@@ -2414,7 +2433,7 @@ boundNamesIn tm = S.toList (ni 0 S.empty tm)
2414 niTms i set [] = set
2433 niTms i set [] = set
2415 niTms i set (x : xs) = niTms i (ni i set x) xs
2434 niTms i set (x : xs) = niTms i (ni i set x) xs
2416
2435
2417− niTacImp i set (TacImp _ _ scr) = ni i set scr
2436+ niTacImp i set (TacImp _ _ scr _) = ni i set scr
2418 niTacImp i set _ = set
2437 niTacImp i set _ = set
2419
2438
2420-- Return names which are valid implicits in the given term (type).
2439-- Return names which are valid implicits in the given term (type).
@@ -2470,6 +2489,8 @@ implicitNamesIn uvars ist tm
2470 ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]
2489 ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]
2471 ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc
2490 ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc
2472 ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc
2491 ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc
2492+ ni 0 env (PLet fc n _ ty val sc) = do ni 0 env ty;
2493+ ni 0 env val; ni 0 (n:env) sc
2473 ni 0 env (PRewrite _ _ l r _) = do ni 0 env l; ni 0 env r
2494 ni 0 env (PRewrite _ _ l r _) = do ni 0 env l; ni 0 env r
2474 ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r
2495 ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r
2475 ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r
2496 ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r
@@ -2523,7 +2544,7 @@ namesIn uvars ist tm = nub $ ni 0 [] tm
2523
2544
2524 ni i env tm = concatMap (ni i env) (children tm)
2545 ni i env tm = concatMap (ni i env) (children tm)
2525
2546
2526− niTacImp i env (TacImp _ _ scr) = ni i env scr
2547+ niTacImp i env (TacImp _ _ scr _) = ni i env scr
2527 niTacImp _ _ _ = []
2548 niTacImp _ _ _ = []
2528
2549
2529-- Return which of the given names are used in the given term.
2550-- Return which of the given names are used in the given term.
@@ -2558,7 +2579,7 @@ usedNamesIn vars ist tm = nub $ ni 0 [] tm
2558
2579
2559 ni i env tm = concatMap (ni i env) (children tm)
2580 ni i env tm = concatMap (ni i env) (children tm)
2560
2581
2561− niTacImp i env (TacImp _ _ scr) = ni i env scr
2582+ niTacImp i env (TacImp _ _ scr _) = ni i env scr
2562 niTacImp _ _ _ = []
2583 niTacImp _ _ _ = []
2563
2584
2564-- Return the list of inaccessible (= dotted) positions for a name.
2585-- Return the list of inaccessible (= dotted) positions for a name.
src/Idris/Apropos.hs+2−2
@@ -72,8 +72,8 @@ instance Apropos Def where
72 isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty
72 isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty
73
73
74instance Apropos (Binder (TT Name)) where
74instance Apropos (Binder (TT Name)) where
75− isApropos str (Lam ty) = str == T.pack "\\" || isApropos str ty
75+ isApropos str (Lam _ ty) = str == T.pack "\\" || isApropos str ty
76− isApropos str (Pi _ ty _) = str == T.pack "->" || isApropos str ty
76+ isApropos str (Pi _ _ ty _) = str == T.pack "->" || isApropos str ty
77 isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val
77 isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val
78 isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val
78 isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val
79 isApropos str _ = False -- these shouldn't occur in defined libraries
79 isApropos str _ = False -- these shouldn't occur in defined libraries
src/Idris/CaseSplit.hs+4−4
@@ -212,7 +212,7 @@ argTys ist (PRef fc hls n)
212 [ty] -> let ty' = normalise (tt_ctxt ist) [] ty in
212 [ty] -> let ty' = normalise (tt_ctxt ist) [] ty in
213 map (tyName . snd) (getArgTys ty') ++ repeat Nothing
213 map (tyName . snd) (getArgTys ty') ++ repeat Nothing
214 _ -> repeat Nothing
214 _ -> repeat Nothing
215− where tyName (Bind _ (Pi _ _ _) _) = Just (sUN "->")
215+ where tyName (Bind _ (Pi _ _ _ _) _) = Just (sUN "->")
216 tyName t | (P _ d _, [_, ty]) <- unApply t,
216 tyName t | (P _ d _, [_, ty]) <- unApply t,
217 d == sUN "Delayed" = tyName ty
217 d == sUN "Delayed" = tyName ty
218 | (P _ n _, _) <- unApply t = Just n
218 | (P _ n _, _) <- unApply t = Just n
@@ -408,14 +408,14 @@ getClause l fn un fp
408 return (showLHSName un ++ " " ++ ap ++ "= ?"
408 return (showLHSName un ++ " " ++ ap ++ "= ?"
409 ++ showRHSName un ++ "_rhs")
409 ++ showRHSName un ++ "_rhs")
410 where mkApp :: IState -> PTerm -> [Name] -> String
410 where mkApp :: IState -> PTerm -> [Name] -> String
411− mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used
411+ mkApp i (PPi (Exp _ _ False _) (MN _ _) _ ty sc) used
412 = let n = getNameFrom i used ty in
412 = let n = getNameFrom i used ty in
413 show n ++ " " ++ mkApp i sc (n : used)
413 show n ++ " " ++ mkApp i sc (n : used)
414− mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used
414+ mkApp i (PPi (Exp _ _ False _) (UN n) _ ty sc) used
415 | thead n == '_'
415 | thead n == '_'
416 = let n = getNameFrom i used ty in
416 = let n = getNameFrom i used ty in
417 show n ++ " " ++ mkApp i sc (n : used)
417 show n ++ " " ++ mkApp i sc (n : used)
418− mkApp i (PPi (Exp _ _ False) n _ _ sc) used
418+ mkApp i (PPi (Exp _ _ False _) n _ _ sc) used
419 = show n ++ " " ++ mkApp i sc (n : used)
419 = show n ++ " " ++ mkApp i sc (n : used)
420 mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used
420 mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used
421 mkApp i _ _ = ""
421 mkApp i _ _ = ""
src/Idris/CmdOptions.hs+3−1
@@ -134,7 +134,9 @@ parseFlags = many $
134 <|> flag' ShowDocDir (long "docdir" <> help "Display idrisdoc install directory")
134 <|> flag' ShowDocDir (long "docdir" <> help "Display idrisdoc install directory")
135 <|> flag' ShowIncs (long "include" <> help "Display the includes flags")
135 <|> flag' ShowIncs (long "include" <> help "Display the includes flags")
136
136
137+ <|> flag' (Verbose 3) (long "V2" <> help "Loudest verbosity")
138+ <|> flag' (Verbose 2) (long "V1" <> help "Louder verbosity")
137− <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")
139+ <|> flag' (Verbose 1) (short 'V' <> long "V0" <>long "verbose" <> help "Loud verbosity")
138
140
139 <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))
141 <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))
140 <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))
142 <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))
src/Idris/Core/Binary.hs+31−11
@@ -490,6 +490,19 @@ instance Binary Raw where
490 return (RUType x1)
490 return (RUType x1)
491 _ -> error "Corrupted binary data for Raw"
491 _ -> error "Corrupted binary data for Raw"
492
492
493+instance Binary RigCount where
494+ put x = case x of
495+ Rig0 -> putWord8 0
496+ Rig1 -> putWord8 1
497+ RigW -> putWord8 2
498+ get = do i <- getWord8
499+ case i of
500+ 0 -> return Rig0
501+ 1 -> return Rig1
502+ 2 -> return RigW
503+ _ -> error "Corrupted binary data for RigCount"
504+
505+
493instance Binary ImplicitInfo where
506instance Binary ImplicitInfo where
494 put x
507 put x
495 = case x of
508 = case x of
@@ -502,12 +515,14 @@ instance Binary ImplicitInfo where
502instance (Binary b) => Binary (Binder b) where
515instance (Binary b) => Binary (Binder b) where
503 put x
516 put x
504 = case x of
517 = case x of
505− Lam x1 -> do putWord8 0
518+ Lam x1 x2 -> do putWord8 0
506− put x1
519+ put x1
520+ put x2
507− Pi x1 x2 x3 -> do putWord8 1
521+ Pi x1 x2 x3 x4 -> do putWord8 1
508− put x1
522+ put x1
509− put x2
523+ put x2
510− put x3
524+ put x3
525+ put x4
511 Let x1 x2 -> do putWord8 2
526 Let x1 x2 -> do putWord8 2
512 put x1
527 put x1
513 put x2
528 put x2
@@ -523,19 +538,22 @@ instance (Binary b) => Binary (Binder b) where
523 Guess x1 x2 -> do putWord8 6
538 Guess x1 x2 -> do putWord8 6
524 put x1
539 put x1
525 put x2
540 put x2
526− PVar x1 -> do putWord8 7
541+ PVar x1 x2 -> do putWord8 7
527− put x1
542+ put x1
543+ put x2
528 PVTy x1 -> do putWord8 8
544 PVTy x1 -> do putWord8 8
529 put x1
545 put x1
530 get
546 get
531 = do i <- getWord8
547 = do i <- getWord8
532 case i of
548 case i of
533 0 -> do x1 <- get
549 0 -> do x1 <- get
550+ x2 <- get
534− return (Lam x1)
551+ return (Lam x1 x2)
535 1 -> do x1 <- get
552 1 -> do x1 <- get
536 x2 <- get
553 x2 <- get
537 x3 <- get
554 x3 <- get
555+ x4 <- get
538− return (Pi x1 x2 x3)
556+ return (Pi x1 x2 x3 x4)
539 2 -> do x1 <- get
557 2 -> do x1 <- get
540 x2 <- get
558 x2 <- get
541 return (Let x1 x2)
559 return (Let x1 x2)
@@ -552,7 +570,8 @@ instance (Binary b) => Binary (Binder b) where
552 x2 <- get
570 x2 <- get
553 return (Guess x1 x2)
571 return (Guess x1 x2)
554 7 -> do x1 <- get
572 7 -> do x1 <- get
573+ x2 <- get
555− return (PVar x1)
574+ return (PVar x1 x2)
556 8 -> do x1 <- get
575 8 -> do x1 <- get
557 return (PVTy x1)
576 return (PVTy x1)
558 _ -> error "Corrupted binary data for Binder"
577 _ -> error "Corrupted binary data for Binder"
@@ -639,6 +658,7 @@ instance {- (Binary n) => -} Binary (TT Name) where
639 TType x1 -> do putWord8 7
658 TType x1 -> do putWord8 7
640 put x1
659 put x1
641 Impossible -> putWord8 8
660 Impossible -> putWord8 8
661+ Inferred x1 -> put x1 -- drop the 'Inferred'
642 UType x1 -> do putWord8 10
662 UType x1 -> do putWord8 10
643 put x1
663 put x1
644 get
664 get
src/Idris/Core/CaseTree.hs+63−7
@@ -244,14 +244,18 @@ type CaseBuilder a = ReaderT ErasureInfo (State CS) a
244runCaseBuilder :: ErasureInfo -> CaseBuilder a -> (CS -> (a, CS))
244runCaseBuilder :: ErasureInfo -> CaseBuilder a -> (CS -> (a, CS))
245runCaseBuilder ei bld = runState $ runReaderT bld ei
245runCaseBuilder ei bld = runState $ runReaderT bld ei
246
246
247+data Phase = CoverageCheck [Int] -- list of positions explicitly given
247−data Phase = CompileTime | RunTime
248+ | CompileTime
249+ | RunTime
248 deriving (Show, Eq)
250 deriving (Show, Eq)
249
251
250-- Generate a simple case tree
252-- Generate a simple case tree
251-- Work Right to Left
253-- Work Right to Left
252
254
253simpleCase :: Bool -> SC -> Bool ->
255simpleCase :: Bool -> SC -> Bool ->
254− Phase -> FC -> [Int] ->
256+ Phase -> FC ->
257+ -- Following two can be empty lists when Phase = CoverageCheck
258+ [Int] -> -- Inaccessible argument positions
255 [(Type, Bool)] -> -- (Argument type, whether it's canonical)
259 [(Type, Bool)] -> -- (Argument type, whether it's canonical)
256 [([Name], Term, Term)] ->
260 [([Name], Term, Term)] ->
257 ErasureInfo ->
261 ErasureInfo ->
@@ -291,7 +295,7 @@ simpleCase tc defcase reflect phase fc inacc argtys cs erInfo
291 -- Check that all pattern variables are reachable by a case split
295 -- Check that all pattern variables are reachable by a case split
292 -- Otherwise, they won't make sense on the RHS.
296 -- Otherwise, they won't make sense on the RHS.
293 chkAccessible (avs, l, c)
297 chkAccessible (avs, l, c)
294− | phase == RunTime || reflect = return (l, c)
298+ | phase /= CompileTime || reflect = return (l, c)
295 | otherwise = do mapM_ (acc l) avs
299 | otherwise = do mapM_ (acc l) avs
296 return (l, c)
300 return (l, c)
297
301
@@ -345,6 +349,7 @@ isConstType _ _ = False
345
349
346data Pat = PCon Bool Name Int [Pat]
350data Pat = PCon Bool Name Int [Pat]
347 | PConst Const
351 | PConst Const
352+ | PInferred Pat
348 | PV Name Type
353 | PV Name Type
349 | PSuc Pat -- special case for n+1 on Integer
354 | PSuc Pat -- special case for n+1 on Integer
350 | PReflected Name [Pat]
355 | PReflected Name [Pat]
@@ -383,10 +388,11 @@ toPat reflect tc = map $ toPat' []
383
388
384 toPat' [] (P Bound n ty) = PV n ty
389 toPat' [] (P Bound n ty) = PV n ty
385 toPat' args (App _ f a) = toPat' (a : args) f
390 toPat' args (App _ f a) = toPat' (a : args) f
391+ toPat' args (Inferred tm) = PInferred (toPat' args tm)
386 toPat' [] (Constant x) | isTypeConst x = PTyPat
392 toPat' [] (Constant x) | isTypeConst x = PTyPat
387 | otherwise = PConst x
393 | otherwise = PConst x
388
394
389− toPat' [] (Bind n (Pi _ t _) sc)
395+ toPat' [] (Bind n (Pi _ _ t _) sc)
390 | reflect && noOccurrence n sc
396 | reflect && noOccurrence n sc
391 = PReflected (sUN "->") [toPat' [] t, toPat' [] sc]
397 = PReflected (sUN "->") [toPat' [] t, toPat' [] sc]
392
398
@@ -438,6 +444,20 @@ order :: Phase -> [(Name, Bool)] -> [Clause] -> [Bool] -> ([Name], [Clause])
438-- order CompileTime ns cs _ = (map fst ns, cs)
444-- order CompileTime ns cs _ = (map fst ns, cs)
439order _ [] cs cans = ([], cs)
445order _ [] cs cans = ([], cs)
440order _ ns' [] cans = (map fst ns', [])
446order _ ns' [] cans = (map fst ns', [])
447+order (CoverageCheck pos) ns' cs cans
448+ = let ns_out = pick 0 [] (map fst ns')
449+ cs_out = map pickClause cs in
450+ (ns_out, cs_out)
451+ where
452+ pickClause (pats, def) = (pick 0 [] pats, def)
453+
454+ -- Order the list so that things in a position in 'pos' are in the first
455+ -- part, then all the other things later. Otherwise preserve order.
456+ pick i skipped [] = reverse skipped
457+ pick i skipped (x : xs)
458+ | i `elem` pos = x : pick (i + 1) skipped xs
459+ | otherwise = pick (i + 1) (x : skipped) xs
460+
441order phase ns' cs cans
461order phase ns' cs cans
442 = let patnames = transpose (map (zip ns') (map (zip cans) (map fst cs)))
462 = let patnames = transpose (map (zip ns') (map (zip cans) (map fst cs)))
443 -- only sort the arguments where there is no clash in
463 -- only sort the arguments where there is no clash in
@@ -484,6 +504,41 @@ order phase ns' cs cans
484 numNames xs (_ : ps) = numNames xs ps
504 numNames xs (_ : ps) = numNames xs ps
485 numNames xs [] = length xs
505 numNames xs [] = length xs
486
506
507+-- Reorder the patterns in the clause so that the PInferred patterns come
508+-- last. Also strip 'PInferred' from the top level patterns so that we can
509+-- go ahead and match.
510+orderByInf :: [Name] -> [Clause] -> ([Name], [Clause])
511+orderByInf vs cs = let alwaysInf = getInf cs in
512+ (selectInf alwaysInf vs,
513+ map deInf (map (selectExp alwaysInf) cs))
514+ where
515+ getInf [] = []
516+ getInf [(pats, def)] = infPos 0 pats
517+ getInf ((pats, def) : cs) = infPos 0 pats `intersect` getInf cs
518+
519+ selectExp :: [Int] -> Clause -> Clause
520+ selectExp infs (pats, def)
521+ = let (notInf, inf) = splitPats 0 infs [] [] pats in
522+ (notInf ++ inf, def)
523+
524+ selectInf :: [Int] -> [a] -> [a]
525+ selectInf infs ns = let (notInf, inf) = splitPats 0 infs [] [] ns in
526+ notInf ++ inf
527+
528+ splitPats i infpos notInf inf [] = (reverse notInf, reverse inf)
529+ splitPats i infpos notInf inf (p : ps)
530+ | i `elem` infpos = splitPats (i + 1) infpos notInf (p : inf) ps
531+ | otherwise = splitPats (i + 1) infpos (p : notInf) inf ps
532+
533+ infPos i [] = []
534+ infPos i (PInferred p : ps) = i : infPos (i + 1) ps
535+ infPos i (_ : ps) = infPos (i + 1) ps
536+
537+ deInf (pats, def) = (map deInfPat pats, def)
538+
539+ deInfPat (PInferred p) = p
540+ deInfPat p = p
541+
487match :: [Name] -> [Clause] -> SC -- error case
542match :: [Name] -> [Clause] -> SC -- error case
488 -> CaseBuilder SC
543 -> CaseBuilder SC
489match [] (([], ret) : xs) err
544match [] (([], ret) : xs) err
@@ -492,8 +547,9 @@ match [] (([], ret) : xs) err
492 case snd ret of
547 case snd ret of
493 Impossible -> return ImpossibleCase
548 Impossible -> return ImpossibleCase
494 tm -> return $ STerm tm -- run out of arguments
549 tm -> return $ STerm tm -- run out of arguments
495−match vs cs err = do let ps = partition cs
550+match vs cs err = do let (vs', de_inf) = orderByInf vs cs
551+ ps = partition de_inf
496− mixture vs ps err
552+ mixture vs' ps err
497
553
498mixture :: [Name] -> [Partition] -> SC -> CaseBuilder SC
554mixture :: [Name] -> [Partition] -> SC -> CaseBuilder SC
499mixture vs [] err = return err
555mixture vs [] err = return err
@@ -767,7 +823,7 @@ prune proj (Case up n alts) = case alts' of
767prune _ t = t
823prune _ t = t
768
824
769stripLambdas :: CaseDef -> CaseDef
825stripLambdas :: CaseDef -> CaseDef
770−stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)
826+stripLambdas (CaseDef ns (STerm (Bind x (Lam _ _) sc)) tm)
771 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)
827 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)
772stripLambdas x = x
828stripLambdas x = x
773
829
src/Idris/Core/DeepSeq.hs+1
@@ -40,6 +40,7 @@ instance NFData ConstraintFC
40instance NFData Err
40instance NFData Err
41instance NFData ErrorReportPart
41instance NFData ErrorReportPart
42instance NFData ImplicitInfo
42instance NFData ImplicitInfo
43+instance NFData RigCount
43instance (NFData b) => NFData (Binder b)
44instance (NFData b) => NFData (Binder b)
44instance NFData UExp
45instance NFData UExp
45instance NFData NameType
46instance NFData NameType
src/Idris/Core/Elaborate.hs+39−36
@@ -24,6 +24,7 @@ import Idris.Core.ProofTerm (bound_in, bound_in_term, getProofTerm, mkProofTerm,
24import Idris.Core.TT
24import Idris.Core.TT
25import Idris.Core.Typecheck
25import Idris.Core.Typecheck
26import Idris.Core.Unify
26import Idris.Core.Unify
27+import Idris.Core.WHNF
27
28
28import Util.Pretty hiding (fill)
29import Util.Pretty hiding (fill)
29
30
@@ -98,7 +99,7 @@ setNextName :: Elab' aux ()
98setNextName = do env <- get_env
99setNextName = do env <- get_env
99 ES (p, a) s e <- get
100 ES (p, a) s e <- get
100 let pargs = map fst (getArgTys (ptype p))
101 let pargs = map fst (getArgTys (ptype p))
101− initNextNameFrom (pargs ++ map fst env)
102+ initNextNameFrom (pargs ++ map fstEnv env)
102
103
103initNextNameFrom :: [Name] -> Elab' aux ()
104initNextNameFrom :: [Name] -> Elab' aux ()
104initNextNameFrom ns = do ES (p, a) s e <- get
105initNextNameFrom ns = do ES (p, a) s e <- get
@@ -326,7 +327,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context
326 isInj ctxt (App _ f a) = isInj ctxt f
327 isInj ctxt (App _ f a) = isInj ctxt f
327 isInj ctxt (Constant _) = True
328 isInj ctxt (Constant _) = True
328 isInj ctxt (TType _) = True
329 isInj ctxt (TType _) = True
329− isInj ctxt (Bind _ (Pi _ _ _) sc) = True
330+ isInj ctxt (Bind _ (Pi _ _ _ _) sc) = True
330 isInj ctxt _ = False
331 isInj ctxt _ = False
331
332
332-- | get implementation argument names
333-- | get implementation argument names
@@ -422,8 +423,11 @@ computeLet n = processTactic' (ComputeLet n)
422simplify :: Elab' aux ()
423simplify :: Elab' aux ()
423simplify = processTactic' Simplify
424simplify = processTactic' Simplify
424
425
425−hnf_compute :: Elab' aux ()
426+whnf_compute :: Elab' aux ()
426−hnf_compute = processTactic' HNF_Compute
427+whnf_compute = processTactic' WHNF_Compute
428+
429+whnf_compute_args :: Elab' aux ()
430+whnf_compute_args = processTactic' WHNF_ComputeArgs
427
431
428eval_in :: Raw -> Elab' aux ()
432eval_in :: Raw -> Elab' aux ()
429eval_in t = processTactic' (EvalIn t)
433eval_in t = processTactic' (EvalIn t)
@@ -437,8 +441,8 @@ intro n = processTactic' (Intro n)
437introTy :: Raw -> Maybe Name -> Elab' aux ()
441introTy :: Raw -> Maybe Name -> Elab' aux ()
438introTy ty n = processTactic' (IntroTy ty n)
442introTy ty n = processTactic' (IntroTy ty n)
439
443
440−forall :: Name -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
444+forall :: Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
441−forall n i t = processTactic' (Forall n i t)
445+forall n r i t = processTactic' (Forall n r i t)
442
446
443letbind :: Name -> Raw -> Raw -> Elab' aux ()
447letbind :: Name -> Raw -> Raw -> Elab' aux ()
444letbind n t v = processTactic' (LetBind n t v)
448letbind n t v = processTactic' (LetBind n t v)
@@ -459,18 +463,17 @@ equiv :: Raw -> Elab' aux ()
459equiv tm = processTactic' (Equiv tm)
463equiv tm = processTactic' (Equiv tm)
460
464
461-- | Turn the current hole into a pattern variable with the provided
465-- | Turn the current hole into a pattern variable with the provided
462−-- name, made unique if MN
466+-- name, made unique if not the same as the head of the hole queue
463patvar :: Name -> Elab' aux ()
467patvar :: Name -> Elab' aux ()
464patvar n@(SN _) = do apply (Var n) []; solve
468patvar n@(SN _) = do apply (Var n) []; solve
465patvar n = do env <- get_env
469patvar n = do env <- get_env
466 hs <- get_holes
470 hs <- get_holes
467− if (n `elem` map fst env) then do apply (Var n) []; solve
471+ if (n `elem` map fstEnv env) then do apply (Var n) []; solve
468− else do n' <- case n of
472+ else do n' <- case hs of
469− UN _ -> return $! n
473+ (h : hs) -> if n == h then return n
470− MN _ _ -> unique_hole n
474+ else unique_hole n
471− NS _ _ -> return $! n
475+ _ -> unique_hole n
472− x -> return $! n
473− processTactic' (PatVar n')
476+ processTactic' (PatVar n)
474
477
475-- | Turn the current hole into a pattern variable with the provided
478-- | Turn the current hole into a pattern variable with the provided
476-- name, but don't make MNs unique.
479-- name, but don't make MNs unique.
@@ -478,11 +481,11 @@ patvar' :: Name -> Elab' aux ()
478patvar' n@(SN _) = do apply (Var n) [] ; solve
481patvar' n@(SN _) = do apply (Var n) [] ; solve
479patvar' n = do env <- get_env
482patvar' n = do env <- get_env
480 hs <- get_holes
483 hs <- get_holes
481− if (n `elem` map fst env) then do apply (Var n) [] ; solve
484+ if (n `elem` map fstEnv env) then do apply (Var n) [] ; solve
482 else processTactic' (PatVar n)
485 else processTactic' (PatVar n)
483
486
484−patbind :: Name -> Elab' aux ()
487+patbind :: Name -> RigCount -> Elab' aux ()
485−patbind n = processTactic' (PatBind n)
488+patbind n r = processTactic' (PatBind n r)
486
489
487focus :: Name -> Elab' aux ()
490focus :: Name -> Elab' aux ()
488focus n = processTactic' (Focus n)
491focus n = processTactic' (Focus n)
@@ -575,9 +578,9 @@ prepare_apply fn imps =
575 -- Count arguments to check if we need to normalise the type
578 -- Count arguments to check if we need to normalise the type
576 let usety = if argsOK (finalise ty) imps
579 let usety = if argsOK (finalise ty) imps
577 then finalise ty
580 then finalise ty
578− else normalise ctxt env (finalise ty)
581+ else whnfArgs ctxt env (finalise ty)
579 claims <- -- trace (show (fn, imps, ty, map fst env, normalise ctxt env (finalise ty))) $
582 claims <- -- trace (show (fn, imps, ty, map fst env, normalise ctxt env (finalise ty))) $
580− mkClaims usety imps [] (map fst env)
583+ mkClaims usety imps [] (map fstEnv env)
581 ES (p, a) s prev <- get
584 ES (p, a) s prev <- get
582 -- reverse the claims we made so that args go left to right
585 -- reverse the claims we made so that args go left to right
583 let n = length (filter not imps)
586 let n = length (filter not imps)
@@ -586,7 +589,7 @@ prepare_apply fn imps =
586 return $! claims
589 return $! claims
587 where
590 where
588 argsOK :: Type -> [a] -> Bool
591 argsOK :: Type -> [a] -> Bool
589− argsOK (Bind n (Pi _ _ _) sc) (i : is) = argsOK sc is
592+ argsOK (Bind n (Pi _ _ _ _) sc) (i : is) = argsOK sc is
590 argsOK _ (i : is) = False
593 argsOK _ (i : is) = False
591 argsOK _ [] = True
594 argsOK _ [] = True
592
595
@@ -595,13 +598,13 @@ prepare_apply fn imps =
595 -> [(Name, Name)] -- ^ Accumulator for produced claims
598 -> [(Name, Name)] -- ^ Accumulator for produced claims
596 -> [Name] -- ^ Hypotheses
599 -> [Name] -- ^ Hypotheses
597 -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.
600 -> Elab' aux [(Name, Name)] -- ^ The names of the arguments and their holes, resp.
598− mkClaims (Bind n' (Pi _ t_in _) sc) (i : is) claims hs =
601+ mkClaims (Bind n' (Pi _ _ t_in _) sc) (i : is) claims hs =
599 do let t = rebind hs t_in
602 do let t = rebind hs t_in
600 n <- getNameFrom (mkMN n')
603 n <- getNameFrom (mkMN n')
601-- when (null claims) (start_unify n)
604-- when (null claims) (start_unify n)
602 let sc' = instantiate (P Bound n t) sc
605 let sc' = instantiate (P Bound n t) sc
603 env <- get_env
606 env <- get_env
604− claim n (forgetEnv (map fst env) t)
607+ claim n (forgetEnv (map fstEnv env) t)
605 when i (movelast n)
608 when i (movelast n)
606 mkClaims sc' is ((n', n) : claims) hs
609 mkClaims sc' is ((n', n) : claims) hs
607 mkClaims t [] claims _ = return $! (reverse claims)
610 mkClaims t [] claims _ = return $! (reverse claims)
@@ -709,7 +712,7 @@ apply_elab n args =
709 priOrder _ Nothing = GT
712 priOrder _ Nothing = GT
710 priOrder (Just (x, _)) (Just (y, _)) = compare x y
713 priOrder (Just (x, _)) (Just (y, _)) = compare x y
711
714
712− doClaims (Bind n' (Pi _ t _) sc) (i : is) claims =
715+ doClaims (Bind n' (Pi _ _ t _) sc) (i : is) claims =
713 do n <- unique_hole (mkMN n')
716 do n <- unique_hole (mkMN n')
714 when (null claims) (start_unify n)
717 when (null claims) (start_unify n)
715 let sc' = instantiate (P Bound n t) sc
718 let sc' = instantiate (P Bound n t) sc
@@ -745,14 +748,14 @@ checkPiGoal n
745 = do g <- goal
748 = do g <- goal
746 ctxt <- get_context
749 ctxt <- get_context
747 env <- get_env
750 env <- get_env
748− case (normalise ctxt env g) of
751+ case (whnf ctxt env g) of
749− Bind _ (Pi _ _ _) _ -> return ()
752+ Bind _ (Pi _ _ _ _) _ -> return ()
750 _ -> do a <- getNameFrom (sMN 0 "__pargTy")
753 _ -> do a <- getNameFrom (sMN 0 "__pargTy")
751 b <- getNameFrom (sMN 0 "__pretTy")
754 b <- getNameFrom (sMN 0 "__pretTy")
752 f <- getNameFrom (sMN 0 "pf")
755 f <- getNameFrom (sMN 0 "pf")
753 claim a RType
756 claim a RType
754 claim b RType
757 claim b RType
755− claim f (RBind n (Pi Nothing (Var a) RType) (Var b))
758+ claim f (RBind n (Pi RigW Nothing (Var a) RType) (Var b))
756 movelast a
759 movelast a
757 movelast b
760 movelast b
758 fill (Var f)
761 fill (Var f)
@@ -772,7 +775,7 @@ infer_app infer fun arg str =
772 s <- getNameFrom (sMN 0 "is")
775 s <- getNameFrom (sMN 0 "is")
773 claim a RType
776 claim a RType
774 claim b RType
777 claim b RType
775− claim f (RBind (sMN 0 "_aX") (Pi Nothing (Var a) RType) (Var b))
778+ claim f (RBind (sMN 0 "_aX") (Pi RigW Nothing (Var a) RType) (Var b))
776 tm <- get_term
779 tm <- get_term
777 start_unify s
780 start_unify s
778 -- if 'infer' is set, we're assuming it's a simply typed application
781 -- if 'infer' is set, we're assuming it's a simply typed application
@@ -820,10 +823,10 @@ dep_app fun arg str =
820 focus s; attack;
823 focus s; attack;
821 ctxt <- get_context
824 ctxt <- get_context
822 env <- get_env
825 env <- get_env
823− case normalise ctxt env fty of
826+ case whnf ctxt env fty of
824 -- if f gives a function type, unify our argument type with
827 -- if f gives a function type, unify our argument type with
825 -- f's expected argument type
828 -- f's expected argument type
826− Bind _ (Pi _ argty _) _ -> unifyGoal (forget argty)
829+ Bind _ (Pi _ _ argty _) _ -> unifyGoal (forget argty)
827 -- Can't infer a type for 'f', so fail here (and drop back to
830 -- Can't infer a type for 'f', so fail here (and drop back to
828 -- simply typed application where we infer the type for f)
831 -- simply typed application where we infer the type for f)
829 _ -> fail "Can't make type"
832 _ -> fail "Can't make type"
@@ -842,11 +845,11 @@ dep_app fun arg str =
842
845
843-- Abstract over an argument of unknown type, giving a name for the hole
846-- Abstract over an argument of unknown type, giving a name for the hole
844-- which we'll fill with the argument type too.
847-- which we'll fill with the argument type too.
845−arg :: Name -> Maybe ImplicitInfo -> Name -> Elab' aux ()
848+arg :: Name -> RigCount -> Maybe ImplicitInfo -> Name -> Elab' aux ()
846−arg n i tyhole = do ty <- unique_hole tyhole
849+arg n r i tyhole = do ty <- unique_hole tyhole
847− claim ty RType
850+ claim ty RType
848− movelast ty
851+ movelast ty
849− forall n i (Var ty)
852+ forall n r i (Var ty)
850
853
851-- try a tactic, if it adds any unification problem, return an error
854-- try a tactic, if it adds any unification problem, return an error
852no_errors :: Elab' aux () -> Maybe Err -> Elab' aux ()
855no_errors :: Elab' aux () -> Maybe Err -> Elab' aux ()
@@ -866,7 +869,7 @@ no_errors tac err
866 case reverse ps' of
869 case reverse ps' of
867 ((x, y, _, env, inerr, while, _) : _) ->
870 ((x, y, _, env, inerr, while, _) : _) ->
868 let (xp, yp) = getProvenance inerr
871 let (xp, yp) = getProvenance inerr
869− env' = map (\(x, b) -> (x, binderTy b)) env in
872+ env' = map (\(x, rig, b) -> (x, binderTy b)) env in
870 lift $ tfail $
873 lift $ tfail $
871 case err of
874 case err of
872 Nothing -> CantUnify False (x, xp) (y, yp) inerr env' 0
875 Nothing -> CantUnify False (x, xp) (y, yp) inerr env' 0
@@ -1010,7 +1013,7 @@ debugElaborator msg = do ps <- fmap proof get
1010 getHoleInfo h = do focus h
1013 getHoleInfo h = do focus h
1011 g <- goal
1014 g <- goal
1012 env <- get_env
1015 env <- get_env
1013− return (h, g, env)
1016+ return (h, g, envBinders env)
1014
1017
1015qshow :: Fails -> String
1018qshow :: Fails -> String
1016qshow fs = show (map (\ (x, y, _, _, _, _, _) -> (x, y)) fs)
1019qshow fs = show (map (\ (x, y, _, _, _, _, _) -> (x, y)) fs)
src/Idris/Core/Evaluate.hs+129−77
@@ -11,20 +11,23 @@ Maintainer : The Idris Community.
11
11
12module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,
12module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,
13 normaliseAll, normaliseBlocking, toValue, quoteTerm,
13 normaliseAll, normaliseBlocking, toValue, quoteTerm,
14+ rt_simplify, simplify, inlineSmall,
14− rt_simplify, simplify, specialise, unfold, convEq, convEq',
15+ specialise, unfold, convEq, convEq',
15 Def(..), CaseInfo(..), CaseDefs(..),
16 Def(..), CaseInfo(..), CaseDefs(..),
16 Accessibility(..), Injectivity, Totality(..), PReason(..), MetaInformation(..),
17 Accessibility(..), Injectivity, Totality(..), PReason(..), MetaInformation(..),
17 Context, initContext, ctxtAlist, next_tvar,
18 Context, initContext, ctxtAlist, next_tvar,
19+ addToCtxt, setAccess, setInjective, setTotal, setRigCount,
18− addToCtxt, setAccess, setInjective, setTotal, setMetaInformation, addCtxtDef, addTyDecl,
20+ setMetaInformation, addCtxtDef, addTyDecl,
19 addDatatype, addCasedef, simplifyCasedef, addOperator,
21 addDatatype, addCasedef, simplifyCasedef, addOperator,
20 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,
22 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,
21 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,
23 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,
22− mapDefCtxt,
24+ mapDefCtxt, tcReducible,
23 lookupTotal, lookupTotalExact, lookupInjectiveExact,
25 lookupTotal, lookupTotalExact, lookupInjectiveExact,
26+ lookupRigCount, lookupRigCountExact,
24 lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict,
27 lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict,
25 isCanonical, isDConName, canBeDConName, isTConName, isConName, isFnName,
28 isCanonical, isDConName, canBeDConName, isTConName, isConName, isFnName,
26 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,
29 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,
27− isUniverse) where
30+ isUniverse, linearCheck, linearCheckArg) where
28
31
29import Idris.Core.CaseTree
32import Idris.Core.CaseTree
30import Idris.Core.TT
33import Idris.Core.TT
@@ -71,6 +74,16 @@ data Value = VP NameType Name Value
71-- | VLazy Env [Value] Term
74-- | VLazy Env [Value] Term
72 | VTmp Int
75 | VTmp Int
73
76
77+canonical :: Value -> Bool
78+canonical (VP (DCon _ _ _) _ _) = True
79+canonical (VApp f a) = canonical f
80+canonical (VConstant _) = True
81+canonical (VType _) = True
82+canonical (VUType _) = True
83+canonical VErased = True
84+canonical _ = False
85+
86+
74instance Show Value where
87instance Show Value where
75 show x = show $ evalState (quote 100 x) initEval
88 show x = show $ evalState (quote 100 x) initEval
76
89
@@ -148,16 +161,9 @@ simplify ctxt env t
148
161
149-- | Like simplify, but we only reduce functions that are marked as okay to
162-- | Like simplify, but we only reduce functions that are marked as okay to
150-- inline, and don't reduce lets
163-- inline, and don't reduce lets
151−inline :: Context -> Env -> TT Name -> TT Name
164+inlineSmall :: Context -> Env -> TT Name -> TT Name
152−inline ctxt env t
165+inlineSmall ctxt env t
153− = evalState (do val <- eval False ctxt [(sUN "lazy", 0),
166+ = evalState (do val <- eval False ctxt []
154− (sUN "force", 0),
155− (sUN "Force", 0),
156− (sUN "assert_smaller", 0),
157− (sUN "assert_total", 0),
158− (sUN "par", 0),
159− (sUN "prim__syntactic_eq", 0),
160− (sUN "fork", 0)]
161 (map finalEntry env) (finalise t)
167 (map finalEntry env) (finalise t)
162 [Simplify False]
168 [Simplify False]
163 quote 0 val) initEval
169 quote 0 val) initEval
@@ -193,13 +199,13 @@ unfold ctxt env ns t
193
199
194-- unbindEnv env (quote 0 (eval ctxt (bindEnv env t)))
200-- unbindEnv env (quote 0 (eval ctxt (bindEnv env t)))
195
201
196−finalEntry :: (Name, Binder (TT Name)) -> (Name, Binder (TT Name))
202+finalEntry :: (Name, RigCount, Binder (TT Name)) -> (Name, RigCount, Binder (TT Name))
197−finalEntry (n, b) = (n, fmap finalise b)
203+finalEntry (n, r, b) = (n, r, fmap finalise b)
198
204
199bindEnv :: EnvTT n -> TT n -> TT n
205bindEnv :: EnvTT n -> TT n -> TT n
200bindEnv [] tm = tm
206bindEnv [] tm = tm
201−bindEnv ((n, Let t v):bs) tm = Bind n (NLet t v) (bindEnv bs tm)
207+bindEnv ((n, r, Let t v):bs) tm = Bind n (NLet t v) (bindEnv bs tm)
202−bindEnv ((n, b):bs) tm = Bind n b (bindEnv bs tm)
208+bindEnv ((n, r, b):bs) tm = Bind n b (bindEnv bs tm)
203
209
204unbindEnv :: EnvTT n -> TT n -> TT n
210unbindEnv :: EnvTT n -> TT n -> TT n
205unbindEnv [] tm = tm
211unbindEnv [] tm = tm
@@ -260,6 +266,8 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
260 atRepl = AtREPL `elem` opts
266 atRepl = AtREPL `elem` opts
261 unfold = Unfold `elem` opts
267 unfold = Unfold `elem` opts
262
268
269+ noFree = all canonical . map snd
270+
263 -- returns 'True' if the function should block
271 -- returns 'True' if the function should block
264 -- normal evaluation should return false
272 -- normal evaluation should return false
265 blockSimplify (CaseInfo inl always dict) n stk
273 blockSimplify (CaseInfo inl always dict) n stk
@@ -276,21 +284,21 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
276 | otherwise = cases_compiletime cd
284 | otherwise = cases_compiletime cd
277
285
278 ev ntimes stk top env (P _ n ty)
286 ev ntimes stk top env (P _ n ty)
279− | Just (Let t v) <- lookup n genv = ev ntimes stk top env v
287+ | Just (Let t v) <- lookupBinder n genv = ev ntimes stk top env v
280 ev ntimes_in stk top env (P Ref n ty)
288 ev ntimes_in stk top env (P Ref n ty)
281 = do let limit = if simpl then 100 else 10000
289 = do let limit = if simpl then 100 else 10000
282 (u, ntimes) <- usable spec unfold limit n ntimes_in
290 (u, ntimes) <- usable spec unfold limit n ntimes_in
283− let red = u && (tcReducible n ctxt || spec || atRepl
291+ let red = u && (tcReducible n ctxt || spec || (atRepl && noFree env)
284 || runtime || unfold
292 || runtime || unfold
285 || sUN "assert_total" `elem` stk)
293 || sUN "assert_total" `elem` stk)
286 if red then
294 if red then
287− do let val = lookupDefAcc n (spec || unfold || atRepl || runtime) ctxt
295+ do let val = lookupDefAccExact n (spec || unfold || (atRepl && noFree env) || runtime) ctxt
288 case val of
296 case val of
289− [(Function _ tm, Public)] ->
297+ Just (Function _ tm, Public) ->
290 ev ntimes (n:stk) True env tm
298 ev ntimes (n:stk) True env tm
291− [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty
299+ Just (TyDecl nt ty, _) -> do vty <- ev ntimes stk True env ty
292− return $ VP nt n vty
300+ return $ VP nt n vty
293− [(CaseOp ci _ _ _ _ cd, acc)]
301+ Just (CaseOp ci _ _ _ _ cd, acc)
294 | (acc == Public || acc == Hidden) &&
302 | (acc == Public || acc == Hidden) &&
295-- || sUN "assert_total" `elem` stk) &&
303-- || sUN "assert_total" `elem` stk) &&
296 null (fst (cases_compiletime cd)) -> -- unoptimised version
304 null (fst (cases_compiletime cd)) -> -- unoptimised version
@@ -331,7 +339,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
331 return $ VBind True n (Let t' v') (\x -> return sc')
339 return $ VBind True n (Let t' v') (\x -> return sc')
332 ev ntimes stk top env (Bind n b sc)
340 ev ntimes stk top env (Bind n b sc)
333 = do b' <- vbind env b
341 = do b' <- vbind env b
334− let n' = uniqueName n (map fst genv ++ map fst env)
342+ let n' = uniqueName n (map fstEnv genv ++ map fst env)
335 return $ VBind True -- (vinstances 0 sc < 2)
343 return $ VBind True -- (vinstances 0 sc < 2)
336 n' b' (\x -> ev ntimes stk False ((n', x):env) sc)
344 n' b' (\x -> ev ntimes stk False ((n', x):env) sc)
337 where vbind env t
345 where vbind env t
@@ -353,7 +361,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
353 evApply ntimes' stk top env [l',t',arg'] d'
361 evApply ntimes' stk top env [l',t',arg'] d'
354 -- Treat "assert_total" specially, as long as it's defined!
362 -- Treat "assert_total" specially, as long as it's defined!
355 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)
363 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)
356− | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl || runtime) ctxt,
364+ | Just (CaseOp _ _ _ _ _ _, _) <- lookupDefAccExact n (spec || (atRepl && noFree env)|| runtime) ctxt,
357 at == txt "assert_total" && not (simpl || unfold)
365 at == txt "assert_total" && not (simpl || unfold)
358 = ev ntimes (n : stk) top env arg
366 = ev ntimes (n : stk) top env arg
359 ev ntimes stk top env (App _ f a)
367 ev ntimes stk top env (App _ f a)
@@ -372,6 +380,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
372 ev ntimes stk top env (Constant c) = return $ VConstant c
380 ev ntimes stk top env (Constant c) = return $ VConstant c
373 ev ntimes stk top env Erased = return VErased
381 ev ntimes stk top env Erased = return VErased
374 ev ntimes stk top env Impossible = return VImpossible
382 ev ntimes stk top env Impossible = return VImpossible
383+ ev ntimes stk top env (Inferred tm) = ev ntimes stk top env tm
375 ev ntimes stk top env (TType i) = return $ VType i
384 ev ntimes stk top env (TType i) = return $ VType i
376 ev ntimes stk top env (UType u) = return $ VUType u
385 ev ntimes stk top env (UType u) = return $ VUType u
377
386
@@ -381,9 +390,9 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
381 = apply ntimes stk top env f args
390 = apply ntimes stk top env f args
382
391
383 reapply ntimes stk top env f@(VP Ref n ty) args
392 reapply ntimes stk top env f@(VP Ref n ty) args
384− = let val = lookupDefAcc n (spec || atRepl || runtime) ctxt in
393+ = let val = lookupDefAccExact n (spec || (atRepl && noFree env) || runtime) ctxt in
385 case val of
394 case val of
386− [(CaseOp ci _ _ _ _ cd, acc)] ->
395+ Just (CaseOp ci _ _ _ _ cd, acc) ->
387 let (ns, tree) = getCases cd in
396 let (ns, tree) = getCases cd in
388 do c <- evCase ntimes n (n:stk) top env ns args tree
397 do c <- evCase ntimes n (n:stk) top env ns args tree
389 case c of
398 case c of
@@ -396,20 +405,20 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
396 = reapply ntimes stk top env f (a : args)
405 = reapply ntimes stk top env f (a : args)
397 reapply ntimes stk top env v args = return v
406 reapply ntimes stk top env v args = return v
398
407
399− apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)
408+ apply ntimes stk top env (VBind True n (Lam _ t) sc) (a:as)
400 = do a' <- sc a
409 = do a' <- sc a
401 app <- apply ntimes stk top env a' as
410 app <- apply ntimes stk top env a' as
402 wknV 1 app
411 wknV 1 app
403 apply ntimes_in stk top env f@(VP Ref n ty) args
412 apply ntimes_in stk top env f@(VP Ref n ty) args
404 = do let limit = if simpl then 100 else 10000
413 = do let limit = if simpl then 100 else 10000
405 (u, ntimes) <- usable spec unfold limit n ntimes_in
414 (u, ntimes) <- usable spec unfold limit n ntimes_in
406− let red = u && (tcReducible n ctxt || spec || atRepl
415+ let red = u && (tcReducible n ctxt || spec || (atRepl && noFree env)
407 || unfold || runtime
416 || unfold || runtime
408 || sUN "assert_total" `elem` stk)
417 || sUN "assert_total" `elem` stk)
409 if red then
418 if red then
410− do let val = lookupDefAcc n (spec || unfold || atRepl || runtime) ctxt
419+ do let val = lookupDefAccExact n (spec || unfold || (atRepl && noFree env) || runtime) ctxt
411 case val of
420 case val of
412− [(CaseOp ci _ _ _ _ cd, acc)]
421+ Just (CaseOp ci _ _ _ _ cd, acc)
413 | acc == Public || acc == Hidden ->
422 | acc == Public || acc == Hidden ->
414 -- unoptimised version
423 -- unoptimised version
415 let (ns, tree) = getCases cd in
424 let (ns, tree) = getCases cd in
@@ -420,7 +429,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
420 case c of
429 case c of
421 (Nothing, _) -> return $ unload env (VP Ref n ty) args
430 (Nothing, _) -> return $ unload env (VP Ref n ty) args
422 (Just v, rest) -> evApply ntimes stk top env rest v
431 (Just v, rest) -> evApply ntimes stk top env rest v
423− [(Operator _ i op, _)] ->
432+ Just (Operator _ i op, _) ->
424 if (i <= length args)
433 if (i <= length args)
425 then case op (take i args) of
434 then case op (take i args) of
426 Nothing -> return $ unload env (VP Ref n ty) args
435 Nothing -> return $ unload env (VP Ref n ty) args
@@ -513,7 +522,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
513 | Just v <- findDefault alts = return $ Just (amap, v)
522 | Just v <- findDefault alts = return $ Just (amap, v)
514 chooseAlt env _ (VP _ n _, args) alts amap
523 chooseAlt env _ (VP _ n _, args) alts amap
515 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)
524 | Just (ns, sc) <- findFn n alts = return $ Just (updateAmap (zip ns args) amap, sc)
516− chooseAlt env _ (VBind _ _ (Pi i s k) t, []) alts amap
525+ chooseAlt env _ (VBind _ _ (Pi _ i s k) t, []) alts amap
517 | Just (ns, sc) <- findFn (sUN "->") alts
526 | Just (ns, sc) <- findFn (sUN "->") alts
518 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern
527 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern
519 return $ Just (updateAmap (zip ns [s, t']) amap, sc)
528 return $ Just (updateAmap (zip ns [s, t']) amap, sc)
@@ -629,17 +638,17 @@ convEq ctxt holes topx topy = ceq [] topx topy where
629 | x `elem` holes || y `elem` holes = return True
638 | x `elem` holes || y `elem` holes = return True
630 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True
639 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True
631 | otherwise = sameDefs ps x y
640 | otherwise = sameDefs ps x y
632− ceq ps x (Bind n (Lam t) (App _ y (V 0)))
641+ ceq ps x (Bind n (Lam _ t) (App _ y (V 0)))
633 = ceq ps x (substV (P Bound n t) y)
642 = ceq ps x (substV (P Bound n t) y)
634− ceq ps (Bind n (Lam t) (App _ x (V 0))) y
643+ ceq ps (Bind n (Lam _ t) (App _ x (V 0))) y
635 = ceq ps (substV (P Bound n t) x) y
644 = ceq ps (substV (P Bound n t) x) y
636− ceq ps x (Bind n (Lam t) (App _ y (P Bound n' _)))
645+ ceq ps x (Bind n (Lam _ t) (App _ y (P Bound n' _)))
637 | n == n' = ceq ps x y
646 | n == n' = ceq ps x y
638− ceq ps (Bind n (Lam t) (App _ x (P Bound n' _))) y
647+ ceq ps (Bind n (Lam _ t) (App _ x (P Bound n' _))) y
639 | n == n' = ceq ps x y
648 | n == n' = ceq ps x y
640
649
641− ceq ps (Bind n (PVar t) sc) y = ceq ps sc y
650+ ceq ps (Bind n (PVar _ t) sc) y = ceq ps sc y
642− ceq ps x (Bind n (PVar t) sc) = ceq ps x sc
651+ ceq ps x (Bind n (PVar _ t) sc) = ceq ps x sc
643 ceq ps (Bind n (PVTy t) sc) y = ceq ps sc y
652 ceq ps (Bind n (PVTy t) sc) y = ceq ps sc y
644 ceq ps x (Bind n (PVTy t) sc) = ceq ps x sc
653 ceq ps x (Bind n (PVTy t) sc) = ceq ps x sc
645
654
@@ -655,7 +664,7 @@ convEq ctxt holes topx topy = ceq [] topx topy where
655 where
664 where
656 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
665 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
657 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
666 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
658− ceqB ps (Pi i v t) (Pi i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
667+ ceqB ps (Pi r i v t) (Pi r' i' v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')
659 ceqB ps b b' = ceq ps (binderTy b) (binderTy b')
668 ceqB ps b b' = ceq ps (binderTy b) (binderTy b')
660 -- Special case for 'case' blocks - size of scope causes complications,
669 -- Special case for 'case' blocks - size of scope causes complications,
661 -- we only want to check the blocks themselves are valid and identical
670 -- we only want to check the blocks themselves are valid and identical
@@ -859,9 +868,11 @@ data MetaInformation =
859
868
860-- | Contexts used for global definitions and for proof state. They contain
869-- | Contexts used for global definitions and for proof state. They contain
861-- universe constraints and existing definitions.
870-- universe constraints and existing definitions.
871+-- Also store maximum RigCount of the name (can't bind a name at multiplicity
872+-- 1 in a RigW, for example)
862data Context = MkContext {
873data Context = MkContext {
863 next_tvar :: Int,
874 next_tvar :: Int,
864− definitions :: Ctxt (Def, Injectivity, Accessibility, Totality, MetaInformation)
875+ definitions :: Ctxt (Def, RigCount, Injectivity, Accessibility, Totality, MetaInformation)
865 } deriving (Show, Generic)
876 } deriving (Show, Generic)
866
877
867
878
@@ -871,53 +882,59 @@ initContext = MkContext 0 emptyContext
871
882
872mapDefCtxt :: (Def -> Def) -> Context -> Context
883mapDefCtxt :: (Def -> Def) -> Context -> Context
873mapDefCtxt f (MkContext t !defs) = MkContext t (mapCtxt f' defs)
884mapDefCtxt f (MkContext t !defs) = MkContext t (mapCtxt f' defs)
874− where f' (!d, i, a, t, m) = f' (f d, i, a, t, m)
885+ where f' (!d, r, i, a, t, m) = f' (f d, r, i, a, t, m)
875
886
876-- | Get the definitions from a context
887-- | Get the definitions from a context
877ctxtAlist :: Context -> [(Name, Def)]
888ctxtAlist :: Context -> [(Name, Def)]
878−ctxtAlist ctxt = map (\(n, (d, i, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)
889+ctxtAlist ctxt = map (\(n, (d, r, i, a, t, m)) -> (n, d)) $ toAlist (definitions ctxt)
879
890
880veval ctxt env t = evalState (eval False ctxt [] env t []) initEval
891veval ctxt env t = evalState (eval False ctxt [] env t []) initEval
881
892
882addToCtxt :: Name -> Term -> Type -> Context -> Context
893addToCtxt :: Name -> Term -> Type -> Context -> Context
883addToCtxt n tm ty uctxt
894addToCtxt n tm ty uctxt
884 = let ctxt = definitions uctxt
895 = let ctxt = definitions uctxt
885− !ctxt' = addDef n (Function ty tm, False, Public, Unchecked, EmptyMI) ctxt in
896+ !ctxt' = addDef n (Function ty tm, RigW, False, Public, Unchecked, EmptyMI) ctxt in
886 uctxt { definitions = ctxt' }
897 uctxt { definitions = ctxt' }
887
898
888setAccess :: Name -> Accessibility -> Context -> Context
899setAccess :: Name -> Accessibility -> Context -> Context
889setAccess n a uctxt
900setAccess n a uctxt
890 = let ctxt = definitions uctxt
901 = let ctxt = definitions uctxt
891− !ctxt' = updateDef n (\ (d, i, _, t, m) -> (d, i, a, t, m)) ctxt in
902+ !ctxt' = updateDef n (\ (d, r, i, _, t, m) -> (d, r, i, a, t, m)) ctxt in
892 uctxt { definitions = ctxt' }
903 uctxt { definitions = ctxt' }
893
904
894setInjective :: Name -> Injectivity -> Context -> Context
905setInjective :: Name -> Injectivity -> Context -> Context
895setInjective n i uctxt
906setInjective n i uctxt
896 = let ctxt = definitions uctxt
907 = let ctxt = definitions uctxt
897− !ctxt' = updateDef n (\ (d, _, a, t, m) -> (d, i, a, t, m)) ctxt in
908+ !ctxt' = updateDef n (\ (d, r, _, a, t, m) -> (d, r, i, a, t, m)) ctxt in
898 uctxt { definitions = ctxt' }
909 uctxt { definitions = ctxt' }
899
910
900setTotal :: Name -> Totality -> Context -> Context
911setTotal :: Name -> Totality -> Context -> Context
901setTotal n t uctxt
912setTotal n t uctxt
902 = let ctxt = definitions uctxt
913 = let ctxt = definitions uctxt
903− !ctxt' = updateDef n (\ (d, i, a, _, m) -> (d, i, a, t, m)) ctxt in
914+ !ctxt' = updateDef n (\ (d, r, i, a, _, m) -> (d, r, i, a, t, m)) ctxt in
915+ uctxt { definitions = ctxt' }
916+
917+setRigCount :: Name -> RigCount -> Context -> Context
918+setRigCount n rc uctxt
919+ = let ctxt = definitions uctxt
920+ !ctxt' = updateDef n (\ (d, _, i, a, t, m) -> (d, rc, i, a, t, m)) ctxt in
904 uctxt { definitions = ctxt' }
921 uctxt { definitions = ctxt' }
905
922
906setMetaInformation :: Name -> MetaInformation -> Context -> Context
923setMetaInformation :: Name -> MetaInformation -> Context -> Context
907setMetaInformation n m uctxt
924setMetaInformation n m uctxt
908 = let ctxt = definitions uctxt
925 = let ctxt = definitions uctxt
909− !ctxt' = updateDef n (\ (d, i, a, t, _) -> (d, i, a, t, m)) ctxt in
926+ !ctxt' = updateDef n (\ (d, r, i, a, t, _) -> (d, r, i, a, t, m)) ctxt in
910 uctxt { definitions = ctxt' }
927 uctxt { definitions = ctxt' }
911
928
912addCtxtDef :: Name -> Def -> Context -> Context
929addCtxtDef :: Name -> Def -> Context -> Context
913addCtxtDef n d c = let ctxt = definitions c
930addCtxtDef n d c = let ctxt = definitions c
914− !ctxt' = addDef n (d, False, Public, Unchecked, EmptyMI) $! ctxt in
931+ !ctxt' = addDef n (d, RigW, False, Public, Unchecked, EmptyMI) $! ctxt in
915 c { definitions = ctxt' }
932 c { definitions = ctxt' }
916
933
917addTyDecl :: Name -> NameType -> Type -> Context -> Context
934addTyDecl :: Name -> NameType -> Type -> Context -> Context
918addTyDecl n nt ty uctxt
935addTyDecl n nt ty uctxt
919 = let ctxt = definitions uctxt
936 = let ctxt = definitions uctxt
920− !ctxt' = addDef n (TyDecl nt ty, False, Public, Unchecked, EmptyMI) ctxt in
937+ !ctxt' = addDef n (TyDecl nt ty, RigW, False, Public, Unchecked, EmptyMI) ctxt in
921 uctxt { definitions = ctxt' }
938 uctxt { definitions = ctxt' }
922
939
923addDatatype :: Datatype Name -> Context -> Context
940addDatatype :: Datatype Name -> Context -> Context
@@ -925,14 +942,14 @@ addDatatype (Data n tag ty unique cons) uctxt
925 = let ctxt = definitions uctxt
942 = let ctxt = definitions uctxt
926 ty' = normalise uctxt [] ty
943 ty' = normalise uctxt [] ty
927 !ctxt' = addCons 0 cons (addDef n
944 !ctxt' = addCons 0 cons (addDef n
928− (TyDecl (TCon tag (arity ty')) ty, True, Public, Unchecked, EmptyMI) ctxt) in
945+ (TyDecl (TCon tag (arity ty')) ty, RigW, True, Public, Unchecked, EmptyMI) ctxt) in
929 uctxt { definitions = ctxt' }
946 uctxt { definitions = ctxt' }
930 where
947 where
931 addCons tag [] ctxt = ctxt
948 addCons tag [] ctxt = ctxt
932 addCons tag ((n, ty) : cons) ctxt
949 addCons tag ((n, ty) : cons) ctxt
933 = let ty' = normalise uctxt [] ty in
950 = let ty' = normalise uctxt [] ty in
934 addCons (tag+1) cons (addDef n
951 addCons (tag+1) cons (addDef n
935− (TyDecl (DCon tag (arity ty') unique) ty, True, Public, Unchecked, EmptyMI) ctxt)
952+ (TyDecl (DCon tag (arity ty') unique) ty, RigW, True, Public, Unchecked, EmptyMI) ctxt)
936
953
937-- FIXME: Too many arguments! Refactor all these Bools.
954-- FIXME: Too many arguments! Refactor all these Bools.
938--
955--
@@ -966,7 +983,7 @@ addCasedef n ei ci@(CaseInfo inline alwaysInline tcdict)
966 (args_rt, sc_rt)
983 (args_rt, sc_rt)
967 op = (CaseOp (ci { case_inlinable = inlc })
984 op = (CaseOp (ci { case_inlinable = inlc })
968 ty argtys ps_in ps_ct cdef,
985 ty argtys ps_in ps_ct cdef,
969− False, access, Unchecked, EmptyMI)
986+ RigW, False, access, Unchecked, EmptyMI)
970 in return $ addDef n op ctxt
987 in return $ addDef n op ctxt
971-- other -> tfail (Msg $ "Error adding case def: " ++ show other)
988-- other -> tfail (Msg $ "Error adding case def: " ++ show other)
972 return uctxt { definitions = ctxt' }
989 return uctxt { definitions = ctxt' }
@@ -979,20 +996,20 @@ simplifyCasedef :: Name -> ErasureInfo -> Context -> TC Context
979simplifyCasedef n ei uctxt
996simplifyCasedef n ei uctxt
980 = do let ctxt = definitions uctxt
997 = do let ctxt = definitions uctxt
981 ctxt' <- case lookupCtxt n ctxt of
998 ctxt' <- case lookupCtxt n ctxt of
982− [(CaseOp ci ty atys [] ps _, inj, acc, tot, metainf)] ->
999+ [(CaseOp ci ty atys [] ps _, rc, inj, acc, tot, metainf)] ->
983 return ctxt -- nothing to simplify (or already done...)
1000 return ctxt -- nothing to simplify (or already done...)
984− [(CaseOp ci ty atys ps_in ps cd, inj, acc, tot, metainf)] ->
1001+ [(CaseOp ci ty atys ps_in ps cd, rc, inj, acc, tot, metainf)] ->
985 do let ps_in' = map simpl ps_in
1002 do let ps_in' = map simpl ps_in
986 pdef = map debind ps_in'
1003 pdef = map debind ps_in'
987 CaseDef args sc _ <- simpleCase False (STerm Erased) False CompileTime emptyFC [] atys pdef ei
1004 CaseDef args sc _ <- simpleCase False (STerm Erased) False CompileTime emptyFC [] atys pdef ei
988 return $ addDef n (CaseOp ci
1005 return $ addDef n (CaseOp ci
989 ty atys ps_in' ps (cd { cases_compiletime = (args, sc) }),
1006 ty atys ps_in' ps (cd { cases_compiletime = (args, sc) }),
990− inj, acc, tot, metainf) ctxt
1007+ rc, inj, acc, tot, metainf) ctxt
991
1008
992 _ -> return ctxt
1009 _ -> return ctxt
993 return uctxt { definitions = ctxt' }
1010 return uctxt { definitions = ctxt' }
994 where
1011 where
995− depat acc (Bind n (PVar t) sc)
1012+ depat acc (Bind n (PVar _ t) sc)
996 = depat (n : acc) (instantiate (P Bound n t) sc)
1013 = depat (n : acc) (instantiate (P Bound n t) sc)
997 depat acc x = (acc, x)
1014 depat acc x = (acc, x)
998 debind (Right (x, y)) = let (vs, x') = depat [] x
1015 debind (Right (x, y)) = let (vs, x') = depat [] x
@@ -1007,10 +1024,10 @@ addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) ->
1007 Context -> Context
1024 Context -> Context
1008addOperator n ty a op uctxt
1025addOperator n ty a op uctxt
1009 = let ctxt = definitions uctxt
1026 = let ctxt = definitions uctxt
1010− ctxt' = addDef n (Operator ty a op, False, Public, Unchecked, EmptyMI) ctxt in
1027+ ctxt' = addDef n (Operator ty a op, RigW, False, Public, Unchecked, EmptyMI) ctxt in
1011 uctxt { definitions = ctxt' }
1028 uctxt { definitions = ctxt' }
1012
1029
1013−tfst (a, _, _, _, _) = a
1030+tfst (a, _, _, _, _, _) = a
1014
1031
1015lookupNames :: Name -> Context -> [Name]
1032lookupNames :: Name -> Context -> [Name]
1016lookupNames n ctxt
1033lookupNames n ctxt
@@ -1096,10 +1113,10 @@ lookupP_all :: Bool -> Bool -> Name -> Context -> [Term]
1096lookupP_all all exact n ctxt
1113lookupP_all all exact n ctxt
1097 = do (n', def) <- names
1114 = do (n', def) <- names
1098 p <- case def of
1115 p <- case def of
1099− (Function ty tm, inj, a, _, _) -> return (P Ref n' ty, a)
1116+ (Function ty tm, _, inj, a, _, _) -> return (P Ref n' ty, a)
1100− (TyDecl nt ty, _, a, _, _) -> return (P nt n' ty, a)
1117+ (TyDecl nt ty, _, _, a, _, _) -> return (P nt n' ty, a)
1101− (CaseOp _ ty _ _ _ _, inj, a, _, _) -> return (P Ref n' ty, a)
1118+ (CaseOp _ ty _ _ _ _, _, inj, a, _, _) -> return (P Ref n' ty, a)
1102− (Operator ty _ _, inj, a, _, _) -> return (P Ref n' ty, a)
1119+ (Operator ty _ _, _, inj, a, _, _) -> return (P Ref n' ty, a)
1103 case snd p of
1120 case snd p of
1104 Hidden -> if all then return (fst p) else []
1121 Hidden -> if all then return (fst p) else []
1105 Private -> if all then return (fst p) else []
1122 Private -> if all then return (fst p) else []
@@ -1126,28 +1143,63 @@ lookupDefAcc :: Name -> Bool -> Context ->
1126lookupDefAcc n mkpublic ctxt
1143lookupDefAcc n mkpublic ctxt
1127 = map mkp $ lookupCtxt n (definitions ctxt)
1144 = map mkp $ lookupCtxt n (definitions ctxt)
1128 -- io_bind a special case for REPL prettiness
1145 -- io_bind a special case for REPL prettiness
1129− where mkp (d, inj, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_pure"))
1146+ where mkp (d, _, inj, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_pure"))
1130− then (d, Public) else (d, a)
1147+ then (d, Public) else (d, a)
1131
1148
1132lookupDefAccExact :: Name -> Bool -> Context ->
1149lookupDefAccExact :: Name -> Bool -> Context ->
1133 Maybe (Def, Accessibility)
1150 Maybe (Def, Accessibility)
1134lookupDefAccExact n mkpublic ctxt
1151lookupDefAccExact n mkpublic ctxt
1135 = fmap mkp $ lookupCtxtExact n (definitions ctxt)
1152 = fmap mkp $ lookupCtxtExact n (definitions ctxt)
1136 -- io_bind a special case for REPL prettiness
1153 -- io_bind a special case for REPL prettiness
1137− where mkp (d, inj, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_pure"))
1154+ where mkp (d, _, inj, a, _, _) = if mkpublic && (not (n == sUN "io_bind" || n == sUN "io_pure"))
1138− then (d, Public) else (d, a)
1155+ then (d, Public) else (d, a)
1139
1156
1140lookupTotal :: Name -> Context -> [Totality]
1157lookupTotal :: Name -> Context -> [Totality]
1141lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)
1158lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)
1142− where mkt (d, inj, a, t, m) = t
1159+ where mkt (d, _, inj, a, t, m) = t
1143
1160
1144lookupTotalExact :: Name -> Context -> Maybe Totality
1161lookupTotalExact :: Name -> Context -> Maybe Totality
1145lookupTotalExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)
1162lookupTotalExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)
1146− where mkt (d, inj, a, t, m) = t
1163+ where mkt (d, _, inj, a, t, m) = t
1164+
1165+lookupRigCount :: Name -> Context -> [Totality]
1166+lookupRigCount n ctxt = map mkt $ lookupCtxt n (definitions ctxt)
1167+ where mkt (d, _, inj, a, t, m) = t
1168+
1169+lookupRigCountExact :: Name -> Context -> Maybe RigCount
1170+lookupRigCountExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)
1171+ where mkt (d, rc, inj, a, t, m) = rc
1147
1172
1148lookupInjectiveExact :: Name -> Context -> Maybe Injectivity
1173lookupInjectiveExact :: Name -> Context -> Maybe Injectivity
1149lookupInjectiveExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)
1174lookupInjectiveExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)
1150− where mkt (d, inj, a, t, m) = inj
1175+ where mkt (d, _, inj, a, t, m) = inj
1176+
1177+-- Assume type is at least in whnfArgs form
1178+linearCheck :: Context -> Type -> TC ()
1179+linearCheck ctxt t = checkArgs t
1180+ where
1181+ checkArgs (Bind n (Pi RigW _ ty _) sc)
1182+ = do linearCheckArg ctxt ty
1183+ checkArgs (substV (P Bound n Erased) sc)
1184+ checkArgs (Bind n (Pi _ _ _ _) sc)
1185+ = checkArgs (substV (P Bound n Erased) sc)
1186+ checkArgs _ = return ()
1187+
1188+linearCheckArg :: Context -> Type -> TC ()
1189+linearCheckArg ctxt ty = mapM_ checkNameOK (allTTNames ty)
1190+ where
1191+ checkNameOK f
1192+ = case lookupRigCountExact f ctxt of
1193+ Just Rig1 ->
1194+ tfail $ Msg $ show f ++ " can only appear in a linear binding"
1195+ _ -> return ()
1196+
1197+ checkArgs (Bind n (Pi RigW _ ty _) sc)
1198+ = do mapM_ checkNameOK (allTTNames ty)
1199+ checkArgs (substV (P Bound n Erased) sc)
1200+ checkArgs (Bind n (Pi _ _ _ _) sc)
1201+ = checkArgs (substV (P Bound n Erased) sc)
1202+ checkArgs _ = return ()
1151
1203
1152-- Check if a name is reducible in the type checker. Partial definitions
1204-- Check if a name is reducible in the type checker. Partial definitions
1153-- are not reducible (so treated as a constant)
1205-- are not reducible (so treated as a constant)
@@ -1159,10 +1211,10 @@ tcReducible n ctxt = case lookupTotalExact n ctxt of
1159
1211
1160lookupMetaInformation :: Name -> Context -> [MetaInformation]
1212lookupMetaInformation :: Name -> Context -> [MetaInformation]
1161lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)
1213lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)
1162− where mkm (d, inj, a, t, m) = m
1214+ where mkm (d, _, inj, a, t, m) = m
1163
1215
1164lookupNameTotal :: Name -> Context -> [(Name, Totality)]
1216lookupNameTotal :: Name -> Context -> [(Name, Totality)]
1165−lookupNameTotal n = map (\(n, (_, _, _, t, _)) -> (n, t)) . lookupCtxtName n . definitions
1217+lookupNameTotal n = map (\(n, (_, _, _, _, t, _)) -> (n, t)) . lookupCtxtName n . definitions
1166
1218
1167
1219
1168lookupVal :: Name -> Context -> [Value]
1220lookupVal :: Name -> Context -> [Value]
@@ -1173,11 +1225,11 @@ lookupVal n ctxt
1173 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))
1225 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))
1174 _ -> []
1226 _ -> []
1175
1227
1176−lookupTyEnv :: Name -> Env -> Maybe (Int, Type)
1228+lookupTyEnv :: Name -> Env -> Maybe (Int, RigCount, Type)
1177lookupTyEnv n env = li n 0 env where
1229lookupTyEnv n env = li n 0 env where
1178 li n i [] = Nothing
1230 li n i [] = Nothing
1179− li n i ((x, b): xs)
1231+ li n i ((x, r, b): xs)
1180− | n == x = Just (i, binderTy b)
1232+ | n == x = Just (i, r, binderTy b)
1181 | otherwise = li n (i+1) xs
1233 | otherwise = li n (i+1) xs
1182
1234
1183-- | Create a unique name given context and other existing names
1235-- | Create a unique name given context and other existing names
src/Idris/Core/Execute.hs+5−4
@@ -91,14 +91,14 @@ toTT (EBind n b body) = do n' <- newN n
91 body' <- body $ EP Bound n' EErased
91 body' <- body $ EP Bound n' EErased
92 b' <- fixBinder b
92 b' <- fixBinder b
93 Bind n' b' <$> toTT body'
93 Bind n' b' <$> toTT body'
94− where fixBinder (Lam t) = Lam <$> toTT t
94+ where fixBinder (Lam rig t) = Lam rig <$> toTT t
95− fixBinder (Pi i t k) = Pi i <$> toTT t <*> toTT k
95+ fixBinder (Pi rig i t k) = Pi rig i <$> toTT t <*> toTT k
96 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
96 fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
97 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
97 fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
98 fixBinder (Hole t) = Hole <$> toTT t
98 fixBinder (Hole t) = Hole <$> toTT t
99 fixBinder (GHole i ns t) = GHole i ns <$> toTT t
99 fixBinder (GHole i ns t) = GHole i ns <$> toTT t
100 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
100 fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
101− fixBinder (PVar t) = PVar <$> toTT t
101+ fixBinder (PVar rig t) = PVar rig <$> toTT t
102 fixBinder (PVTy t) = PVTy <$> toTT t
102 fixBinder (PVTy t) = PVTy <$> toTT t
103 newN n = do (ExecState hs ns) <- lift get
103 newN n = do (ExecState hs ns) <- lift get
104 let n' = uniqueName n ns
104 let n' = uniqueName n ns
@@ -114,7 +114,7 @@ toTT (EConstant c) = return (Constant c)
114toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env
114toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env
115 return $ normalise ctxt env' tm
115 return $ normalise ctxt env' tm
116 where toBinder (n, v) = do v' <- toTT v
116 where toBinder (n, v) = do v' <- toTT v
117− return (n, Let Erased v')
117+ return (n, RigW, Let Erased v')
118toTT (EHandle _) = execFail $ Msg "Can't convert handles back to TT after execution."
118toTT (EHandle _) = execFail $ Msg "Can't convert handles back to TT after execution."
119toTT (EPtr ptr) = execFail $ Msg "Can't convert pointers back to TT after execution."
119toTT (EPtr ptr) = execFail $ Msg "Can't convert pointers back to TT after execution."
120
120
@@ -212,6 +212,7 @@ doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
212 doExec env ctxt ((x:xs) !! i)
212 doExec env ctxt ((x:xs) !! i)
213doExec env ctxt Erased = return EErased
213doExec env ctxt Erased = return EErased
214doExec env ctxt Impossible = fail "Tried to execute an impossible case"
214doExec env ctxt Impossible = fail "Tried to execute an impossible case"
215+doExec env ctxt (Inferred t) = doExec env ctxt t
215doExec env ctxt (TType u) = return (EType u)
216doExec env ctxt (TType u) = return (EType u)
216doExec env ctxt (UType u) = return (EUType u)
217doExec env ctxt (UType u) = return (EUType u)
217
218
src/Idris/Core/ProofState.hs+75−60
@@ -23,6 +23,7 @@ import Idris.Core.ProofTerm
23import Idris.Core.TT
23import Idris.Core.TT
24import Idris.Core.Typecheck
24import Idris.Core.Typecheck
25import Idris.Core.Unify
25import Idris.Core.Unify
26+import Idris.Core.WHNF
26
27
27import Util.Pretty hiding (fill)
28import Util.Pretty hiding (fill)
28
29
@@ -81,12 +82,13 @@ data Tactic = Attack
81 | Compute
82 | Compute
82 | ComputeLet Name
83 | ComputeLet Name
83 | Simplify
84 | Simplify
84− | HNF_Compute
85+ | WHNF_Compute
86+ | WHNF_ComputeArgs
85 | EvalIn Raw
87 | EvalIn Raw
86 | CheckIn Raw
88 | CheckIn Raw
87 | Intro (Maybe Name)
89 | Intro (Maybe Name)
88 | IntroTy Raw (Maybe Name)
90 | IntroTy Raw (Maybe Name)
89− | Forall Name (Maybe ImplicitInfo) Raw
91+ | Forall Name RigCount (Maybe ImplicitInfo) Raw
90 | LetBind Name Raw Raw
92 | LetBind Name Raw Raw
91 | ExpandLet Name Term
93 | ExpandLet Name Term
92 | Rewrite Raw
94 | Rewrite Raw
@@ -94,7 +96,7 @@ data Tactic = Attack
94 | CaseTac Raw
96 | CaseTac Raw
95 | Equiv Raw
97 | Equiv Raw
96 | PatVar Name
98 | PatVar Name
97− | PatBind Name
99+ | PatBind Name RigCount
98 | Focus Name
100 | Focus Name
99 | Defer [Name] Name
101 | Defer [Name] Name
100 | DeferType Name Raw [Name]
102 | DeferType Name Raw [Name]
@@ -127,12 +129,12 @@ instance Show ProofState where
127 ") -------\n " ++
129 ") -------\n " ++
128 show h ++ " : " ++ showG wkenv (goalType g) ++ "\n"
130 show h ++ " : " ++ showG wkenv (goalType g) ++ "\n"
129 where showPs env [] = ""
131 where showPs env [] = ""
130− showPs env ((n, Let t v):bs)
132+ showPs env ((n, _, Let t v):bs)
131 = " " ++ show n ++ " : " ++
133 = " " ++ show n ++ " : " ++
132 showEnv env ({- normalise ctxt env -} t) ++ " = " ++
134 showEnv env ({- normalise ctxt env -} t) ++ " = " ++
133 showEnv env ({- normalise ctxt env -} v) ++
135 showEnv env ({- normalise ctxt env -} v) ++
134 "\n" ++ showPs env bs
136 "\n" ++ showPs env bs
135− showPs env ((n, b):bs)
137+ showPs env ((n, _, b):bs)
136 = " " ++ show n ++ " : " ++
138 = " " ++ show n ++ " : " ++
137 showEnv env ({- normalise ctxt env -} (binderTy b)) ++
139 showEnv env ({- normalise ctxt env -} (binderTy b)) ++
138 "\n" ++ showPs env bs
140 "\n" ++ showPs env bs
@@ -158,18 +160,18 @@ instance Pretty ProofState OutputAnnotation where
158 prettyGoal ps b = prettyEnv ps $ binderTy b
160 prettyGoal ps b = prettyEnv ps $ binderTy b
159
161
160 prettyPs env [] = empty
162 prettyPs env [] = empty
161− prettyPs env ((n, Let t v):bs) =
163+ prettyPs env ((n, _, Let t v):bs) =
162 nest nestingSize (pretty n <+> colon <+>
164 nest nestingSize (pretty n <+> colon <+>
163 prettyEnv env t <+> text "=" <+> prettyEnv env v <+>
165 prettyEnv env t <+> text "=" <+> prettyEnv env v <+>
164 nest nestingSize (prettyPs env bs))
166 nest nestingSize (prettyPs env bs))
165− prettyPs env ((n, b):bs) =
167+ prettyPs env ((n, _, b):bs) =
166 nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) <+>
168 nest nestingSize (pretty n <+> colon <+> prettyEnv env (binderTy b) <+>
167 nest nestingSize (prettyPs env bs))
169 nest nestingSize (prettyPs env bs))
168
170
169holeName i = sMN i "hole"
171holeName i = sMN i "hole"
170
172
171qshow :: Fails -> String
173qshow :: Fails -> String
172−qshow fs = show (map (\ (x, y, hs, env, _, _, t) -> (t, map fst env, x, y, hs)) fs)
174+qshow fs = show (map (\ (x, y, hs, env, _, _, t) -> (t, map fstEnv env, x, y, hs)) fs)
173
175
174match_unify' :: Context -> Env ->
176match_unify' :: Context -> Env ->
175 (TT Name, Maybe Provenance) ->
177 (TT Name, Maybe Provenance) ->
@@ -361,7 +363,7 @@ computeLet ctxt n tm = cl [] tm where
361 cl env (Bind n' (Let t v) sc)
363 cl env (Bind n' (Let t v) sc)
362 | n' == n = let v' = normalise ctxt env v in
364 | n' == n = let v' = normalise ctxt env v in
363 Bind n' (Let t v') sc
365 Bind n' (Let t v') sc
364− cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, b):env) sc)
366+ cl env (Bind n' b sc) = Bind n' (fmap (cl env) b) (cl ((n, Rig0, b):env) sc)
365 cl env (App s f a) = App s (cl env f) (cl env a)
367 cl env (App s f a) = App s (cl env f) (cl env a)
366 cl env t = t
368 cl env t = t
367
369
@@ -390,7 +392,7 @@ claimFn n bn argty ctxt env t@(Bind x (Hole retty) sc) =
390 lift $ isType ctxt env tyt
392 lift $ isType ctxt env tyt
391 action (\ps -> let (g:gs) = holes ps in
393 action (\ps -> let (g:gs) = holes ps in
392 ps { holes = g : n : gs } )
394 ps { holes = g : n : gs } )
393− return $ Bind n (Hole (Bind bn (Pi Nothing tyv tyt) retty)) t
395+ return $ Bind n (Hole (Bind bn (Pi RigW Nothing tyv tyt) retty)) t
394claimFn _ _ _ ctxt env _ = fail "Can't make function type here"
396claimFn _ _ _ ctxt env _ = fail "Can't make function type here"
395
397
396reorder_claims :: RunTactic
398reorder_claims :: RunTactic
@@ -461,7 +463,7 @@ setinj n ctxt env (Bind x b sc)
461
463
462defer :: [Name] -> Name -> RunTactic
464defer :: [Name] -> Name -> RunTactic
463defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =
465defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =
464− do let env' = filter (\(n, t) -> n `notElem` dropped) env
466+ do let env' = filter (\(n, _, t) -> n `notElem` dropped) env
465 action (\ps -> let hs = holes ps in
467 action (\ps -> let hs = holes ps in
466 ps { usedns = n : usedns ps,
468 ps { usedns = n : usedns ps,
467 holes = hs \\ [x] })
469 holes = hs \\ [x] })
@@ -470,9 +472,9 @@ defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =
470 (mkApp (P Ref n ty) (map getP (reverse env'))))
472 (mkApp (P Ref n ty) (map getP (reverse env'))))
471 where
473 where
472 mkTy [] t = t
474 mkTy [] t = t
473− mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar [] 0))) (mkTy bs t)
475+ mkTy ((n,rig,b) : bs) t = Bind n (Pi RigW Nothing (binderTy b) (TType (UVar [] 0))) (mkTy bs t)
474
476
475− getP (n, b) = P Bound n (binderTy b)
477+ getP (n, rig, b) = P Bound n (binderTy b)
476defer dropped n ctxt env _ = fail "Can't defer a non-hole focus."
478defer dropped n ctxt env _ = fail "Can't defer a non-hole focus."
477
479
478-- as defer, but build the type and application explicitly
480-- as defer, but build the type and application explicitly
@@ -486,7 +488,7 @@ deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =
486 return (Bind n (GHole 0 [] fty)
488 return (Bind n (GHole 0 [] fty)
487 (mkApp (P Ref n ty) (map getP args)))
489 (mkApp (P Ref n ty) (map getP args)))
488 where
490 where
489− getP n = case lookup n env of
491+ getP n = case lookupBinder n env of
490 Just b -> P Bound n (binderTy b)
492 Just b -> P Bound n (binderTy b)
491 Nothing -> error ("deferType can't find " ++ show n)
493 Nothing -> error ("deferType can't find " ++ show n)
492deferType _ _ _ _ _ _ = fail "Can't defer a non-hole focus."
494deferType _ _ _ _ _ _ = fail "Can't defer a non-hole focus."
@@ -539,7 +541,7 @@ fill guess ctxt env (Bind x (Hole ty) sc) =
539 -- some expected types show up commonly in errors and indicate a
541 -- some expected types show up commonly in errors and indicate a
540 -- specific problem.
542 -- specific problem.
541 -- argTy -> retTy suggests a function applied to too many arguments
543 -- argTy -> retTy suggests a function applied to too many arguments
542− chkPurpose val (Bind _ (Pi _ (P _ (MN _ _) _) _) (P _ (MN _ _) _))
544+ chkPurpose val (Bind _ (Pi _ _ (P _ (MN _ _) _) _) (P _ (MN _ _) _))
543 = TooManyArgs val
545 = TooManyArgs val
544 chkPurpose _ _ = ExpectedType
546 chkPurpose _ _ = ExpectedType
545fill _ _ _ _ = fail "Can't fill here."
547fill _ _ _ _ = fail "Can't fill here."
@@ -650,27 +652,27 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
650 Just name -> name
652 Just name -> name
651 Nothing -> x
653 Nothing -> x
652 let t' = case t of
654 let t' = case t of
653− x@(Bind y (Pi _ s _) _) -> x
655+ x@(Bind y (Pi _ _ s _) _) -> x
654 _ -> normalise ctxt env t
656 _ -> normalise ctxt env t
655 (tyv, tyt) <- lift $ check ctxt env ty
657 (tyv, tyt) <- lift $ check ctxt env ty
656-- ns <- lift $ unify ctxt env tyv t'
658-- ns <- lift $ unify ctxt env tyv t'
657 case t' of
659 case t' of
658− Bind y (Pi _ s _) t -> let t' = updsubst y (P Bound n s) t in
660+ Bind y (Pi rig _ s _) t -> let t' = updsubst y (P Bound n s) t in
659− do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)
661+ do ns <- unify' ctxt env (s, Nothing) (tyv, Nothing)
660− ps <- get
662+ ps <- get
661− let (uh, uns) = unified ps
663+ let (uh, uns) = unified ps
662−-- put (ps { unified = (uh, uns ++ ns) })
664+-- put (ps { unified = (uh, uns ++ ns) })
663− return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))
665+ return $ Bind n (Lam rig tyv) (Bind x (Hole t') (P Bound x t'))
664 _ -> lift $ tfail $ CantIntroduce t'
666 _ -> lift $ tfail $ CantIntroduce t'
665introTy ty n ctxt env _ = fail "Can't introduce here."
667introTy ty n ctxt env _ = fail "Can't introduce here."
666
668
667intro :: Maybe Name -> RunTactic
669intro :: Maybe Name -> RunTactic
668intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
670intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
669 do let t' = case t of
671 do let t' = case t of
670− x@(Bind y (Pi _ s _) _) -> x
672+ x@(Bind y (Pi _ _ s _) _) -> x
671 _ -> normalise ctxt env t
673 _ -> normalise ctxt env t
672 case t' of
674 case t' of
673− Bind y (Pi _ s _) t ->
675+ Bind y (Pi rig _ s _) t ->
674 let n = case mn of
676 let n = case mn of
675 Just name -> name
677 Just name -> name
676 Nothing -> y
678 Nothing -> y
@@ -678,17 +680,17 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
678 -- because we want to substitute even in portions of
680 -- because we want to substitute even in portions of
679 -- terms that we know do not contain holes.
681 -- terms that we know do not contain holes.
680 t' = subst y (P Bound n s) t
682 t' = subst y (P Bound n s) t
681− in return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))
683+ in return $ Bind n (Lam rig s) (Bind x (Hole t') (P Bound x t'))
682 _ -> lift $ tfail $ CantIntroduce t'
684 _ -> lift $ tfail $ CantIntroduce t'
683intro n ctxt env _ = fail "Can't introduce here."
685intro n ctxt env _ = fail "Can't introduce here."
684
686
685−forall :: Name -> Maybe ImplicitInfo -> Raw -> RunTactic
687+forall :: Name -> RigCount -> Maybe ImplicitInfo -> Raw -> RunTactic
686−forall n impl ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
688+forall n rig impl ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
687 do (tyv, tyt) <- lift $ check ctxt env ty
689 do (tyv, tyt) <- lift $ check ctxt env ty
688 unify' ctxt env (tyt, Nothing) (TType (UVar [] 0), Nothing)
690 unify' ctxt env (tyt, Nothing) (TType (UVar [] 0), Nothing)
689 unify' ctxt env (t, Nothing) (TType (UVar [] 0), Nothing)
691 unify' ctxt env (t, Nothing) (TType (UVar [] 0), Nothing)
690− return $ Bind n (Pi impl tyv (TType (UVar [] 0))) (Bind x (Hole t) (P Bound x t))
692+ return $ Bind n (Pi rig impl tyv (TType (UVar [] 0))) (Bind x (Hole t) (P Bound x t))
691−forall n impl ty ctxt env _ = fail "Can't pi bind here"
693+forall n rig impl ty ctxt env _ = fail "Can't pi bind here"
692
694
693patvar :: Name -> RunTactic
695patvar :: Name -> RunTactic
694patvar n ctxt env (Bind x (Hole t) sc) =
696patvar n ctxt env (Bind x (Hole t) sc) =
@@ -700,7 +702,7 @@ patvar n ctxt env (Bind x (Hole t) sc) =
700 (notunified ps),
702 (notunified ps),
701 injective = addInj n x (injective ps)
703 injective = addInj n x (injective ps)
702 })
704 })
703− return $ Bind n (PVar t) (updsubst x (P Bound n t) sc)
705+ return $ Bind n (PVar RigW t) (updsubst x (P Bound n t) sc)
704 where addInj n x ps | x `elem` ps = n : ps
706 where addInj n x ps | x `elem` ps = n : ps
705 | otherwise = ps
707 | otherwise = ps
706patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm
708patvar n ctxt env tm = fail $ "Can't add pattern var at " ++ show tm
@@ -723,7 +725,7 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =
723 let tmt' = normalise ctxt env tmt
725 let tmt' = normalise ctxt env tmt
724 case unApply tmt' of
726 case unApply tmt' of
725 (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->
727 (P _ (UN q) _, [lt,rt,l,r]) | q == txt "=" ->
726− do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)
728+ do let p = Bind rname (Lam RigW lt) (mkP (P Bound rname lt) r l t)
727 let newt = mkP l r l t
729 let newt = mkP l r l t
728 let sc = forget $ (Bind x (Hole newt)
730 let sc = forget $ (Bind x (Hole newt)
729 (mkApp (P Ref (sUN "replace") (TType (UVal 0)))
731 (mkApp (P Ref (sUN "replace") (TType (UVal 0)))
@@ -783,7 +785,7 @@ casetac tm induction ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do
783 Var nm -> uniqueNameCtxt ctxt nm currentNames
785 Var nm -> uniqueNameCtxt ctxt nm currentNames
784 _ -> uniqueNameCtxt ctxt (sMN 0 "iv") currentNames
786 _ -> uniqueNameCtxt ctxt (sMN 0 "iv") currentNames
785 let tmvar = P Bound tmnm tmt'
787 let tmvar = P Bound tmnm tmt'
786− prop <- replaceIndicies indxnames indicies $ Bind tmnm (Lam tmt') (mkP tmvar tmv tmvar t)
788+ prop <- replaceIndicies indxnames indicies $ Bind tmnm (Lam RigW tmt') (mkP tmvar tmv tmvar t)
787 consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs)
789 consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (getProofTerm (pterm ps))) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (getProofTerm (pterm ps)))) consargs)
788 let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0)))
790 let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (tacn tnm)) (TType (UVal 0)))
789 (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))
791 (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))
@@ -810,7 +812,7 @@ casetac tm induction ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do
810 makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []
812 makeIndexNames = foldr (\_ nms -> (uniqueNameCtxt ctxt (sMN 0 "idx") nms):nms) []
811 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)
813 replaceIndicies idnms idxs prop = foldM (\t (idnm, idx) -> do (idxv, idxt) <- lift $ check ctxt env (forget idx)
812 let var = P Bound idnm idxt
814 let var = P Bound idnm idxt
813− return $ Bind idnm (Lam idxt) (mkP var idxv var t)) prop $ zip idnms idxs
815+ return $ Bind idnm (Lam RigW idxt) (mkP var idxv var t)) prop $ zip idnms idxs
814casetac tm induction ctxt env _ = fail $ "Can't do " ++ (if induction then "induction" else "case analysis") ++ " here"
816casetac tm induction ctxt env _ = fail $ "Can't do " ++ (if induction then "induction" else "case analysis") ++ " here"
815
817
816
818
@@ -821,28 +823,33 @@ equiv tm ctxt env (Bind x (Hole t) sc) =
821 return $ Bind x (Hole tmv) sc
823 return $ Bind x (Hole tmv) sc
822equiv tm ctxt env _ = fail "Can't equiv here"
824equiv tm ctxt env _ = fail "Can't equiv here"
823
825
824−patbind :: Name -> RunTactic
826+patbind :: Name -> RigCount -> RunTactic
825−patbind n ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
827+patbind n rig ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =
826 do let t' = case t of
828 do let t' = case t of
827 x@(Bind y (PVTy s) t) -> x
829 x@(Bind y (PVTy s) t) -> x
828 _ -> normalise ctxt env t
830 _ -> normalise ctxt env t
829 case t' of
831 case t' of
830 Bind y (PVTy s) t -> let t' = updsubst y (P Bound n s) t in
832 Bind y (PVTy s) t -> let t' = updsubst y (P Bound n s) t in
831− return $ Bind n (PVar s) (Bind x (Hole t') (P Bound x t'))
833+ return $ Bind n (PVar rig s) (Bind x (Hole t') (P Bound x t'))
832 _ -> fail "Nothing to pattern bind"
834 _ -> fail "Nothing to pattern bind"
833−patbind n ctxt env _ = fail "Can't pattern bind here"
835+patbind n _ ctxt env _ = fail "Can't pattern bind here"
834
836
835compute :: RunTactic
837compute :: RunTactic
836compute ctxt env (Bind x (Hole ty) sc) =
838compute ctxt env (Bind x (Hole ty) sc) =
837 do return $ Bind x (Hole (normalise ctxt env ty)) sc
839 do return $ Bind x (Hole (normalise ctxt env ty)) sc
838compute ctxt env t = return t
840compute ctxt env t = return t
839
841
840−hnf_compute :: RunTactic
842+whnf_compute :: RunTactic
841−hnf_compute ctxt env (Bind x (Hole ty) sc) =
843+whnf_compute ctxt env (Bind x (Hole ty) sc) =
842− do let ty' = normalise ctxt env ty in
844+ do let ty' = whnf ctxt env ty in
843−-- trace ("HNF " ++ show (ty, ty')) $
844 return $ Bind x (Hole ty') sc
845 return $ Bind x (Hole ty') sc
846+whnf_compute ctxt env t = return t
847+
848+whnf_compute_args :: RunTactic
849+whnf_compute_args ctxt env (Bind x (Hole ty) sc) =
850+ do let ty' = whnfArgs ctxt env ty in
851+ return $ Bind x (Hole ty') sc
845−hnf_compute ctxt env t = return t
852+whnf_compute_args ctxt env t = return t
846
853
847-- reduce let bindings only
854-- reduce let bindings only
848simplify :: RunTactic
855simplify :: RunTactic
@@ -907,8 +914,8 @@ keepGiven du (u : us) hs = keepGiven du us hs
907
914
908updateEnv [] e = e
915updateEnv [] e = e
909updateEnv ns [] = []
916updateEnv ns [] = []
910−updateEnv ns ((n, b) : env)
917+updateEnv ns ((n, rig, b) : env)
911− = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env
918+ = (n, rig, fmap (updateSolvedTerm ns) b) : updateEnv ns env
912
919
913updateProv ns (SourceTerm t) = SourceTerm $ updateSolvedTerm ns t
920updateProv ns (SourceTerm t) = SourceTerm $ updateSolvedTerm ns t
914updateProv ns p = p
921updateProv ns p = p
@@ -995,6 +1002,18 @@ updateProblems ps updates probs = rec 10 updates probs
995 (x', y', newx || newy,
1002 (x', y', newx || newy,
996 updateEnv ns env, updateError ns err, fc, fa)
1003 updateEnv ns env, updateError ns err, fc, fa)
997
1004
1005+orderUpdateSolved :: [(Name, Term)] -> ProofTerm -> (ProofTerm, [Name])
1006+orderUpdateSolved ns tm = update [] ns tm
1007+ where
1008+ update done [] t = (t, done)
1009+ update done ((n, P _ n' _) : ns) t | n == n' = update done ns t
1010+ update done (n : ns) t = update (fst n : done)
1011+ (map (updateMatch n) ns)
1012+ (updateSolved [n] t)
1013+
1014+ -- Update the later solutions too
1015+ updateMatch n (x, tm) = (x, updateSolvedTerm [n] tm)
1016+
998-- attempt to solve remaining problems with match_unify
1017-- attempt to solve remaining problems with match_unify
999matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails
1018matchProblems :: Bool -> ProofState -> [(Name, TT Name)] -> Fails
1000 -> ([(Name, TT Name)], Fails)
1019 -> ([(Name, TT Name)], Fails)
@@ -1058,30 +1077,25 @@ processTactic (ComputeLet n) ps
1058 (getProofTerm (pterm ps)) }, "")
1077 (getProofTerm (pterm ps)) }, "")
1059processTactic UnifyProblems ps
1078processTactic UnifyProblems ps
1060 = do let (ns', probs') = updateProblems ps [] (map setReady (problems ps))
1079 = do let (ns', probs') = updateProblems ps [] (map setReady (problems ps))
1061− pterm' = orderUpdateSolved ns' (pterm ps)
1080+ (pterm', dropped) = orderUpdateSolved ns' (pterm ps)
1062− traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show (map fst ns')) $
1081+ traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show dropped) $
1063 return (ps { pterm = pterm', solved = Nothing, problems = probs',
1082 return (ps { pterm = pterm', solved = Nothing, problems = probs',
1064 previous = Just ps, plog = "",
1083 previous = Just ps, plog = "",
1065 notunified = updateNotunified ns' (notunified ps),
1084 notunified = updateNotunified ns' (notunified ps),
1066− recents = recents ps ++ map fst ns',
1085+ recents = recents ps ++ dropped,
1067 dotted = filter (notIn ns') (dotted ps),
1086 dotted = filter (notIn ns') (dotted ps),
1068− holes = holes ps \\ (map fst ns') }, plog ps)
1087+ holes = holes ps \\ dropped }, plog ps)
1069 where notIn ns (h, _) = h `notElem` map fst ns
1088 where notIn ns (h, _) = h `notElem` map fst ns
1070− orderUpdateSolved [] t = t
1071− orderUpdateSolved (n : ns) t = orderUpdateSolved ns (updateSolved [n] t)
1072processTactic (MatchProblems all) ps
1089processTactic (MatchProblems all) ps
1073 = do let (ns', probs') = matchProblems all ps [] (map setReady (problems ps))
1090 = do let (ns', probs') = matchProblems all ps [] (map setReady (problems ps))
1074 (ns'', probs'') = matchProblems all ps ns' probs'
1091 (ns'', probs'') = matchProblems all ps ns' probs'
1075− pterm' = orderUpdateSolved ns'' (resetProofTerm (pterm ps))
1092+ (pterm', dropped) = orderUpdateSolved ns'' (resetProofTerm (pterm ps))
1076− traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show ns'') $
1093+ traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show dropped) $
1077 return (ps { pterm = pterm', solved = Nothing, problems = probs'',
1094 return (ps { pterm = pterm', solved = Nothing, problems = probs'',
1078 previous = Just ps, plog = "",
1095 previous = Just ps, plog = "",
1079 notunified = updateNotunified ns'' (notunified ps),
1096 notunified = updateNotunified ns'' (notunified ps),
1080− recents = recents ps ++ map fst ns'',
1097+ recents = recents ps ++ dropped,
1081− holes = holes ps \\ (map fst ns'') }, plog ps)
1098+ holes = holes ps \\ dropped }, plog ps)
1082− where
1083− orderUpdateSolved [] t = t
1084− orderUpdateSolved (n : ns) t = orderUpdateSolved ns (updateSolved [n] t)
1085processTactic t ps
1099processTactic t ps
1086 = case holes ps of
1100 = case holes ps of
1087 [] -> case t of
1101 [] -> case t of
@@ -1131,10 +1145,11 @@ process t h = tactic (Just h) (mktac t)
1131 mktac (StartUnify n) = start_unify n
1145 mktac (StartUnify n) = start_unify n
1132 mktac Compute = compute
1146 mktac Compute = compute
1133 mktac Simplify = Idris.Core.ProofState.simplify
1147 mktac Simplify = Idris.Core.ProofState.simplify
1134− mktac HNF_Compute = hnf_compute
1148+ mktac WHNF_Compute = whnf_compute
1149+ mktac WHNF_ComputeArgs = whnf_compute_args
1135 mktac (Intro n) = intro n
1150 mktac (Intro n) = intro n
1136 mktac (IntroTy ty n) = introTy ty n
1151 mktac (IntroTy ty n) = introTy ty n
1137− mktac (Forall n i t) = forall n i t
1152+ mktac (Forall n r i t) = forall n r i t
1138 mktac (LetBind n t v) = letbind n t v
1153 mktac (LetBind n t v) = letbind n t v
1139 mktac (ExpandLet n b) = expandLet n b
1154 mktac (ExpandLet n b) = expandLet n b
1140 mktac (Rewrite t) = rewrite t
1155 mktac (Rewrite t) = rewrite t
@@ -1142,7 +1157,7 @@ process t h = tactic (Just h) (mktac t)
1142 mktac (CaseTac t) = casetac t False
1157 mktac (CaseTac t) = casetac t False
1143 mktac (Equiv t) = equiv t
1158 mktac (Equiv t) = equiv t
1144 mktac (PatVar n) = patvar n
1159 mktac (PatVar n) = patvar n
1145− mktac (PatBind n) = patbind n
1160+ mktac (PatBind n rig) = patbind n rig
1146 mktac (CheckIn r) = check_in r
1161 mktac (CheckIn r) = check_in r
1147 mktac (EvalIn r) = eval_in r
1162 mktac (EvalIn r) = eval_in r
1148 mktac (Focus n) = focus n
1163 mktac (Focus n) = focus n
src/Idris/Core/ProofTerm.hs+11−11
@@ -84,7 +84,7 @@ findHole n env t = fh' env Top t where
84 | Just (p, env', tm) <- fh' env path f = Just (AppL s p a, env', tm)
84 | Just (p, env', tm) <- fh' env path f = Just (AppL s p a, env', tm)
85 fh' env path (Bind x b sc)
85 fh' env path (Bind x b sc)
86 | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)
86 | Just (bp, env', tm) <- fhB env path b = Just (InBind x bp sc, env', tm)
87− | Just (p, env', tm) <- fh' ((x,b):env) path sc = Just (InScope x b p, env', tm)
87+ | Just (p, env', tm) <- fh' ((x,RigW,b):env) path sc = Just (InScope x b p, env', tm)
88 fh' _ _ _ = Nothing
88 fh' _ _ _ = Nothing
89
89
90 fhB env path (Let t v)
90 fhB env path (Let t v)
@@ -170,10 +170,10 @@ updateSolvedTerm' xs x = updateSolved' xs x where
170 _ -> let (t', _) = updateSolved' xs t in
170 _ -> let (t', _) = updateSolved' xs t in
171 (updsubst n v t', True)
171 (updsubst n v t', True)
172 updateSolved' xs tm@(Bind n b t)
172 updateSolved' xs tm@(Bind n b t)
173− | otherwise = let (t', ut) = updateSolved' xs t
173+ = let (t', ut) = updateSolved' xs t
174− (b', ub) = updateSolvedB' xs b in
174+ (b', ub) = updateSolvedB' xs b in
175− if ut || ub then (Bind n b' t', True)
175+ if ut || ub then (Bind n b' t', True)
176− else (tm, False)
176+ else (tm, False)
177 updateSolved' xs t@(App Complete f a) = (t, False)
177 updateSolved' xs t@(App Complete f a) = (t, False)
178 updateSolved' xs t@(App s f a)
178 updateSolved' xs t@(App s f a)
179 = let (f', uf) = updateSolved' xs f
179 = let (f', uf) = updateSolved' xs f
@@ -255,7 +255,7 @@ updsubst n v tm = fst $ subst' 0 tm
255updateEnv :: [(Name, Term)] -> Env -> Env
255updateEnv :: [(Name, Term)] -> Env -> Env
256updateEnv [] e = e
256updateEnv [] e = e
257updateEnv ns [] = []
257updateEnv ns [] = []
258−updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env
258+updateEnv ns ((n, r, b) : env) = (n, r, fmap (updateSolvedTerm ns) b) : updateEnv ns env
259
259
260-- | Fill out solved holes in a term zipper.
260-- | Fill out solved holes in a term zipper.
261updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath
261updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath
@@ -284,7 +284,7 @@ updateSolvedPath ns (InScope n b sc)
284updateSolved :: [(Name, Term)] -> ProofTerm -> ProofTerm
284updateSolved :: [(Name, Term)] -> ProofTerm -> ProofTerm
285updateSolved xs pt@(PT path env sub ups)
285updateSolved xs pt@(PT path env sub ups)
286 = PT path -- (updateSolvedPath xs path)
286 = PT path -- (updateSolvedPath xs path)
287− (updateEnv xs (filter (\(n, t) -> n `notElem` map fst xs) env))
287+ (updateEnv xs (filter (\(n, r, t) -> n `notElem` map fst xs) env))
288 (updateSolvedTerm xs sub)
288 (updateSolvedTerm xs sub)
289 (ups ++ xs)
289 (ups ++ xs)
290
290
@@ -297,10 +297,10 @@ goal h pt@(PT path env sub ups)
297 g env (Bind n b@(Guess _ _) sc)
297 g env (Bind n b@(Guess _ _) sc)
298 | same h n = return $ GD env b
298 | same h n = return $ GD env b
299 | otherwise
299 | otherwise
300− = gb env b `mplus` g ((n, b):env) sc
300+ = gb env b `mplus` g ((n, RigW, b):env) sc
301 g env (Bind n b sc) | hole b && same h n = return $ GD env b
301 g env (Bind n b sc) | hole b && same h n = return $ GD env b
302 | otherwise
302 | otherwise
303− = g ((n, b):env) sc `mplus` gb env b
303+ = g ((n, RigW, b):env) sc `mplus` gb env b
304 g env (App Complete f a) = fail "Can't find hole"
304 g env (App Complete f a) = fail "Can't find hole"
305 g env (App _ f a) = g env a `mplus` g env f
305 g env (App _ f a) = g env a `mplus` g env f
306 g env t = fail "Can't find hole"
306 g env t = fail "Can't find hole"
@@ -338,12 +338,12 @@ atHole h f c e pt -- @(PT path env sub)
338 = do -- binder first
338 = do -- binder first
339 (b', u) <- ulift2 f c env Guess t v
339 (b', u) <- ulift2 f c env Guess t v
340 if u then return (Bind n b' sc, True)
340 if u then return (Bind n b' sc, True)
341− else do (sc', u) <- atH f c ((n, b) : env) sc
341+ else do (sc', u) <- atH f c ((n, RigW, b) : env) sc
342 return (Bind n b' sc', u)
342 return (Bind n b' sc', u)
343 atH f c env binder@(Bind n b sc)
343 atH f c env binder@(Bind n b sc)
344 | hole b && same h n = updated (f c env binder)
344 | hole b && same h n = updated (f c env binder)
345 | otherwise -- scope first
345 | otherwise -- scope first
346− = do (sc', u) <- atH f c ((n, b) : env) sc
346+ = do (sc', u) <- atH f c ((n, RigW, b) : env) sc
347 if u then return (Bind n b sc', True)
347 if u then return (Bind n b sc', True)
348 else do (b', u) <- atHb f c env b
348 else do (b', u) <- atHb f c env b
349 return (Bind n b' sc', u)
349 return (Bind n b' sc', u)
src/Idris/Core/TT.hs+113−53
@@ -31,7 +31,7 @@ module Idris.Core.TT(
31 , Env(..), EnvTT(..), Err(..), Err'(..), ErrorReportPart(..)
31 , Env(..), EnvTT(..), Err(..), Err'(..), ErrorReportPart(..)
32 , FC(..), FC'(..), ImplicitInfo(..), IntTy(..), Name(..)
32 , FC(..), FC'(..), ImplicitInfo(..), IntTy(..), Name(..)
33 , NameOutput(..), NameType(..), NativeTy(..), OutputAnnotation(..)
33 , NameOutput(..), NameType(..), NativeTy(..), OutputAnnotation(..)
34− , Provenance(..), Raw(..), SpecialName(..), TC(..), Term(..)
34+ , Provenance(..), Raw(..), RigCount(..), SpecialName(..), TC(..), Term(..)
35 , TermSize(..), TextFormatting(..), TT(..),Type(..), TypeInfo(..)
35 , TermSize(..), TextFormatting(..), TT(..),Type(..), TypeInfo(..)
36 , UConstraint(..), UCs(..), UExp(..), Universe(..)
36 , UConstraint(..), UCs(..), UExp(..), Universe(..)
37 , addAlist, addBinder, addDef, allTTNames, arity, bindAll
37 , addAlist, addBinder, addDef, allTTNames, arity, bindAll
@@ -49,6 +49,8 @@ module Idris.Core.TT(
49 , substV, sUN, tcname, termSmallerThan, tfail, thead, tnull
49 , substV, sUN, tcname, termSmallerThan, tfail, thead, tnull
50 , toAlist, traceWhen, txt, unApply, uniqueBinders, uniqueName
50 , toAlist, traceWhen, txt, unApply, uniqueBinders, uniqueName
51 , uniqueNameFrom, uniqueNameSet, unList, updateDef, vToP, weakenTm
51 , uniqueNameFrom, uniqueNameSet, unList, updateDef, vToP, weakenTm
52+ , rigPlus, rigMult, fstEnv, rigEnv, sndEnv, lookupBinder, envBinders
53+ , envZero
52 ) where
54 ) where
53
55
54import Util.Pretty hiding (Str)
56import Util.Pretty hiding (Str)
@@ -851,9 +853,11 @@ deriving instance Binary ImplicitInfo
851-- | All binding forms are represented in a uniform fashion. This type only represents
853-- | All binding forms are represented in a uniform fashion. This type only represents
852-- the types of bindings (and their values, if any); the attached identifiers are part
854-- the types of bindings (and their values, if any); the attached identifiers are part
853-- of the 'Bind' constructor for the 'TT' type.
855-- of the 'Bind' constructor for the 'TT' type.
856+data Binder b = Lam { binderCount :: RigCount,
854−data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}
857+ binderTy :: !b {-^ type annotation for bound variable-}}
855 -- ^ A function binding
858 -- ^ A function binding
859+ | Pi { binderCount :: RigCount,
856− | Pi { binderImpl :: Maybe ImplicitInfo,
860+ binderImpl :: Maybe ImplicitInfo,
857 binderTy :: !b,
861 binderTy :: !b,
858 binderKind :: !b }
862 binderKind :: !b }
859 -- ^ A binding that occurs in a function type
863 -- ^ A binding that occurs in a function type
@@ -885,7 +889,8 @@ data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}
885 -- substituted - the guess is to keep it
889 -- substituted - the guess is to keep it
886 -- computationally inert while working on other things
890 -- computationally inert while working on other things
887 -- if necessary.
891 -- if necessary.
892+ | PVar { binderCount :: RigCount,
888− | PVar { binderTy :: !b }
893+ binderTy :: !b }
889 -- ^ A pattern variable (these are bound around terms
894 -- ^ A pattern variable (these are bound around terms
890 -- that make up pattern-match clauses)
895 -- that make up pattern-match clauses)
891 | PVTy { binderTy :: !b }
896 | PVTy { binderTy :: !b }
@@ -896,25 +901,25 @@ deriving instance Binary Binder
896!-}
901!-}
897
902
898instance Sized a => Sized (Binder a) where
903instance Sized a => Sized (Binder a) where
899− size (Lam ty) = 1 + size ty
904+ size (Lam _ ty) = 1 + size ty
900− size (Pi _ ty _) = 1 + size ty
905+ size (Pi _ _ ty _) = 1 + size ty
901 size (Let ty val) = 1 + size ty + size val
906 size (Let ty val) = 1 + size ty + size val
902 size (NLet ty val) = 1 + size ty + size val
907 size (NLet ty val) = 1 + size ty + size val
903 size (Hole ty) = 1 + size ty
908 size (Hole ty) = 1 + size ty
904 size (GHole _ _ ty) = 1 + size ty
909 size (GHole _ _ ty) = 1 + size ty
905 size (Guess ty val) = 1 + size ty + size val
910 size (Guess ty val) = 1 + size ty + size val
906− size (PVar ty) = 1 + size ty
911+ size (PVar _ ty) = 1 + size ty
907 size (PVTy ty) = 1 + size ty
912 size (PVTy ty) = 1 + size ty
908
913
909fmapMB :: Monad m => (a -> m b) -> Binder a -> m (Binder b)
914fmapMB :: Monad m => (a -> m b) -> Binder a -> m (Binder b)
910fmapMB f (Let t v) = liftM2 Let (f t) (f v)
915fmapMB f (Let t v) = liftM2 Let (f t) (f v)
911fmapMB f (NLet t v) = liftM2 NLet (f t) (f v)
916fmapMB f (NLet t v) = liftM2 NLet (f t) (f v)
912fmapMB f (Guess t v) = liftM2 Guess (f t) (f v)
917fmapMB f (Guess t v) = liftM2 Guess (f t) (f v)
913−fmapMB f (Lam t) = liftM Lam (f t)
918+fmapMB f (Lam c t) = liftM (Lam c) (f t)
914−fmapMB f (Pi i t k) = liftM2 (Pi i) (f t) (f k)
919+fmapMB f (Pi c i t k) = liftM2 (Pi c i) (f t) (f k)
915fmapMB f (Hole t) = liftM Hole (f t)
920fmapMB f (Hole t) = liftM Hole (f t)
916fmapMB f (GHole i ns t) = liftM (GHole i ns) (f t)
921fmapMB f (GHole i ns t) = liftM (GHole i ns) (f t)
917−fmapMB f (PVar t) = liftM PVar (f t)
922+fmapMB f (PVar c t) = liftM (PVar c) (f t)
918fmapMB f (PVTy t) = liftM PVTy (f t)
923fmapMB f (PVTy t) = liftM PVTy (f t)
919
924
920raw_apply :: Raw -> [Raw] -> Raw
925raw_apply :: Raw -> [Raw] -> Raw
@@ -1008,6 +1013,9 @@ data TT n = P NameType n (TT n) -- ^ named references with type
1008 -- (-1) is a special case for 'subtract one from BI'
1013 -- (-1) is a special case for 'subtract one from BI'
1009 | Erased -- ^ an erased term
1014 | Erased -- ^ an erased term
1010 | Impossible -- ^ special case for totality checking
1015 | Impossible -- ^ special case for totality checking
1016+ | Inferred (TT n) -- ^ For building case trees when coverage checkimg only.
1017+ -- Marks a term as being inferred by the machine, rather than
1018+ -- given by the programmer
1011 | TType UExp -- ^ the type of types at some level
1019 | TType UExp -- ^ the type of types at some level
1012 | UType Universe -- ^ Uniqueness type universe (disjoint from TType)
1020 | UType Universe -- ^ Uniqueness type universe (disjoint from TType)
1013 deriving (Ord, Functor, Data, Generic, Typeable)
1021 deriving (Ord, Functor, Data, Generic, Typeable)
@@ -1055,12 +1063,48 @@ instance Sized a => Sized (TT a) where
1055 size (TType u) = 1 + size u
1063 size (TType u) = 1 + size u
1056 size (Proj a _) = 1 + size a
1064 size (Proj a _) = 1 + size a
1057 size Impossible = 1
1065 size Impossible = 1
1066+ size (Inferred t) = size t
1058 size (UType u) = 1 + size u
1067 size (UType u) = 1 + size u
1059
1068
1060instance Pretty a o => Pretty (TT a) o where
1069instance Pretty a o => Pretty (TT a) o where
1061 pretty _ = text "test"
1070 pretty _ = text "test"
1062
1071
1072+data RigCount = Rig0 | Rig1 | RigW
1073+ deriving (Show, Eq, Ord, Data, Generic, Typeable)
1074+
1075+rigPlus :: RigCount -> RigCount -> RigCount
1076+rigPlus Rig0 Rig0 = Rig0
1077+rigPlus Rig0 Rig1 = Rig1
1078+rigPlus Rig0 RigW = RigW
1079+rigPlus Rig1 Rig0 = Rig1
1080+rigPlus Rig1 Rig1 = RigW
1081+rigPlus Rig1 RigW = RigW
1082+rigPlus RigW Rig0 = RigW
1083+rigPlus RigW Rig1 = RigW
1084+rigPlus RigW RigW = RigW
1085+
1086+rigMult :: RigCount -> RigCount -> RigCount
1087+rigMult Rig0 Rig0 = Rig0
1088+rigMult Rig0 Rig1 = Rig0
1089+rigMult Rig0 RigW = Rig0
1090+rigMult Rig1 Rig0 = Rig0
1091+rigMult Rig1 Rig1 = Rig1
1092+rigMult Rig1 RigW = RigW
1093+rigMult RigW Rig0 = Rig0
1094+rigMult RigW Rig1 = RigW
1095+rigMult RigW RigW = RigW
1096+
1063−type EnvTT n = [(n, Binder (TT n))]
1097+type EnvTT n = [(n, RigCount, Binder (TT n))]
1098+
1099+fstEnv (n, c, b) = n
1100+rigEnv (n, c, b) = c
1101+sndEnv (n, c, b) = b
1102+
1103+envBinders = map (\(n, _, b) -> (n, b))
1104+envZero = map (\(n, _, b) -> (n, Rig0, b))
1105+
1106+lookupBinder :: Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
1107+lookupBinder n = lookup n . envBinders
1064
1108
1065data Datatype n = Data { d_typename :: n,
1109data Datatype n = Data { d_typename :: n,
1066 d_typetag :: Int,
1110 d_typetag :: Int,
@@ -1082,7 +1126,9 @@ data TypeInfo = TI { con_names :: [Name],
1082 codata :: Bool,
1126 codata :: Bool,
1083 data_opts :: DataOpts,
1127 data_opts :: DataOpts,
1084 param_pos :: [Int],
1128 param_pos :: [Int],
1085− mutual_types :: [Name] }
1129+ mutual_types :: [Name],
1130+ linear_con :: Bool -- is there a linear argument?
1131+ }
1086 deriving (Show, Generic)
1132 deriving (Show, Generic)
1087{-!
1133{-!
1088deriving instance Binary TypeInfo
1134deriving instance Binary TypeInfo
@@ -1110,7 +1156,7 @@ isInjective (P (DCon _ _ _) _ _) = True
1110isInjective (P (TCon _ _) _ _) = True
1156isInjective (P (TCon _ _) _ _) = True
1111isInjective (Constant _) = True
1157isInjective (Constant _) = True
1112isInjective (TType x) = True
1158isInjective (TType x) = True
1113−isInjective (Bind _ (Pi _ _ _) sc) = True
1159+isInjective (Bind _ (Pi _ _ _ _) sc) = True
1114isInjective (App _ f a) = isInjective f
1160isInjective (App _ f a) = isInjective f
1115isInjective _ = False
1161isInjective _ = False
1116
1162
@@ -1344,7 +1390,7 @@ freeNames t = nub $ freeNames' t
1344
1390
1345-- | Return the arity of a (normalised) type
1391-- | Return the arity of a (normalised) type
1346arity :: TT n -> Int
1392arity :: TT n -> Int
1347−arity (Bind n (Pi _ t _) sc) = 1 + arity sc
1393+arity (Bind n (Pi _ _ t _) sc) = 1 + arity sc
1348arity _ = 0
1394arity _ = 0
1349
1395
1350-- | Deconstruct an application; returns the function and a list of arguments
1396-- | Deconstruct an application; returns the function and a list of arguments
@@ -1379,6 +1425,7 @@ termSmallerThan x (V i) = True
1379termSmallerThan x (Constant c) = True
1425termSmallerThan x (Constant c) = True
1380termSmallerThan x Erased = True
1426termSmallerThan x Erased = True
1381termSmallerThan x Impossible = True
1427termSmallerThan x Impossible = True
1428+termSmallerThan x (Inferred t) = termSmallerThan x t
1382termSmallerThan x (TType u) = True
1429termSmallerThan x (TType u) = True
1383termSmallerThan x (UType u) = True
1430termSmallerThan x (UType u) = True
1384
1431
@@ -1421,6 +1468,7 @@ safeForgetEnv env (UType u) = Just $ RUType u
1421safeForgetEnv env Erased = Just $ RConstant Forgot
1468safeForgetEnv env Erased = Just $ RConstant Forgot
1422safeForgetEnv env (Proj tm i) = error "Don't know how to forget a projection"
1469safeForgetEnv env (Proj tm i) = error "Don't know how to forget a projection"
1423safeForgetEnv env Impossible = error "Don't know how to forget Impossible"
1470safeForgetEnv env Impossible = error "Don't know how to forget Impossible"
1471+safeForgetEnv env (Inferred t) = safeForgetEnv env t
1424
1472
1425-- | Introduce a 'Bind' into the given term for each element of the
1473-- | Introduce a 'Bind' into the given term for each element of the
1426-- given list of (name, binder) pairs.
1474-- given list of (name, binder) pairs.
@@ -1438,22 +1486,22 @@ bindTyArgs b xs = bindAll (map (\ (n, ty) -> (n, b ty)) xs)
1438-- | Return a list of pairs of the names of the outermost 'Pi'-bound
1486-- | Return a list of pairs of the names of the outermost 'Pi'-bound
1439-- variables in the given term, together with their types.
1487-- variables in the given term, together with their types.
1440getArgTys :: TT n -> [(n, TT n)]
1488getArgTys :: TT n -> [(n, TT n)]
1441−getArgTys (Bind n (PVar _) sc) = getArgTys sc
1489+getArgTys (Bind n (PVar _ _) sc) = getArgTys sc
1442getArgTys (Bind n (PVTy _) sc) = getArgTys sc
1490getArgTys (Bind n (PVTy _) sc) = getArgTys sc
1443−getArgTys (Bind n (Pi _ t _) sc) = (n, t) : getArgTys sc
1491+getArgTys (Bind n (Pi _ _ t _) sc) = (n, t) : getArgTys sc
1444getArgTys _ = []
1492getArgTys _ = []
1445
1493
1446getRetTy :: TT n -> TT n
1494getRetTy :: TT n -> TT n
1447−getRetTy (Bind n (PVar _) sc) = getRetTy sc
1495+getRetTy (Bind n (PVar _ _) sc) = getRetTy sc
1448getRetTy (Bind n (PVTy _) sc) = getRetTy sc
1496getRetTy (Bind n (PVTy _) sc) = getRetTy sc
1449−getRetTy (Bind n (Pi _ _ _) sc) = getRetTy sc
1497+getRetTy (Bind n (Pi _ _ _ _) sc) = getRetTy sc
1450getRetTy sc = sc
1498getRetTy sc = sc
1451
1499
1452-- | As getRetTy but substitutes names for de Bruijn indices
1500-- | As getRetTy but substitutes names for de Bruijn indices
1453substRetTy :: TT n -> TT n
1501substRetTy :: TT n -> TT n
1454−substRetTy (Bind n (PVar ty) sc) = substRetTy (substV (P Ref n ty) sc)
1502+substRetTy (Bind n (PVar _ ty) sc) = substRetTy (substV (P Ref n ty) sc)
1455substRetTy (Bind n (PVTy ty) sc) = substRetTy (substV (P Ref n ty) sc)
1503substRetTy (Bind n (PVTy ty) sc) = substRetTy (substV (P Ref n ty) sc)
1456−substRetTy (Bind n (Pi _ ty _) sc) = substRetTy (substV (P Ref n ty) sc)
1504+substRetTy (Bind n (Pi _ _ ty _) sc) = substRetTy (substV (P Ref n ty) sc)
1457substRetTy sc = sc
1505substRetTy sc = sc
1458
1506
1459
1507
@@ -1566,15 +1614,15 @@ prettyEnv env t = prettyEnv' env t False
1566 prettySe p env (V i) debug
1614 prettySe p env (V i) debug
1567 | i < length env =
1615 | i < length env =
1568 if debug then
1616 if debug then
1569− text . show . fst $ env!!i
1617+ text . show . fstEnv $ env!!i
1570 else
1618 else
1571 lbracket <+> text (show i) <+> rbracket
1619 lbracket <+> text (show i) <+> rbracket
1572 | otherwise = text "unbound" <+> text (show i) <+> text "!"
1620 | otherwise = text "unbound" <+> text (show i) <+> text "!"
1573− prettySe p env (Bind n b@(Pi _ t _) sc) debug
1621+ prettySe p env (Bind n b@(Pi _ _ t _) sc) debug
1574 | noOccurrence n sc && not debug =
1622 | noOccurrence n sc && not debug =
1575− bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug
1623+ bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, Rig0, b):env) sc debug
1576 prettySe p env (Bind n b sc) debug =
1624 prettySe p env (Bind n b sc) debug =
1577− bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, b):env) sc debug
1625+ bracket p 2 $ prettySb env n b debug <> prettySe 10 ((n, Rig0, b):env) sc debug
1578 prettySe p env (App _ f a) debug =
1626 prettySe p env (App _ f a) debug =
1579 bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug
1627 bracket p 1 $ prettySe 1 env f debug <+> prettySe 0 env a debug
1580 prettySe p env (Proj x i) debug =
1628 prettySe p env (Proj x i) debug =
@@ -1583,14 +1631,18 @@ prettyEnv env t = prettyEnv' env t False
1583 prettySe p env Erased debug = text "[_]"
1631 prettySe p env Erased debug = text "[_]"
1584 prettySe p env (TType i) debug = text "Type" <+> (text . show $ i)
1632 prettySe p env (TType i) debug = text "Type" <+> (text . show $ i)
1585 prettySe p env Impossible debug = text "Impossible"
1633 prettySe p env Impossible debug = text "Impossible"
1634+ prettySe p env (Inferred tm) debug = text "<" <+> prettySe p env tm debug <+> text ">"
1586 prettySe p env (UType u) debug = text (show u)
1635 prettySe p env (UType u) debug = text (show u)
1587
1636
1588 -- Render a `Binder` and its name
1637 -- Render a `Binder` and its name
1589− prettySb env n (Lam t) = prettyB env "λ" "=>" n t
1638+ prettySb env n (Lam _ t) = prettyB env "λ" "=>" n t
1590 prettySb env n (Hole t) = prettyB env "?defer" "." n t
1639 prettySb env n (Hole t) = prettyB env "?defer" "." n t
1591 prettySb env n (GHole _ _ t) = prettyB env "?gdefer" "." n t
1640 prettySb env n (GHole _ _ t) = prettyB env "?gdefer" "." n t
1592− prettySb env n (Pi _ t _) = prettyB env "(" ") ->" n t
1641+ prettySb env n (Pi Rig0 _ t _) = prettyB env "(" ") ->" n t
1642+ prettySb env n (Pi Rig1 _ t _) = prettyB env "(" ") -o" n t
1643+ prettySb env n (Pi RigW _ t _) = prettyB env "(" ") ->" n t
1644+ prettySb env n (PVar Rig1 t) = prettyB env "pat 1 " "." n t
1593− prettySb env n (PVar t) = prettyB env "pat" "." n t
1645+ prettySb env n (PVar _ t) = prettyB env "pat" "." n t
1594 prettySb env n (PVTy t) = prettyB env "pty" "." n t
1646 prettySb env n (PVTy t) = prettyB env "pty" "." n t
1595 prettySb env n (Let t v) = prettyBv env "let" "in" n t v
1647 prettySb env n (Let t v) = prettyBv env "let" "in" n t v
1596 prettySb env n (NLet t v) = prettyBv env "nlet" "in" n t v
1648 prettySb env n (NLet t v) = prettyBv env "nlet" "in" n t v
@@ -1613,30 +1665,37 @@ showEnv' env t dbg = se 10 env t where
1613 se p env (P nt n t) = show n
1665 se p env (P nt n t) = show n
1614 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""
1666 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""
1615 se p env (V i) | i < length env && i >= 0
1667 se p env (V i) | i < length env && i >= 0
1616− = (show $ fst $ env!!i) ++
1668+ = (show $ fstEnv $ env!!i) ++
1617 if dbg then "{" ++ show i ++ "}" else ""
1669 if dbg then "{" ++ show i ++ "}" else ""
1618 | otherwise = "!!V " ++ show i ++ "!!"
1670 | otherwise = "!!V " ++ show i ++ "!!"
1619− se p env (Bind n b@(Pi (Just _) t k) sc)
1671+ se p env (Bind n b@(Pi rig (Just _) t k) sc)
1620− = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc
1672+ = bracket p 2 $ sb env n b ++ se 10 ((n, rig, b):env) sc
1621− se p env (Bind n b@(Pi _ t k) sc)
1673+ se p env (Bind n b@(Pi rig _ t k) sc)
1622− | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc
1674+ | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow rig ++ se 10 ((n,Rig0,b):env) sc
1623− where arrow (TType _) = " -> "
1675+ where arrow Rig0 = " -> "
1624− arrow u = " [" ++ show u ++ "] -> "
1676+ arrow Rig1 = " -o "
1677+ arrow RigW = " -> "
1625− se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc
1678+ se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,Rig0,b):env) sc
1626 se p env (App _ f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a
1679 se p env (App _ f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a
1627 se p env (Proj x i) = se 1 env x ++ "!" ++ show i
1680 se p env (Proj x i) = se 1 env x ++ "!" ++ show i
1628 se p env (Constant c) = show c
1681 se p env (Constant c) = show c
1629 se p env Erased = "[__]"
1682 se p env Erased = "[__]"
1630 se p env Impossible = "[impossible]"
1683 se p env Impossible = "[impossible]"
1684+ se p env (Inferred t) = "<" ++ se p env t ++ ">"
1631 se p env (TType i) = "Type " ++ show i
1685 se p env (TType i) = "Type " ++ show i
1632 se p env (UType u) = show u
1686 se p env (UType u) = show u
1633
1687
1688+ sb env n (Lam Rig1 t) = showb env "\\ 1 " " => " n t
1634− sb env n (Lam t) = showb env "\\ " " => " n t
1689+ sb env n (Lam _ t) = showb env "\\ " " => " n t
1635 sb env n (Hole t) = showb env "? " ". " n t
1690 sb env n (Hole t) = showb env "? " ". " n t
1636 sb env n (GHole i ns t) = showb env "?defer " ". " n t
1691 sb env n (GHole i ns t) = showb env "?defer " ". " n t
1637− sb env n (Pi (Just _) t _) = showb env "{" "} -> " n t
1692+ sb env n (Pi Rig1 (Just _) t _) = showb env "{" "} -o " n t
1693+ sb env n (Pi _ (Just _) t _) = showb env "{" "} -> " n t
1694+ sb env n (Pi Rig1 _ t _) = showb env "(" ") -0 " n t
1638− sb env n (Pi _ t _) = showb env "(" ") -> " n t
1695+ sb env n (Pi _ _ t _) = showb env "(" ") -> " n t
1696+ sb env n (PVar Rig0 t) = showb env "pat 0 " ". " n t
1697+ sb env n (PVar Rig1 t) = showb env "pat 1 " ". " n t
1639− sb env n (PVar t) = showb env "pat " ". " n t
1698+ sb env n (PVar _ t) = showb env "pat " ". " n t
1640 sb env n (PVTy t) = showb env "pty " ". " n t
1699 sb env n (PVTy t) = showb env "pty " ". " n t
1641 sb env n (Let t v) = showbv env "let " " in " n t v
1700 sb env n (Let t v) = showbv env "let " " in " n t v
1642 sb env n (NLet t v) = showbv env "nlet " " in " n t v
1701 sb env n (NLet t v) = showbv env "nlet " " in " n t v
@@ -1678,14 +1737,14 @@ weakenTm i t = wk i 0 t
1678weakenEnv :: EnvTT n -> EnvTT n
1737weakenEnv :: EnvTT n -> EnvTT n
1679weakenEnv env = wk (length env - 1) env
1738weakenEnv env = wk (length env - 1) env
1680 where wk i [] = []
1739 where wk i [] = []
1681− wk i ((n, b) : bs) = (n, weakenTmB i b) : wk (i - 1) bs
1740+ wk i ((n, c, b) : bs) = (n, c, weakenTmB i b) : wk (i - 1) bs
1682 weakenTmB i (Let t v) = Let (weakenTm i t) (weakenTm i v)
1741 weakenTmB i (Let t v) = Let (weakenTm i t) (weakenTm i v)
1683 weakenTmB i (Guess t v) = Guess (weakenTm i t) (weakenTm i v)
1742 weakenTmB i (Guess t v) = Guess (weakenTm i t) (weakenTm i v)
1684 weakenTmB i t = t { binderTy = weakenTm i (binderTy t) }
1743 weakenTmB i t = t { binderTy = weakenTm i (binderTy t) }
1685
1744
1686-- | Weaken every term in the environment by the given amount
1745-- | Weaken every term in the environment by the given amount
1687weakenTmEnv :: Int -> EnvTT n -> EnvTT n
1746weakenTmEnv :: Int -> EnvTT n -> EnvTT n
1688−weakenTmEnv i = map (\ (n, b) -> (n, fmap (weakenTm i) b))
1747+weakenTmEnv i = map (\ (n, c, b) -> (n, c, fmap (weakenTm i) b))
1689
1748
1690refsIn :: TT Name -> [Name]
1749refsIn :: TT Name -> [Name]
1691refsIn (P _ n _) = [n]
1750refsIn (P _ n _) = [n]
@@ -1736,20 +1795,21 @@ pprintTT bound tm = pp startPrec bound tm
1736 text "!" <> text (show i)
1795 text "!" <> text (show i)
1737 pp p bound Erased = text "<<<erased>>>"
1796 pp p bound Erased = text "<<<erased>>>"
1738 pp p bound Impossible = text "<<<impossible>>>"
1797 pp p bound Impossible = text "<<<impossible>>>"
1798+ pp p bound (Inferred t) = text "<" <+> pp p bound t <+> text ">"
1739 pp p bound (TType ue) = annotate (AnnType "Type" "The type of types") $
1799 pp p bound (TType ue) = annotate (AnnType "Type" "The type of types") $
1740 text "Type"
1800 text "Type"
1741 pp p bound (UType u) = text (show u)
1801 pp p bound (UType u) = text (show u)
1742
1802
1743− ppb p bound n (Lam ty) sc =
1803+ ppb p bound n (Lam rig ty) sc =
1744 bracket p startPrec . group . align . hang 2 $
1804 bracket p startPrec . group . align . hang 2 $
1745 text "λ" <+> bindingOf n False <+> text "." <> line <> sc
1805 text "λ" <+> bindingOf n False <+> text "." <> line <> sc
1746− ppb p bound n (Pi _ ty k) sc =
1806+ ppb p bound n (Pi rig _ ty k) sc =
1747 bracket p startPrec . group . align $
1807 bracket p startPrec . group . align $
1748 lparen <> (bindingOf n False) <+> colon <+>
1808 lparen <> (bindingOf n False) <+> colon <+>
1749 (group . align) (pp startPrec bound ty) <>
1809 (group . align) (pp startPrec bound ty) <>
1750− rparen <+> mkArrow k <> line <> sc
1810+ rparen <+> mkArrow rig <> line <> sc
1751− where mkArrow (UType UniqueType) = text "⇴"
1811+ where mkArrow Rig1 = text "⇴"
1752− mkArrow (UType NullType) = text "⥛"
1812+ mkArrow Rig0 = text "⥛"
1753 mkArrow _ = text "→"
1813 mkArrow _ = text "→"
1754 ppb p bound n (Let ty val) sc =
1814 ppb p bound n (Let ty val) sc =
1755 bracket p startPrec . group . align $
1815 bracket p startPrec . group . align $
@@ -1778,7 +1838,7 @@ pprintTT bound tm = pp startPrec bound tm
1778 text "?" <> bindingOf n False <+>
1838 text "?" <> bindingOf n False <+>
1779 text "≈" <+> pp startPrec bound val <+>
1839 text "≈" <+> pp startPrec bound val <+>
1780 text "." <> line <> sc
1840 text "." <> line <> sc
1781− ppb p bound n (PVar ty) sc =
1841+ ppb p bound n (PVar _ ty) sc =
1782 bracket p startPrec . group . align . hang 2 $
1842 bracket p startPrec . group . align . hang 2 $
1783 annotate AnnKeyword (text "pat") <+>
1843 annotate AnnKeyword (text "pat") <+>
1784 bindingOf n False <+> colon <+> pp startPrec bound ty <+>
1844 bindingOf n False <+> colon <+> pp startPrec bound ty <+>
@@ -1829,10 +1889,10 @@ pprintRaw bound (RBind n b body) =
1829 , ppb b
1889 , ppb b
1830 , pprintRaw (n:bound) body]
1890 , pprintRaw (n:bound) body]
1831 where
1891 where
1832− ppb (Lam ty) = enclose lparen rparen . group . align . hang 2 $
1892+ ppb (Lam _ ty) = enclose lparen rparen . group . align . hang 2 $
1833− text "Lam" <$> pprintRaw bound ty
1893+ text "Lam" <$> pprintRaw bound ty
1834− ppb (Pi _ ty k) = enclose lparen rparen . group . align . hang 2 $
1894+ ppb (Pi _ _ ty k) = enclose lparen rparen . group . align . hang 2 $
1835− vsep [text "Pi", pprintRaw bound ty, pprintRaw bound k]
1895+ vsep [text "Pi", pprintRaw bound ty, pprintRaw bound k]
1836 ppb (Let ty v) = enclose lparen rparen . group . align . hang 2 $
1896 ppb (Let ty v) = enclose lparen rparen . group . align . hang 2 $
1837 vsep [text "Let", pprintRaw bound ty, pprintRaw bound v]
1897 vsep [text "Let", pprintRaw bound ty, pprintRaw bound v]
1838 ppb (NLet ty v) = enclose lparen rparen . group . align . hang 2 $
1898 ppb (NLet ty v) = enclose lparen rparen . group . align . hang 2 $
@@ -1843,8 +1903,8 @@ pprintRaw bound (RBind n b body) =
1843 text "GHole" <$> pprintRaw bound ty
1903 text "GHole" <$> pprintRaw bound ty
1844 ppb (Guess ty v) = enclose lparen rparen . group . align . hang 2 $
1904 ppb (Guess ty v) = enclose lparen rparen . group . align . hang 2 $
1845 vsep [text "Guess", pprintRaw bound ty, pprintRaw bound v]
1905 vsep [text "Guess", pprintRaw bound ty, pprintRaw bound v]
1846− ppb (PVar ty) = enclose lparen rparen . group . align . hang 2 $
1906+ ppb (PVar _ ty) = enclose lparen rparen . group . align . hang 2 $
1847− text "PVar" <$> pprintRaw bound ty
1907+ text "PVar" <$> pprintRaw bound ty
1848 ppb (PVTy ty) = enclose lparen rparen . group . align . hang 2 $
1908 ppb (PVTy ty) = enclose lparen rparen . group . align . hang 2 $
1849 text "PVTy" <$> pprintRaw bound ty
1909 text "PVTy" <$> pprintRaw bound ty
1850pprintRaw bound (RApp f x) =
1910pprintRaw bound (RApp f x) =
src/Idris/Core/Typecheck.hs+142−103
@@ -12,6 +12,7 @@ Maintainer : The Idris Community.
12module Idris.Core.Typecheck where
12module Idris.Core.Typecheck where
13
13
14import Idris.Core.Evaluate
14import Idris.Core.Evaluate
15+import Idris.Core.WHNF
15import Idris.Core.TT
16import Idris.Core.TT
16
17
17import Control.Monad.State
18import Control.Monad.State
@@ -25,7 +26,7 @@ import Debug.Trace
25
26
26convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC ()
27convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC ()
27convertsC ctxt env x y =
28convertsC ctxt env x y =
28− do let hs = map fst (filter isHole env)
29+ do let hs = map fstEnv (filter isHole env)
29 c1 <- convEq ctxt hs x y
30 c1 <- convEq ctxt hs x y
30 if c1 then return ()
31 if c1 then return ()
31 else
32 else
@@ -38,7 +39,7 @@ convertsC ctxt env x y =
38
39
39converts :: Context -> Env -> Term -> Term -> TC ()
40converts :: Context -> Env -> Term -> Term -> TC ()
40converts ctxt env x y
41converts ctxt env x y
41− = let hs = map fst (filter isHole env) in
42+ = let hs = map fstEnv (filter isHole env) in
42 case convEq' ctxt hs x y of
43 case convEq' ctxt hs x y of
43 OK True -> return ()
44 OK True -> return ()
44 _ -> case convEq' ctxt hs (finalise (normalise ctxt env x))
45 _ -> case convEq' ctxt hs (finalise (normalise ctxt env x))
@@ -48,10 +49,10 @@ converts ctxt env x y
48 (finalise (normalise ctxt env x))
49 (finalise (normalise ctxt env x))
49 (finalise (normalise ctxt env y)) (errEnv env))
50 (finalise (normalise ctxt env y)) (errEnv env))
50
51
51−isHole (n, Hole _) = True
52+isHole (n, _, Hole _) = True
52isHole _ = False
53isHole _ = False
53
54
54−errEnv = map (\(x, b) -> (x, binderTy b))
55+errEnv = map (\(x, _, b) -> (x, binderTy b))
55
56
56isType :: Context -> Env -> Term -> TC ()
57isType :: Context -> Env -> Term -> TC ()
57isType ctxt env tm = isType' (normalise ctxt env tm)
58isType ctxt env tm = isType' (normalise ctxt env tm)
@@ -86,7 +87,10 @@ check ctxt env tm
86 = evalStateT (check' True [] ctxt env tm) (0, [])
87 = evalStateT (check' True [] ctxt env tm) (0, [])
87
88
88check' :: Bool -> String -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)
89check' :: Bool -> String -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)
90+check' holes tcns ctxt env top
89−check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top where
91+ = do (tm, ty, _) <- chk Rig1 (TType (UVar tcns (-5))) Nothing env top
92+ return (tm, ty)
93+ where
90
94
91 smaller (UType NullType) _ = UType NullType
95 smaller (UType NullType) _ = UType NullType
92 smaller _ (UType NullType) = UType NullType
96 smaller _ (UType NullType) = UType NullType
@@ -97,75 +101,89 @@ check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top wh
97 astate | holes = MaybeHoles
101 astate | holes = MaybeHoles
98 | otherwise = Complete
102 | otherwise = Complete
99
103
104+ chk :: RigCount -> -- multiplicity (need enough in context to produce this many of the term)
100− chk :: Type -> -- uniqueness level
105+ Type -> -- uniqueness level
101 Maybe UExp -> -- universe for kind
106 Maybe UExp -> -- universe for kind
102− Env -> Raw -> StateT UCs TC (Term, Type)
107+ Env -> Raw -> StateT UCs TC (Term, Type, [Name])
103− chk u lvl env (Var n)
108+ chk rigc u lvl env (Var n)
104− | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)
109+ | Just (i, erig, ty) <- lookupTyEnv n env
110+ = case rigSafe holes erig rigc n of
111+ Nothing -> return (P Bound n ty, ty, used rigc n)
112+ Just msg -> lift $ tfail $ Msg msg
105 -- If we're elaborating, we don't want the private names; if we're
113 -- If we're elaborating, we don't want the private names; if we're
106 -- checking an already elaborated term, we do
114 -- checking an already elaborated term, we do
107− | [P nt n' ty] <- lookupP_all (not holes) False n ctxt
108− = return (P nt n' ty, ty)
109− -- If the names are ambiguous, require it to be fully qualified
110 | [P nt n' ty] <- lookupP_all (not holes) True n ctxt
115 | [P nt n' ty] <- lookupP_all (not holes) True n ctxt
111− = return (P nt n' ty, ty)
116+ = return (P nt n' ty, ty, [])
117+-- -- If the names are ambiguous, require it to be fully qualified
118+-- | [P nt n' ty] <- lookupP_all (not holes) True n ctxt
119+-- = return (P nt n' ty, ty, [])
112 | otherwise = do lift $ tfail $ NoSuchVariable n
120 | otherwise = do lift $ tfail $ NoSuchVariable n
121+ where rigSafe True _ _ n = Nothing
122+ rigSafe _ Rig1 RigW n = Just ("Trying to use linear name " ++ show n ++ " in non-linear context")
123+ rigSafe _ Rig0 RigW n = Just ("Trying to use irrelevant name " ++ show n ++ " in relevant context")
124+ rigSafe _ _ _ n = Nothing
125+
126+ used Rig0 n = []
127+ used _ n = [n]
128+
113− chk u lvl env ap@(RApp f RType) | not holes
129+ chk rigc u lvl env ap@(RApp f RType) | not holes
114 -- special case to reduce constraintss
130 -- special case to reduce constraintss
115− = do (fv, fty) <- chk u Nothing env f
131+ = do (fv, fty, fns) <- chk rigc u Nothing env f
116− let fty' = case uniqueBinders (map fst env) (finalise fty) of
132+ let fty' = case uniqueBinders (map fstEnv env) (finalise fty) of
117− ty@(Bind x (Pi i s k) t) -> ty
133+ ty@(Bind x (Pi _ i s k) t) -> ty
118− _ -> uniqueBinders (map fst env)
134+ _ -> uniqueBinders (map fstEnv env)
119 $ case normalise ctxt env fty of
135 $ case normalise ctxt env fty of
120− ty@(Bind x (Pi i s k) t) -> ty
136+ ty@(Bind x (Pi _ i s k) t) -> ty
121 _ -> normalise ctxt env fty
137 _ -> normalise ctxt env fty
122 case fty' of
138 case fty' of
123− Bind x (Pi i (TType v') k) t ->
139+ Bind x (Pi rig i (TType v') k) t ->
124 do (v, cs) <- get
140 do (v, cs) <- get
125 put (v+1, ULT (UVar tcns v) v' : cs)
141 put (v+1, ULT (UVar tcns v) v' : cs)
126 let apty = simplify initContext env
142 let apty = simplify initContext env
127 (Bind x (Let (TType v') (TType (UVar tcns v))) t)
143 (Bind x (Let (TType v') (TType (UVar tcns v))) t)
128− return (App Complete fv (TType (UVar tcns v)), apty)
144+ return (App Complete fv (TType (UVar tcns v)), apty, fns)
129− Bind x (Pi i s k) t ->
145+ Bind x (Pi rig i s k) t ->
130− do (av, aty) <- chk u Nothing env RType
146+ do (av, aty, _) <- chk rigc u Nothing env RType
131 convertsC ctxt env aty s
147 convertsC ctxt env aty s
132 let apty = simplify initContext env
148 let apty = simplify initContext env
133 (Bind x (Let aty av) t)
149 (Bind x (Let aty av) t)
134− return (App astate fv av, apty)
150+ return (App astate fv av, apty, fns)
135 t -> lift $ tfail $ NonFunctionType fv fty
151 t -> lift $ tfail $ NonFunctionType fv fty
136− chk u lvl env ap@(RApp f a)
152+ chk rigc u lvl env ap@(RApp f a)
137− = do (fv, fty) <- chk u Nothing env f
153+ = do (fv, fty, fns) <- chk rigc u Nothing env f
154+ let (rigf, fty') =
138− let fty' = case uniqueBinders (map fst env) (finalise fty) of
155+ case uniqueBinders (map fstEnv env) (finalise fty) of
139− ty@(Bind x (Pi i s k) t) -> ty
156+ ty@(Bind x (Pi rig i s k) t) -> (rig, ty)
140− _ -> uniqueBinders (map fst env)
141− $ case normalise ctxt env fty of
157+ _ -> case normalise ctxt env fty of
142− ty@(Bind x (Pi i s k) t) -> ty
158+ ty@(Bind x (Pi rig i s k) t) ->
159+ (rig, uniqueBinders (map fstEnv env) ty)
160+ _ -> (RigW, uniqueBinders (map fstEnv env)
143− _ -> normalise ctxt env fty
161+ (normalise ctxt env fty)) -- This is an error, caught below...
144− (av, aty) <- chk u Nothing env a
162+ (av, aty, ans) <- chk (rigMult rigc rigf) u Nothing env a
145 case fty' of
163 case fty' of
146− Bind x (Pi i s k) t ->
164+ Bind x (Pi rig i s k) t ->
147 do convertsC ctxt env aty s
165 do convertsC ctxt env aty s
148 let apty = simplify initContext env
166 let apty = simplify initContext env
149 (Bind x (Let aty av) t)
167 (Bind x (Let aty av) t)
150− return (App astate fv av, apty)
168+ return (App astate fv av, apty, fns ++ ans)
151 t -> lift $ tfail $ NonFunctionType fv fty
169 t -> lift $ tfail $ NonFunctionType fv fty
152− chk u lvl env RType
170+ chk rigc u lvl env RType
153− | holes = return (TType (UVal 0), TType (UVal 0))
171+ | holes = return (TType (UVal 0), TType (UVal 0), [])
154 | otherwise = do (v, cs) <- get
172 | otherwise = do (v, cs) <- get
155 let c = ULT (UVar tcns v) (UVar tcns (v+1))
173 let c = ULT (UVar tcns v) (UVar tcns (v+1))
156 put (v+2, (c:cs))
174 put (v+2, (c:cs))
157− return (TType (UVar tcns v), TType (UVar tcns (v+1)))
175+ return (TType (UVar tcns v), TType (UVar tcns (v+1)), [])
158− chk u lvl env (RUType un)
176+ chk rigc u lvl env (RUType un)
159− | holes = return (UType un, TType (UVal 0))
177+ | holes = return (UType un, TType (UVal 0), [])
160 | otherwise = do -- TODO! Issue #1715 on the issue tracker.
178 | otherwise = do -- TODO! Issue #1715 on the issue tracker.
161 -- https://github.com/idris-lang/Idris-dev/issues/1715
179 -- https://github.com/idris-lang/Idris-dev/issues/1715
162 -- (v, cs) <- get
180 -- (v, cs) <- get
163 -- let c = ULT (UVar v) (UVar (v+1))
181 -- let c = ULT (UVar v) (UVar (v+1))
164 -- put (v+2, (c:cs))
182 -- put (v+2, (c:cs))
165 -- return (TType (UVar v), TType (UVar (v+1)))
183 -- return (TType (UVar v), TType (UVar (v+1)))
166− return (UType un, TType (UVal 0))
184+ return (UType un, TType (UVal 0), [])
167− chk u lvl env (RConstant Forgot) = return (Erased, Erased)
185+ chk rigc u lvl env (RConstant Forgot) = return (Erased, Erased, [])
168− chk u lvl env (RConstant c) = return (Constant c, constType c)
186+ chk rigc u lvl env (RConstant c) = return (Constant c, constType c, [])
169 where constType (I _) = Constant (AType (ATInt ITNative))
187 where constType (I _) = Constant (AType (ATInt ITNative))
170 constType (BI _) = Constant (AType (ATInt ITBig))
188 constType (BI _) = Constant (AType (ATInt ITBig))
171 constType (Fl _) = Constant (AType ATFloat)
189 constType (Fl _) = Constant (AType ATFloat)
@@ -178,15 +196,17 @@ check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top wh
178 constType TheWorld = Constant WorldType
196 constType TheWorld = Constant WorldType
179 constType Forgot = Erased
197 constType Forgot = Erased
180 constType _ = TType (UVal 0)
198 constType _ = TType (UVal 0)
181− chk u lvl env (RBind n (Pi i s k) t)
199+ chk rigc u lvl env (RBind n (Pi rig i s k) t)
182− = do (sv, st) <- chk u Nothing env s
200+ = do (sv, st, sns) <- chk Rig0 u Nothing (envZero env) s
201+ when (rig == RigW) $
202+ lift $ linearCheckArg ctxt (normalise ctxt env sv)
183 (v, cs) <- get
203 (v, cs) <- get
184− (kv, kt) <- chk u Nothing env k -- no need to validate these constraints, they are independent
204+ (kv, kt, _) <- chk Rig0 u Nothing (envZero env) k -- no need to validate these constraints, they are independent
185 put (v+1, cs)
205 put (v+1, cs)
186 let maxu = case lvl of
206 let maxu = case lvl of
187 Nothing -> UVar tcns v
207 Nothing -> UVar tcns v
188 Just v' -> v'
208 Just v' -> v'
189− (tv, tt) <- chk st (Just maxu) ((n, Pi i sv kv) : env) t
209+ (tv, tt, tns) <- chk Rig0 st (Just maxu) ((n, Rig0, Pi Rig0 i sv kv) : envZero env) t
190
210
191-- convertsC ctxt env st (TType maxu)
211-- convertsC ctxt env st (TType maxu)
192-- convertsC ctxt env tt (TType maxu)
212-- convertsC ctxt env tt (TType maxu)
@@ -200,18 +220,18 @@ check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top wh
200 put (v, ULE su maxu :
220 put (v, ULE su maxu :
201 ULE tu maxu : cs)
221 ULE tu maxu : cs)
202 let k' = TType (UVar tcns v) `smaller` st `smaller` kv `smaller` u
222 let k' = TType (UVar tcns v) `smaller` st `smaller` kv `smaller` u
203− return (Bind n (Pi i (uniqueBinders (map fst env) sv) k')
223+ return (Bind n (Pi rig i (uniqueBinders (map fstEnv env) sv) k')
204− (pToV n tv), k')
224+ (pToV n tv), k', sns ++ tns)
205 (un, un') ->
225 (un, un') ->
206 let k' = st `smaller` kv `smaller` un `smaller` un' `smaller` u in
226 let k' = st `smaller` kv `smaller` un `smaller` un' `smaller` u in
207− return (Bind n (Pi i (uniqueBinders (map fst env) sv) k')
227+ return (Bind n (Pi rig i (uniqueBinders (map fstEnv env) sv) k')
208− (pToV n tv), k')
228+ (pToV n tv), k', sns ++ tns)
209
229
210− where mkUniquePi kv (Bind n (Pi i s k) sc)
230+ where mkUniquePi kv (Bind n (Pi rig i s k) sc)
211 = let k' = smaller kv k in
231 = let k' = smaller kv k in
212− Bind n (Pi i s k') (mkUniquePi k' sc)
232+ Bind n (Pi rig i s k') (mkUniquePi k' sc)
213− mkUniquePi kv (Bind n (Lam t) sc)
233+ mkUniquePi kv (Bind n (Lam rig t) sc)
214− = Bind n (Lam (mkUniquePi kv t)) (mkUniquePi kv sc)
234+ = Bind n (Lam rig (mkUniquePi kv t)) (mkUniquePi kv sc)
215 mkUniquePi kv (Bind n (Let t v) sc)
235 mkUniquePi kv (Bind n (Let t v) sc)
216 = Bind n (Let (mkUniquePi kv t) v) (mkUniquePi kv sc)
236 = Bind n (Let (mkUniquePi kv t) v) (mkUniquePi kv sc)
217 mkUniquePi kv t = t
237 mkUniquePi kv t = t
@@ -219,84 +239,103 @@ check' holes tcns ctxt env top = chk (TType (UVar tcns (-5))) Nothing env top wh
219 -- Kind of the whole thing is the kind of the most unique thing
239 -- Kind of the whole thing is the kind of the most unique thing
220 -- in the environment (because uniqueness taints everything...)
240 -- in the environment (because uniqueness taints everything...)
221 mostUnique [] k = k
241 mostUnique [] k = k
222− mostUnique (Pi _ _ pk : es) k = mostUnique es (smaller pk k)
242+ mostUnique (Pi _ _ _ pk : es) k = mostUnique es (smaller pk k)
223 mostUnique (_ : es) k = mostUnique es k
243 mostUnique (_ : es) k = mostUnique es k
224
244
225− chk u lvl env (RBind n b sc)
245+ chk rigc u lvl env (RBind n b sc)
226− = do (b', bt') <- checkBinder b
246+ = do (b', bt', bns) <- checkBinder b
227− (scv, sct) <- chk (smaller bt' u) Nothing ((n, b'):env) sc
247+ (scv, sct, scns) <- chk rigc (smaller bt' u) Nothing ((n, getCount b, b'):env) sc
248+ when (getCount b == RigW) $
249+ lift $ linearCheckArg ctxt (normalise ctxt env (binderTy b'))
250+ checkUsageOK (getCount b) scns
228− discharge n b' bt' (pToV n scv) (pToV n sct)
251+ discharge n b' bt' (pToV n scv) (pToV n sct) (bns ++ scns)
252+ where getCount (Pi rig _ _ _) = rigMult rigc rig
253+ getCount (PVar rig _) = rigMult rigc rig
254+ getCount (Lam rig _) = rigMult rigc rig
255+ getCount _ = rigMult rigc RigW
256+
257+ checkUsageOK Rig0 _ = return ()
258+ checkUsageOK RigW _ = return ()
259+ checkUsageOK Rig1 ns
260+ = let used = length (filter (==n) ns) in
261+ if used == 1 then return ()
262+ else lift $ tfail $ Msg $ "There are " ++ (show used) ++
263+ " uses of linear name " ++ show n
264+
229− where checkBinder (Lam t)
265+ checkBinder (Lam rig t)
230− = do (tv, tt) <- chk u Nothing env t
266+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
231 let tv' = normalise ctxt env tv
267 let tv' = normalise ctxt env tv
232 convType tcns ctxt env tt
268 convType tcns ctxt env tt
233− return (Lam tv, tt)
269+ return (Lam rig tv, tt, [])
234 checkBinder (Let t v)
270 checkBinder (Let t v)
235− = do (tv, tt) <- chk u Nothing env t
271+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
272+ -- May have multiple uses, check at RigW
273+ -- (or rather, like an application of a lambda, multiply)
274+ -- (Consider: adding a single use let?)
236− (vv, vt) <- chk u Nothing env v
275+ (vv, vt, vns) <- chk (rigMult rigc RigW) u Nothing env v
237 let tv' = normalise ctxt env tv
276 let tv' = normalise ctxt env tv
238 convertsC ctxt env vt tv
277 convertsC ctxt env vt tv
239 convType tcns ctxt env tt
278 convType tcns ctxt env tt
240− return (Let tv vv, tt)
279+ return (Let tv vv, tt, vns)
241 checkBinder (NLet t v)
280 checkBinder (NLet t v)
242− = do (tv, tt) <- chk u Nothing env t
281+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
243− (vv, vt) <- chk u Nothing env v
282+ (vv, vt, vns) <- chk rigc u Nothing env v
244 let tv' = normalise ctxt env tv
283 let tv' = normalise ctxt env tv
245 convertsC ctxt env vt tv
284 convertsC ctxt env vt tv
246 convType tcns ctxt env tt
285 convType tcns ctxt env tt
247− return (NLet tv vv, tt)
286+ return (NLet tv vv, tt, vns)
248 checkBinder (Hole t)
287 checkBinder (Hole t)
249 | not holes = lift $ tfail (IncompleteTerm undefined)
288 | not holes = lift $ tfail (IncompleteTerm undefined)
250 | otherwise
289 | otherwise
251− = do (tv, tt) <- chk u Nothing env t
290+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
252 let tv' = normalise ctxt env tv
291 let tv' = normalise ctxt env tv
253 convType tcns ctxt env tt
292 convType tcns ctxt env tt
254− return (Hole tv, tt)
293+ return (Hole tv, tt, [])
255 checkBinder (GHole i ns t)
294 checkBinder (GHole i ns t)
256− = do (tv, tt) <- chk u Nothing env t
295+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
257 let tv' = normalise ctxt env tv
296 let tv' = normalise ctxt env tv
258 convType tcns ctxt env tt
297 convType tcns ctxt env tt
259− return (GHole i ns tv, tt)
298+ return (GHole i ns tv, tt, [])
260 checkBinder (Guess t v)
299 checkBinder (Guess t v)
261 | not holes = lift $ tfail (IncompleteTerm undefined)
300 | not holes = lift $ tfail (IncompleteTerm undefined)
262 | otherwise
301 | otherwise
263− = do (tv, tt) <- chk u Nothing env t
302+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
264− (vv, vt) <- chk u Nothing env v
303+ (vv, vt, vns) <- chk rigc u Nothing env v
265 let tv' = normalise ctxt env tv
304 let tv' = normalise ctxt env tv
266 convertsC ctxt env vt tv
305 convertsC ctxt env vt tv
267 convType tcns ctxt env tt
306 convType tcns ctxt env tt
268− return (Guess tv vv, tt)
307+ return (Guess tv vv, tt, vns)
269− checkBinder (PVar t)
308+ checkBinder (PVar rig t)
270− = do (tv, tt) <- chk u Nothing env t
309+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
271 let tv' = normalise ctxt env tv
310 let tv' = normalise ctxt env tv
272 convType tcns ctxt env tt
311 convType tcns ctxt env tt
273 -- Normalised version, for erasure purposes (it's easier
312 -- Normalised version, for erasure purposes (it's easier
274 -- to tell if it's a collapsible variable)
313 -- to tell if it's a collapsible variable)
275− return (PVar tv, tt)
314+ return (PVar rig tv, tt, [])
276 checkBinder (PVTy t)
315 checkBinder (PVTy t)
277− = do (tv, tt) <- chk u Nothing env t
316+ = do (tv, tt, _) <- chk Rig0 u Nothing (envZero env) t
278 let tv' = normalise ctxt env tv
317 let tv' = normalise ctxt env tv
279 convType tcns ctxt env tt
318 convType tcns ctxt env tt
280− return (PVTy tv, tt)
319+ return (PVTy tv, tt, [])
281−
320+
282− discharge n (Lam t) bt scv sct
321+ discharge n (Lam r t) bt scv sct ns
283− = return (Bind n (Lam t) scv, Bind n (Pi Nothing t bt) sct)
322+ = return (Bind n (Lam r t) scv, Bind n (Pi r Nothing t bt) sct, ns)
284− discharge n (Pi i t k) bt scv sct
323+ discharge n (Pi r i t k) bt scv sct ns
285− = return (Bind n (Pi i t k) scv, sct)
324+ = return (Bind n (Pi r i t k) scv, sct, ns)
286− discharge n (Let t v) bt scv sct
325+ discharge n (Let t v) bt scv sct ns
287− = return (Bind n (Let t v) scv, Bind n (Let t v) sct)
326+ = return (Bind n (Let t v) scv, Bind n (Let t v) sct, ns)
288− discharge n (NLet t v) bt scv sct
327+ discharge n (NLet t v) bt scv sct ns
289− = return (Bind n (NLet t v) scv, Bind n (Let t v) sct)
328+ = return (Bind n (NLet t v) scv, Bind n (Let t v) sct, ns)
290− discharge n (Hole t) bt scv sct
329+ discharge n (Hole t) bt scv sct ns
291− = return (Bind n (Hole t) scv, sct)
330+ = return (Bind n (Hole t) scv, sct, ns)
292− discharge n (GHole i ns t) bt scv sct
331+ discharge n (GHole i ns t) bt scv sct uns
293− = return (Bind n (GHole i ns t) scv, sct)
332+ = return (Bind n (GHole i ns t) scv, sct, uns)
294− discharge n (Guess t v) bt scv sct
333+ discharge n (Guess t v) bt scv sct ns
295− = return (Bind n (Guess t v) scv, sct)
334+ = return (Bind n (Guess t v) scv, sct, ns)
296− discharge n (PVar t) bt scv sct
335+ discharge n (PVar r t) bt scv sct ns
297− = return (Bind n (PVar t) scv, Bind n (PVTy t) sct)
336+ = return (Bind n (PVar r t) scv, Bind n (PVTy t) sct, ns)
298− discharge n (PVTy t) bt scv sct
337+ discharge n (PVTy t) bt scv sct ns
299− = return (Bind n (PVTy t) scv, sct)
338+ = return (Bind n (PVTy t) scv, sct, ns)
300
339
301-- Number of times a name can be used
340-- Number of times a name can be used
302data UniqueUse = Never -- no more times
341data UniqueUse = Never -- no more times
@@ -316,7 +355,7 @@ checkUnique borrowed ctxt env tm
316 isVar _ = False
355 isVar _ = False
317
356
318 chkBinders :: Env -> Term -> StateT [(Name, (UniqueUse, Universe))] TC ()
357 chkBinders :: Env -> Term -> StateT [(Name, (UniqueUse, Universe))] TC ()
319− chkBinders env (V i) | length env > i = chkName (fst (env!!i))
358+ chkBinders env (V i) | length env > i = chkName (fstEnv (env!!i))
320 chkBinders env (P _ n _) = chkName n
359 chkBinders env (P _ n _) = chkName n
321 -- 'lending' a unique or nulltype variable doesn't count as a use,
360 -- 'lending' a unique or nulltype variable doesn't count as a use,
322 -- but we still can't lend something that's already been used.
361 -- but we still can't lend something that's already been used.
@@ -336,13 +375,13 @@ checkUnique borrowed ctxt env tm
336 case b of
375 case b of
337 Let t v -> chkBinders env v
376 Let t v -> chkBinders env v
338 _ -> return ()
377 _ -> return ()
339− chkBinders ((n, b) : env) t
378+ chkBinders ((n, Rig0, b) : env) t
340 chkBinders env t = return ()
379 chkBinders env t = return ()
341
380
342 chkBinderName :: Env -> Name -> Binder Term ->
381 chkBinderName :: Env -> Name -> Binder Term ->
343 StateT [(Name, (UniqueUse, Universe))] TC ()
382 StateT [(Name, (UniqueUse, Universe))] TC ()
344 chkBinderName env n b
383 chkBinderName env n b
345− = do let rawty = forgetEnv (map fst env) (binderTy b)
384+ = do let rawty = forgetEnv (map fstEnv env) (binderTy b)
346 (_, kind) <- lift $ check ctxt env rawty
385 (_, kind) <- lift $ check ctxt env rawty
347 case kind of
386 case kind of
348 UType UniqueType -> do ns <- get
387 UType UniqueType -> do ns <- get
src/Idris/Core/Unify.hs+40−40
@@ -140,8 +140,8 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =
140 uB bnames (Let tx vx) (Let ty vy) = do h1 <- un bnames tx ty
140 uB bnames (Let tx vx) (Let ty vy) = do h1 <- un bnames tx ty
141 h2 <- un bnames vx vy
141 h2 <- un bnames vx vy
142 combine bnames h1 h2
142 combine bnames h1 h2
143− uB bnames (Lam tx) (Lam ty) = un bnames tx ty
143+ uB bnames (Lam _ tx) (Lam _ ty) = un bnames tx ty
144− uB bnames (Pi i tx _) (Pi i' ty _) = un bnames tx ty
144+ uB bnames (Pi r i tx _) (Pi r' i' ty _) = un bnames tx ty
145 uB bnames x y = do UI s f <- get
145 uB bnames x y = do UI s f <- get
146 let r = recoverable (normalise ctxt env (binderTy x))
146 let r = recoverable (normalise ctxt env (binderTy x))
147 (normalise ctxt env (binderTy y))
147 (normalise ctxt env (binderTy y))
@@ -204,13 +204,13 @@ match_unify ctxt env (topx, xfrom) (topy, yfrom) inj holes from =
204 bind i ns tm
204 bind i ns tm
205 | i < 0 = tm
205 | i < 0 = tm
206 | otherwise = let ((x,y),ty) = ns!!i in
206 | otherwise = let ((x,y),ty) = ns!!i in
207− App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))
207+ App MaybeHoles (Bind y (Lam RigW ty) (bind (i-1) ns tm))
208 (P Bound x ty)
208 (P Bound x ty)
209
209
210renameBinders env (x, t) = (x, renameBindersTm env t)
210renameBinders env (x, t) = (x, renameBindersTm env t)
211
211
212renameBindersTm :: Env -> TT Name -> TT Name
212renameBindersTm :: Env -> TT Name -> TT Name
213−renameBindersTm env tm = uniqueBinders (map fst env) tm
213+renameBindersTm env tm = uniqueBinders (map fstEnv env) tm
214 where
214 where
215 uniqueBinders env (Bind n b sc)
215 uniqueBinders env (Bind n b sc)
216 | n `elem` env
216 | n `elem` env
@@ -370,7 +370,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
370 = case compare (envPos 0 x env) (envPos 0 y env) of
370 = case compare (envPos 0 x env) (envPos 0 y env) of
371 LT -> do sc 1; checkCycle bnames (x, ty)
371 LT -> do sc 1; checkCycle bnames (x, ty)
372 _ -> do sc 1; checkCycle bnames (y, tx)
372 _ -> do sc 1; checkCycle bnames (y, tx)
373− where envPos i n ((n',_):env) | n == n' = i
373+ where envPos i n ((n',_,_):env) | n == n' = i
374 envPos i n (_:env) = envPos (i+1) n env
374 envPos i n (_:env) = envPos (i+1) n env
375 envPos _ _ _ = 100000
375 envPos _ _ _ = 100000
376 un' env fn bnames xtm@(P _ x _) tm
376 un' env fn bnames xtm@(P _ x _) tm
@@ -424,7 +424,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
424 = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $
424 = -- trace ("PATTERN RULE SOLVE: " ++ show (mv, tm, env, bindLams args (substEnv env tm))) $
425 checkCycle bnames (mv, eta [] $ bindLams args (substEnv env tm))
425 checkCycle bnames (mv, eta [] $ bindLams args (substEnv env tm))
426 where rigid (V i) = True
426 where rigid (V i) = True
427− rigid (P _ t _) = t `elem` map fst env &&
427+ rigid (P _ t _) = t `elem` map fstEnv env &&
428 not (holeIn env t || t `elem` holes)
428 not (holeIn env t || t `elem` holes)
429 rigid _ = False
429 rigid _ = False
430
430
@@ -450,24 +450,24 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
450 bindLams [] tm = tm
450 bindLams [] tm = tm
451 bindLams (a : as) tm = bindLam a (bindLams as tm)
451 bindLams (a : as) tm = bindLam a (bindLams as tm)
452
452
453− bindLam (V i) tm = Bind (fst (env !! i))
453+ bindLam (V i) tm = Bind (fstEnv (env !! i))
454− (Lam (binderTy (snd (env !! i))))
454+ (Lam RigW (binderTy (sndEnv (env !! i))))
455 tm
455 tm
456− bindLam (P _ n ty) tm = Bind n (Lam ty) tm
456+ bindLam (P _ n ty) tm = Bind n (Lam RigW ty) tm
457 bindLam _ tm = error "Can't happen [non rigid bindLam]"
457 bindLam _ tm = error "Can't happen [non rigid bindLam]"
458
458
459 substEnv [] tm = tm
459 substEnv [] tm = tm
460− substEnv ((n, t) : env) tm
460+ substEnv ((n, _, t) : env) tm
461 = substEnv env (substV (P Bound n (binderTy t)) tm)
461 = substEnv env (substV (P Bound n (binderTy t)) tm)
462
462
463 -- remove any unnecessary lambdas (helps with interface
463 -- remove any unnecessary lambdas (helps with interface
464 -- resolution later).
464 -- resolution later).
465− eta ks (Bind n (Lam ty) sc) = eta ((n, ty) : ks) sc
465+ eta ks (Bind n (Lam r ty) sc) = eta ((n, r, ty) : ks) sc
466 eta ks t = rebind ks t
466 eta ks t = rebind ks t
467
467
468− rebind ((n, ty) : ks) (App _ f (P _ n' _))
468+ rebind ((n, r, ty) : ks) (App _ f (P _ n' _))
469 | n == n' = eta ks f
469 | n == n' = eta ks f
470− rebind ((n, ty) : ks) t = rebind ks (Bind n (Lam ty) t)
470+ rebind ((n, r, ty) : ks) t = rebind ks (Bind n (Lam r ty) t)
471 rebind _ t = t
471 rebind _ t = t
472
472
473 un' env fn bnames appx@(App _ _ _) appy@(App _ _ _)
473 un' env fn bnames appx@(App _ _ _) appy@(App _ _ _)
@@ -475,13 +475,13 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
475-- = uplus (unApp fn bnames appx appy)
475-- = uplus (unApp fn bnames appx appy)
476-- (unifyTmpFail appx appy) -- take the whole lot
476-- (unifyTmpFail appx appy) -- take the whole lot
477
477
478− un' env fn bnames x (Bind n (Lam t) (App _ y (P Bound n' _)))
478+ un' env fn bnames x (Bind n (Lam _ t) (App _ y (P Bound n' _)))
479 | n == n' = un' env False bnames x y
479 | n == n' = un' env False bnames x y
480− un' env fn bnames (Bind n (Lam t) (App _ x (P Bound n' _))) y
480+ un' env fn bnames (Bind n (Lam _ t) (App _ x (P Bound n' _))) y
481 | n == n' = un' env False bnames x y
481 | n == n' = un' env False bnames x y
482− un' env fn bnames x (Bind n (Lam t) (App _ y (V 0)))
482+ un' env fn bnames x (Bind n (Lam _ t) (App _ y (V 0)))
483 = un' env False bnames x y
483 = un' env False bnames x y
484− un' env fn bnames (Bind n (Lam t) (App _ x (V 0))) y
484+ un' env fn bnames (Bind n (Lam _ t) (App _ x (V 0))) y
485 = un' env False bnames x y
485 = un' env False bnames x y
486-- un' env fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)
486-- un' env fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)
487-- = un' env False ((x,y):bnames) sx sy
487-- = un' env False ((x,y):bnames) sx sy
@@ -491,27 +491,27 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
491 -- f D unifies with t -> D. This is dubious, but it helps with
491 -- f D unifies with t -> D. This is dubious, but it helps with
492 -- interface resolution for interfaces over functions.
492 -- interface resolution for interfaces over functions.
493
493
494− un' env fn bnames (App _ f x) (Bind n (Pi i t k) y)
494+ un' env fn bnames (App _ f x) (Bind n (Pi r i t k) y)
495 | noOccurrence n y && injectiveApp f
495 | noOccurrence n y && injectiveApp f
496 = do ux <- un' env False bnames x y
496 = do ux <- un' env False bnames x y
497− uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam (TType (UVar [] 0)))
497+ uf <- un' env False bnames f (Bind (sMN 0 "uv") (Lam RigW (TType (UVar [] 0)))
498− (Bind n (Pi i t k) (V 1)))
498+ (Bind n (Pi r i t k) (V 1)))
499 combine env bnames ux uf
499 combine env bnames ux uf
500
500
501− un' env fn bnames (Bind n (Pi i t k) y) (App _ f x)
501+ un' env fn bnames (Bind n (Pi r i t k) y) (App _ f x)
502 | noOccurrence n y && injectiveApp f
502 | noOccurrence n y && injectiveApp f
503 = do ux <- un' env False bnames y x
503 = do ux <- un' env False bnames y x
504− uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam (TType (UVar [] 0)))
504+ uf <- un' env False bnames (Bind (sMN 0 "uv") (Lam RigW (TType (UVar [] 0)))
505− (Bind n (Pi i t k) (V 1))) f
505+ (Bind n (Pi r i t k) (V 1))) f
506 combine env bnames ux uf
506 combine env bnames ux uf
507
507
508 un' env fn bnames (Bind x bx sx) (Bind y by sy)
508 un' env fn bnames (Bind x bx sx) (Bind y by sy)
509 | sameBinder bx by
509 | sameBinder bx by
510 = do h1 <- uB env bnames bx by
510 = do h1 <- uB env bnames bx by
511− h2 <- un' ((x, bx) : env) False (((x,y),binderTy bx):bnames) sx sy
511+ h2 <- un' ((x, RigW, bx) : env) False (((x,y),binderTy bx):bnames) sx sy
512 combine env bnames h1 h2
512 combine env bnames h1 h2
513− where sameBinder (Lam _) (Lam _) = True
513+ where sameBinder (Lam _ _) (Lam _ _) = True
514− sameBinder (Pi i _ _) (Pi i' _ _) = True
514+ sameBinder (Pi _ i _ _) (Pi _ i' _ _) = True
515 sameBinder _ _ = False -- never unify holes/guesses/etc
515 sameBinder _ _ = False -- never unify holes/guesses/etc
516 un' env fn bnames x y
516 un' env fn bnames x y
517 | OK True <- convEq' ctxt holes x y = do sc 1; return []
517 | OK True <- convEq' ctxt holes x y = do sc 1; return []
@@ -606,7 +606,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
606 P _ x _ -> x `elem` holes || patIn env x
606 P _ x _ -> x `elem` holes || patIn env x
607 _ -> False
607 _ -> False
608 inenv t = case t of
608 inenv t = case t of
609− P _ x _ -> x `elem` (map fst env)
609+ P _ x _ -> x `elem` (map fstEnv env)
610 _ -> False
610 _ -> False
611
611
612 notFn t = injective t || metavar t || inenv t
612 notFn t = injective t || metavar t || inenv t
@@ -642,10 +642,10 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
642 h2 <- un' env False bnames vx vy
642 h2 <- un' env False bnames vx vy
643 sc 1
643 sc 1
644 combine env bnames h1 h2
644 combine env bnames h1 h2
645− uB env bnames (Lam tx) (Lam ty) = do sc 1; un' env False bnames tx ty
645+ uB env bnames (Lam _ tx) (Lam _ ty) = do sc 1; un' env False bnames tx ty
646− uB env bnames (Pi _ tx _) (Pi _ ty _) = do sc 1; un' env False bnames tx ty
646+ uB env bnames (Pi _ _ tx _) (Pi _ _ ty _) = do sc 1; un' env False bnames tx ty
647 uB env bnames (Hole tx) (Hole ty) = un' env False bnames tx ty
647 uB env bnames (Hole tx) (Hole ty) = un' env False bnames tx ty
648− uB env bnames (PVar tx) (PVar ty) = un' env False bnames tx ty
648+ uB env bnames (PVar _ tx) (PVar _ ty) = un' env False bnames tx ty
649 uB env bnames x y
649 uB env bnames x y
650 = do UI s f <- get
650 = do UI s f <- get
651 let r = recoverable (normalise ctxt env (binderTy x))
651 let r = recoverable (normalise ctxt env (binderTy x))
@@ -679,7 +679,7 @@ unify ctxt env (topx, xfrom) (topy, yfrom) inj holes usersupp from =
679 bind i ns tm
679 bind i ns tm
680 | i < 0 = tm
680 | i < 0 = tm
681 | otherwise = let ((x,y),ty) = ns!!i in
681 | otherwise = let ((x,y),ty) = ns!!i in
682− App MaybeHoles (Bind y (Lam ty) (bind (i-1) ns tm))
682+ App MaybeHoles (Bind y (Lam RigW ty) (bind (i-1) ns tm))
683 (P Bound x ty)
683 (P Bound x ty)
684
684
685 combine env bnames as [] = return as
685 combine env bnames as [] = return as
@@ -754,33 +754,33 @@ recoverable (App _ f a) (App _ f' a')
754 | f == f' = recoverable a a'
754 | f == f' = recoverable a a'
755recoverable (App _ f a) (App _ f' a')
755recoverable (App _ f a) (App _ f' a')
756 = recoverable f f' -- && recoverable a a'
756 = recoverable f f' -- && recoverable a a'
757−recoverable f (Bind _ (Pi _ _ _) sc)
757+recoverable f (Bind _ (Pi _ _ _ _) sc)
758 | (P (DCon _ _ _) _ _, _) <- unApply f = False
758 | (P (DCon _ _ _) _ _, _) <- unApply f = False
759 | (P (TCon _ _) _ _, _) <- unApply f = False
759 | (P (TCon _ _) _ _, _) <- unApply f = False
760 | (Constant _) <- f = False
760 | (Constant _) <- f = False
761 | TType _ <- f = False
761 | TType _ <- f = False
762 | UType _ <- f = False
762 | UType _ <- f = False
763−recoverable (Bind _ (Pi _ _ _) sc) f
763+recoverable (Bind _ (Pi _ _ _ _) sc) f
764 | (P (DCon _ _ _) _ _, _) <- unApply f = False
764 | (P (DCon _ _ _) _ _, _) <- unApply f = False
765 | (P (TCon _ _) _ _, _) <- unApply f = False
765 | (P (TCon _ _) _ _, _) <- unApply f = False
766 | (Constant _) <- f = False
766 | (Constant _) <- f = False
767 | TType _ <- f = False
767 | TType _ <- f = False
768 | UType _ <- f = False
768 | UType _ <- f = False
769−recoverable (Bind _ (Lam _) sc) f = recoverable sc f
769+recoverable (Bind _ (Lam _ _) sc) f = recoverable sc f
770−recoverable f (Bind _ (Lam _) sc) = recoverable f sc
770+recoverable f (Bind _ (Lam _ _) sc) = recoverable f sc
771recoverable x y = True
771recoverable x y = True
772
772
773−errEnv :: [(a, Binder b)] -> [(a, b)]
773+errEnv :: [(a, r, Binder b)] -> [(a, b)]
774−errEnv = map (\(x, b) -> (x, binderTy b))
774+errEnv = map (\(x, _, b) -> (x, binderTy b))
775
775
776holeIn :: Env -> Name -> Bool
776holeIn :: Env -> Name -> Bool
777−holeIn env n = case lookup n env of
777+holeIn env n = case lookupBinder n env of
778 Just (Hole _) -> True
778 Just (Hole _) -> True
779 Just (Guess _ _) -> True
779 Just (Guess _ _) -> True
780 _ -> False
780 _ -> False
781
781
782patIn :: Env -> Name -> Bool
782patIn :: Env -> Name -> Bool
783−patIn env n = case lookup n env of
783+patIn env n = case lookupBinder n env of
784− Just (PVar _) -> True
784+ Just (PVar _ _) -> True
785 Just (PVTy _) -> True
785 Just (PVTy _) -> True
786 _ -> False
786 _ -> False
src/Idris/Core/WHNF.hs+70−25
@@ -8,7 +8,7 @@ Maintainer : The Idris Community.
8
8
9{-# LANGUAGE PatternGuards #-}
9{-# LANGUAGE PatternGuards #-}
10{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
10{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
11−module Idris.Core.WHNF(whnf, WEnv) where
11+module Idris.Core.WHNF(whnf, whnfArgs, WEnv) where
12
12
13import Idris.Core.CaseTree
13import Idris.Core.CaseTree
14import Idris.Core.Evaluate hiding (quote)
14import Idris.Core.Evaluate hiding (quote)
@@ -20,6 +20,7 @@ import Debug.Trace
20-- | A stack entry consists of a term and the environment it is to be
20-- | A stack entry consists of a term and the environment it is to be
21-- evaluated in (i.e. it's a thunk)
21-- evaluated in (i.e. it's a thunk)
22type StackEntry = (Term, WEnv)
22type StackEntry = (Term, WEnv)
23+
23data WEnv = WEnv Int -- number of free variables
24data WEnv = WEnv Int -- number of free variables
24 [(Term, WEnv)]
25 [(Term, WEnv)]
25 deriving Show
26 deriving Show
@@ -34,10 +35,11 @@ type Stack = [StackEntry]
34-- environment it was encountered in, so that when we quote back to a term
35-- environment it was encountered in, so that when we quote back to a term
35-- we get the substitutions right.
36-- we get the substitutions right.
36
37
37−data WHNF = WDCon Int Int Bool Name (Type, WEnv) -- ^ data constructor
38+data WHNF = WDCon Int Int Bool Name (Term, WEnv) -- ^ data constructor
38 | WTCon Int Int Name (Type, WEnv) -- ^ type constructor
39 | WTCon Int Int Name (Type, WEnv) -- ^ type constructor
39− | WPRef Name (Type, WEnv) -- ^irreducible global (e.g. a postulate)
40+ | WPRef Name (Term, WEnv) -- ^irreducible global (e.g. a postulate)
40− | WBind Name (Binder Term) (Term, WEnv)
41+ | WV Int
42+ | WBind Name (Binder (Term, WEnv)) (Term, WEnv)
41 | WApp WHNF (Term, WEnv)
43 | WApp WHNF (Term, WEnv)
42 | WConstant Const
44 | WConstant Const
43 | WProj WHNF Int
45 | WProj WHNF Int
@@ -46,24 +48,56 @@ data WHNF = WDCon Int Int Bool Name (Type, WEnv) -- ^ data constructor
46 | WErased
48 | WErased
47 | WImpossible
49 | WImpossible
48
50
49−-- | Reduce a *closed* term to weak head normal form.
51+-- NOTE: These aren't yet ready to be used in practice - there's still a
50−whnf :: Context -> Term -> Term
52+-- bug or two in the handling of de Bruijn indices.
51−whnf ctxt tm = quote (do_whnf ctxt (WEnv 0 []) tm)
53+
54+-- | Reduce a term to weak head normal form.
55+whnf :: Context -> Env -> Term -> Term
56+-- whnf ctxt env tm = let res = whnf' ctxt env tm in
57+-- trace (show tm ++ "\n==>\n" ++ show res ++ "\n") res
58+whnf ctxt env tm =
59+ inlineSmall ctxt env $ -- reduce small things in body. This is primarily
60+ -- to get rid of any noisy "assert_smaller/assert_total"
61+ -- and evaluate any simple operators, which makes things
62+ -- easier to read.
63+ whnf' ctxt env tm
64+whnf' ctxt env tm =
65+ quote (do_whnf ctxt (map finalEntry env) (finalise tm))
66+
67+-- | Reduce a type so that all arguments are expanded
68+whnfArgs :: Context -> Env -> Term -> Term
69+whnfArgs ctxt env tm = inlineSmall ctxt env $ finalise (whnfArgs' ctxt env tm)
70+whnfArgs' ctxt env tm
71+ = case whnf' ctxt env tm of
72+ -- The assumption is that de Bruijn indices refer to local things
73+ -- (so not in the external environment) so we need to instantiate
74+ -- the name
75+ Bind n b@(Pi rig _ ty _) sc ->
76+ Bind n b (whnfArgs' ctxt ((n, rig, b):env)
77+ (subst n (P Bound n ty) sc))
78+ res -> tm
79+
80+finalEntry :: (Name, RigCount, Binder (TT Name)) -> (Name, RigCount, Binder (TT Name))
81+finalEntry (n, r, b) = (n, r, fmap finalise b)
52
82
53−do_whnf :: Context -> WEnv -> Term -> WHNF
83+do_whnf :: Context -> Env -> Term -> WHNF
54−do_whnf ctxt env tm = eval env [] tm
84+do_whnf ctxt genv tm = eval (WEnv 0 []) [] tm
55 where
85 where
56 eval :: WEnv -> Stack -> Term -> WHNF
86 eval :: WEnv -> Stack -> Term -> WHNF
57 eval wenv@(WEnv d env) stk (V i)
87 eval wenv@(WEnv d env) stk (V i)
58 | i < length env = let (tm, env') = env !! i in
88 | i < length env = let (tm, env') = env !! i in
59 eval env' stk tm
89 eval env' stk tm
60− | otherwise = error "Can't happen: WHNF scope error"
90+ | otherwise = WV i
61 eval wenv@(WEnv d env) stk (Bind n (Let t v) sc)
91 eval wenv@(WEnv d env) stk (Bind n (Let t v) sc)
62 = eval (WEnv d ((v, wenv) : env)) stk sc
92 = eval (WEnv d ((v, wenv) : env)) stk sc
63− eval (WEnv d env) [] (Bind n b sc) = WBind n b (sc, WEnv (d + 1) env)
93+ eval (WEnv d env) ((tm, tenv) : stk) (Bind n b@(Lam _ _) sc)
64− eval (WEnv d env) ((tm, tenv) : stk) (Bind n b sc)
65 = eval (WEnv d ((tm, tenv) : env)) stk sc
94 = eval (WEnv d ((tm, tenv) : env)) stk sc
95+ eval wenv@(WEnv d env) stk (Bind n b sc) -- stk must be empty if well typed
96+ =let n' = uniqueName n (map fstEnv genv) in
97+ WBind n' (fmap (\t -> (t, wenv)) b) (sc, WEnv (d + 1) env)
66
98
99+ eval env stk (P nt n ty)
100+ | Just (Let t v) <- lookupBinder n genv = eval env stk v
67 eval env stk (P nt n ty) = apply env nt n ty stk
101 eval env stk (P nt n ty) = apply env nt n ty stk
68 eval env stk (App _ f a) = eval env ((a, env) : stk) f
102 eval env stk (App _ f a) = eval env ((a, env) : stk) f
69 eval env stk (Constant c) = unload (WConstant c) stk
103 eval env stk (Constant c) = unload (WConstant c) stk
@@ -73,30 +107,34 @@ do_whnf ctxt env tm = eval env [] tm
73
107
74 eval env stk Erased = unload WErased stk
108 eval env stk Erased = unload WErased stk
75 eval env stk Impossible = unload WImpossible stk
109 eval env stk Impossible = unload WImpossible stk
110+ eval env stk (Inferred tm) = eval env stk tm
76 eval env stk (TType u) = unload (WType u) stk
111 eval env stk (TType u) = unload (WType u) stk
77 eval env stk (UType u) = unload (WUType u) stk
112 eval env stk (UType u) = unload (WUType u) stk
78
113
79 apply :: WEnv -> NameType -> Name -> Type -> Stack -> WHNF
114 apply :: WEnv -> NameType -> Name -> Type -> Stack -> WHNF
80− apply env nt n ty stk
115+ apply env nt n ty stk
81 = let wp = case nt of
116 = let wp = case nt of
82 DCon t a u -> WDCon t a u n (ty, env)
117 DCon t a u -> WDCon t a u n (ty, env)
83 TCon t a -> WTCon t a n (ty, env)
118 TCon t a -> WTCon t a n (ty, env)
84 Ref -> WPRef n (ty, env)
119 Ref -> WPRef n (ty, env)
85 _ -> WPRef n (ty, env)
120 _ -> WPRef n (ty, env)
86 in
121 in
87− case lookupDefExact n ctxt of
122+ if not (tcReducible n ctxt)
88− Just (CaseOp ci _ _ _ _ cd) ->
123+ then unload wp stk
89− let (ns, tree) = cases_compiletime cd in
124+ else case lookupDefAccExact n False ctxt of
90− case evalCase env ns tree stk of
125+ Just (CaseOp ci _ _ _ _ cd, acc)
91− Just w -> w
126+ | acc == Public || acc == Hidden ->
92− Nothing -> unload wp stk
127+ let (ns, tree) = cases_compiletime cd in
93− Just (Operator _ i op) ->
128+ case evalCase env ns tree stk of
129+ Just w -> w
130+ Nothing -> unload wp stk
131+ Just (Operator _ i op, acc) ->
94 if i <= length stk
132 if i <= length stk
95 then case runOp env op (take i stk) (drop i stk) of
133 then case runOp env op (take i stk) (drop i stk) of
96 Just v -> v
134 Just v -> v
97 Nothing -> unload wp stk
135 Nothing -> unload wp stk
98 else unload wp stk
136 else unload wp stk
99− _ -> unload wp stk
137+ _ -> unload wp stk
100
138
101 unload :: WHNF -> Stack -> WHNF
139 unload :: WHNF -> Stack -> WHNF
102 unload f [] = f
140 unload f [] = f
@@ -112,6 +150,8 @@ do_whnf ctxt env tm = eval env [] tm
112 -- aren't run on constants are themselves pretty ugly
150 -- aren't run on constants are themselves pretty ugly
113 -- (it's prim__believe_me and prim__syntacticEq, for
151 -- (it's prim__believe_me and prim__syntacticEq, for
114 -- example) so let's not worry too much...
152 -- example) so let's not worry too much...
153+ -- We will need to deal with believe_me before dropping this
154+ -- into the type checker, though.
115 Just val -> Just $ eval env rest (quoteTerm val)
155 Just val -> Just $ eval env rest (quoteTerm val)
116 _ -> Nothing
156 _ -> Nothing
117
157
@@ -189,7 +229,9 @@ quote :: WHNF -> Term
189quote (WDCon t a u n (ty, env)) = P (DCon t a u) n (quoteEnv env ty)
229quote (WDCon t a u n (ty, env)) = P (DCon t a u) n (quoteEnv env ty)
190quote (WTCon t a n (ty, env)) = P (TCon t a) n (quoteEnv env ty)
230quote (WTCon t a n (ty, env)) = P (TCon t a) n (quoteEnv env ty)
191quote (WPRef n (ty, env)) = P Ref n (quoteEnv env ty)
231quote (WPRef n (ty, env)) = P Ref n (quoteEnv env ty)
192−quote (WBind n ty (sc, env)) = Bind n ty (quoteEnv env sc)
232+quote (WV i) = V i
233+quote (WBind n b (sc, env)) = Bind n (fmap (\ (t, env) -> quoteEnv env t) b)
234+ (quoteEnv env sc)
193quote (WApp f (a, env)) = App Complete (quote f) (quoteEnv env a)
235quote (WApp f (a, env)) = App Complete (quote f) (quoteEnv env a)
194quote (WConstant c) = Constant c
236quote (WConstant c) = Constant c
195quote (WProj t i) = Proj (quote t) i
237quote (WProj t i) = Proj (quote t) i
@@ -201,10 +243,13 @@ quote WImpossible = Impossible
201quoteEnv :: WEnv -> Term -> Term
243quoteEnv :: WEnv -> Term -> Term
202quoteEnv (WEnv d ws) tm = qe' d ws tm
244quoteEnv (WEnv d ws) tm = qe' d ws tm
203 where
245 where
246+ -- d is number of free variables in the external environment
247+ -- (all bound in the scope of 'ws')
204 qe' d ts (V i)
248 qe' d ts (V i)
205− | i < d = V i
249+ | (i - d) < length ts && (i - d) >= 0
206− | otherwise = let (tm, env) = ts !! (i - d) in
250+ = let (tm, env) = ts !! (i - d) in
207− quoteEnv env tm
251+ quoteEnv env tm
252+ | otherwise = V i
208 qe' d ts (Bind n b sc)
253 qe' d ts (Bind n b sc)
209 = Bind n (fmap (qe' d ts) b) (qe' (d + 1) ts sc)
254 = Bind n (fmap (qe' d ts) b) (qe' (d + 1) ts sc)
210 qe' d ts (App c f a)
255 qe' d ts (App c f a)
src/Idris/Coverage.hs+302−256
@@ -6,7 +6,8 @@ License : BSD3
6Maintainer : The Idris Community.
6Maintainer : The Idris Community.
7-}
7-}
8{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9−module Idris.Coverage where
9+module Idris.Coverage(genClauses, validCoverageCase, recoverableCoverage,
10+ mkPatTm) where
10
11
11import Idris.AbsSyntax
12import Idris.AbsSyntax
12import Idris.Core.CaseTree
13import Idris.Core.CaseTree
@@ -61,100 +62,269 @@ mkPatTm t = do i <- getIState
61--
62--
62-- This will only work after the given clauses have been typechecked and the
63-- This will only work after the given clauses have been typechecked and the
63-- names are fully explicit!
64-- names are fully explicit!
64−genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]
65+genClauses :: FC -> Name -> [([Name], Term)] -> -- (Argument names, LHS)
65−genClauses fc n xs given
66+ [PTerm] -> Idris [PTerm]
67+-- No clauses (only valid via elab reflection). We should probably still do
68+-- a check here somehow, e.g. that one of the arguments is an obviously
69+-- empty type. In practice, this should only really be used for Void elimination.
70+genClauses fc n lhs_tms [] = return []
71+genClauses fc n lhs_tms given
66 = do i <- getIState
72 = do i <- getIState
67− let lhs_tms = map (\x -> flattenArgs $ delab' i x True True) xs
73+
68− -- if a placeholder was given, don't bother generating cases for it
74+ let lhs_given = zipWith removePlaceholders lhs_tms
69− let lhs_tms' = zipWith mergePlaceholders lhs_tms
75+ (map (stripUnmatchable i) (map flattenArgs given))
70− (map (stripUnmatchable i) (map flattenArgs given))
76+
71− let lhss = map pUnApply lhs_tms'
77+ logCoverage 5 $ "Building coverage tree for:\n" ++ showSep "\n" (map show (lhs_given))
72− nty <- case lookupTyExact n (tt_ctxt i) of
78+ let givenpos = mergePos (map getGivenPos given)
73− Just t -> return (normalise (tt_ctxt i) [] t)
79+
74− _ -> fail "Can't happen - genClauses, lookupTyExact"
80+ (cns, ctree_in) <-
75−
81+ case simpleCase False (UnmatchedCase "Undefined") False
76− let argss = transpose lhss
82+ (CoverageCheck givenpos) emptyFC [] []
77− let all_args = map (genAll i) (zip (genPH i nty) argss)
83+ lhs_given
78− logCoverage 5 $ "COVERAGE of " ++ show n
84+ (const []) of
79− logCoverage 5 $ "using type " ++ show nty
85+ OK (CaseDef cns ctree_in _) ->
80− logCoverage 5 $ "non-concrete args " ++ show (genPH i nty)
86+ return (cns, ctree_in)
81−
87+ Error e -> tclift $ tfail $ At fc e
82− logCoverage 5 $ show (lhs_tms, lhss)
88+
83− logCoverage 5 $ "Args are: " ++ show argss
89+ let ctree = trimOverlapping (addMissingCons i ctree_in)
84− logCoverage 5 $ show (map length argss) ++ "\nAll args:\n" ++ show (map length all_args)
90+ let (coveredas, missingas) = mkNewClauses (tt_ctxt i) n cns ctree
85− logCoverage 10 $ "All args are: " ++ show all_args
91+ let covered = map (\t -> delab' i t True True) coveredas
86− logCoverage 3 $ "Original: \n" ++
92+ let missing = filter (\x -> x `notElem` covered) $
87− showSep "\n" (map (\t -> showTmImpls (delab' i t True True)) xs)
93+ map (\t -> delab' i t True True) missingas
88− -- add an infinite supply of explicit arguments to update the possible
94+
89− -- cases for (the return type may be variadic, or function type, so
95+ logCoverage 5 $ "Coverage from case tree for " ++ show n ++ ": " ++ show ctree
90− -- there may be more case splitting that the idris_implicits record
96+ logCoverage 2 $ show (length missing) ++ " missing clauses for " ++ show n
91− -- suggests)
97+ logCoverage 3 $ "Missing clauses:\n" ++ showSep "\n"
92− let parg = case lookupCtxt n (idris_implicits i) of
98+ (map showTmImpls missing)
93− (p : _) ->
99+ logCoverage 10 $ "Covered clauses:\n" ++ showSep "\n"
94− p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)
100+ (map showTmImpls covered)
95− _ -> repeat (pexp Placeholder)
101+ return missing
96− let tryclauses = mkClauses parg all_args
102+ where
97− logCoverage 3 $ show (length tryclauses) ++ " initially to check"
98− logCoverage 2 $ showSep "\n" (map (showTm i) tryclauses)
99−
100− let xsdelab = map (\x -> stripUnmatchable i (delab' i x True True)) xs
101− let new = filter (noMatch i xsdelab) tryclauses
102− logCoverage 2 $ show (length new) ++ " clauses to check for impossibility"
103− logCoverage 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)
104−-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)
105− return new
106−-- return (map (\t -> PClause n t [] PImpossible []) new)
107− where getLHS i term
108− | (f, args) <- unApply term = map (\t -> delab' i t True True) args
109− | otherwise = []
110−
111− -- if an argument has a non-concrete type (i.e. it's a function
112− -- that calculates something from a previous argument) we'll also
113− -- need to generate a placeholder pattern for it since it could be
114− -- anything based on earlier values
115− genPH :: IState -> Type -> [Bool]
116− genPH ist (Bind n (Pi _ ty _) sc) = notConcrete ist ty : genPH ist sc
117− genPH ist ty = []
118−
119− notConcrete ist t | (P _ n _, args) <- unApply t,
120− not (isConName n (tt_ctxt ist)) = True
121− notConcrete _ _ = False
122−
123− pUnApply (PApp _ f args) = map getTm args
124− pUnApply _ = []
125−
126 flattenArgs (PApp fc (PApp _ f as) as')
103 flattenArgs (PApp fc (PApp _ f as) as')
127 = flattenArgs (PApp fc f (as ++ as'))
104 = flattenArgs (PApp fc f (as ++ as'))
128 flattenArgs t = t
105 flattenArgs t = t
129
106
130− -- Return whether the given clause matches none of the input clauses
107+getGivenPos :: PTerm -> [Int]
131− -- (xs)
108+getGivenPos (PApp _ _ pargs) = getGiven 0 (map getTm pargs)
132− noMatch i xs tm = all (\x -> case matchClause i x tm of
109+ where
133− Right ms -> False
110+ getGiven i (Placeholder : tms) = getGiven (i + 1) tms
134− Left miss -> True) xs
111+ getGiven i (_ : tms) = i : getGiven (i + 1) tms
135−
112+ getGiven i [] = []
136−
113+getGivenPos _ = []
137− mergePlaceholders :: PTerm -> PTerm -> PTerm
114+
138− mergePlaceholders x Placeholder = Placeholder
115+-- Return a list of Ints which are in every list
139− mergePlaceholders (PApp fc f args) (PApp fc' f' args')
116+mergePos :: [[Int]] -> [Int]
140− = PApp fc' f' (zipWith mergePArg args args')
117+mergePos [] = []
141− where mergePArg x y = let xtm = mergePlaceholders (getTm x) (getTm y) in
118+mergePos [x] = x
142− x { getTm = xtm}
119+mergePos (x : xs) = intersect x (mergePos xs)
143− mergePlaceholders x _ = x
120+
144−
121+removePlaceholders :: ([Name], Term) -> PTerm -> ([Name], Term, Term)
145− mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]
122+removePlaceholders (ns, tm) ptm = (ns, rp tm ptm, Erased)
146− mkClauses parg args
123+ where
147− | all (== [Placeholder]) args = []
124+ rp Erased Placeholder = Erased
148− mkClauses parg args
125+ rp tm Placeholder = Inferred tm
149− = do args' <- mkArg args
126+ rp tm (PApp _ pf pargs)
150− let tm = PApp fc (PRef fc [] n) (zipWith upd args' parg)
127+ | (tf, targs) <- unApply tm
151− return tm
128+ = let tf' = rp tf pf
152− where
129+ targs' = zipWith rp targs (map getTm pargs) in
153− mkArg :: [[PTerm]] -> [[PTerm]]
130+ mkApp tf' targs'
154− mkArg [] = return []
131+ rp tm (PPair _ _ _ pl pr)
155− mkArg (a : as) = do a' <- a
132+ | (tf, [tyl, tyr, tl, tr]) <- unApply tm
156− as' <- mkArg as
133+ = let tl' = rp tl pl
157− return (a':as')
134+ tr' = rp tr pr in
135+ mkApp tf [Erased, Erased, tl', tr']
136+ rp tm (PDPair _ _ _ pl pt pr)
137+ | (tf, [tyl, tyr, tl, tr]) <- unApply tm
138+ = let tl' = rp tl pl
139+ tr' = rp tr pr in
140+ mkApp tf [Erased, Erased, tl', tr']
141+ rp tm _ = tm
142+
143+mkNewClauses :: Context -> Name -> [Name] -> SC -> ([Term], [Term])
144+mkNewClauses ctxt fn ns sc
145+ = (map (mkPlApp (P Ref fn Erased)) $
146+ mkFromSC True (map (\n -> P Ref n Erased) ns) sc,
147+ map (mkPlApp (P Ref fn Erased)) $
148+ mkFromSC False (map (\n -> P Ref n Erased) ns) sc)
149+ where
150+ mkPlApp f args = mkApp f (map erasePs args)
151+
152+ erasePs ap@(App t f a)
153+ | (f, args) <- unApply ap = mkApp f (map erasePs args)
154+ erasePs (P _ n _) | not (isConName n ctxt) = Erased
155+ erasePs tm = tm
156+
157+ mkFromSC cov args sc = evalState (mkFromSC' cov args sc) []
158+
159+ mkFromSC' :: Bool -> [Term] -> SC -> State [[Term]] [[Term]]
160+ mkFromSC' cov args (STerm _)
161+ = if cov then return [args] else return [] -- leaf of provided case
162+ mkFromSC' cov args (UnmatchedCase _)
163+ = if cov then return [] else return [args] -- leaf of missing case
164+ mkFromSC' cov args ImpossibleCase = return []
165+ mkFromSC' cov args (Case _ x alts)
166+ = do done <- get
167+ if (args `elem` done)
168+ then return []
169+ else do alts' <- mapM (mkFromAlt cov args x) alts
170+ put (args : done)
171+ return (concat alts')
172+ mkFromSC' cov args _ = return [] -- Should never happen
173+
174+ mkFromAlt :: Bool -> [Term] -> Name -> CaseAlt -> State [[Term]] [[Term]]
175+ mkFromAlt cov args x (ConCase c t conargs sc)
176+ = let argrep = mkApp (P (DCon t (length args) False) c Erased)
177+ (map (\n -> P Ref n Erased) conargs)
178+ args' = map (subst x argrep) args in
179+ mkFromSC' cov args' sc
180+ mkFromAlt cov args x (ConstCase c sc)
181+ = let argrep = Constant c
182+ args' = map (subst x argrep) args in
183+ mkFromSC' cov args' sc
184+ mkFromAlt cov args x (DefaultCase sc)
185+ = mkFromSC' cov args sc
186+ mkFromAlt cov _ _ _ = return []
187+
188+-- Modify the generated case tree (the case tree builder doesn't have access
189+-- to the context, so can't do this itself).
190+-- Replaces any missing cases with explicit cases for the missing constructors
191+addMissingCons :: IState -> SC -> SC
192+addMissingCons ist sc = evalState (addMissingConsSt ist sc) 0
193+
194+addMissingConsSt :: IState -> SC -> State Int SC
195+addMissingConsSt ist (Case t n alts) = liftM (Case t n) (addMissingAlts n alts)
196+ where
197+ addMissingAlt :: CaseAlt -> State Int CaseAlt
198+ addMissingAlt (ConCase n i ns sc)
199+ = liftM (ConCase n i ns) (addMissingConsSt ist sc)
200+ addMissingAlt (FnCase n ns sc)
201+ = liftM (FnCase n ns) (addMissingConsSt ist sc)
202+ addMissingAlt (ConstCase c sc)
203+ = liftM (ConstCase c) (addMissingConsSt ist sc)
204+ addMissingAlt (SucCase n sc)
205+ = liftM (SucCase n) (addMissingConsSt ist sc)
206+ addMissingAlt (DefaultCase sc)
207+ = liftM DefaultCase (addMissingConsSt ist sc)
208+
209+ addMissingAlts argn as
210+-- | any hasDefault as = map addMissingAlt as
211+ | cons@(n:_) <- mapMaybe collectCons as,
212+ Just tyn <- getConType n,
213+ Just ti <- lookupCtxtExact tyn (idris_datatypes ist)
214+ -- If we've fallen through on this argument earlier, then the
215+ -- things which were matched in other cases earlier can't be missing
216+ -- cases now
217+ = let missing = con_names ti \\ cons in
218+ do as' <- addCases missing as
219+ mapM addMissingAlt as'
220+ | consts@(n:_) <- mapMaybe collectConsts as
221+ = let missing = nub (map nextConst consts) \\ consts in
222+ mapM addMissingAlt (addCons missing as)
223+ addMissingAlts n as = mapM addMissingAlt as
224+
225+ addCases missing [] = return []
226+ addCases missing (DefaultCase rhs : rest)
227+ = do missing' <- mapM (genMissingAlt rhs) missing
228+ return (mapMaybe id missing' ++ rest)
229+ addCases missing (c : rest)
230+ = liftM (c :) $ addCases missing rest
231+
232+ addCons missing [] = []
233+ addCons missing (DefaultCase rhs : rest)
234+ = map (genMissingConAlt rhs) missing ++ rest
235+ addCons missing (c : rest) = c : addCons missing rest
236+
237+ genMissingAlt rhs n
238+ | Just (TyDecl (DCon tag arity _) ty) <- lookupDefExact n (tt_ctxt ist)
239+ = do name <- get
240+ put (name + arity)
241+ let args = map (name +) [0..arity-1]
242+ return $ Just $ ConCase n tag (map (\i -> sMN i "m") args) rhs
243+ | otherwise = return Nothing
244+
245+ genMissingConAlt rhs n = ConstCase n rhs
246+
247+ collectCons (ConCase n i args sc) = Just n
248+ collectCons _ = Nothing
249+
250+ collectConsts (ConstCase c sc) = Just c
251+ collectConsts _ = Nothing
252+
253+ hasDefault (DefaultCase (UnmatchedCase _)) = False
254+ hasDefault (DefaultCase _) = True
255+ hasDefault _ = False
256+
257+ getConType n = do ty <- lookupTyExact n (tt_ctxt ist)
258+ case unApply (getRetTy (normalise (tt_ctxt ist) [] ty)) of
259+ (P _ tyn _, _) -> Just tyn
260+ _ -> Nothing
261+
262+ -- for every constant in a term (at any level) take next one to make sure
263+ -- that constants which are not explicitly handled are covered
264+ nextConst (I c) = I (c + 1)
265+ nextConst (BI c) = BI (c + 1)
266+ nextConst (Fl c) = Fl (c + 1)
267+ nextConst (B8 c) = B8 (c + 1)
268+ nextConst (B16 c) = B16 (c + 1)
269+ nextConst (B32 c) = B32 (c + 1)
270+ nextConst (B64 c) = B64 (c + 1)
271+ nextConst (Ch c) = Ch (chr $ ord c + 1)
272+ nextConst (Str c) = Str (c ++ "'")
273+ nextConst o = o
274+
275+addMissingConsSt ist sc = return sc
276+
277+trimOverlapping :: SC -> SC
278+trimOverlapping sc = trim [] [] sc
279+ where
280+ trim :: [(Name, (Name, [Name]))] -> -- Variable - constructor+args already matched
281+ [(Name, [Name])] -> -- Variable - constructors which it can't be
282+ SC -> SC
283+ trim mustbes nots (Case t vn alts)
284+ | Just (c, args) <- lookup vn mustbes
285+ = Case t vn (trimAlts mustbes nots vn (substMatch (c, args) alts))
286+ | Just cantbe <- lookup vn nots
287+ = let alts' = filter (notConMatch cantbe) alts in
288+ Case t vn (trimAlts mustbes nots vn alts')
289+ | otherwise = Case t vn (trimAlts mustbes nots vn alts)
290+ trim cs nots sc = sc
291+
292+ trimAlts cs nots vn [] = []
293+ trimAlts cs nots vn (ConCase cn t args sc : rest)
294+ = ConCase cn t args (trim (addMatch vn (cn, args) cs) nots sc) :
295+ trimAlts cs (addCantBe vn cn nots) vn rest
296+ trimAlts cs nots vn (FnCase n ns sc : rest)
297+ = FnCase n ns (trim cs nots sc) : trimAlts cs nots vn rest
298+ trimAlts cs nots vn (ConstCase c sc : rest)
299+ = ConstCase c (trim cs nots sc) : trimAlts cs nots vn rest
300+ trimAlts cs nots vn (SucCase n sc : rest)
301+ = SucCase n (trim cs nots sc) : trimAlts cs nots vn rest
302+ trimAlts cs nots vn (DefaultCase sc : rest)
303+ = DefaultCase (trim cs nots sc) : trimAlts cs nots vn rest
304+
305+ isConMatch c (ConCase cn t args sc) = c == cn
306+ isConMatch _ _ = False
307+
308+ substMatch :: (Name, [Name]) -> [CaseAlt] -> [CaseAlt]
309+ substMatch ca [] = []
310+ substMatch (c,args) (ConCase cn t args' sc : _)
311+ | c == cn = [ConCase c t args (substNames (zip args' args) sc)]
312+ substMatch ca (_:cs) = substMatch ca cs
313+
314+ substNames [] sc = sc
315+ substNames ((n, n') : ns) sc
316+ = substNames ns (substSC n n' sc)
317+
318+ notConMatch cs (ConCase cn t args sc) = cn `notElem` cs
319+ notConMatch cs _ = True
320+
321+ addMatch vn cn cs = (vn, cn) : cs
322+
323+ addCantBe :: Name -> Name -> [(Name, [Name])] -> [(Name, [Name])]
324+ addCantBe vn cn [] = [(vn, [cn])]
325+ addCantBe vn cn ((n, cbs) : nots)
326+ | vn == n = ((n, nub (cn : cbs)) : nots)
327+ | otherwise = ((n, cbs) : addCantBe vn cn nots)
158
328
159-- | Does this error result rule out a case as valid when coverage checking?
329-- | Does this error result rule out a case as valid when coverage checking?
160validCoverageCase :: Context -> Err -> Bool
330validCoverageCase :: Context -> Err -> Bool
@@ -179,10 +349,29 @@ recoverableCoverage :: Context -> Err -> Bool
179recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)
349recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)
180 = let topx' = normalise ctxt [] topx
350 = let topx' = normalise ctxt [] topx
181 topy' = normalise ctxt [] topy in
351 topy' = normalise ctxt [] topy in
182− r || checkRec topx' topy'
352+ evalState (checkRec topx' topy') []
183 where -- different notion of recoverable than in unification, since we
353 where -- different notion of recoverable than in unification, since we
184 -- have no metavars -- just looking to see if a constructor is failing
354 -- have no metavars -- just looking to see if a constructor is failing
185− -- to unify with a function that may be reduced later
355+ -- to unify with a function that may be reduced later, or if any
356+ -- variables need to have two different constructor forms
357+
358+ -- The state is a mapping of name to what it has failed to unify
359+ -- with
360+ checkRec :: Term -> Term -> State [(Name, Term)] Bool
361+ checkRec (P Bound x _) tm
362+ | (P yt _ _, _) <- unApply tm,
363+ conType yt = do nmap <- get
364+ case lookup x nmap of
365+ Nothing -> do put ((x, tm) : nmap)
366+ return True
367+ Just y' -> checkRec tm y'
368+ checkRec tm (P Bound y _)
369+ | (P xt _ _, _) <- unApply tm,
370+ conType xt = do nmap <- get
371+ case lookup y nmap of
372+ Nothing -> do put ((y, tm) : nmap)
373+ return True
374+ Just x' -> checkRec tm x'
186 checkRec (App _ f a) p@(P _ _ _) = checkRec f p
375 checkRec (App _ f a) p@(P _ _ _) = checkRec f p
187 checkRec p@(P _ _ _) (App _ f a) = checkRec p f
376 checkRec p@(P _ _ _) (App _ f a) = checkRec p f
188 checkRec fa@(App _ _ _) fa'@(App _ _ _)
377 checkRec fa@(App _ _ _) fa'@(App _ _ _)
@@ -190,175 +379,32 @@ recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)
190 (f', as') <- unApply fa'
379 (f', as') <- unApply fa'
191 = if (length as /= length as')
380 = if (length as /= length as')
192 then checkRec f f'
381 then checkRec f f'
193− else checkRec f f' && and (zipWith checkRec as as')
382+ else checkRecs (f : as) (f' : as')
194− checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt
383+ where
195− checkRec _ _ = False
384+ checkRecs [] [] = return True
196−
385+ checkRecs (a : as) (b : bs) = do aok <- checkRec a b
386+ asok <- checkRecs as bs
387+ return (aok && asok)
388+ checkRec (P xt x _) (P yt y _)
389+ | x == y = return True
390+ | ntRec xt yt = return True
391+ checkRec _ _ = return False
392+
393+ conType (DCon _ _ _) = True
394+ conType (TCon _ _) = True
395+ conType _ = False
396+
397+ -- If either name is a reference or a bound variable, then further
398+ -- development may fix the error, so consider it recoverable.
399+ -- If both names are constructors, and the name is different, then
400+ -- it's not recoverable
197 ntRec x y | Ref <- x = True
401 ntRec x y | Ref <- x = True
198 | Ref <- y = True
402 | Ref <- y = True
199− | (Bound, Bound) <- (x, y) = True
403+ | Bound <- x = True
404+ | Bound <- y = True
200 | otherwise = False -- name is different, unrecoverable
405 | otherwise = False -- name is different, unrecoverable
201recoverableCoverage ctxt (At _ e) = recoverableCoverage ctxt e
406recoverableCoverage ctxt (At _ e) = recoverableCoverage ctxt e
202recoverableCoverage ctxt (Elaborating _ _ _ e) = recoverableCoverage ctxt e
407recoverableCoverage ctxt (Elaborating _ _ _ e) = recoverableCoverage ctxt e
203recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e
408recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e
204recoverableCoverage _ _ = False
409recoverableCoverage _ _ = False
205
410
206−genAll :: IState -> (Bool, [PTerm]) -> [PTerm]
207−genAll i (addPH, args)
208− = case filter (/=Placeholder) $ fnub $ mergePHs $ fnub (concatMap otherPats (fnub args)) of
209− [] -> [Placeholder]
210− xs -> ph xs
211− where
212− -- Add a placeholder - this is to account for the case where an argument
213− -- has a dependent type calculated from another argument, to make sure that
214− -- all dependencies are covered. If they are, any generated case will
215− -- match given cases.
216− -- (Also this helps when checking, because if we eliminate the placeholder
217− -- quickly then lots of other cases get ruled out fast)
218− ph ts = if addPH then Placeholder : ts else ts
219−
220− -- Merge patterns with placeholders in other patterns, to ensure we've
221− -- covered all possible generated cases
222− -- e.g. if we have (True, _) (False, _) (_, True) (_, False)
223− -- we should merge these to get (True, True), (False, False)
224− -- (False, True) and (True, False)
225− mergePHs :: [PTerm] -> [PTerm]
226− mergePHs xs = mergePHs' xs xs
227−
228− mergePHs' [] all = []
229− mergePHs' (x : xs) all = mergePH x all ++ mergePHs' xs all
230−
231− mergePH :: PTerm -> [PTerm] -> [PTerm]
232− mergePH tm [] = []
233− mergePH tm (x : xs)
234− | Just merged <- mergePTerm tm x = merged : mergePH tm xs
235− | otherwise = mergePH tm xs
236−
237− mergePTerm :: PTerm -> PTerm -> Maybe PTerm
238− mergePTerm x Placeholder = Just x
239− mergePTerm Placeholder x = Just x
240− mergePTerm tm@(PRef fc1 hl1 n1) (PRef fc2 hl2 n2)
241− | n1 == n2 = Just tm
242− mergePTerm (PPair fc1 hl1 p1 x1 y1) (PPair fc2 hl2 p2 x2 y2)
243− = do x <- mergePTerm x1 x2
244− y <- mergePTerm y1 y2
245− Just (PPair fc1 hl1 p1 x y)
246− mergePTerm (PDPair fc1 hl1 p1 x1 t1 y1) (PDPair fc2 hl2 p2 x2 t2 y2)
247− = do x <- mergePTerm x1 x2
248− y <- mergePTerm y1 y2
249− t <- mergePTerm t1 t2
250− Just (PDPair fc1 hl1 p1 x t y)
251− mergePTerm (PApp fc1 f1 args1) (PApp fc2 f2 args2)
252− = do fm <- mergePTerm f1 f2
253− margs <- mergeArgs args1 args2
254− Just (PApp fc1 fm margs)
255− where
256− mergeArgs [] [] = Just []
257− mergeArgs (a : as) (b : bs)
258− = do ma_in <- mergePTerm (getTm a) (getTm b)
259− let ma = a { getTm = ma_in }
260− mas <- mergeArgs as bs
261− Just (ma : mas)
262− mergeArgs _ _ = Nothing
263− mergePTerm x y | x == y = Just x
264− | otherwise = Nothing
265−
266− -- for every constant in a term (at any level) take next one to make sure
267− -- that constants which are not explicitly handled are covered
268− nextConst (PConstant fc c) = PConstant NoFC (nc' c)
269− nextConst o = o
270−
271− nc' (I c) = I (c + 1)
272− nc' (BI c) = BI (c + 1)
273− nc' (Fl c) = Fl (c + 1)
274− nc' (B8 c) = B8 (c + 1)
275− nc' (B16 c) = B16 (c + 1)
276− nc' (B32 c) = B32 (c + 1)
277− nc' (B64 c) = B64 (c + 1)
278− nc' (Ch c) = Ch (chr $ ord c + 1)
279− nc' (Str c) = Str (c ++ "'")
280− nc' o = o
281−
282− otherPats :: PTerm -> [PTerm]
283− otherPats (PRef fc hl n) = ph $ ops fc n []
284− otherPats (PApp _ (PRef fc hl n) xs) = ph $ ops fc n xs
285− otherPats (PPair fc hls _ l r)
286− = ph $ ops fc pairCon
287− ([pimp (sUN "A") Placeholder True,
288− pimp (sUN "B") Placeholder True] ++
289− [pexp l, pexp r])
290− otherPats (PDPair fc hls p t _ v)
291− = ph $ ops fc sigmaCon
292− ([pimp (sUN "a") Placeholder True,
293− pimp (sUN "P") Placeholder True] ++
294− [pexp t,pexp v])
295− otherPats o@(PConstant _ c) = ph [o, nextConst o]
296− otherPats arg = return Placeholder
297−
298− ops fc n xs
299− | (TyDecl c@(DCon _ arity _) ty : _) <- lookupDef n (tt_ctxt i)
300− = do xs' <- mapM otherPats (map getExpTm xs)
301− let p = resugar (PApp fc (PRef fc [] n) (zipWith upd xs' xs))
302− let tyn = getTy n (tt_ctxt i)
303− case lookupCtxt tyn (idris_datatypes i) of
304− (TI ns _ _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n])
305− _ -> [p]
306− ops fc n arg = return Placeholder
307−
308− getExpTm (PImp _ True _ _ _) = Placeholder -- machine inferred, no point!
309− getExpTm t = getTm t
310−
311− -- put it back to its original form
312− resugar (PApp _ (PRef fc hl n) [_,_,t,v])
313− | n == sigmaCon
314− = PDPair fc [] TypeOrTerm (getTm t) Placeholder (getTm v)
315− resugar (PApp _ (PRef fc hl n) [_,_,l,r])
316− | n == pairCon
317− = PPair fc [] IsTerm (getTm l) (getTm r)
318− resugar t = t
319−
320− dropForce force (x : xs) i | i `elem` force
321− = upd Placeholder x : dropForce force xs (i + 1)
322− dropForce force (x : xs) i = x : dropForce force xs (i + 1)
323− dropForce _ [] _ = []
324−
325−
326− getTy n ctxt = case lookupTy n ctxt of
327− (t : _) -> case unApply (getRetTy t) of
328− (P _ tyn _, _) -> tyn
329− x -> error $ "Can't happen getTy 1 " ++ show (n, x)
330− _ -> error "Can't happen getTy 2"
331−
332− mkPat fc x = case lookupCtxt x (idris_implicits i) of
333− (pargs : _)
334− -> PApp fc (PRef fc [] x) (map (upd Placeholder) pargs)
335− _ -> error "Can't happen - genAll"
336−
337− fnub :: [PTerm] -> [PTerm]
338− fnub xs = fnub' [] xs
339−
340− fnub' :: [PTerm] -> [PTerm] -> [PTerm]
341− fnub' acc (x : xs) | x `qelem` acc = fnub' acc (filter (not.(quickEq x)) xs)
342− | otherwise = fnub' (x : acc) xs
343− fnub' acc [] = acc
344−
345− -- quick check for constructor equality
346− quickEq :: PTerm -> PTerm -> Bool
347− quickEq (PConstant _ n) (PConstant _ n') = n == n'
348− quickEq (PRef _ _ n) (PRef _ _ n') = n == n'
349− quickEq (PPair _ _ _ l r) (PPair _ _ _ l' r') = quickEq l l' && quickEq r r'
350− quickEq (PApp _ t as) (PApp _ t' as')
351− | length as == length as'
352− = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as'))
353− quickEq Placeholder Placeholder = True
354− quickEq x y = False
355−
356− qelem :: PTerm -> [PTerm] -> Bool
357− qelem x [] = False
358− qelem x (y : ys) | x `quickEq` y = True
359− | otherwise = qelem x ys
360−
361−
362−upd :: t -> PArg' t -> PArg' t
363−upd p' p = p { getTm = p' }
364−
src/Idris/DataOpts.hs+1−1
@@ -103,7 +103,7 @@ applyDataOptRT n tag arity uniq args
103 satArgs n = map (\i -> sMN i "sat") [1..n]
103 satArgs n = map (\i -> sMN i "sat") [1..n]
104
104
105 bind [] tm = tm
105 bind [] tm = tm
106− bind (n:ns) tm = Bind n (Lam Erased) (pToV n (bind ns tm))
106+ bind (n:ns) tm = Bind n (Lam RigW Erased) (pToV n (bind ns tm))
107
107
108 -- Nat special cases
108 -- Nat special cases
109 -- TODO: Would be nice if this was configurable in idris source!
109 -- TODO: Would be nice if this was configurable in idris source!
src/Idris/Delaborate.hs+21−20
@@ -135,29 +135,29 @@ delabTy' ist imps tm fullname mvs docases = de [] imps tm
135 = case lookup n (idris_metavars ist) of
135 = case lookup n (idris_metavars ist) of
136 Just (Just _, mi, _, _, _) -> mkMVApp n []
136 Just (Just _, mi, _, _, _) -> mkMVApp n []
137 _ -> PRef un [] n
137 _ -> PRef un [] n
138− de env _ (Bind n (Lam ty) sc)
138+ de env _ (Bind n (Lam _ ty) sc)
139 = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)
139 = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)
140− de env (_ : is) (Bind n (Pi (Just impl) ty _) sc)
140+ de env (_ : is) (Bind n (Pi rig (Just impl) ty _) sc)
141 | toplevel_imp impl -- information in 'imps' repeated
141 | toplevel_imp impl -- information in 'imps' repeated
142− = PPi (Imp [] Dynamic False (Just impl) False) n NoFC (de env [] ty) (de ((n,n):env) is sc)
142+ = PPi (Imp [] Dynamic False (Just impl) False rig) n NoFC (de env [] ty) (de ((n,n):env) is sc)
143− de env is (Bind n (Pi (Just impl) ty _) sc)
143+ de env is (Bind n (Pi rig (Just impl) ty _) sc)
144 | tcimplementation impl
144 | tcimplementation impl
145 = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)
145 = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)
146 | otherwise
146 | otherwise
147− = PPi (Imp [] Dynamic False (Just impl) False) n NoFC (de env [] ty) (de ((n,n):env) is sc)
147+ = PPi (Imp [] Dynamic False (Just impl) False rig) n NoFC (de env [] ty) (de ((n,n):env) is sc)
148− de env ((PImp { argopts = opts }):is) (Bind n (Pi _ ty _) sc)
148+ de env ((PImp { argopts = opts }):is) (Bind n (Pi rig _ ty _) sc)
149− = PPi (Imp opts Dynamic False Nothing False) n NoFC (de env [] ty) (de ((n,n):env) is sc)
149+ = PPi (Imp opts Dynamic False Nothing False rig) n NoFC (de env [] ty) (de ((n,n):env) is sc)
150− de env (PConstraint _ _ _ _:is) (Bind n (Pi _ ty _) sc)
150+ de env (PConstraint _ _ _ _:is) (Bind n (Pi rig _ ty _) sc)
151− = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)
151+ = PPi (constraint { pcount = rig}) n NoFC (de env [] ty) (de ((n,n):env) is sc)
152− de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi _ ty _) sc)
152+ de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi rig _ ty _) sc)
153− = PPi (tacimpl tac) n NoFC (de env [] ty) (de ((n,n):env) is sc)
153+ = PPi ((tacimpl tac) { pcount = rig }) n NoFC (de env [] ty) (de ((n,n):env) is sc)
154− de env (plic:is) (Bind n (Pi _ ty _) sc)
154+ de env (plic:is) (Bind n (Pi rig _ ty _) sc)
155− = PPi (Exp (argopts plic) Dynamic False)
155+ = PPi (Exp (argopts plic) Dynamic False rig)
156 n NoFC
156 n NoFC
157 (de env [] ty)
157 (de env [] ty)
158 (de ((n,n):env) is sc)
158 (de ((n,n):env) is sc)
159− de env [] (Bind n (Pi _ ty _) sc)
159+ de env [] (Bind n (Pi rig _ ty _) sc)
160− = PPi expl n NoFC (de env [] ty) (de ((n,n):env) [] sc)
160+ = PPi (expl { pcount = rig }) n NoFC (de env [] ty) (de ((n,n):env) [] sc)
161
161
162 de env imps (Bind n (Let ty val) sc)
162 de env imps (Bind n (Let ty val) sc)
163 | docases
163 | docases
@@ -173,6 +173,7 @@ delabTy' ist imps tm fullname mvs docases = de [] imps tm
173 de env _ (Proj _ _) = error "Delaboration got run-time-only Proj!"
173 de env _ (Proj _ _) = error "Delaboration got run-time-only Proj!"
174 de env _ Erased = Placeholder
174 de env _ Erased = Placeholder
175 de env _ Impossible = Placeholder
175 de env _ Impossible = Placeholder
176+ de env _ (Inferred t) = Placeholder
176 de env _ (TType i) = PType un
177 de env _ (TType i) = PType un
177 de env _ (UType u) = PUniverse un u
178 de env _ (UType u) = PUniverse un u
178
179
@@ -187,7 +188,7 @@ delabTy' ist imps tm fullname mvs docases = de [] imps tm
187 deFn env (P _ n _) [l,r]
188 deFn env (P _ n _) [l,r]
188 | n == pairTy = PPair un [] IsType (de env [] l) (de env [] r)
189 | n == pairTy = PPair un [] IsType (de env [] l) (de env [] r)
189 | n == sUN "lazy" = de env [] r -- TODO: Fix string based matching
190 | n == sUN "lazy" = de env [] r -- TODO: Fix string based matching
190− deFn env (P _ n _) [ty, Bind x (Lam _) r]
191+ deFn env (P _ n _) [ty, Bind x (Lam _ _) r]
191 | n == sigmaTy
192 | n == sigmaTy
192 = PDPair un [] IsType (PRef un [] x) (de env [] ty)
193 = PDPair un [] IsType (PRef un [] x) (de env [] ty)
193 (de ((x,x):env) [] (instantiate (P Bound x ty) r))
194 (de ((x,x):env) [] (instantiate (P Bound x ty) r))
@@ -338,9 +339,9 @@ pprintErr' i (CantConvert x_in y_in env) =
338 indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env)
339 indented (annTm y_ns (pprintTerm' i (map (\ (n, b) -> (n, False)) env)
339 y)) <>
340 y)) <>
340 if (opt_errContext (idris_options i)) then line <> text "Conversion failure" <$> showSc i env else empty
341 if (opt_errContext (idris_options i)) then line <> text "Conversion failure" <$> showSc i env else empty
341− where flagUnique (Bind n (Pi i t k@(UType u)) sc)
342+ where flagUnique (Bind n (Pi rig i t k@(UType u)) sc)
342 = App Complete (P Ref (sUN (show u)) Erased)
343 = App Complete (P Ref (sUN (show u)) Erased)
343− (Bind n (Pi i (flagUnique t) k) (flagUnique sc))
344+ (Bind n (Pi rig i (flagUnique t) k) (flagUnique sc))
344 flagUnique (App s f a) = App s (flagUnique f) (flagUnique a)
345 flagUnique (App s f a) = App s (flagUnique f) (flagUnique a)
345 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)
346 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)
346 flagUnique t = t
347 flagUnique t = t
@@ -526,13 +527,13 @@ pprintErr' i (ElabScriptDebug msg tm holes) =
526 indented (vsep (map ppHole holes)) <> line <> line <>
527 indented (vsep (map ppHole holes)) <> line <> line <>
527 text "Term: " <> indented (pprintTT [] tm)
528 text "Term: " <> indented (pprintTT [] tm)
528
529
529− where ppHole :: (Name, Type, Env) -> Doc OutputAnnotation
530+ where ppHole :: (Name, Type, [(Name, Binder Type)]) -> Doc OutputAnnotation
530 ppHole (hn, goal, env) =
531 ppHole (hn, goal, env) =
531 ppAssumptions [] (reverse env) <>
532 ppAssumptions [] (reverse env) <>
532 text "----------------------------------" <> line <>
533 text "----------------------------------" <> line <>
533 bindingOf hn False <+> text ":" <+>
534 bindingOf hn False <+> text ":" <+>
534 pprintTT (map fst (reverse env)) goal <> line
535 pprintTT (map fst (reverse env)) goal <> line
535− ppAssumptions :: [Name] -> Env -> Doc OutputAnnotation
536+ ppAssumptions :: [Name] -> [(Name, Binder Type)] -> Doc OutputAnnotation
536 ppAssumptions ns [] = empty
537 ppAssumptions ns [] = empty
537 ppAssumptions ns ((n, b) : rest) =
538 ppAssumptions ns ((n, b) : rest) =
538 bindingOf n False <+>
539 bindingOf n False <+>
src/Idris/Docs.hs+3−3
@@ -220,7 +220,7 @@ pprintDocs ist (InterfaceDoc n doc meths params constraints implementations sub_
220 dumpImplementation :: PTerm -> Doc OutputAnnotation
220 dumpImplementation :: PTerm -> Doc OutputAnnotation
221 dumpImplementation = pprintPTerm ppo params' [] infixes
221 dumpImplementation = pprintPTerm ppo params' [] infixes
222
222
223− prettifySubInterfaces (PPi (Constraint _ _) _ _ tm _) = prettifySubInterfaces tm
223+ prettifySubInterfaces (PPi (Constraint _ _ _) _ _ tm _) = prettifySubInterfaces tm
224 prettifySubInterfaces (PPi plcity nm fc t1 t2) = PPi plcity (safeHead nm pNames) NoFC (prettifySubInterfaces t1) (prettifySubInterfaces t2)
224 prettifySubInterfaces (PPi plcity nm fc t1 t2) = PPi plcity (safeHead nm pNames) NoFC (prettifySubInterfaces t1) (prettifySubInterfaces t2)
225 prettifySubInterfaces (PApp fc ref args) = PApp fc ref $ updateArgs pNames args
225 prettifySubInterfaces (PApp fc ref args) = PApp fc ref $ updateArgs pNames args
226 prettifySubInterfaces tm = tm
226 prettifySubInterfaces tm = tm
@@ -235,7 +235,7 @@ pprintDocs ist (InterfaceDoc n doc meths params constraints implementations sub_
235 updateRef nm (PRef fc _ _) = PRef fc [] nm
235 updateRef nm (PRef fc _ _) = PRef fc [] nm
236 updateRef _ pt = pt
236 updateRef _ pt = pt
237
237
238− isSubInterface (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args')) = nm == n && map getTm args == map getTm args'
238+ isSubInterface (PPi (Constraint _ _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args')) = nm == n && map getTm args == map getTm args'
239 isSubInterface (PPi _ _ _ _ pt) = isSubInterface pt
239 isSubInterface (PPi _ _ _ _ pt) = isSubInterface pt
240 isSubInterface _ = False
240 isSubInterface _ = False
241
241
@@ -356,7 +356,7 @@ docInterface n ci
356 getDImpl (PImplementation _ _ _ _ _ _ _ _ _ _ _ _ t _ _) = Just t
356 getDImpl (PImplementation _ _ _ _ _ _ _ _ _ _ _ _ t _ _) = Just t
357 getDImpl _ = Nothing
357 getDImpl _ = Nothing
358
358
359− isSubInterface (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))
359+ isSubInterface (PPi (Constraint _ _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))
360 = nm == n && map getTm args == map getTm args'
360 = nm == n && map getTm args == map getTm args'
361 isSubInterface (PPi _ _ _ _ pt)
361 isSubInterface (PPi _ _ _ _ pt)
362 = isSubInterface pt
362 = isSubInterface pt
src/Idris/Elab/Clause.hs+70−34
@@ -14,6 +14,7 @@ import Idris.Core.CaseTree
14import Idris.Core.Elaborate hiding (Tactic(..))
14import Idris.Core.Elaborate hiding (Tactic(..))
15import Idris.Core.Evaluate
15import Idris.Core.Evaluate
16import Idris.Core.Execute
16import Idris.Core.Execute
17+import Idris.Core.WHNF
17import Idris.Core.TT
18import Idris.Core.TT
18import Idris.Core.Typecheck
19import Idris.Core.Typecheck
19import Idris.Coverage
20import Idris.Coverage
@@ -75,6 +76,8 @@ elabClauses info' fc opts n_in cs =
75 -- Check n actually exists, with no definition yet
76 -- Check n actually exists, with no definition yet
76 let tys = lookupTy n ctxt
77 let tys = lookupTy n ctxt
77 let reflect = Reflection `elem` opts
78 let reflect = Reflection `elem` opts
79+ when (reflect && FCReflection `notElem` idris_language_extensions ist) $
80+ ierror $ At fc (Msg "You must turn on the FirstClassReflection extension to use %reflection")
78 checkUndefined n ctxt
81 checkUndefined n ctxt
79 unless (length tys > 1) $ do
82 unless (length tys > 1) $ do
80 fty <- case tys of
83 fty <- case tys of
@@ -186,12 +189,14 @@ elabClauses info' fc opts n_in cs =
186 pmissing <-
189 pmissing <-
187 if cov && not (hasDefault pats_raw)
190 if cov && not (hasDefault pats_raw)
188 then do -- Generate clauses from the given possible cases
191 then do -- Generate clauses from the given possible cases
189− missing <- genClauses fc n (map getLHS pdef_cov) cs_full
192+ missing <- genClauses fc n
193+ (map (\ (ns,tm,_) -> (ns, tm)) pdef)
194+ cs_full
190 -- missing <- genMissing n scargs sc
195 -- missing <- genMissing n scargs sc
191 missing' <- checkPossibles info fc True n missing
196 missing' <- checkPossibles info fc True n missing
192 -- Filter out the ones which match one of the
197 -- Filter out the ones which match one of the
193 -- given cases (including impossible ones)
198 -- given cases (including impossible ones)
194− let clhs = map getLHS pdef_cov
199+ let clhs = map getLHS pdef
195 logElab 2 $ "Must be unreachable (" ++ show (length missing') ++ "):\n" ++
200 logElab 2 $ "Must be unreachable (" ++ show (length missing') ++ "):\n" ++
196 showSep "\n" (map showTmImpls missing') ++
201 showSep "\n" (map showTmImpls missing') ++
197 "\nAgainst: " ++
202 "\nAgainst: " ++
@@ -201,7 +206,7 @@ elabClauses info' fc opts n_in cs =
201 -- unification may force a variable to take a
206 -- unification may force a variable to take a
202 -- particular form, rather than force a case
207 -- particular form, rather than force a case
203 -- to be impossible.
208 -- to be impossible.
204− return (filter (noMatch ist clhs) missing')
209+ return missing' -- (filter (noMatch ist clhs) missing')
205 else return []
210 else return []
206 let pcover = null pmissing
211 let pcover = null pmissing
207
212
@@ -282,6 +287,10 @@ elabClauses info' fc opts n_in cs =
282 Just Public -> mapM_ (checkVisibility fc n Public Public) calls
287 Just Public -> mapM_ (checkVisibility fc n Public Public) calls
283 _ -> return ()
288 _ -> return ()
284 addCalls n calls
289 addCalls n calls
290+ let rig = if linearArg (whnfArgs ctxt [] ty)
291+ then Rig1
292+ else RigW
293+ updateContext (setRigCount n (minRig ctxt rig calls))
285 addIBC (IBCCG n)
294 addIBC (IBCCG n)
286 _ -> return ()
295 _ -> return ()
287 return ()
296 return ()
@@ -325,12 +334,12 @@ elabClauses info' fc opts n_in cs =
325 debind (Left x) = let (vs, x') = depat [] x in
334 debind (Left x) = let (vs, x') = depat [] x in
326 (vs, x', Impossible)
335 (vs, x', Impossible)
327
336
328− depat acc (Bind n (PVar t) sc) = depat ((n, t) : acc) (instantiate (P Bound n t) sc)
337+ depat acc (Bind n (PVar rig t) sc) = depat ((n, t) : acc) (instantiate (P Bound n t) sc)
329 depat acc x = (acc, x)
338 depat acc x = (acc, x)
330
339
331
340
332− getPVs (Bind x (PVar _) tm) = let (vs, tm') = getPVs tm
341+ getPVs (Bind x (PVar rig _) tm) = let (vs, tm') = getPVs tm
333− in (x:vs, tm')
342+ in (x:vs, tm')
334 getPVs tm = ([], tm)
343 getPVs tm = ([], tm)
335
344
336 isPatVar vs (P Bound n _) = n `elem` vs
345 isPatVar vs (P Bound n _) = n `elem` vs
@@ -374,6 +383,12 @@ elabClauses info' fc opts n_in cs =
374 Just t -> return t
383 Just t -> return t
375 Nothing -> ierror (At fc (Msg "No specialisation achieved"))
384 Nothing -> ierror (At fc (Msg "No specialisation achieved"))
376
385
386+ minRig :: Context -> RigCount -> [Name] -> RigCount
387+ minRig c minr [] = minr
388+ minRig c minr (r : rs) = case lookupRigCountExact r c of
389+ Nothing -> minRig c minr rs
390+ Just rc -> minRig c (min minr rc) rs
391+
377forceWith :: Ctxt OptInfo -> Term -> Term
392forceWith :: Ctxt OptInfo -> Term -> Term
378forceWith opts lhs = -- trace (show lhs ++ "\n==>\n" ++ show (force lhs) ++ "\n----") $
393forceWith opts lhs = -- trace (show lhs ++ "\n==>\n" ++ show (force lhs) ++ "\n----") $
379 force lhs
394 force lhs
@@ -524,8 +539,8 @@ elabPE info fc caller r =
524 [] -> False
539 [] -> False
525 _ -> True
540 _ -> True
526 concreteTm ist (Constant _) = True
541 concreteTm ist (Constant _) = True
527− concreteTm ist (Bind n (Lam _) sc) = True
542+ concreteTm ist (Bind n (Lam _ _) sc) = True
528− concreteTm ist (Bind n (Pi _ _ _) sc) = True
543+ concreteTm ist (Bind n (Pi _ _ _ _) sc) = True
529 concreteTm ist (Bind n (Let _ _) sc) = concreteTm ist sc
544 concreteTm ist (Bind n (Let _ _) sc) = concreteTm ist sc
530 concreteTm ist _ = False
545 concreteTm ist _ = False
531
546
@@ -562,7 +577,10 @@ elabPE info fc caller r =
562 qhash hash (x:xs) = qhash (hash * 33 + fromIntegral(fromEnum x)) xs
577 qhash hash (x:xs) = qhash (hash * 33 + fromIntegral(fromEnum x)) xs
563
578
564-- | Checks if the clause is a possible left hand side.
579-- | Checks if the clause is a possible left hand side.
565−checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool
580+-- NOTE: A lot of this is repeated for reflected definitions in Idris.Elab.Term
581+-- One day, these should be merged, but until then remember that if you edit
582+-- this you might need to edit the other version...
583+checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris (Maybe PTerm)
566checkPossible info fc tcgen fname lhs_in
584checkPossible info fc tcgen fname lhs_in
567 = do ctxt <- getContext
585 = do ctxt <- getContext
568 i <- getIState
586 i <- getIState
@@ -570,7 +588,7 @@ checkPossible info fc tcgen fname lhs_in
570 logElab 10 $ "Trying missing case: " ++ showTmImpls lhs
588 logElab 10 $ "Trying missing case: " ++ showTmImpls lhs
571 -- if the LHS type checks, it is possible
589 -- if the LHS type checks, it is possible
572 case elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState
590 case elaborate (constraintNS info) ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState
573− (erun fc (buildTC i info ELHS [] fname
591+ (erun fc (buildTC i info EImpossible [] fname
574 (allNamesIn lhs_in)
592 (allNamesIn lhs_in)
575 (infTerm lhs))) of
593 (infTerm lhs))) of
576 OK (ElabResult lhs' _ _ ctxt' newDecls highlights newGName, _) ->
594 OK (ElabResult lhs' _ _ ctxt' newDecls highlights newGName, _) ->
@@ -582,18 +600,29 @@ checkPossible info fc tcgen fname lhs_in
582 let emptyPat = hasEmptyPat ctxt (idris_datatypes i) lhs_tm
600 let emptyPat = hasEmptyPat ctxt (idris_datatypes i) lhs_tm
583 if emptyPat then
601 if emptyPat then
584 do logElab 10 $ "Empty type in pattern "
602 do logElab 10 $ "Empty type in pattern "
585− return False
603+ return Nothing
586 else
604 else
587 case recheck (constraintNS info) ctxt' [] (forget lhs_tm) lhs_tm of
605 case recheck (constraintNS info) ctxt' [] (forget lhs_tm) lhs_tm of
588− OK _ -> do logElab 10 $ "Valid"
606+ OK (tm, _, _) ->
589− return True
607+ do logElab 10 $ "Valid " ++ show tm ++ "\n"
608+ ++ " from " ++ show lhs
609+ return (Just (delab' i tm True True))
590 err -> do logElab 10 $ "Conversion failure"
610 err -> do logElab 10 $ "Conversion failure"
591− return False
611+ return Nothing
592 -- if it's a recoverable error, the case may become possible
612 -- if it's a recoverable error, the case may become possible
593− Error err -> do logLvl 10 $ "Impossible case " ++ show err
613+ Error err -> do logLvl 10 $ "Impossible case " ++ (pshow i err)
594− if tcgen then return (recoverableCoverage ctxt err)
614+ -- tcgen means that it was generated by genClauses,
595− else return (validCoverageCase ctxt err ||
615+ -- so only looking for an error. Otherwise, it
616+ -- needs to be the right kind of error (a type mismatch
617+ -- in the same family).
618+ if tcgen then returnTm i err (recoverableCoverage ctxt err)
619+ else returnTm i err (validCoverageCase ctxt err ||
596 recoverableCoverage ctxt err)
620 recoverableCoverage ctxt err)
621+ where returnTm i err True = do logLvl 10 $ "Possibly resolvable error on " ++
622+ pshow i (fmap (normalise (tt_ctxt i) []) err)
623+ ++ " on " ++ showTmImpls lhs_in
624+ return $ Just lhs_in
625+ returnTm i err False = return $ Nothing
597
626
598-- Filter out the terms which are not well type left hand sides. Whenever we
627-- Filter out the terms which are not well type left hand sides. Whenever we
599-- eliminate one, also eliminate later ones which match it without checking,
628-- eliminate one, also eliminate later ones which match it without checking,
@@ -608,7 +637,9 @@ checkPossibles info fc tcgen fname (lhs : rest)
608 -- check, just remove from the next batch
637 -- check, just remove from the next batch
609 let rest' = filter (\x -> not (qmatch x lhs)) (take 200 rest) ++ drop 200 rest
638 let rest' = filter (\x -> not (qmatch x lhs)) (take 200 rest) ++ drop 200 rest
610 restpos <- checkPossibles info fc tcgen fname rest'
639 restpos <- checkPossibles info fc tcgen fname rest'
611− if not ok then return restpos else return (lhs : restpos)
640+ case ok of
641+ Nothing -> return restpos
642+ Just lhstm -> return (lhstm : restpos)
612 where
643 where
613 qmatch _ Placeholder = True
644 qmatch _ Placeholder = True
614 qmatch (PApp _ f args) (PApp _ f' args')
645 qmatch (PApp _ f args) (PApp _ f' args')
@@ -624,14 +655,14 @@ checkPossibles _ _ _ _ [] = return []
624
655
625findUnique :: Context -> Env -> Term -> [Name]
656findUnique :: Context -> Env -> Term -> [Name]
626findUnique ctxt env (Bind n b sc)
657findUnique ctxt env (Bind n b sc)
627− = let rawTy = forgetEnv (map fst env) (binderTy b)
658+ = let rawTy = forgetEnv (map fstEnv env) (binderTy b)
628 uniq = case check ctxt env rawTy of
659 uniq = case check ctxt env rawTy of
629 OK (_, UType UniqueType) -> True
660 OK (_, UType UniqueType) -> True
630 OK (_, UType NullType) -> True
661 OK (_, UType NullType) -> True
631 OK (_, UType AllTypes) -> True
662 OK (_, UType AllTypes) -> True
632 _ -> False in
663 _ -> False in
633− if uniq then n : findUnique ctxt ((n, b) : env) sc
664+ if uniq then n : findUnique ctxt ((n, RigW, b) : env) sc
634− else findUnique ctxt ((n, b) : env) sc
665+ else findUnique ctxt ((n, RigW, b) : env) sc
635findUnique _ _ _ = []
666findUnique _ _ _ = []
636
667
637getUnfolds (UnfoldIface n ns : _) = Just (n, ns)
668getUnfolds (UnfoldIface n ns : _) = Just (n, ns)
@@ -671,12 +702,12 @@ elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])
671 let lhs = addImpl [] i lhs_in
702 let lhs = addImpl [] i lhs_in
672 b <- checkPossible info fc tcgen fname lhs_in
703 b <- checkPossible info fc tcgen fname lhs_in
673 case b of
704 case b of
674− True -> tclift $ tfail (At fc
705+ Just _ -> tclift $ tfail (At fc
675− (Msg $ show lhs_in ++ " is a valid case"))
706+ (Msg $ show lhs_in ++ " is a valid case"))
676− False -> do ptm <- mkPatTm lhs_in
707+ Nothing -> do ptm <- mkPatTm lhs_in
677− logElab 5 $ "Elaborated impossible case " ++ showTmImpls lhs ++
708+ logElab 5 $ "Elaborated impossible case " ++ showTmImpls lhs ++
678− "\n" ++ show ptm
709+ "\n" ++ show ptm
679− return (Left ptm, lhs)
710+ return (Left ptm, lhs)
680elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as whereblock)
711elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as whereblock)
681 = do let tcgen = Dictionary `elem` opts
712 = do let tcgen = Dictionary `elem` opts
682 push_estack fname False
713 push_estack fname False
@@ -828,7 +859,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc
828
859
829 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)
860 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)
830
861
831− logElab 5 "DONE CHECK"
862+ logElab 3 "DONE CHECK"
832 logElab 3 $ "---> " ++ show rhsElab
863 logElab 3 $ "---> " ++ show rhsElab
833 ctxt <- getContext
864 ctxt <- getContext
834
865
@@ -902,7 +933,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc
902 rev <- case ret_fam of
933 rev <- case ret_fam of
903 P _ rfamn _ ->
934 P _ rfamn _ ->
904 case lookupCtxt rfamn (idris_datatypes i) of
935 case lookupCtxt rfamn (idris_datatypes i) of
905− [TI _ _ dopts _ _] ->
936+ [TI _ _ dopts _ _ _] ->
906 return (DataErrRev `elem` dopts &&
937 return (DataErrRev `elem` dopts &&
907 size clhs <= size crhs)
938 size clhs <= size crhs)
908 _ -> return False
939 _ -> return False
@@ -1007,7 +1038,12 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)
1007
1038
1008 logElab 5 ("Checked " ++ show clhs)
1039 logElab 5 ("Checked " ++ show clhs)
1009 let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))
1040 let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))
1010− let wval = rhs_trans info $ addImplBound i (map fst bargs) wval_in
1041+ wval <- case wval_in of
1042+ Placeholder -> ierror $ At fc $
1043+ Msg "No expression for the with block to inspect.\nYou need to replace the _ with an expression."
1044+ _ -> return $
1045+ rhs_trans info $
1046+ addImplBound i (map fst bargs) wval_in
1011 logElab 5 ("Checking " ++ showTmImpls wval)
1047 logElab 5 ("Checking " ++ showTmImpls wval)
1012 -- Elaborate wval in this context
1048 -- Elaborate wval in this context
1013 ((wvalElab, defer, is, ctxt', newDecls, highlights, newGName), _) <-
1049 ((wvalElab, defer, is, ctxt', newDecls, highlights, newGName), _) <-
@@ -1081,7 +1117,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)
1081 let wargname = sMN windex "warg"
1117 let wargname = sMN windex "warg"
1082
1118
1083 logElab 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)
1119 logElab 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)
1084− let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar [] 0))) (bargs_pre ++
1120+ let wtype = bindTyArgs (flip (Pi RigW Nothing) (TType (UVar [] 0))) (bargs_pre ++
1085 (wargname, wargtype) :
1121 (wargname, wargtype) :
1086 map (abstract wargname wargval wargtype) bargs_post ++
1122 map (abstract wargname wargval wargtype) bargs_post ++
1087 case mpn of
1123 case mpn of
@@ -1175,7 +1211,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)
1175 (crhs, crhsty) <- recheckC (constraintNS info) fc id [] rhs'
1211 (crhs, crhsty) <- recheckC (constraintNS info) fc id [] rhs'
1176 return (Right (clhs, crhs), lhs)
1212 return (Right (clhs, crhs), lhs)
1177 where
1213 where
1178− getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t
1214+ getImps (Bind n (Pi _ _ _ _) t) = pexp Placeholder : getImps t
1179 getImps _ = []
1215 getImps _ = []
1180
1216
1181 mkAuxC pn wname lhs ns ns' (PClauses fc o n cs)
1217 mkAuxC pn wname lhs ns ns' (PClauses fc o n cs)
@@ -1274,13 +1310,13 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)
1274 -- This is something of a hack, because matching on the top level
1310 -- This is something of a hack, because matching on the top level
1275 -- application won't find this information for us
1311 -- application won't find this information for us
1276 addResolvesArgs :: FC -> Term -> [PArg] -> [PArg]
1312 addResolvesArgs :: FC -> Term -> [PArg] -> [PArg]
1277− addResolvesArgs fc (Bind n (Pi _ ty _) sc) (a : args)
1313+ addResolvesArgs fc (Bind n (Pi _ _ ty _) sc) (a : args)
1278 | (P _ cn _, _) <- unApply ty,
1314 | (P _ cn _, _) <- unApply ty,
1279 getTm a == Placeholder
1315 getTm a == Placeholder
1280 = case lookupCtxtExact cn (idris_interfaces ist) of
1316 = case lookupCtxtExact cn (idris_interfaces ist) of
1281 Just _ -> a { getTm = PResolveTC fc } : addResolvesArgs fc sc args
1317 Just _ -> a { getTm = PResolveTC fc } : addResolvesArgs fc sc args
1282 Nothing -> a : addResolvesArgs fc sc args
1318 Nothing -> a : addResolvesArgs fc sc args
1283− addResolvesArgs fc (Bind n (Pi _ ty _) sc) (a : args)
1319+ addResolvesArgs fc (Bind n (Pi _ _ ty _) sc) (a : args)
1284 = a : addResolvesArgs fc sc args
1320 = a : addResolvesArgs fc sc args
1285 addResolvesArgs fc _ args = args
1321 addResolvesArgs fc _ args = args
1286
1322
src/Idris/Elab/Data.hs+8−4
@@ -104,7 +104,8 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)
104 -- TI contains information about mutually declared types - this will
104 -- TI contains information about mutually declared types - this will
105 -- be updated when the mutual block is complete
105 -- be updated when the mutual block is complete
106 putIState (i { idris_datatypes =
106 putIState (i { idris_datatypes =
107− addDef n (TI (map fst cons) codata opts params [n])
107+ addDef n (TI (map fst cons) codata opts params [n]
108+ (any linearArg (map snd cons)))
108 (idris_datatypes i) })
109 (idris_datatypes i) })
109 addIBC (IBCDef n)
110 addIBC (IBCDef n)
110 addIBC (IBCData n)
111 addIBC (IBCData n)
@@ -119,6 +120,9 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)
119 -- TMP HACK! Make this a data option
120 -- TMP HACK! Make this a data option
120 updateContext (addDatatype (Data n ttag cty unique cons))
121 updateContext (addDatatype (Data n ttag cty unique cons))
121 updateContext (setMetaInformation n metainf)
122 updateContext (setMetaInformation n metainf)
123+ when (any linearArg (map snd cons)) $
124+ updateContext (setRigCount n Rig1)
125+
122 mapM_ totcheck (zip (repeat fc) (map fst cons))
126 mapM_ totcheck (zip (repeat fc) (map fst cons))
123-- mapM_ (checkPositive n) cons
127-- mapM_ (checkPositive n) cons
124
128
@@ -267,7 +271,7 @@ forceArgs ctxt ty = forceFrom 0 ty
267 -- then when we look at the return type, if we see MN pos name
271 -- then when we look at the return type, if we see MN pos name
268 -- constructor guarded, then 'pos' is a forceable position
272 -- constructor guarded, then 'pos' is a forceable position
269 forceFrom :: Int -> Type -> [Int]
273 forceFrom :: Int -> Type -> [Int]
270− forceFrom i (Bind n (Pi _ _ _) sc)
274+ forceFrom i (Bind n (Pi _ _ _ _) sc)
271 = forceFrom (i + 1) (substV (P Ref (sMN i "FF") Erased) sc)
275 = forceFrom (i + 1) (substV (P Ref (sMN i "FF") Erased) sc)
272 forceFrom i sc
276 forceFrom i sc
273 -- Go under the top level type application
277 -- Go under the top level type application
@@ -310,7 +314,7 @@ addParamConstraints fc ps cty cons
310 where
314 where
311 getParamNames (n, ty) = (ty, getPs ty)
315 getParamNames (n, ty) = (ty, getPs ty)
312
316
313− getPs (Bind n (Pi _ _ _) sc)
317+ getPs (Bind n (Pi _ _ _ _) sc)
314 = getPs (substV (P Ref n Erased) sc)
318 = getPs (substV (P Ref n Erased) sc)
315 getPs t | (f, args) <- unApply t
319 getPs t | (f, args) <- unApply t
316 = paramArgs 0 args
320 = paramArgs 0 args
@@ -321,7 +325,7 @@ addParamConstraints fc ps cty cons
321
325
322 addConConstraint ps cvar (ty, pnames) = constraintTy ty
326 addConConstraint ps cvar (ty, pnames) = constraintTy ty
323 where
327 where
324− constraintTy (Bind n (Pi _ ty _) sc)
328+ constraintTy (Bind n (Pi _ _ ty _) sc)
325 = case getRetTy ty of
329 = case getRetTy ty of
326 TType avar -> do tit <- typeInType
330 TType avar -> do tit <- typeInType
327 when (not tit) $ do
331 when (not tit) $ do
src/Idris/Elab/Implementation.hs+6−6
@@ -310,16 +310,16 @@ elabImplementation info syn doc argDocs what fc cs parents acc opts n nfc ps pex
310 where
310 where
311 needed is p = pname p `elem` map pname is
311 needed is p = pname p `elem` map pname is
312
312
313− lamBind i (PPi (Constraint _ _) _ _ _ sc) sc'
313+ lamBind i (PPi (Constraint _ _ _) _ _ _ sc) sc'
314 = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')
314 = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')
315 lamBind i (PPi _ n _ ty sc) sc'
315 lamBind i (PPi _ n _ ty sc) sc'
316 = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')
316 = PLam fc (sMN i "meth") NoFC Placeholder (lamBind (i+1) sc sc')
317 lamBind i _ sc = sc
317 lamBind i _ sc = sc
318− methArgs i (PPi (Imp _ _ _ _ _) n _ ty sc)
318+ methArgs i (PPi (Imp _ _ _ _ _ _) n _ ty sc)
319 = PImp 0 True [] n (PRef fc [] (sMN i "meth")) : methArgs (i+1) sc
319 = PImp 0 True [] n (PRef fc [] (sMN i "meth")) : methArgs (i+1) sc
320− methArgs i (PPi (Exp _ _ _) n _ ty sc)
320+ methArgs i (PPi (Exp _ _ _ _) n _ ty sc)
321 = PExp 0 [] (sMN 0 "marg") (PRef fc [] (sMN i "meth")) : methArgs (i+1) sc
321 = PExp 0 [] (sMN 0 "marg") (PRef fc [] (sMN i "meth")) : methArgs (i+1) sc
322− methArgs i (PPi (Constraint _ _) n _ ty sc)
322+ methArgs i (PPi (Constraint _ _ _) n _ ty sc)
323 = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc
323 = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc
324 methArgs i _ = []
324 methArgs i _ = []
325
325
@@ -354,7 +354,7 @@ elabImplementation info syn doc argDocs what fc cs parents acc opts n nfc ps pex
354 extrabind [] x = x
354 extrabind [] x = x
355
355
356 coninsert :: [(Name, PTerm)] -> [(Name, PTerm)] -> PTerm -> PTerm
356 coninsert :: [(Name, PTerm)] -> [(Name, PTerm)] -> PTerm -> PTerm
357− coninsert cs ex (PPi p@(Imp _ _ _ _ _) n fc t sc) = PPi p n fc t (coninsert cs ex sc)
357+ coninsert cs ex (PPi p@(Imp _ _ _ _ _ _) n fc t sc) = PPi p n fc t (coninsert cs ex sc)
358 coninsert cs ex sc = conbind cs (extrabind ex sc)
358 coninsert cs ex sc = conbind cs (extrabind ex sc)
359
359
360 -- Reorder declarations to be in the same order as defined in the
360 -- Reorder declarations to be in the same order as defined in the
@@ -516,6 +516,6 @@ checkInjectiveArgs fc n ds (Just ty)
516 isInj i (Bind n b sc) = isInj i sc
516 isInj i (Bind n b sc) = isInj i sc
517 isInj _ _ = True
517 isInj _ _ = True
518
518
519− instantiateRetTy (Bind n (Pi _ _ _) sc)
519+ instantiateRetTy (Bind n (Pi _ _ _ _) sc)
520 = substV (P Bound n Erased) (instantiateRetTy sc)
520 = substV (P Bound n Erased) (instantiateRetTy sc)
521 instantiateRetTy t = t
521 instantiateRetTy t = t
src/Idris/Elab/Interface.hs+8−8
@@ -210,7 +210,7 @@ elabInterface info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd
210 logElab 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'
210 logElab 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'
211 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),
211 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),
212 (n, (False, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)
212 (n, (False, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)
213− (\ l s p -> Imp l s p Nothing True) t'))),
213+ (\ l s p r -> Imp l s p Nothing True r) t'))),
214 (n, (nfc, syn, o, t) ) )
214 (n, (nfc, syn, o, t) ) )
215 tdecl impps allmeths (PData doc _ syn _ _ (PLaterdecl n nfc t))
215 tdecl impps allmeths (PData doc _ syn _ _ (PLaterdecl n nfc t))
216 = do let o = []
216 = do let o = []
@@ -218,7 +218,7 @@ elabInterface info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd
218 logElab 2 $ "Data method " ++ show n ++ " : " ++ showTmImpls t'
218 logElab 2 $ "Data method " ++ show n ++ " : " ++ showTmImpls t'
219 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),
219 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),
220 (n, (True, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)
220 (n, (True, nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)
221− (\ l s p -> Imp l s p Nothing True) t'))),
221+ (\ l s p r -> Imp l s p Nothing True r) t'))),
222 (n, (nfc, syn, o, t) ) )
222 (n, (nfc, syn, o, t) ) )
223 tdecl impps allmeths (PData doc _ syn _ _ _)
223 tdecl impps allmeths (PData doc _ syn _ _ _)
224 = ierror $ At fc (Msg "Data definitions not allowed in an interface declaration")
224 = ierror $ At fc (Msg "Data definitions not allowed in an interface declaration")
@@ -294,9 +294,9 @@ elabInterface info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd
294 return [PTy doc [] syn fc o m mfc ty',
294 return [PTy doc [] syn fc o m mfc ty',
295 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]
295 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]
296
296
297− getMArgs (PPi (Imp _ _ _ _ _) n _ ty sc) = IA n : getMArgs sc
297+ getMArgs (PPi (Imp _ _ _ _ _ _) n _ ty sc) = IA n : getMArgs sc
298− getMArgs (PPi (Exp _ _ _) n _ ty sc) = EA n : getMArgs sc
298+ getMArgs (PPi (Exp _ _ _ _) n _ ty sc) = EA n : getMArgs sc
299− getMArgs (PPi (Constraint _ _) n _ ty sc) = CA : getMArgs sc
299+ getMArgs (PPi (Constraint _ _ _) n _ ty sc) = CA : getMArgs sc
300 getMArgs _ = []
300 getMArgs _ = []
301
301
302 getMeth :: [Name] -> [Name] -> Name -> PTerm
302 getMeth :: [Name] -> [Name] -> Name -> PTerm
@@ -337,9 +337,9 @@ elabInterface info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd
337 addC _ _ tm = tm
337 addC _ _ tm = tm
338
338
339 -- make arguments explicit and don't bind interface parameters
339 -- make arguments explicit and don't bind interface parameters
340− toExp ns e (PPi (Imp l s p _ _) n fc ty sc)
340+ toExp ns e (PPi (Imp l s p _ _ r) n fc ty sc)
341 | n `elem` ns = toExp ns e sc
341 | n `elem` ns = toExp ns e sc
342− | otherwise = PPi (e l s p) n fc ty (toExp ns e sc)
342+ | otherwise = PPi (e l s p r) n fc ty (toExp ns e sc)
343 toExp ns e (PPi p n fc ty sc) = PPi p n fc ty (toExp ns e sc)
343 toExp ns e (PPi p n fc ty sc) = PPi p n fc ty (toExp ns e sc)
344 toExp ns e sc = sc
344 toExp ns e sc = sc
345
345
@@ -376,7 +376,7 @@ findDets n ns =
376 Just ty -> getDetPos 0 ns ty
376 Just ty -> getDetPos 0 ns ty
377 Nothing -> []
377 Nothing -> []
378 where
378 where
379− getDetPos i ns (Bind n (Pi _ _ _) sc)
379+ getDetPos i ns (Bind n (Pi _ _ _ _) sc)
380 | n `elem` ns = i : getDetPos (i + 1) ns sc
380 | n `elem` ns = i : getDetPos (i + 1) ns sc
381 | otherwise = getDetPos (i + 1) ns sc
381 | otherwise = getDetPos (i + 1) ns sc
382 getDetPos _ _ _ = []
382 getDetPos _ _ _ = []
src/Idris/Elab/Record.hs+4−4
@@ -460,10 +460,10 @@ in_name n = n
460
460
461-- | Creates a PArg with a given plicity, name, and term.
461-- | Creates a PArg with a given plicity, name, and term.
462asArg :: Plicity -> Name -> PTerm -> PArg
462asArg :: Plicity -> Name -> PTerm -> PArg
463−asArg (Imp os _ _ _ _) n t = PImp 0 False os n t
463+asArg (Imp os _ _ _ _ _) n t = PImp 0 False os n t
464−asArg (Exp os _ _) n t = PExp 0 os n t
464+asArg (Exp os _ _ _) n t = PExp 0 os n t
465−asArg (Constraint os _) n t = PConstraint 0 os n t
465+asArg (Constraint os _ _) n t = PConstraint 0 os n t
466−asArg (TacImp os _ s) n t = PTacImplicit 0 os n s t
466+asArg (TacImp os _ s _) n t = PTacImplicit 0 os n s t
467
467
468-- | Machine name "rec".
468-- | Machine name "rec".
469recName :: Name
469recName :: Name
src/Idris/Elab/Rewrite.hs+7−7
@@ -77,7 +77,7 @@ elabRewrite elab ist fc substfn_in rule sc_in newg
77 let pred = PLam fc rname fc Placeholder
77 let pred = PLam fc rname fc Placeholder
78 (delab ist pred_tt)
78 (delab ist pred_tt)
79 let rewrite = stripImpls $
79 let rewrite = stripImpls $
80− addImplBound ist (map fst env) (PApp fc (PRef fc [] substfn)
80+ addImplBound ist (map fstEnv env) (PApp fc (PRef fc [] substfn)
81 [pexp pred, pexp rule, pexp sc])
81 [pexp pred, pexp rule, pexp sc])
82-- trace ("LHS: " ++ show l ++ "\n" ++
82-- trace ("LHS: " ++ show l ++ "\n" ++
83-- "RHS: " ++ show r ++ "\n" ++
83-- "RHS: " ++ show r ++ "\n" ++
@@ -156,10 +156,10 @@ data ParamInfo = Index
156
156
157getParamInfo :: Type -> [PArg] -> Int -> [Int] -> [ParamInfo]
157getParamInfo :: Type -> [PArg] -> Int -> [Int] -> [ParamInfo]
158-- Skip the top level implicits, we just need the explicit ones
158-- Skip the top level implicits, we just need the explicit ones
159−getParamInfo (Bind n (Pi _ _ _) sc) (PExp{} : is) i ps
159+getParamInfo (Bind n (Pi _ _ _ _) sc) (PExp{} : is) i ps
160 | i `elem` ps = Param : getParamInfo sc is (i + 1) ps
160 | i `elem` ps = Param : getParamInfo sc is (i + 1) ps
161 | otherwise = Index : getParamInfo sc is (i + 1) ps
161 | otherwise = Index : getParamInfo sc is (i + 1) ps
162−getParamInfo (Bind n (Pi _ _ _) sc) (_ : is) i ps
162+getParamInfo (Bind n (Pi _ _ _ _) sc) (_ : is) i ps
163 | i `elem` ps = ImplicitParam : getParamInfo sc is (i + 1) ps
163 | i `elem` ps = ImplicitParam : getParamInfo sc is (i + 1) ps
164 | otherwise = ImplicitIndex : getParamInfo sc is (i + 1) ps
164 | otherwise = ImplicitIndex : getParamInfo sc is (i + 1) ps
165getParamInfo _ _ _ _ = []
165getParamInfo _ _ _ _ = []
@@ -249,13 +249,13 @@ mkLemma info lemma tcon ps ty =
249 mkArgs _ _ _ = []
249 mkArgs _ _ _ = []
250
250
251 bindIdxs ist [] ty is tm = tm
251 bindIdxs ist [] ty is tm = tm
252− bindIdxs ist (Param : pinfo) (Bind n (Pi _ ty _) sc) is tm
252+ bindIdxs ist (Param : pinfo) (Bind n (Pi _ _ ty _) sc) is tm
253 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
253 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
254− bindIdxs ist (Index : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm
254+ bindIdxs ist (Index : pinfo) (Bind n (Pi _ _ ty _) sc) (i : is) tm
255 = PPi forall_imp i fc (delab ist ty)
255 = PPi forall_imp i fc (delab ist ty)
256 (bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm)
256 (bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm)
257− bindIdxs ist (ImplicitParam : pinfo) (Bind n (Pi _ ty _) sc) is tm
257+ bindIdxs ist (ImplicitParam : pinfo) (Bind n (Pi _ _ ty _) sc) is tm
258 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
258 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
259− bindIdxs ist (ImplicitIndex : pinfo) (Bind n (Pi _ ty _) sc) (i : is) tm
259+ bindIdxs ist (ImplicitIndex : pinfo) (Bind n (Pi _ _ ty _) sc) (i : is) tm
260 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
260 = bindIdxs ist pinfo (instantiate (P Bound n ty) sc) is tm
261 bindIdxs _ _ _ _ tm = tm
261 bindIdxs _ _ _ _ tm = tm
src/Idris/Elab/Term.hs+146−101
@@ -18,7 +18,7 @@ import Idris.Core.ProofTerm (getProofTerm)
18import Idris.Core.TT
18import Idris.Core.TT
19import Idris.Core.Typecheck (check, converts, isType, recheck)
19import Idris.Core.Typecheck (check, converts, isType, recheck)
20import Idris.Core.Unify
20import Idris.Core.Unify
21−import Idris.Core.WHNF (whnf)
21+import Idris.Core.WHNF (whnf,whnfArgs)
22import Idris.Coverage (genClauses, recoverableCoverage, validCoverageCase)
22import Idris.Coverage (genClauses, recoverableCoverage, validCoverageCase)
23import Idris.Delaborate
23import Idris.Delaborate
24import Idris.DSL
24import Idris.DSL
@@ -45,7 +45,7 @@ import qualified Data.Set as S
45import qualified Data.Text as T
45import qualified Data.Text as T
46import Debug.Trace
46import Debug.Trace
47
47
48−data ElabMode = ETyDecl | ETransLHS | ELHS | ERHS
48+data ElabMode = ETyDecl | ETransLHS | ELHS | EImpossible | ERHS
49 deriving Eq
49 deriving Eq
50
50
51
51
@@ -143,7 +143,7 @@ build ist info emode opts fn tm
143 if log /= ""
143 if log /= ""
144 then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
144 then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
145 else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
145 else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
146− where pattern = emode == ELHS
146+ where pattern = emode == ELHS || emode == EImpossible
147 tydecl = emode == ETyDecl
147 tydecl = emode == ETyDecl
148
148
149 mkPat = do hs <- get_holes
149 mkPat = do hs <- get_holes
@@ -189,7 +189,7 @@ buildTC ist info emode opts fn ns tm
189 if (log /= "")
189 if (log /= "")
190 then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
190 then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
191 else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
191 else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
192− where pattern = emode == ELHS
192+ where pattern = emode == ELHS || emode == EImpossible
193
193
194-- | return whether arguments of the given constructor name can be
194-- | return whether arguments of the given constructor name can be
195-- matched on. If they're polymorphic, no, unless the type has beed
195-- matched on. If they're polymorphic, no, unless the type has beed
@@ -201,7 +201,7 @@ getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon
201 Nothing -> []
201 Nothing -> []
202 Just ty -> checkArgs [] [] ty
202 Just ty -> checkArgs [] [] ty
203 where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]
203 where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]
204− checkArgs env ns (Bind n (Pi _ t _) sc)
204+ checkArgs env ns (Bind n (Pi _ _ t _) sc)
205 = let env' = case t of
205 = let env' = case t of
206 TType _ -> n : env
206 TType _ -> n : env
207 _ -> env in
207 _ -> env in
@@ -227,7 +227,7 @@ goal_polymorphic =
227 do ty <- goal
227 do ty <- goal
228 case ty of
228 case ty of
229 P _ n _ -> do env <- get_env
229 P _ n _ -> do env <- get_env
230− case lookup n env of
230+ case lookupBinder n env of
231 Nothing -> return False
231 Nothing -> return False
232 _ -> return True
232 _ -> return True
233 _ -> return False
233 _ -> return False
@@ -245,23 +245,30 @@ elab :: IState
245elab ist info emode opts fn tm
245elab ist info emode opts fn tm
246 = do let loglvl = opt_logLevel (idris_options ist)
246 = do let loglvl = opt_logLevel (idris_options ist)
247 when (loglvl > 5) $ unifyLog True
247 when (loglvl > 5) $ unifyLog True
248− compute -- expand type synonyms, etc
248+ whnf_compute_args -- expand type synonyms, etc
249 let fc = maybe "(unknown)"
249 let fc = maybe "(unknown)"
250 elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote)
250 elabE initElabCtxt (elabFC info) tm -- (in argument, guarded, in type, in qquote)
251 est <- getAux
251 est <- getAux
252 sequence_ (get_delayed_elab est)
252 sequence_ (get_delayed_elab est)
253 end_unify
253 end_unify
254+ when (pattern || intransform) $
255+ -- convert remaining holes to pattern vars
256+ do unify_all
257+ matchProblems False -- only the ones we matched earlier
258+ unifyProblems
259+ mkPat
260+ update_term liftPats
254 ptm <- get_term
261 ptm <- get_term
255− when (pattern || intransform) -- convert remaining holes to pattern vars
262+ when pattern $
256− (do unify_all
263+ -- Look for Rig1 (linear) pattern bindings
257− matchProblems False -- only the ones we matched earlier
264+ do let pnms = findLinear ist [] ptm
258− unifyProblems
265+ update_term (setLinear pnms)
259− mkPat
260− update_term liftPats)
261 where
266 where
262− pattern = emode == ELHS
267+ pattern = emode == ELHS || emode == EImpossible
268+ eimpossible = emode == EImpossible
263 intransform = emode == ETransLHS
269 intransform = emode == ETransLHS
264 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS
270 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS
271+ || emode == EImpossible
265 autoimpls = opt_autoimpls (idris_options ist)
272 autoimpls = opt_autoimpls (idris_options ist)
266
273
267 get_delayed_elab est =
274 get_delayed_elab est =
@@ -293,7 +300,7 @@ elab ist info emode opts fn tm
293
300
294 -- | elabE elaborates an expression, possibly wrapping implicit coercions
301 -- | elabE elaborates an expression, possibly wrapping implicit coercions
295 -- and forces/delays. If you make a recursive call in elab', it is
302 -- and forces/delays. If you make a recursive call in elab', it is
296− -- normally correct to call elabE - the ones that don't are desugarings
303+ -- normally correct to call elabE - the ones that don't are `desugarings
297 -- typically
304 -- typically
298 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
305 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
299 elabE ina fc' t =
306 elabE ina fc' t =
@@ -332,13 +339,13 @@ elab ist info emode opts fn tm
332 pexp ct]))
339 pexp ct]))
333
340
334 forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)
341 forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)
335− | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),
342+ | (P _ (UN ht) _, _) <- unApply (whnf (tt_ctxt ist) env t),
336 ht == txt "Delayed" = notDelay orig
343 ht == txt "Delayed" = notDelay orig
337 forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)
344 forceErr orig env (CantUnify _ (t,_) (t',_) _ _ _)
338− | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),
345+ | (P _ (UN ht) _, _) <- unApply (whnf (tt_ctxt ist) env t'),
339 ht == txt "Delayed" = notDelay orig
346 ht == txt "Delayed" = notDelay orig
340 forceErr orig env (InfiniteUnify _ t _)
347 forceErr orig env (InfiniteUnify _ t _)
341− | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),
348+ | (P _ (UN ht) _, _) <- unApply (whnf (tt_ctxt ist) env t),
342 ht == txt "Delayed" = notDelay orig
349 ht == txt "Delayed" = notDelay orig
343 forceErr orig env (Elaborating _ _ _ t) = forceErr orig env t
350 forceErr orig env (Elaborating _ _ _ t) = forceErr orig env t
344 forceErr orig env (ElaboratingArg _ _ _ t) = forceErr orig env t
351 forceErr orig env (ElaboratingArg _ _ _ t) = forceErr orig env t
@@ -349,7 +356,7 @@ elab ist info emode opts fn tm
349 notDelay _ = True
356 notDelay _ = True
350
357
351 local f = do e <- get_env
358 local f = do e <- get_env
352− return (f `elem` map fst e)
359+ return (f `elem` map fstEnv e)
353
360
354 -- | Is a constant a type?
361 -- | Is a constant a type?
355 constType :: Const -> Bool
362 constType :: Const -> Bool
@@ -370,7 +377,10 @@ elab ist info emode opts fn tm
370 solve
377 solve
371 highlightSource fc' (AnnType "Type" "The type of types")
378 highlightSource fc' (AnnType "Type" "The type of types")
372 elab' ina fc (PUniverse fc' u) =
379 elab' ina fc (PUniverse fc' u) =
373− do apply (RUType u) []
380+ do unless (UniquenessTypes `elem` idris_language_extensions ist
381+ || e_qq ina) $
382+ lift $ tfail $ At fc' (Msg "You must turn on the UniquenessTypes extension to use UniqueType or AnyType")
383+ apply (RUType u) []
374 solve
384 solve
375 highlightSource fc' (AnnType (show u) "The type of unique types")
385 highlightSource fc' (AnnType (show u) "The type of unique types")
376-- elab' (_,_,inty) (PConstant c)
386-- elab' (_,_,inty) (PConstant c)
@@ -387,7 +397,7 @@ elab ist info emode opts fn tm
387 highlightSource fc' (AnnConst c)
397 highlightSource fc' (AnnConst c)
388 elab' ina fc (PQuote r) = do fill r; solve
398 elab' ina fc (PQuote r) = do fill r; solve
389 elab' ina _ (PTrue fc _) =
399 elab' ina _ (PTrue fc _) =
390− do compute
400+ do whnf_compute
391 g <- goal
401 g <- goal
392 case g of
402 case g of
393 TType _ -> elab' ina (Just fc) (PRef fc [] unitTy)
403 TType _ -> elab' ina (Just fc) (PRef fc [] unitTy)
@@ -421,7 +431,7 @@ elab ist info emode opts fn tm
421 pexp l, pexp r]))
431 pexp l, pexp r]))
422
432
423 elab' ina _ (PPair fc hls _ l r)
433 elab' ina _ (PPair fc hls _ l r)
424− = do compute
434+ = do whnf_compute
425 g <- goal
435 g <- goal
426 let (tc, _) = unApply g
436 let (tc, _) = unApply g
427 case g of
437 case g of
@@ -444,7 +454,7 @@ elab ist info emode opts fn tm
444 IsType -> asType
454 IsType -> asType
445 IsTerm -> asValue
455 IsTerm -> asValue
446 TypeOrTerm ->
456 TypeOrTerm ->
447− do compute
457+ do whnf_compute
448 g <- goal
458 g <- goal
449 case g of
459 case g of
450 TType _ -> asType
460 TType _ -> asType
@@ -498,11 +508,13 @@ elab ist info emode opts fn tm
498 showHd x = getNameFrom (sMN 0 "_") -- We probably should do something better than this here
508 showHd x = getNameFrom (sMN 0 "_") -- We probably should do something better than this here
499
509
500 doPrune as =
510 doPrune as =
501− do compute
511+ do compute -- to get 'Delayed' if it's there
502 ty <- goal
512 ty <- goal
503− let (tc, _) = unApply (unDelay ty)
513+ ctxt <- get_context
504 env <- get_env
514 env <- get_env
505− return $ pruneByType env tc (unDelay ty) ist as
515+ let ty' = unDelay ty
516+ let (tc, _) = unApply ty'
517+ return $ pruneByType eimpossible env tc ty' ist as
506
518
507 unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,
519 unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,
508 l == txt "Delayed" = unDelay arg
520 l == txt "Delayed" = unDelay arg
@@ -532,7 +544,7 @@ elab ist info emode opts fn tm
532 (trySeq' deferr xs) True
544 (trySeq' deferr xs) True
533 elab' ina fc (PAlternative ms TryImplicit (orig : alts)) = do
545 elab' ina fc (PAlternative ms TryImplicit (orig : alts)) = do
534 env <- get_env
546 env <- get_env
535− compute
547+ whnf_compute
536 ty <- goal
548 ty <- goal
537 let doelab = elab' ina fc orig
549 let doelab = elab' ina fc orig
538 tryCatch doelab
550 tryCatch doelab
@@ -564,7 +576,7 @@ elab ist info emode opts fn tm
564 recoverableErr _ = True
576 recoverableErr _ = True
565
577
566 pruneAlts (CantUnify _ (inc, _) (outc, _) _ _ _) alts env
578 pruneAlts (CantUnify _ (inc, _) (outc, _) _ _ _) alts env
567− = case unApply (normalise (tt_ctxt ist) env inc) of
579+ = case unApply (whnf (tt_ctxt ist) env inc) of
568 (P (TCon _ _) n _, _) -> filter (hasArg n env) alts
580 (P (TCon _ _) n _, _) -> filter (hasArg n env) alts
569 (Constant _, _) -> alts
581 (Constant _, _) -> alts
570 _ -> filter isLend alts -- special case hack for 'Borrowed'
582 _ -> filter isLend alts -- special case hack for 'Borrowed'
@@ -656,7 +668,7 @@ elab ist info emode opts fn tm
656 do fty <- get_type (Var n) -- check for implicits
668 do fty <- get_type (Var n) -- check for implicits
657 ctxt <- get_context
669 ctxt <- get_context
658 env <- get_env
670 env <- get_env
659− let a' = insertScopedImps fc (normalise ctxt env fty) []
671+ let a' = insertScopedImps fc (whnfArgs ctxt env fty) []
660 if null a'
672 if null a'
661 then erun fc $
673 then erun fc $
662 do apply (Var n) []
674 do apply (Var n) []
@@ -698,19 +710,30 @@ elab ist info emode opts fn tm
698 solve
710 solve
699 highlightSource nfc (AnnBoundName n False)
711 highlightSource nfc (AnnBoundName n False)
700 elab' ina fc (PPi p n nfc Placeholder sc)
712 elab' ina fc (PPi p n nfc Placeholder sc)
701− = do attack; arg n (is_scoped p) (sMN 0 "ty")
713+ = do attack;
714+ case pcount p of
715+ RigW -> return ()
716+ _ -> unless (LinearTypes `elem` idris_language_extensions ist
717+ || e_qq ina) $
718+ lift $ tfail $ At nfc (Msg "You must turn on the LinearTypes extension to use a count")
719+ arg n (pcount p) (is_scoped p) (sMN 0 "phTy")
702 addAutoBind p n
720 addAutoBind p n
703 addPSname n -- okay for proof search
721 addPSname n -- okay for proof search
704 elabE (ina { e_inarg = True, e_intype = True }) fc sc
722 elabE (ina { e_inarg = True, e_intype = True }) fc sc
705 solve
723 solve
706 highlightSource nfc (AnnBoundName n False)
724 highlightSource nfc (AnnBoundName n False)
707 elab' ina fc (PPi p n nfc ty sc)
725 elab' ina fc (PPi p n nfc ty sc)
708− = do attack; tyn <- getNameFrom (sMN 0 "ty")
726+ = do attack; tyn <- getNameFrom (sMN 0 "piTy")
709 claim tyn RType
727 claim tyn RType
710 n' <- case n of
728 n' <- case n of
711 MN _ _ -> unique_hole n
729 MN _ _ -> unique_hole n
712 _ -> return n
730 _ -> return n
713− forall n' (is_scoped p) (Var tyn)
731+ case pcount p of
732+ RigW -> return ()
733+ _ -> unless (LinearTypes `elem` idris_language_extensions ist
734+ || e_qq ina) $
735+ lift $ tfail $ At nfc (Msg "You must turn on the LinearTypes extension to use a linear argument")
736+ forall n' (pcount p) (is_scoped p) (Var tyn)
714 addAutoBind p n'
737 addAutoBind p n'
715 addPSname n' -- okay for proof search
738 addPSname n' -- okay for proof search
716 focus tyn
739 focus tyn
@@ -753,7 +776,7 @@ elab ist info emode opts fn tm
753 (ivs' \\ ivs)
776 (ivs' \\ ivs)
754 -- HACK: If the name leaks into its type, it may leak out of
777 -- HACK: If the name leaks into its type, it may leak out of
755 -- scope outside, so substitute in the outer scope.
778 -- scope outside, so substitute in the outer scope.
756− expandLet n (case lookup n env of
779+ expandLet n (case lookupBinder n env of
757 Just (Let t v) -> v
780 Just (Let t v) -> v
758 other -> error ("Value not a let binding: " ++ show other))
781 other -> error ("Value not a let binding: " ++ show other))
759 solve
782 solve
@@ -803,10 +826,10 @@ elab ist info emode opts fn tm
803 ans <- claimArgTys env xs
826 ans <- claimArgTys env xs
804 return ((aval, (True, (Var an))) : ans)
827 return ((aval, (True, (Var an))) : ans)
805 fnTy [] ret = forget ret
828 fnTy [] ret = forget ret
806− fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi Nothing xt RType) (fnTy xs ret)
829+ fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi RigW Nothing xt RType) (fnTy xs ret)
807
830
808 localVar env (PRef _ _ x)
831 localVar env (PRef _ _ x)
809− = case lookup x env of
832+ = case lookupBinder x env of
810 Just _ -> Just x
833 Just _ -> Just x
811 _ -> Nothing
834 _ -> Nothing
812 localVar env _ = Nothing
835 localVar env _ = Nothing
@@ -840,7 +863,7 @@ elab ist info emode opts fn tm
840 let dataCon = isDConName f ctxt
863 let dataCon = isDConName f ctxt
841 annot <- findHighlight f
864 annot <- findHighlight f
842 mapM_ checkKnownImplicit args_in
865 mapM_ checkKnownImplicit args_in
843− let args = insertScopedImps fc (normalise ctxt env fty) args_in
866+ let args = insertScopedImps fc (whnfArgs ctxt env fty) args_in
844 let unmatchableArgs = if pattern
867 let unmatchableArgs = if pattern
845 then getUnmatchable (tt_ctxt ist) f
868 then getUnmatchable (tt_ctxt ist) f
846 else []
869 else []
@@ -849,7 +872,7 @@ elab ist info emode opts fn tm
849 && isTConName f (tt_ctxt ist)) $
872 && isTConName f (tt_ctxt ist)) $
850 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)
873 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)
851-- trace (show (f, args_in, args)) $
874-- trace (show (f, args_in, args)) $
852− if (f `elem` map fst env && length args == 1 && length args_in == 1)
875+ if (f `elem` map fstEnv env && length args == 1 && length args_in == 1)
853 then -- simple app, as below
876 then -- simple app, as below
854 do simple_app False
877 do simple_app False
855 (elabE (ina { e_isfn = True }) (Just fc) (PRef ffc hls f))
878 (elabE (ina { e_isfn = True }) (Just fc) (PRef ffc hls f))
@@ -897,12 +920,12 @@ elab ist info emode opts fn tm
897 imp <- if (e_isfn ina) then
920 imp <- if (e_isfn ina) then
898 do guess <- get_guess
921 do guess <- get_guess
899 env <- get_env
922 env <- get_env
900− case safeForgetEnv (map fst env) guess of
923+ case safeForgetEnv (map fstEnv env) guess of
901 Nothing ->
924 Nothing ->
902 return []
925 return []
903 Just rguess -> do
926 Just rguess -> do
904 gty <- get_type rguess
927 gty <- get_type rguess
905− let ty_n = normalise ctxt env gty
928+ let ty_n = whnf ctxt env gty
906 return $ getReqImps ty_n
929 return $ getReqImps ty_n
907 else return []
930 else return []
908 -- Now we find out how many implicits we needed at the
931 -- Now we find out how many implicits we needed at the
@@ -950,16 +973,16 @@ elab ist info emode opts fn tm
950 = lift $ tfail $ UnknownImplicit (pname imp) f
973 = lift $ tfail $ UnknownImplicit (pname imp) f
951 checkKnownImplicit _ = return ()
974 checkKnownImplicit _ = return ()
952
975
953− getReqImps (Bind x (Pi (Just i) ty _) sc)
976+ getReqImps (Bind x (Pi _ (Just i) ty _) sc)
954 = i : getReqImps sc
977 = i : getReqImps sc
955 getReqImps _ = []
978 getReqImps _ = []
956
979
957 checkIfInjective n = do
980 checkIfInjective n = do
958 env <- get_env
981 env <- get_env
959− case lookup n env of
982+ case lookupBinder n env of
960 Nothing -> return ()
983 Nothing -> return ()
961 Just b ->
984 Just b ->
962− case unApply (normalise (tt_ctxt ist) env (binderTy b)) of
985+ case unApply (whnf (tt_ctxt ist) env (binderTy b)) of
963 (P _ c _, args) ->
986 (P _ c _, args) ->
964 case lookupCtxtExact c (idris_interfaces ist) of
987 case lookupCtxtExact c (idris_interfaces ist) of
965 Nothing -> return ()
988 Nothing -> return ()
@@ -1032,6 +1055,9 @@ elab ist info emode opts fn tm
1032 elab' ina fc (PElabError e) = lift $ tfail e
1055 elab' ina fc (PElabError e) = lift $ tfail e
1033 elab' ina mfc (PRewrite fc substfn rule sc newg)
1056 elab' ina mfc (PRewrite fc substfn rule sc newg)
1034 = elabRewrite (elab' ina mfc) ist fc substfn rule sc newg
1057 = elabRewrite (elab' ina mfc) ist fc substfn rule sc newg
1058+ -- A common error case if trying to typecheck an autogenerated case block
1059+ elab' ina _ c@(PCase fc Placeholder opts)
1060+ = lift $ tfail (Msg "No expression for the case to inspect.\nYou need to replace the _ with an expression.")
1035 elab' ina _ c@(PCase fc scr opts)
1061 elab' ina _ c@(PCase fc scr opts)
1036 = do attack
1062 = do attack
1037
1063
@@ -1069,13 +1095,13 @@ elab ist info emode opts fn tm
1069 -- unnecessarily (can only do this for unique things, since we
1095 -- unnecessarily (can only do this for unique things, since we
1070 -- assume they don't appear implicitly in types)
1096 -- assume they don't appear implicitly in types)
1071 ptm <- get_term
1097 ptm <- get_term
1072− let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)
1098+ let inOpts = (filter (/= scvn) (map fstEnv args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)
1073
1099
1074 let argsDropped = filter (isUnique envU)
1100 let argsDropped = filter (isUnique envU)
1075 (nub $ allNamesIn scr ++ inApp ptm ++
1101 (nub $ allNamesIn scr ++ inApp ptm ++
1076 inOpts)
1102 inOpts)
1077
1103
1078− let args' = filter (\(n, _) -> n `notElem` argsDropped) args
1104+ let args' = filter (\(n, _, _) -> n `notElem` argsDropped) args
1079
1105
1080 attack
1106 attack
1081 cname' <- defer argsDropped (mkN (mkCaseName fc fn))
1107 cname' <- defer argsDropped (mkN (mkCaseName fc fn))
@@ -1126,8 +1152,8 @@ elab ist info emode opts fn tm
1126 Just u -> u
1152 Just u -> u
1127 _ -> False
1153 _ -> False
1128
1154
1129− getKind env (n, _)
1155+ getKind env (n, _, _)
1130− = case lookup n env of
1156+ = case lookupBinder n env of
1131 Nothing -> return (n, False) -- can't happen, actually...
1157 Nothing -> return (n, False) -- can't happen, actually...
1132 Just b ->
1158 Just b ->
1133 do ty <- get_type (forget (binderTy b))
1159 do ty <- get_type (forget (binderTy b))
@@ -1210,13 +1236,13 @@ elab ist info emode opts fn tm
1210 loadState
1236 loadState
1211 updateAux (\aux -> aux { highlighting = hs })
1237 updateAux (\aux -> aux { highlighting = hs })
1212
1238
1213− let quoted = fmap (explicitNames . binderVal) $ lookup nTm env
1239+ let quoted = fmap (explicitNames . binderVal) $ lookupBinder nTm env
1214 isRaw = case unApply (normaliseAll ctxt env finalTy) of
1240 isRaw = case unApply (normaliseAll ctxt env finalTy) of
1215 (P _ n _, []) | n == reflm "Raw" -> True
1241 (P _ n _, []) | n == reflm "Raw" -> True
1216 _ -> False
1242 _ -> False
1217 case quoted of
1243 case quoted of
1218 Just q -> do ctxt <- get_context
1244 Just q -> do ctxt <- get_context
1219− (q', _, _) <- lift $ recheck (constraintNS info) ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q
1245+ (q', _, _) <- lift $ recheck (constraintNS info) ctxt [(uq, RigW, Lam RigW Erased) | uq <- unquoteNames] (forget q) q
1220 if pattern
1246 if pattern
1221 then if isRaw
1247 then if isRaw
1222 then reflectRawQuotePattern unquoteNames (forget q')
1248 then reflectRawQuotePattern unquoteNames (forget q')
@@ -1245,7 +1271,7 @@ elab ist info emode opts fn tm
1245 elab' ina fc (PQuoteName n True nfc) =
1271 elab' ina fc (PQuoteName n True nfc) =
1246 do ctxt <- get_context
1272 do ctxt <- get_context
1247 env <- get_env
1273 env <- get_env
1248− case lookup n env of
1274+ case lookupBinder n env of
1249 Just _ -> do fill $ reflectName n
1275 Just _ -> do fill $ reflectName n
1250 solve
1276 solve
1251 highlightSource nfc (AnnBoundName n False)
1277 highlightSource nfc (AnnBoundName n False)
@@ -1274,7 +1300,9 @@ elab ist info emode opts fn tm
1274 dotterm
1300 dotterm
1275 elab' ina fc t
1301 elab' ina fc t
1276 elab' ina fc (PRunElab fc' tm ns) =
1302 elab' ina fc (PRunElab fc' tm ns) =
1277− do attack
1303+ do unless (ElabReflection `elem` idris_language_extensions ist) $
1304+ lift $ tfail $ At fc' (Msg "You must turn on the ElabReflection extension to use %runElab")
1305+ attack
1278 n <- getNameFrom (sMN 0 "tacticScript")
1306 n <- getNameFrom (sMN 0 "tacticScript")
1279 let scriptTy = RApp (Var (sNS (sUN "Elab")
1307 let scriptTy = RApp (Var (sNS (sUN "Elab")
1280 ["Elab", "Reflection", "Language"]))
1308 ["Elab", "Reflection", "Language"]))
@@ -1312,7 +1340,7 @@ elab ist info emode opts fn tm
1312 env <- get_env
1340 env <- get_env
1313 ctxt <- get_context
1341 ctxt <- get_context
1314 let v = fmap (normaliseAll ctxt env . finalise . binderVal)
1342 let v = fmap (normaliseAll ctxt env . finalise . binderVal)
1315− (lookup n env)
1343+ (lookupBinder n env)
1316 loadState -- we have the highlighting - re-elaborate the value
1344 loadState -- we have the highlighting - re-elaborate the value
1317 elab' ina fc tm
1345 elab' ina fc tm
1318 case v of
1346 case v of
@@ -1335,9 +1363,9 @@ elab ist info emode opts fn tm
1335 delayElab pri t
1363 delayElab pri t
1336 = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })
1364 = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })
1337
1365
1338− isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))
1366+ isScr :: PTerm -> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
1339− isScr (PRef _ _ n) (n', b) = (n', (n == n', b))
1367+ isScr (PRef _ _ n) (n', _, b) = (n', (n == n', b))
1340− isScr _ (n', b) = (n', (False, b))
1368+ isScr _ (n', _, b) = (n', (False, b))
1341
1369
1342 caseBlock :: FC -> Name
1370 caseBlock :: FC -> Name
1343 -> PTerm -- original scrutinee
1371 -> PTerm -- original scrutinee
@@ -1437,8 +1465,8 @@ elab ist info emode opts fn tm
1437 mkDelay env (PAlternative ms b xs) = PAlternative ms b (map (mkDelay env) xs)
1465 mkDelay env (PAlternative ms b xs) = PAlternative ms b (map (mkDelay env) xs)
1438 mkDelay env t
1466 mkDelay env t
1439 = let fc = fileFC "Delay" in
1467 = let fc = fileFC "Delay" in
1440− addImplBound ist (map fst env) (PApp fc (PRef fc [] (sUN "Delay"))
1468+ addImplBound ist (map fstEnv env) (PApp fc (PRef fc [] (sUN "Delay"))
1441− [pexp t])
1469+ [pexp t])
1442
1470
1443
1471
1444 -- Don't put implicit coercions around applications which are marked
1472 -- Don't put implicit coercions around applications which are marked
@@ -1463,7 +1491,7 @@ elab ist info emode opts fn tm
1463 case fullApp tm of
1491 case fullApp tm of
1464 -- if f is global, leave it alone because we've already
1492 -- if f is global, leave it alone because we've already
1465 -- expanded it to the right arity
1493 -- expanded it to the right arity
1466− PApp fc ftm@(PRef _ _ f) args | Just aty <- lookup f env ->
1494+ PApp fc ftm@(PRef _ _ f) args | Just aty <- lookupBinder f env ->
1467 do let a = length (getArgTys (normalise (tt_ctxt ist) env (binderTy aty)))
1495 do let a = length (getArgTys (normalise (tt_ctxt ist) env (binderTy aty)))
1468 return (mkPApp fc a ftm args)
1496 return (mkPApp fc a ftm args)
1469 _ -> return tm
1497 _ -> return tm
@@ -1472,12 +1500,12 @@ elab ist info emode opts fn tm
1472 fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))
1500 fullApp (PApp _ (PApp fc f args) xs) = fullApp (PApp fc f (args ++ xs))
1473 fullApp x = x
1501 fullApp x = x
1474
1502
1475− insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs
1503+ insertScopedImps fc (Bind n (Pi _ im@(Just i) _ _) sc) xs
1476 | tcimplementation i && not (toplevel_imp i)
1504 | tcimplementation i && not (toplevel_imp i)
1477 = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs
1505 = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs
1478 | not (toplevel_imp i)
1506 | not (toplevel_imp i)
1479 = pimp n Placeholder True : insertScopedImps fc sc xs
1507 = pimp n Placeholder True : insertScopedImps fc sc xs
1480− insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)
1508+ insertScopedImps fc (Bind n (Pi _ _ _ _) sc) (x : xs)
1481 = x : insertScopedImps fc sc xs
1509 = x : insertScopedImps fc sc xs
1482 insertScopedImps _ _ xs = xs
1510 insertScopedImps _ _ xs = xs
1483
1511
@@ -1488,7 +1516,7 @@ elab ist info emode opts fn tm
1488 addLam ty' t
1516 addLam ty' t
1489 where
1517 where
1490 -- just one level at a time
1518 -- just one level at a time
1491− addLam (Bind n (Pi (Just _) _ _) sc) t =
1519+ addLam (Bind n (Pi _ (Just _) _ _) sc) t =
1492 do impn <- unique_hole n -- (sMN 0 "scoped_imp")
1520 do impn <- unique_hole n -- (sMN 0 "scoped_imp")
1493 if e_isfn ina -- apply to an implicit immediately
1521 if e_isfn ina -- apply to an implicit immediately
1494 then return (PApp emptyFC
1522 then return (PApp emptyFC
@@ -1516,7 +1544,7 @@ elab ist info emode opts fn tm
1516 mkCoerce env (PAlternative ms aty tms) n
1544 mkCoerce env (PAlternative ms aty tms) n
1517 = PAlternative ms aty (map (\t -> mkCoerce env t n) tms)
1545 = PAlternative ms aty (map (\t -> mkCoerce env t n) tms)
1518 mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in
1546 mkCoerce env t n = let fc = maybe (fileFC "Coercion") id (highestFC t) in
1519− addImplBound ist (map fst env)
1547+ addImplBound ist (map fstEnv env)
1520 (PApp fc (PRef fc [] n) [pexp (PCoerced t)])
1548 (PApp fc (PRef fc [] n) [pexp (PCoerced t)])
1521
1549
1522 -- | Elaborate the arguments to a function
1550 -- | Elaborate the arguments to a function
@@ -1575,7 +1603,7 @@ elab ist info emode opts fn tm
1575 fail $ "Can't elaborate these args: " ++ show arg ++ " " ++ show hole
1603 fail $ "Can't elaborate these args: " ++ show arg ++ " " ++ show hole
1576
1604
1577 addAutoBind :: Plicity -> Name -> ElabD ()
1605 addAutoBind :: Plicity -> Name -> ElabD ()
1578− addAutoBind (Imp _ _ _ _ False) n
1606+ addAutoBind (Imp _ _ _ _ False _) n
1579 = updateAux (\est -> est { auto_binds = n : auto_binds est })
1607 = updateAux (\est -> est { auto_binds = n : auto_binds est })
1580 addAutoBind _ _ = return ()
1608 addAutoBind _ _ = return ()
1581
1609
@@ -1625,17 +1653,17 @@ pruneAlt xs = map prune xs
1625
1653
1626-- Rule out alternatives that don't return the same type as the head of the goal
1654-- Rule out alternatives that don't return the same type as the head of the goal
1627-- (If there are none left as a result, do nothing)
1655-- (If there are none left as a result, do nothing)
1628−pruneByType :: Env -> Term -> -- head of the goal
1656+pruneByType :: Bool -> Env -> Term -> -- head of the goal
1629 Type -> -- goal
1657 Type -> -- goal
1630 IState -> [PTerm] -> [PTerm]
1658 IState -> [PTerm] -> [PTerm]
1631-- if an alternative has a locally bound name at the head, take it
1659-- if an alternative has a locally bound name at the head, take it
1632−pruneByType env t goalty c as
1660+pruneByType imp env t goalty c as
1633 | Just a <- locallyBound as = [a]
1661 | Just a <- locallyBound as = [a]
1634 where
1662 where
1635 locallyBound [] = Nothing
1663 locallyBound [] = Nothing
1636 locallyBound (t:ts)
1664 locallyBound (t:ts)
1637 | Just n <- getName t,
1665 | Just n <- getName t,
1638− n `elem` map fst env = Just t
1666+ n `elem` map fstEnv env = Just t
1639 | otherwise = locallyBound ts
1667 | otherwise = locallyBound ts
1640 getName (PRef _ _ n) = Just n
1668 getName (PRef _ _ n) = Just n
1641 getName (PApp _ (PRef _ _ (UN l)) [_, _, arg]) -- ignore Delays
1669 getName (PApp _ (PRef _ _ (UN l)) [_, _, arg]) -- ignore Delays
@@ -1645,7 +1673,7 @@ pruneByType env t goalty c as
1645 getName _ = Nothing
1673 getName _ = Nothing
1646
1674
1647-- 'n' is the name at the head of the goal type
1675-- 'n' is the name at the head of the goal type
1648−pruneByType env (P _ n _) goalty ist as
1676+pruneByType imp env (P _ n _) goalty ist as
1649-- if the goal type is polymorphic, keep everything
1677-- if the goal type is polymorphic, keep everything
1650 | Nothing <- lookupTyExact n ctxt = as
1678 | Nothing <- lookupTyExact n ctxt = as
1651-- if the goal type is a ?metavariable, keep everything
1679-- if the goal type is a ?metavariable, keep everything
@@ -1677,12 +1705,13 @@ pruneByType env (P _ n _) goalty ist as
1677 Just ty -> case unApply (getRetTy ty) of
1705 Just ty -> case unApply (getRetTy ty) of
1678 (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f)
1706 (P _ ctyn _, _) | isTConName ctyn ctxt && not (ctyn == f)
1679 -> False
1707 -> False
1680− _ -> let ty' = normalise ctxt [] ty in
1708+ _ -> let ty' = whnf ctxt [] ty in
1681−-- trace ("Trying " ++ show (getRetTy ty') ++ " for " ++ show goalty) $
1709+-- trace ("Trying " ++ show f' ++ " : " ++ show (getRetTy ty') ++ " for " ++ show goalty
1710+-- ++ "\nMATCH: " ++ show (pat, matching (getRetTy ty') goalty)) $
1682 case unApply (getRetTy ty') of
1711 case unApply (getRetTy ty') of
1683 (V _, _) ->
1712 (V _, _) ->
1684 isPlausible ist var env n ty
1713 isPlausible ist var env n ty
1685− _ -> matching (getRetTy ty') goalty
1714+ _ -> matchingTypes imp (getRetTy ty') goalty
1686 || isCoercion (getRetTy ty') goalty
1715 || isCoercion (getRetTy ty') goalty
1687-- May be useful to keep for debugging purposes for a bit:
1716-- May be useful to keep for debugging purposes for a bit:
1688-- let res = matching (getRetTy ty') goalty in
1717-- let res = matching (getRetTy ty') goalty in
@@ -1690,9 +1719,12 @@ pruneByType env (P _ n _) goalty ist as
1690-- ("Rejecting " ++ show (getRetTy ty', goalty)) res
1719-- ("Rejecting " ++ show (getRetTy ty', goalty)) res
1691 _ -> False
1720 _ -> False
1692
1721
1722+ matchingTypes True = matchingHead
1723+ matchingTypes False = matching
1724+
1693 -- If the goal is a constructor, it must match the suggested function type
1725 -- If the goal is a constructor, it must match the suggested function type
1694 matching (P _ ctyn _) (P _ n' _)
1726 matching (P _ ctyn _) (P _ n' _)
1695− | isTConName n' ctxt = ctyn == n'
1727+ | isTConName n' ctxt && isTConName ctyn ctxt = ctyn == n'
1696 | otherwise = True
1728 | otherwise = True
1697 -- Variables match anything
1729 -- Variables match anything
1698 matching (V _) _ = True
1730 matching (V _) _ = True
@@ -1703,14 +1735,28 @@ pruneByType env (P _ n _) goalty ist as
1703 matching (Bind n _ sc) _ = True
1735 matching (Bind n _ sc) _ = True
1704 matching _ (Bind n _ sc) = True
1736 matching _ (Bind n _ sc) = True
1705 -- If we hit a function name, it's a plausible match
1737 -- If we hit a function name, it's a plausible match
1706− matching (App _ (P _ f _) _) _ | not (isConName f ctxt) = True
1738+ matching apl@(App _ _ _) apr@(App _ _ _)
1707− matching _ (App _ (P _ f _) _) | not (isConName f ctxt) = True
1739+ | (P _ fl _, argsl) <- unApply apl,
1708− -- Otherwise, match the rest of the structure
1740+ (P _ fr _, argsr) <- unApply apr
1709− matching (App _ f a) (App _ f' a') = matching f f' && matching a a'
1741+ = fl == fr && and (zipWith matching argsl argsr)
1742+ || (not (isConName fl ctxt && isConName fr ctxt))
1743+ -- If the application structures aren't easily comparable, it's a
1744+ -- plausible match
1745+ matching (App _ f a) (App _ f' a') = True
1710 matching (TType _) (TType _) = True
1746 matching (TType _) (TType _) = True
1711 matching (UType _) (UType _) = True
1747 matching (UType _) (UType _) = True
1712 matching l r = l == r
1748 matching l r = l == r
1713
1749
1750+ -- In impossible-case mode, only look at the heads (this is to account for
1751+ -- the non type-directed case with 'impossible' - we'd be ruling out
1752+ -- too much and wouldn't find the mismatch we're looking for)
1753+ matchingHead apl@(App _ _ _) apr@(App _ _ _)
1754+ | (P _ fl _, argsl) <- unApply apl,
1755+ (P _ fr _, argsr) <- unApply apr,
1756+ isConName fl ctxt && isConName fr ctxt
1757+ = fl == fr
1758+ matchingHead _ _ = True
1759+
1714 -- Return whether there is a possible coercion between the return type
1760 -- Return whether there is a possible coercion between the return type
1715 -- of an alternative and the goal type
1761 -- of an alternative and the goal type
1716 isCoercion rty gty | (P _ r _, _) <- unApply rty
1762 isCoercion rty gty | (P _ r _, _) <- unApply rty
@@ -1735,7 +1781,7 @@ pruneByType env (P _ n _) goalty ist as
1735 _ -> False
1781 _ -> False
1736
1782
1737
1783
1738−pruneByType _ t _ _ as = as
1784+pruneByType _ _ t _ _ as = as
1739
1785
1740-- Could the name feasibly be the return type?
1786-- Could the name feasibly be the return type?
1741-- If there is an interface constraint on the return type, and no implementation
1787-- If there is an interface constraint on the return type, and no implementation
@@ -1752,7 +1798,7 @@ isPlausible ist var env n ty
1752 where
1798 where
1753 collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->
1799 collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->
1754 (Maybe Name, [(Term, [Name])])
1800 (Maybe Name, [(Term, [Name])])
1755− collectConstraints env tcs (Bind n (Pi _ ty _) sc)
1801+ collectConstraints env tcs (Bind n (Pi _ _ ty _) sc)
1756 = let tcs' = case unApply ty of
1802 = let tcs' = case unApply ty of
1757 (P _ c _, _) ->
1803 (P _ c _, _) ->
1758 case lookupCtxtExact c (idris_interfaces ist) of
1804 case lookupCtxtExact c (idris_interfaces ist) of
@@ -1770,7 +1816,7 @@ isPlausible ist var env n ty
1770findHighlight :: Name -> ElabD OutputAnnotation
1816findHighlight :: Name -> ElabD OutputAnnotation
1771findHighlight n = do ctxt <- get_context
1817findHighlight n = do ctxt <- get_context
1772 env <- get_env
1818 env <- get_env
1773− case lookup n env of
1819+ case lookupBinder n env of
1774 Just _ -> return $ AnnBoundName n False
1820 Just _ -> return $ AnnBoundName n False
1775 Nothing -> case lookupTyExact n ctxt of
1821 Nothing -> case lookupTyExact n ctxt of
1776 Just _ -> return $ AnnName n Nothing Nothing Nothing
1822 Just _ -> return $ AnnName n Nothing Nothing Nothing
@@ -1790,7 +1836,7 @@ solveAuto ist fn ambigok (n, failc)
1790 when (not isg) $
1836 when (not isg) $
1791 proofSearch' ist True ambigok 100 True Nothing fn [] [])
1837 proofSearch' ist True ambigok 100 True Nothing fn [] [])
1792 (lift $ Error (addLoc failc
1838 (lift $ Error (addLoc failc
1793− (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))))
1839+ (CantSolveGoal g (map (\(n, _, b) -> (n, binderTy b)) env))))
1794 return ()
1840 return ()
1795 where addLoc (FailContext fc f x : prev) err
1841 where addLoc (FailContext fc f x : prev) err
1796 = At fc (ElaboratingArg f x
1842 = At fc (ElaboratingArg f x
@@ -1863,7 +1909,7 @@ case_ ind autoSolve ist fn tm = do
1863 focus valn
1909 focus valn
1864 elab ist toplevel ERHS [] (sMN 0 "tac") tm
1910 elab ist toplevel ERHS [] (sMN 0 "tac") tm
1865 env <- get_env
1911 env <- get_env
1866− let (Just binding) = lookup letn env
1912+ let (Just binding) = lookupBinder letn env
1867 let val = binderVal binding
1913 let val = binderVal binding
1868 if ind then induction (forget val)
1914 if ind then induction (forget val)
1869 else casetac (forget val)
1915 else casetac (forget val)
@@ -1886,7 +1932,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
1886 returnUnit = return $ P (DCon 0 0 False) unitCon (P (TCon 0 0) unitTy Erased)
1932 returnUnit = return $ P (DCon 0 0 False) unitCon (P (TCon 0 0) unitTy Erased)
1887
1933
1888 patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
1934 patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
1889− patvars ns (Bind n (PVar t) sc) = patvars ((n, t) : ns) (instantiate (P Bound n t) sc)
1935+ patvars ns (Bind n (PVar _ t) sc) = patvars ((n, t) : ns) (instantiate (P Bound n t) sc)
1890 patvars ns tm = (ns, tm)
1936 patvars ns tm = (ns, tm)
1891
1937
1892 pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
1938 pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
@@ -1955,7 +2001,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
1955
2001
1956 -- | Add another argument to a Pi
2002 -- | Add another argument to a Pi
1957 mkPi :: RFunArg -> Raw -> Raw
2003 mkPi :: RFunArg -> Raw -> Raw
1958− mkPi arg rTy = RBind (argName arg) (Pi Nothing (argTy arg) (RUType AllTypes)) rTy
2004+ mkPi arg rTy = RBind (argName arg) (Pi RigW Nothing (argTy arg) (RUType AllTypes)) rTy
1959
2005
1960 mustBeType ctxt tm ty =
2006 mustBeType ctxt tm ty =
1961 case normaliseAll ctxt [] (finalise ty) of
2007 case normaliseAll ctxt [] (finalise ty) of
@@ -2012,7 +2058,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
2012 _ -> n
2058 _ -> n
2013
2059
2014 getRetTy :: Type -> Type
2060 getRetTy :: Type -> Type
2015− getRetTy (Bind _ (Pi _ _ _) sc) = getRetTy sc
2061+ getRetTy (Bind _ (Pi _ _ _ _) sc) = getRetTy sc
2016 getRetTy ty = ty
2062 getRetTy ty = ty
2017
2063
2018 elabScriptStuck :: Term -> ElabD a
2064 elabScriptStuck :: Term -> ElabD a
@@ -2220,7 +2266,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
2220 = do ~[n, ty] <- tacTmArgs 2 tac args
2266 = do ~[n, ty] <- tacTmArgs 2 tac args
2221 n' <- reifyTTName n
2267 n' <- reifyTTName n
2222 ty' <- reifyRaw ty
2268 ty' <- reifyRaw ty
2223− forall n' Nothing ty'
2269+ forall n' RigW Nothing ty'
2224 returnUnit
2270 returnUnit
2225 | n == tacN "Prim__PatVar"
2271 | n == tacN "Prim__PatVar"
2226 = do ~[n] <- tacTmArgs 1 tac args
2272 = do ~[n] <- tacTmArgs 1 tac args
@@ -2230,7 +2276,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
2230 | n == tacN "Prim__PatBind"
2276 | n == tacN "Prim__PatBind"
2231 = do ~[n] <- tacTmArgs 1 tac args
2277 = do ~[n] <- tacTmArgs 1 tac args
2232 n' <- reifyTTName n
2278 n' <- reifyTTName n
2233− patbind n'
2279+ patbind n' RigW
2234 returnUnit
2280 returnUnit
2235 | n == tacN "Prim__LetBind"
2281 | n == tacN "Prim__LetBind"
2236 = do ~[n, ty, tm] <- tacTmArgs 3 tac args
2282 = do ~[n, ty, tm] <- tacTmArgs 3 tac args
@@ -2252,7 +2298,7 @@ runElabAction info ist fc env tm ns = do tm' <- eval tm
2252 = do ~[tm] <- tacTmArgs 1 tac args
2298 = do ~[tm] <- tacTmArgs 1 tac args
2253 tm' <- reifyTT tm
2299 tm' <- reifyTT tm
2254 ctxt <- get_context
2300 ctxt <- get_context
2255− fmap fst . checkClosed . reflect $ whnf ctxt tm'
2301+ fmap fst . checkClosed . reflect $ whnf ctxt [] tm'
2256 | n == tacN "Prim__Converts"
2302 | n == tacN "Prim__Converts"
2257 = do ~[env, tm1, tm2] <- tacTmArgs 3 tac args
2303 = do ~[env, tm1, tm2] <- tacTmArgs 3 tac args
2258 env' <- reifyEnv env
2304 env' <- reifyEnv env
@@ -2426,11 +2472,11 @@ runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
2426runTac autoSolve ist perhapsFC fn tac
2472runTac autoSolve ist perhapsFC fn tac
2427 = do env <- get_env
2473 = do env <- get_env
2428 g <- goal
2474 g <- goal
2429− let tac' = fmap (addImplBound ist (map fst env)) tac
2475+ let tac' = fmap (addImplBound ist (map fstEnv env)) tac
2430 if autoSolve
2476 if autoSolve
2431 then runT tac'
2477 then runT tac'
2432 else no_errors (runT tac')
2478 else no_errors (runT tac')
2433− (Just (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env)))
2479+ (Just (CantSolveGoal g (map (\(n, _, b) -> (n, binderTy b)) env)))
2434 where
2480 where
2435 runT (Intro []) = do g <- goal
2481 runT (Intro []) = do g <- goal
2436 attack; intro (bname g)
2482 attack; intro (bname g)
@@ -2460,7 +2506,7 @@ runTac autoSolve ist perhapsFC fn tac
2460 tryAll tacs
2506 tryAll tacs
2461 when autoSolve solveAll
2507 when autoSolve solveAll
2462 where envArgs n = do e <- get_env
2508 where envArgs n = do e <- get_env
2463− case lookup n e of
2509+ case lookupBinder n e of
2464 Just t -> return $ map (const False)
2510 Just t -> return $ map (const False)
2465 (getArgTys (binderTy t))
2511 (getArgTys (binderTy t))
2466 _ -> return []
2512 _ -> return []
@@ -2478,7 +2524,7 @@ runTac autoSolve ist perhapsFC fn tac
2478 where isImp (PImp _ _ _ _ _) = True
2524 where isImp (PImp _ _ _ _ _) = True
2479 isImp _ = False
2525 isImp _ = False
2480 envArgs n = do e <- get_env
2526 envArgs n = do e <- get_env
2481− case lookup n e of
2527+ case lookupBinder n e of
2482 Just t -> return $ map (const False)
2528 Just t -> return $ map (const False)
2483 (getArgTys (binderTy t))
2529 (getArgTys (binderTy t))
2484 _ -> return []
2530 _ -> return []
@@ -2587,9 +2633,9 @@ runTac autoSolve ist perhapsFC fn tac
2587 where tacticTy = Var (reflm "Tactic")
2633 where tacticTy = Var (reflm "Tactic")
2588 listTy = Var (sNS (sUN "List") ["List", "Prelude"])
2634 listTy = Var (sNS (sUN "List") ["List", "Prelude"])
2589 scriptTy = (RBind (sMN 0 "__pi_arg")
2635 scriptTy = (RBind (sMN 0 "__pi_arg")
2590− (Pi Nothing (RApp listTy envTupleType) RType)
2636+ (Pi RigW Nothing (RApp listTy envTupleType) RType)
2591 (RBind (sMN 1 "__pi_arg")
2637 (RBind (sMN 1 "__pi_arg")
2592− (Pi Nothing (Var $ reflm "TT") RType) tacticTy))
2638+ (Pi RigW Nothing (Var $ reflm "TT") RType) tacticTy))
2593 runT (ByReflection tm) -- run the reflection function 'tm' on the
2639 runT (ByReflection tm) -- run the reflection function 'tm' on the
2594 -- goal, then apply the resulting reflected Tactic
2640 -- goal, then apply the resulting reflected Tactic
2595 = do tgoal <- goal
2641 = do tgoal <- goal
@@ -2785,7 +2831,7 @@ processTacticDecls info steps =
2785 mapM_ (addIBC . IBCDef . cn) ctors
2831 mapM_ (addIBC . IBCDef . cn) ctors
2786 ctxt <- getContext
2832 ctxt <- getContext
2787 let params = findParams tyn (normalise ctxt [] tyconTy) (map cty ctors)
2833 let params = findParams tyn (normalise ctxt [] tyconTy) (map cty ctors)
2788− let typeInfo = TI (map cn ctors) False [] params []
2834+ let typeInfo = TI (map cn ctors) False [] params [] False
2789 -- implicit precondition to IBCData is that idris_datatypes on the IState is populated.
2835 -- implicit precondition to IBCData is that idris_datatypes on the IState is populated.
2790 -- otherwise writing the IBC just fails silently!
2836 -- otherwise writing the IBC just fails silently!
2791 updateIState $ \i -> i { idris_datatypes =
2837 updateIState $ \i -> i { idris_datatypes =
@@ -2826,15 +2872,16 @@ processTacticDecls info steps =
2826 RClausesInstrs n cs ->
2872 RClausesInstrs n cs ->
2827 do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n
2873 do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n
2828 solveDeferred emptyFC n
2874 solveDeferred emptyFC n
2829− let lhss = map (\(_, lhs, _) -> lhs) cs
2875+ let lhss = map (\(ns, lhs, _) -> (map fst ns, lhs)) cs
2830 let fc = fileFC "elab_reflected"
2876 let fc = fileFC "elab_reflected"
2831 pmissing <-
2877 pmissing <-
2832 do ist <- getIState
2878 do ist <- getIState
2833 possible <- genClauses fc n lhss
2879 possible <- genClauses fc n lhss
2834− (map (\lhs ->
2880+ (map (\ (ns, lhs) ->
2835 delab' ist lhs True True) lhss)
2881 delab' ist lhs True True) lhss)
2836 missing <- filterM (checkPossible n) possible
2882 missing <- filterM (checkPossible n) possible
2837− return (filter (noMatch ist lhss) missing)
2883+ let undef = filter (noMatch ist (map snd lhss)) missing
2884+ return undef
2838 let tot = if null pmissing
2885 let tot = if null pmissing
2839 then Unchecked -- still need to check recursive calls
2886 then Unchecked -- still need to check recursive calls
2840 else Partial NotCovering -- missing cases implies not total
2887 else Partial NotCovering -- missing cases implies not total
@@ -2871,16 +2918,16 @@ processTacticDecls info steps =
2871 where
2918 where
2872 -- TODO: see if the code duplication with Idris.Elab.Clause can be
2919 -- TODO: see if the code duplication with Idris.Elab.Clause can be
2873 -- reduced or eliminated.
2920 -- reduced or eliminated.
2921+ -- These are always cases generated by genClauses
2874 checkPossible :: Name -> PTerm -> Idris Bool
2922 checkPossible :: Name -> PTerm -> Idris Bool
2875 checkPossible fname lhs_in =
2923 checkPossible fname lhs_in =
2876 do ctxt <- getContext
2924 do ctxt <- getContext
2877 ist <- getIState
2925 ist <- getIState
2878 let lhs = addImplPat ist lhs_in
2926 let lhs = addImplPat ist lhs_in
2879 let fc = fileFC "elab_reflected_totality"
2927 let fc = fileFC "elab_reflected_totality"
2880− let tcgen = False -- TODO: later we may support dictionary generation
2881 case elaborate (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState
2928 case elaborate (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState
2882− (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in)
2929+ (erun fc (buildTC ist info EImpossible [] fname (allNamesIn lhs_in)
2883− (infTerm lhs))) of
2930+ (infTerm lhs))) of
2884 OK (ElabResult lhs' _ _ _ _ _ name', _) ->
2931 OK (ElabResult lhs' _ _ _ _ _ name', _) ->
2885 do -- not recursively calling here, because we don't
2932 do -- not recursively calling here, because we don't
2886 -- want to run infinitely many times
2933 -- want to run infinitely many times
@@ -2890,9 +2937,7 @@ processTacticDecls info steps =
2890 OK _ -> return True
2937 OK _ -> return True
2891 err -> return False
2938 err -> return False
2892 -- if it's a recoverable error, the case may become possible
2939 -- if it's a recoverable error, the case may become possible
2893− Error err -> if tcgen then return (recoverableCoverage ctxt err)
2940+ Error err -> return (recoverableCoverage ctxt err)
2894− else return (validCoverageCase ctxt err ||
2895− recoverableCoverage ctxt err)
2896
2941
2897
2942
2898 -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause
2943 -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause
src/Idris/Elab/Transform.hs+3−3
@@ -114,11 +114,11 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in
114 return (clhs_tm, crhs_tm)
114 return (clhs_tm, crhs_tm)
115
115
116 where
116 where
117− depat (Bind n (PVar t) sc) = depat (instantiate (P Bound n t) sc)
117+ depat (Bind n (PVar _ t) sc) = depat (instantiate (P Bound n t) sc)
118 depat x = x
118 depat x = x
119
119
120− renamepats (n' : ns) (Bind n (PVar t) sc)
120+ renamepats (n' : ns) (Bind n (PVar rig t) sc)
121− = Bind n' (PVar t) (renamepats ns sc) -- all Vs
121+ = Bind n' (PVar rig t) (renamepats ns sc) -- all Vs
122 renamepats _ sc = sc
122 renamepats _ sc = sc
123
123
124 -- names for transformation variables. Need to ensure these don't clash
124 -- names for transformation variables. Need to ensure these don't clash
src/Idris/Elab/Type.hs+9−4
@@ -16,6 +16,7 @@ import Idris.ASTUtils
16import Idris.Core.CaseTree
16import Idris.Core.CaseTree
17import Idris.Core.Elaborate hiding (Tactic(..))
17import Idris.Core.Elaborate hiding (Tactic(..))
18import Idris.Core.Evaluate
18import Idris.Core.Evaluate
19+import Idris.Core.WHNF
19import Idris.Core.Execute
20import Idris.Core.Execute
20import Idris.Core.TT
21import Idris.Core.TT
21import Idris.Core.Typecheck
22import Idris.Core.Typecheck
@@ -132,14 +133,18 @@ buildType info syn fc opts n ty' = do
132 let fninfo = FnInfo (param_pos 0 pnames cty)
133 let fninfo = FnInfo (param_pos 0 pnames cty)
133 setFnInfo n fninfo
134 setFnInfo n fninfo
134 addIBC (IBCFnInfo n fninfo)
135 addIBC (IBCFnInfo n fninfo)
136+
137+ -- If we use any types with linear constructor arguments, we'd better
138+ -- make sure they are use-once
139+ tcliftAt fc $ linearCheck ctxt (whnfArgs ctxt [] cty)
135
140
136 return (cty, ckind, ty, inacc)
141 return (cty, ckind, ty, inacc)
137 where
142 where
138− patToImp (Bind n (PVar t) sc) = Bind n (Pi Nothing t (TType (UVar [] 0))) (patToImp sc)
143+ patToImp (Bind n (PVar rig t) sc) = Bind n (Pi rig Nothing t (TType (UVar [] 0))) (patToImp sc)
139 patToImp (Bind n b sc) = Bind n b (patToImp sc)
144 patToImp (Bind n b sc) = Bind n b (patToImp sc)
140 patToImp t = t
145 patToImp t = t
141
146
142− param_pos i ns (Bind n (Pi _ t _) sc)
147+ param_pos i ns (Bind n (Pi _ _ t _) sc)
143 | n `elem` ns = i : param_pos (i + 1) ns sc
148 | n `elem` ns = i : param_pos (i + 1) ns sc
144 | otherwise = param_pos (i + 1) ns sc
149 | otherwise = param_pos (i + 1) ns sc
145 param_pos i ns t = []
150 param_pos i ns t = []
@@ -192,7 +197,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par
192 let (fam, _) = unApply (getRetTy nty')
197 let (fam, _) = unApply (getRetTy nty')
193 let corec = case fam of
198 let corec = case fam of
194 P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of
199 P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of
195− [TI _ True _ _ _] -> True
200+ [TI _ True _ _ _ _] -> True
196 _ -> False
201 _ -> False
197 _ -> False
202 _ -> False
198 -- Productivity checking now via checking for guarded 'Delay'
203 -- Productivity checking now via checking for guarded 'Delay'
@@ -260,7 +265,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par
260 lst = txt "List"
265 lst = txt "List"
261 errrep = txt "ErrorReportPart"
266 errrep = txt "ErrorReportPart"
262
267
263− tyIsHandler (Bind _ (Pi _ (P _ (NS (UN e) ns1) _) _)
268+ tyIsHandler (Bind _ (Pi _ _ (P _ (NS (UN e) ns1) _) _)
264 (App _ (P _ (NS (UN m) ns2) _)
269 (App _ (P _ (NS (UN m) ns2) _)
265 (App _ (P _ (NS (UN l) ns3) _)
270 (App _ (P _ (NS (UN l) ns3) _)
266 (P _ (NS (UN r) ns4) _))))
271 (P _ (NS (UN r) ns4) _))))
src/Idris/Elab/Utils.hs+66−33
@@ -11,6 +11,7 @@ module Idris.Elab.Utils where
11import Idris.AbsSyntax
11import Idris.AbsSyntax
12import Idris.Core.Elaborate hiding (Tactic(..))
12import Idris.Core.Elaborate hiding (Tactic(..))
13import Idris.Core.Evaluate
13import Idris.Core.Evaluate
14+import Idris.Core.WHNF
14import Idris.Core.TT
15import Idris.Core.TT
15import Idris.Core.Typecheck
16import Idris.Core.Typecheck
16import Idris.DeepSeq
17import Idris.DeepSeq
@@ -103,7 +104,7 @@ checkAddDef add toplvl info fc mkerr definable ((n, (i, top, t, psns)) : ns)
103-- | Get the list of (index, name) of inaccessible arguments from an elaborated
104-- | Get the list of (index, name) of inaccessible arguments from an elaborated
104-- type
105-- type
105inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)]
106inaccessibleImps :: Int -> Type -> [Bool] -> [(Int, Name)]
106−inaccessibleImps i (Bind n (Pi _ t _) sc) (inacc : ins)
107+inaccessibleImps i (Bind n (Pi _ _ t _) sc) (inacc : ins)
107 | inacc = (i, n) : inaccessibleImps (i + 1) sc ins
108 | inacc = (i, n) : inaccessibleImps (i + 1) sc ins
108 | otherwise = inaccessibleImps (i + 1) sc ins
109 | otherwise = inaccessibleImps (i + 1) sc ins
109inaccessibleImps _ _ _ = []
110inaccessibleImps _ _ _ = []
@@ -184,8 +185,8 @@ decorateid decorate (PClauses f o n cs)
184
185
185-- if 't' is an interface application, assume its arguments are injective
186-- if 't' is an interface application, assume its arguments are injective
186pbinds :: IState -> Term -> ElabD ()
187pbinds :: IState -> Term -> ElabD ()
187−pbinds i (Bind n (PVar t) sc)
188+pbinds i (Bind n (PVar rig t) sc)
188− = do attack; patbind n
189+ = do attack; patbind n rig
189 env <- get_env
190 env <- get_env
190 case unApply (normalise (tt_ctxt i) env t) of
191 case unApply (normalise (tt_ctxt i) env t) of
191 (P _ c _, args) -> case lookupCtxt c (idris_interfaces i) of
192 (P _ c _, args) -> case lookupCtxt c (idris_interfaces i) of
@@ -198,26 +199,26 @@ pbinds i (Bind n (PVar t) sc)
198 setinjArg _ = return ()
199 setinjArg _ = return ()
199pbinds i tm = return ()
200pbinds i tm = return ()
200
201
201−pbty (Bind n (PVar t) sc) tm = Bind n (PVTy t) (pbty sc tm)
202+pbty (Bind n (PVar _ t) sc) tm = Bind n (PVTy t) (pbty sc tm)
202pbty _ tm = tm
203pbty _ tm = tm
203
204
204−getPBtys (Bind n (PVar t) sc) = (n, t) : getPBtys sc
205+getPBtys (Bind n (PVar _ t) sc) = (n, t) : getPBtys sc
205getPBtys (Bind n (PVTy t) sc) = (n, t) : getPBtys sc
206getPBtys (Bind n (PVTy t) sc) = (n, t) : getPBtys sc
206getPBtys _ = []
207getPBtys _ = []
207
208
208−psolve (Bind n (PVar t) sc) = do solve; psolve sc
209+psolve (Bind n (PVar _ t) sc) = do solve; psolve sc
209psolve tm = return ()
210psolve tm = return ()
210
211
211−pvars ist (Bind n (PVar t) sc) = (n, delab ist t) : pvars ist sc
212+pvars ist (Bind n (PVar _ t) sc) = (n, delab ist t) : pvars ist sc
212pvars ist _ = []
213pvars ist _ = []
213
214
214−getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi _ t _) sc)
215+getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi _ _ t _) sc)
215 = nub $ getFixedInType i env [] t ++
216 = nub $ getFixedInType i env [] t ++
216 getFixedInType i (n : env) is (instantiate (P Bound n t) sc)
217 getFixedInType i (n : env) is (instantiate (P Bound n t) sc)
217 ++ case unApply t of
218 ++ case unApply t of
218 (P _ n _, _) -> if n `elem` env then [n] else []
219 (P _ n _, _) -> if n `elem` env then [n] else []
219 _ -> []
220 _ -> []
220−getFixedInType i env (_ : is) (Bind n (Pi _ t _) sc)
221+getFixedInType i env (_ : is) (Bind n (Pi _ _ t _) sc)
221 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)
222 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)
222getFixedInType i env is tm@(App _ f a)
223getFixedInType i env is tm@(App _ f a)
223 | (P _ tn _, args) <- unApply tm
224 | (P _ tn _, args) <- unApply tm
@@ -231,7 +232,7 @@ getFixedInType i env is tm@(App _ f a)
231 getFixedInType i env is a
232 getFixedInType i env is a
232getFixedInType i _ _ _ = []
233getFixedInType i _ _ _ = []
233
234
234−getFlexInType i env ps (Bind n (Pi _ t _) sc)
235+getFlexInType i env ps (Bind n (Pi _ _ t _) sc)
235 = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++
236 = nub $ (if (not (n `elem` ps)) then getFlexInType i env ps t else []) ++
236 getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)
237 getFlexInType i (n : env) ps (instantiate (P Bound n t) sc)
237
238
@@ -260,7 +261,7 @@ getParamsInType i env ps t = let fix = getFixedInType i env ps t
260 flex = getFlexInType i env fix t in
261 flex = getFlexInType i env fix t in
261 [x | x <- fix, not (x `elem` flex)]
262 [x | x <- fix, not (x `elem` flex)]
262
263
263−getTCinj i (Bind n (Pi _ t _) sc)
264+getTCinj i (Bind n (Pi _ _ t _) sc)
264 = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc)
265 = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc)
265getTCinj i ap@(App _ f a)
266getTCinj i ap@(App _ f a)
266 | (P _ n _, args) <- unApply ap,
267 | (P _ n _, args) <- unApply ap,
@@ -292,13 +293,13 @@ getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []
292 where
293 where
293 getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] ()
294 getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] ()
294 getUniq env us (Bind n b sc)
295 getUniq env us (Bind n b sc)
295− = let uniq = case check ctxt env (forgetEnv (map fst env) (binderTy b)) of
296+ = let uniq = case check ctxt env (forgetEnv (map fstEnv env) (binderTy b)) of
296 OK (_, UType UniqueType) -> True
297 OK (_, UType UniqueType) -> True
297 OK (_, UType NullType) -> True
298 OK (_, UType NullType) -> True
298 OK (_, UType AllTypes) -> True
299 OK (_, UType AllTypes) -> True
299 _ -> False in
300 _ -> False in
300 do getUniqB env us b
301 do getUniqB env us b
301− getUniq ((n,b):env) ((n, uniq):us) sc
302+ getUniq ((n, RigW, b):env) ((n, uniq):us) sc
302 getUniq env us (App _ f a) = do getUniq env us f; getUniq env us a
303 getUniq env us (App _ f a) = do getUniq env us f; getUniq env us a
303 getUniq env us (V i)
304 getUniq env us (V i)
304 | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()
305 | i < length us = if snd (us!!i) then use (fst (us!!i)) else return ()
@@ -310,14 +311,14 @@ getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []
310
311
311 getUniqB env us (Let t v) = getUniq env us v
312 getUniqB env us (Let t v) = getUniq env us v
312 getUniqB env us (Guess t v) = getUniq env us v
313 getUniqB env us (Guess t v) = getUniq env us v
313−-- getUniqB env us (Pi t v) = do getUniq env us t; getUniq env us v
314+-- getUniqB env us (Pi _ _ t v) = do getUniq env us t; getUniq env us v
314 getUniqB env us (NLet t v) = getUniq env us v
315 getUniqB env us (NLet t v) = getUniq env us v
315 getUniqB env us b = return () -- getUniq env us (binderTy b)
316 getUniqB env us b = return () -- getUniq env us (binderTy b)
316
317
317-- In a functional application, return the names which are used
318-- In a functional application, return the names which are used
318-- directly in a static position
319-- directly in a static position
319getStaticNames :: IState -> Term -> [Name]
320getStaticNames :: IState -> Term -> [Name]
320−getStaticNames ist (Bind n (PVar _) sc)
321+getStaticNames ist (Bind n (PVar _ _) sc)
321 = getStaticNames ist (instantiate (P Bound n Erased) sc)
322 = getStaticNames ist (instantiate (P Bound n Erased) sc)
322getStaticNames ist tm
323getStaticNames ist tm
323 | (P _ fn _, args) <- unApply tm
324 | (P _ fn _, args) <- unApply tm
@@ -331,7 +332,7 @@ getStaticNames ist tm
331getStaticNames _ _ = []
332getStaticNames _ _ = []
332
333
333getStatics :: [Name] -> Term -> [Bool]
334getStatics :: [Name] -> Term -> [Bool]
334−getStatics ns (Bind n (Pi _ _ _) t)
335+getStatics ns (Bind n (Pi _ _ _ _) t)
335 | n `elem` ns = True : getStatics ns t
336 | n `elem` ns = True : getStatics ns t
336 | otherwise = False : getStatics ns t
337 | otherwise = False : getStatics ns t
337getStatics _ _ = []
338getStatics _ _ = []
@@ -407,7 +408,7 @@ findParams tyn famty ts =
407 getDataApp f@(App _ _ _)
408 getDataApp f@(App _ _ _)
408 | (P _ d _, args) <- unApply f
409 | (P _ d _, args) <- unApply f
409 = if (d == tyn) then [mParam args args] else []
410 = if (d == tyn) then [mParam args args] else []
410− getDataApp (Bind n (Pi _ t _) sc)
411+ getDataApp (Bind n (Pi _ _ t _) sc)
411 = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)
412 = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)
412 getDataApp _ = []
413 getDataApp _ = []
413
414
@@ -478,9 +479,9 @@ orderPats tm = op [] tm
478 where
479 where
479 op [] (App s f a) = App s f (op [] a) -- for Infer terms
480 op [] (App s f a) = App s f (op [] a) -- for Infer terms
480
481
481− op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc
482+ op ps (Bind n (PVar r t) sc) = op ((n, PVar r t) : ps) sc
482 op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc
483 op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc
483− op ps (Bind n (Pi i t k) sc) = op ((n, Pi i t k) : ps) sc
484+ op ps (Bind n (Pi rig i t k) sc) = op ((n, Pi rig i t k) : ps) sc
484 op ps sc = bindAll (sortP ps) sc
485 op ps sc = bindAll (sortP ps) sc
485
486
486 -- Keep explicit Pi in the same order, insert others as necessary,
487 -- Keep explicit Pi in the same order, insert others as necessary,
@@ -488,8 +489,8 @@ orderPats tm = op [] tm
488 sortP ps = let (exps, imps) = partition isExp ps in
489 sortP ps = let (exps, imps) = partition isExp ps in
489 pick (reverse exps) imps
490 pick (reverse exps) imps
490
491
491− isExp (_, Pi Nothing _ _) = True
492+ isExp (_, Pi rig Nothing _ _) = True
492− isExp (_, Pi (Just i) _ _) = toplevel_imp i && not (machine_gen i)
493+ isExp (_, Pi rig (Just i) _ _) = toplevel_imp i && not (machine_gen i)
493 isExp _ = False
494 isExp _ = False
494
495
495 pick acc [] = acc
496 pick acc [] = acc
@@ -510,13 +511,13 @@ liftPats tm = let (tm', ps) = runState (getPats tm) [] in
510 where
511 where
511 bindPats [] tm = tm
512 bindPats [] tm = tm
512 bindPats ((n, t):ps) tm
513 bindPats ((n, t):ps) tm
513− | n `notElem` map fst ps = Bind n (PVar t) (bindPats ps tm)
514+ | n `notElem` map fst ps = Bind n (PVar RigW t) (bindPats ps tm)
514 | otherwise = bindPats ps tm
515 | otherwise = bindPats ps tm
515
516
516 getPats :: Term -> State [(Name, Type)] Term
517 getPats :: Term -> State [(Name, Type)] Term
517− getPats (Bind n (PVar t) sc) = do ps <- get
518+ getPats (Bind n (PVar _ t) sc) = do ps <- get
518− put ((n, t) : ps)
519+ put ((n, t) : ps)
519− getPats sc
520+ getPats sc
520 getPats (Bind n (Guess t v) sc) = do t' <- getPats t
521 getPats (Bind n (Guess t v) sc) = do t' <- getPats t
521 v' <- getPats v
522 v' <- getPats v
522 sc' <- getPats sc
523 sc' <- getPats sc
@@ -525,13 +526,13 @@ liftPats tm = let (tm', ps) = runState (getPats tm) [] in
525 v' <- getPats v
526 v' <- getPats v
526 sc' <- getPats sc
527 sc' <- getPats sc
527 return (Bind n (Let t' v') sc')
528 return (Bind n (Let t' v') sc')
528− getPats (Bind n (Pi i t k) sc) = do t' <- getPats t
529+ getPats (Bind n (Pi rig i t k) sc) = do t' <- getPats t
529− k' <- getPats k
530+ k' <- getPats k
530− sc' <- getPats sc
531+ sc' <- getPats sc
531− return (Bind n (Pi i t' k') sc')
532+ return (Bind n (Pi rig i t' k') sc')
532− getPats (Bind n (Lam t) sc) = do t' <- getPats t
533+ getPats (Bind n (Lam r t) sc) = do t' <- getPats t
533− sc' <- getPats sc
534+ sc' <- getPats sc
534− return (Bind n (Lam t') sc')
535+ return (Bind n (Lam r t') sc')
535 getPats (Bind n (Hole t) sc) = do t' <- getPats t
536 getPats (Bind n (Hole t) sc) = do t' <- getPats t
536 sc' <- getPats sc
537 sc' <- getPats sc
537 return (Bind n (Hole t') sc')
538 return (Bind n (Hole t') sc')
@@ -568,6 +569,38 @@ isEmpty ctxt tyctxt ty
568isEmpty ctxt tyinfo ty = False
569isEmpty ctxt tyinfo ty = False
569
570
570hasEmptyPat :: Context -> Ctxt TypeInfo -> Term -> Bool
571hasEmptyPat :: Context -> Ctxt TypeInfo -> Term -> Bool
571−hasEmptyPat ctxt tyctxt (Bind n (PVar ty) sc)
572+hasEmptyPat ctxt tyctxt (Bind n (PVar _ ty) sc)
572 = isEmpty ctxt tyctxt ty || hasEmptyPat ctxt tyctxt sc
573 = isEmpty ctxt tyctxt ty || hasEmptyPat ctxt tyctxt sc
573hasEmptyPat ctxt tyctxt _ = False
574hasEmptyPat ctxt tyctxt _ = False
575+
576+-- Find names which are applied to a function in a Rig1 position
577+findLinear :: IState -> [Name] -> Term -> [(Name, RigCount)]
578+findLinear ist env tm | (P _ f _, args) <- unApply tm,
579+ f `notElem` env,
580+ Just ty_in <- lookupTyExact f (tt_ctxt ist)
581+ = let ty = whnfArgs (tt_ctxt ist) [] ty_in in
582+ nub $ concatMap (findLinear ist env) args ++ findLinArg ty args
583+ where
584+ findLinArg (Bind n (Pi c _ _ _) sc) (P _ a _ : as)
585+ | Rig0 <- c = (a, c) : findLinArg sc as
586+ | Rig1 <- c = (a, c) : findLinArg sc as
587+ findLinArg (Bind n (Pi _ _ _ _) sc) (a : as)
588+ = findLinArg (whnf (tt_ctxt ist) [] (substV a sc)) as
589+ findLinArg _ _ = []
590+findLinear ist env (App _ f a)
591+ = nub $ findLinear ist env f ++ findLinear ist env a
592+findLinear ist env (Bind n b sc) = findLinear ist (n : env) sc
593+findLinear ist _ _ = []
594+
595+setLinear :: [(Name, RigCount)] -> Term -> Term
596+setLinear ns (Bind n b@(PVar r t) sc)
597+ | Just r <- lookup n ns = Bind n (PVar r t) (setLinear ns sc)
598+ | otherwise = Bind n b (setLinear ns sc)
599+setLinear ns tm = tm
600+
601+linearArg :: Type -> Bool
602+linearArg (Bind n (Pi Rig1 _ _ _) sc) = True
603+linearArg (Bind n (Pi _ _ _ _) sc) = linearArg sc
604+linearArg _ = False
605+
606+
src/Idris/ElabDecls.hs+13−8
@@ -116,9 +116,9 @@ elabPrims = do i <- getIState
116
116
117 p_believeMe [_,_,x] = Just x
117 p_believeMe [_,_,x] = Just x
118 p_believeMe _ = Nothing
118 p_believeMe _ = Nothing
119− believeTy = Bind (sUN "a") (Pi Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))
119+ believeTy = Bind (sUN "a") (Pi RigW Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))
120− (Bind (sUN "b") (Pi Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))
120+ (Bind (sUN "b") (Pi RigW Nothing (TType (UVar [] (-2))) (TType (UVar [] (-1))))
121− (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar [] (-1)))) (V 1)))
121+ (Bind (sUN "x") (Pi RigW Nothing (V 1) (TType (UVar [] (-1)))) (V 1)))
122 elabBelieveMe
122 elabBelieveMe
123 = do let prim__believe_me = sUN "prim__believe_me"
123 = do let prim__believe_me = sUN "prim__believe_me"
124 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)
124 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)
@@ -141,10 +141,10 @@ elabPrims = do i <- getIState
141 vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased
141 vnNothing = VP (DCon 0 1 False) (sNS (sUN "Nothing") ["Maybe", "Prelude"]) VErased
142 vnRefl = VP (DCon 0 2 False) eqCon VErased
142 vnRefl = VP (DCon 0 2 False) eqCon VErased
143
143
144− synEqTy = Bind (sUN "a") (Pi Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))
144+ synEqTy = Bind (sUN "a") (Pi RigW Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))
145− (Bind (sUN "b") (Pi Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))
145+ (Bind (sUN "b") (Pi RigW Nothing (TType (UVar [] (-3))) (TType (UVar [] (-2))))
146− (Bind (sUN "x") (Pi Nothing (V 1) (TType (UVar [] (-2))))
146+ (Bind (sUN "x") (Pi RigW Nothing (V 1) (TType (UVar [] (-2))))
147− (Bind (sUN "y") (Pi Nothing (V 1) (TType (UVar [] (-2))))
147+ (Bind (sUN "y") (Pi RigW Nothing (V 1) (TType (UVar [] (-2))))
148 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)
148 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)
149 [V 3, V 2, V 1, V 0]]))))
149 [V 3, V 2, V 1, V 0]]))))
150 elabSynEq
150 elabSynEq
@@ -284,6 +284,8 @@ elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc cs
284-}
284-}
285elabDecl' _ info (PDSL n dsl)
285elabDecl' _ info (PDSL n dsl)
286 = do i <- getIState
286 = do i <- getIState
287+ unless (DSLNotation `elem` idris_language_extensions i) $
288+ ifail "You must turn on the DSLNotation extension to use a dsl block"
287 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })
289 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })
288 addIBC (IBCDSL n)
290 addIBC (IBCDSL n)
289elabDecl' what info (PDirective i)
291elabDecl' what info (PDirective i)
@@ -296,6 +298,9 @@ elabDecl' what info (PTransform fc safety old new)
296 = do elabTransform info fc safety old new
298 = do elabTransform info fc safety old new
297 return ()
299 return ()
298elabDecl' what info (PRunElabDecl fc script ns)
300elabDecl' what info (PRunElabDecl fc script ns)
299− = do elabRunElab info fc script ns
301+ = do i <- getIState
302+ unless (ElabReflection `elem` idris_language_extensions i) $
303+ ierror $ At fc (Msg "You must turn on the ElabReflection extension to use %runElab")
304+ elabRunElab info fc script ns
300 return ()
305 return ()
301elabDecl' _ _ _ = return () -- skipped this time
306elabDecl' _ _ _ = return () -- skipped this time
src/Idris/Erasure.hs+7−7
@@ -366,8 +366,8 @@ buildDepMap ci used externs ctx startNames
366 getDepsTerm vs bs cd (Bind n bdr body)
366 getDepsTerm vs bs cd (Bind n bdr body)
367 -- here we just push IM.empty on the de bruijn stack
367 -- here we just push IM.empty on the de bruijn stack
368 -- the args will be marked as used at the usage site
368 -- the args will be marked as used at the usage site
369− | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body
369+ | Lam _ ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body
370− | Pi _ ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body
370+ | Pi _ _ ty _ <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd body
371
371
372 -- let-bound variables can get partially evaluated
372 -- let-bound variables can get partially evaluated
373 -- it is sufficient just to plug the Cond in when the bound names are used
373 -- it is sufficient just to plug the Cond in when the bound names are used
@@ -421,11 +421,11 @@ buildDepMap ci used externs ctx startNames
421 V i -> snd (bs !! i) cd `union` unconditionalDeps args
421 V i -> snd (bs !! i) cd `union` unconditionalDeps args
422
422
423 -- we interpret applied lambdas as lets in order to reuse code here
423 -- we interpret applied lambdas as lets in order to reuse code here
424− Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet app)
424+ Bind n (Lam _ ty) t -> getDepsTerm vs bs cd (lamToLet app)
425
425
426 -- and we interpret applied lets as lambdas
426 -- and we interpret applied lets as lambdas
427− Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')
427+ Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam RigW ty) t) t')
428− Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')
428+ Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam RigW ty) t) t')
429
429
430 Proj t i
430 Proj t i
431 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t
431 -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t
@@ -504,7 +504,7 @@ buildDepMap ci used externs ctx startNames
504 (f, args) = unApply tm
504 (f, args) = unApply tm
505
505
506 lamToLet' :: [Term] -> Term -> Term
506 lamToLet' :: [Term] -> Term -> Term
507− lamToLet' (v:vs) (Bind n (Lam ty) tm) = Bind n (Let ty v) $ lamToLet' vs tm
507+ lamToLet' (v:vs) (Bind n (Lam _ ty) tm) = Bind n (Let ty v) $ lamToLet' vs tm
508 lamToLet' [] tm = tm
508 lamToLet' [] tm = tm
509 lamToLet' vs tm = error $
509 lamToLet' vs tm = error $
510 "Erasure.hs:lamToLet': unexpected input: "
510 "Erasure.hs:lamToLet': unexpected input: "
@@ -512,7 +512,7 @@ buildDepMap ci used externs ctx startNames
512
512
513 -- split "\x_i -> T(x_i)" into [x_i] and T
513 -- split "\x_i -> T(x_i)" into [x_i] and T
514 unfoldLams :: Term -> ([Name], Term)
514 unfoldLams :: Term -> ([Name], Term)
515− unfoldLams (Bind n (Lam ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')
515+ unfoldLams (Bind n (Lam _ ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')
516 unfoldLams t = ([], t)
516 unfoldLams t = ([], t)
517
517
518 union :: Deps -> Deps -> Deps
518 union :: Deps -> Deps -> Deps
src/Idris/ErrReverse.hs+2−2
@@ -33,7 +33,7 @@ errReverse ist t = rewrite 5 t -- (elideLambdas t)
33 -- Assume pattern bindings match in l and r (if they don't just treat
33 -- Assume pattern bindings match in l and r (if they don't just treat
34 -- the rule as invalid and return t)
34 -- the rule as invalid and return t)
35
35
36− applyNames ns t (Bind n (PVar ty) scl) (Bind n' (PVar ty') scr)
36+ applyNames ns t (Bind n (PVar _ ty) scl) (Bind n' (PVar _ ty') scr)
37 | n == n' = applyNames (n : ns) t (instantiate (P Ref n ty) scl)
37 | n == n' = applyNames (n : ns) t (instantiate (P Ref n ty) scl)
38 (instantiate (P Ref n' ty') scr)
38 (instantiate (P Ref n' ty') scr)
39 | otherwise = t
39 | otherwise = t
@@ -70,7 +70,7 @@ errReverse ist t = rewrite 5 t -- (elideLambdas t)
70 -- it as it won't be very enlightening.
70 -- it as it won't be very enlightening.
71
71
72 elideLambdas (App s f a) = App s (elideLambdas f) (elideLambdas a)
72 elideLambdas (App s f a) = App s (elideLambdas f) (elideLambdas a)
73− elideLambdas (Bind n (Lam t) sc)
73+ elideLambdas (Bind n (Lam _ t) sc)
74 | size sc > 200 = P Ref (sUN "...") Erased
74 | size sc > 200 = P Ref (sUN "...") Erased
75 elideLambdas (Bind n b sc)
75 elideLambdas (Bind n b sc)
76 = Bind n (fmap elideLambdas b) (elideLambdas sc)
76 = Bind n (fmap elideLambdas b) (elideLambdas sc)
src/Idris/Error.hs+6
@@ -79,6 +79,12 @@ tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err
79tclift (Error err@(UniverseError fc _ _ _ _)) = do setErrSpan fc; throwError err
79tclift (Error err@(UniverseError fc _ _ _ _)) = do setErrSpan fc; throwError err
80tclift (Error err) = throwError err
80tclift (Error err) = throwError err
81
81
82+tcliftAt :: FC -> TC a -> Idris a
83+tcliftAt fc (OK v) = return v
84+tcliftAt fc (Error err@(At _ e)) = do setErrSpan fc; throwError err
85+tcliftAt fc (Error err@(UniverseError _ _ _ _ _)) = do setErrSpan fc; throwError err
86+tcliftAt fc (Error err) = do setErrSpan fc; throwError (At fc err)
87+
82tctry :: TC a -> TC a -> Idris a
88tctry :: TC a -> TC a -> Idris a
83tctry tc1 tc2
89tctry tc1 tc2
84 = case tc1 of
90 = case tc1 of
src/Idris/IBC.hs+29−17
@@ -47,7 +47,7 @@ import System.Directory
47import System.FilePath
47import System.FilePath
48
48
49ibcVersion :: Word16
49ibcVersion :: Word16
50−ibcVersion = 155
50+ibcVersion = 160
51
51
52-- | When IBC is being loaded - we'll load different things (and omit
52-- | When IBC is being loaded - we'll load different things (and omit
53-- different structures/definitions) depending on which phase we're in.
53-- different structures/definitions) depending on which phase we're in.
@@ -220,7 +220,9 @@ writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArch
220
220
221writeIBC :: FilePath -> FilePath -> Idris ()
221writeIBC :: FilePath -> FilePath -> Idris ()
222writeIBC src f
222writeIBC src f
223− = do logIBC 1 $ "Writing ibc " ++ show f
223+ = do
224+ logIBC 1 $ "Writing IBC for: " ++ show f
225+ iReport 2 $ "Writing IBC for: " ++ show f
224 i <- getIState
226 i <- getIState
225-- case (Data.List.map fst (idris_metavars i)) \\ primDefs of
227-- case (Data.List.map fst (idris_metavars i)) \\ primDefs of
226-- (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"
228-- (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"
@@ -313,7 +315,7 @@ ibc i (IBCCG n) f = case lookupCtxtExact n (idris_callgraph i) of
313 _ -> ifail "IBC write failed"
315 _ -> ifail "IBC write failed"
314ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }
316ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }
315ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f }
317ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f }
316−ibc i (IBCFlags n) f
318+ibc i (IBCFlags n) f
317 = case lookupCtxtExact n (idris_flags i) of
319 = case lookupCtxtExact n (idris_flags i) of
318 Just a -> return f { ibc_flags = (n,a): ibc_flags f }
320 Just a -> return f { ibc_flags = (n,a): ibc_flags f }
319 _ -> ifail "IBC write failed"
321 _ -> ifail "IBC write failed"
@@ -1326,26 +1328,30 @@ instance Binary Static where
1326instance Binary Plicity where
1328instance Binary Plicity where
1327 put x
1329 put x
1328 = case x of
1330 = case x of
1329− Imp x1 x2 x3 x4 _ ->
1331+ Imp x1 x2 x3 x4 _ x5 ->
1330 do putWord8 0
1332 do putWord8 0
1331 put x1
1333 put x1
1332 put x2
1334 put x2
1333 put x3
1335 put x3
1334 put x4
1336 put x4
1335− Exp x1 x2 x3 ->
1337+ put x5
1338+ Exp x1 x2 x3 x4 ->
1336 do putWord8 1
1339 do putWord8 1
1337 put x1
1340 put x1
1338 put x2
1341 put x2
1339 put x3
1342 put x3
1340− Constraint x1 x2 ->
1343+ put x4
1344+ Constraint x1 x2 x3 ->
1341 do putWord8 2
1345 do putWord8 2
1342 put x1
1346 put x1
1343 put x2
1347 put x2
1344− TacImp x1 x2 x3 ->
1348+ put x3
1349+ TacImp x1 x2 x3 x4 ->
1345 do putWord8 3
1350 do putWord8 3
1346 put x1
1351 put x1
1347 put x2
1352 put x2
1348 put x3
1353 put x3
1354+ put x4
1349 get
1355 get
1350 = do i <- getWord8
1356 = do i <- getWord8
1351 case i of
1357 case i of
@@ -1353,18 +1359,22 @@ instance Binary Plicity where
1353 x2 <- get
1359 x2 <- get
1354 x3 <- get
1360 x3 <- get
1355 x4 <- get
1361 x4 <- get
1356− return (Imp x1 x2 x3 x4 False)
1362+ x5 <- get
1363+ return (Imp x1 x2 x3 x4 False x5)
1357 1 -> do x1 <- get
1364 1 -> do x1 <- get
1358 x2 <- get
1365 x2 <- get
1359 x3 <- get
1366 x3 <- get
1360− return (Exp x1 x2 x3)
1367+ x4 <- get
1368+ return (Exp x1 x2 x3 x4)
1361 2 -> do x1 <- get
1369 2 -> do x1 <- get
1362 x2 <- get
1370 x2 <- get
1363− return (Constraint x1 x2)
1371+ x3 <- get
1372+ return (Constraint x1 x2 x3)
1364 3 -> do x1 <- get
1373 3 -> do x1 <- get
1365 x2 <- get
1374 x2 <- get
1366 x3 <- get
1375 x3 <- get
1367− return (TacImp x1 x2 x3)
1376+ x4 <- get
1377+ return (TacImp x1 x2 x3 x4)
1368 _ -> error "Corrupted binary data for Plicity"
1378 _ -> error "Corrupted binary data for Plicity"
1369
1379
1370
1380
@@ -2414,17 +2424,19 @@ instance Binary FnInfo where
2414 return (FnInfo x1)
2424 return (FnInfo x1)
2415
2425
2416instance Binary TypeInfo where
2426instance Binary TypeInfo where
2417− put (TI x1 x2 x3 x4 x5) = do put x1
2427+ put (TI x1 x2 x3 x4 x5 x6) = do put x1
2418− put x2
2428+ put x2
2419− put x3
2429+ put x3
2420− put x4
2430+ put x4
2421− put x5
2431+ put x5
2432+ put x6
2422 get = do x1 <- get
2433 get = do x1 <- get
2423 x2 <- get
2434 x2 <- get
2424 x3 <- get
2435 x3 <- get
2425 x4 <- get
2436 x4 <- get
2426 x5 <- get
2437 x5 <- get
2427− return (TI x1 x2 x3 x4 x5)
2438+ x6 <- get
2439+ return (TI x1 x2 x3 x4 x5 x6)
2428
2440
2429instance Binary SynContext where
2441instance Binary SynContext where
2430 put x
2442 put x
src/Idris/IdrisDoc.hs+2−2
@@ -19,7 +19,7 @@ import Idris.Docs
19import Idris.Docstrings (nullDocstring)
19import Idris.Docstrings (nullDocstring)
20import qualified Idris.Docstrings as Docstrings
20import qualified Idris.Docstrings as Docstrings
21import Idris.Parser.Helpers (opChars)
21import Idris.Parser.Helpers (opChars)
22−import IRTS.System (getDataFileName)
22+import IRTS.System (getIdrisDataFileByName)
23
23
24import Control.Applicative ((<|>))
24import Control.Applicative ((<|>))
25import Control.Monad (forM_)
25import Control.Monad (forM_)
@@ -708,5 +708,5 @@ copyDependencies :: FilePath -- ^ The base directory to which
708 -- dependencies should be written
708 -- dependencies should be written
709 -> IO ()
709 -> IO ()
710copyDependencies dir =
710copyDependencies dir =
711− do styles <- getDataFileName $ "idrisdoc" </> "styles.css"
711+ do styles <- getIdrisDataFileByName $ "idrisdoc" </> "styles.css"
712 copyFile styles (dir </> "styles.css")
712 copyFile styles (dir </> "styles.css")
src/Idris/Info.hs+5
@@ -22,6 +22,7 @@ module Idris.Info
22 , getIdrisHistoryFile
22 , getIdrisHistoryFile
23 , getIdrisInstalledPackages
23 , getIdrisInstalledPackages
24 , getIdrisLoggingCategories
24 , getIdrisLoggingCategories
25+ , getIdrisDataFileByName
25 ) where
26 ) where
26
27
27import Idris.AbsSyntax (loggingCatsStr)
28import Idris.AbsSyntax (loggingCatsStr)
@@ -34,6 +35,7 @@ import Version_idris (gitHash)
34import Data.Version
35import Data.Version
35import System.Directory
36import System.Directory
36import System.FilePath
37import System.FilePath
38+
37getIdrisDataDir :: IO String
39getIdrisDataDir :: IO String
38getIdrisDataDir = S.getIdrisDataDir
40getIdrisDataDir = S.getIdrisDataDir
39
41
@@ -88,3 +90,6 @@ getIdrisInstalledPackages = installedPackages
88
90
89getIdrisLoggingCategories :: IO [String]
91getIdrisLoggingCategories :: IO [String]
90getIdrisLoggingCategories = return $ words loggingCatsStr
92getIdrisLoggingCategories = return $ words loggingCatsStr
93+
94+getIdrisDataFileByName :: String -> IO FilePath
95+getIdrisDataFileByName = S.getIdrisDataFileByName
src/Idris/Interactive.hs+8−8
@@ -390,10 +390,10 @@ makeLemma fn updatefile l n
390 where getIndent s = length (takeWhile isSpace s)
390 where getIndent s = length (takeWhile isSpace s)
391
391
392 appArgs skip 0 _ = ""
392 appArgs skip 0 _ = ""
393− appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)
393+ appArgs skip i (Bind n@(UN c) (Pi _ _ _ _) sc)
394 | (thead c /= '_' && n `notElem` skip)
394 | (thead c /= '_' && n `notElem` skip)
395 = " " ++ show n ++ appArgs skip (i - 1) sc
395 = " " ++ show n ++ appArgs skip (i - 1) sc
396− appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc
396+ appArgs skip i (Bind _ (Pi _ _ _ _) sc) = appArgs skip (i - 1) sc
397 appArgs skip i _ = ""
397 appArgs skip i _ = ""
398
398
399 stripMNBind _ args t | args <= 0 = stripImp t
399 stripMNBind _ args t | args <= 0 = stripImp t
@@ -416,7 +416,7 @@ makeLemma fn updatefile l n
416 constraints i [n] ty = showSep ", " (showConstraints i [n] ty) ++ " => "
416 constraints i [n] ty = showSep ", " (showConstraints i [n] ty) ++ " => "
417 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "
417 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "
418
418
419− showConstraints i ns (Bind n (Pi _ ty _) sc)
419+ showConstraints i ns (Bind n (Pi _ _ ty _) sc)
420 | n `elem` ns = show (delab i ty) :
420 | n `elem` ns = show (delab i ty) :
421 showConstraints i ns (substV (P Bound n Erased) sc)
421 showConstraints i ns (substV (P Bound n Erased) sc)
422 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)
422 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)
@@ -428,9 +428,9 @@ makeLemma fn updatefile l n
428 -- Also, make interface implementations implicit
428 -- Also, make interface implementations implicit
429 guessImps :: IState -> Context -> Term -> [Name]
429 guessImps :: IState -> Context -> Term -> [Name]
430 -- machine names aren't lifted
430 -- machine names aren't lifted
431− guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)
431+ guessImps ist ctxt (Bind n@(MN _ _) (Pi _ _ ty _) sc)
432 = n : guessImps ist ctxt sc
432 = n : guessImps ist ctxt sc
433− guessImps ist ctxt (Bind n (Pi _ ty _) sc)
433+ guessImps ist ctxt (Bind n (Pi _ _ ty _) sc)
434 | guarded ctxt n (substV (P Bound n Erased) sc)
434 | guarded ctxt n (substV (P Bound n Erased) sc)
435 = n : guessImps ist ctxt sc
435 = n : guessImps ist ctxt sc
436 | isInterface ist ty
436 | isInterface ist ty
@@ -441,7 +441,7 @@ makeLemma fn updatefile l n
441 guessImps ist ctxt _ = []
441 guessImps ist ctxt _ = []
442
442
443 paramty (TType _) = True
443 paramty (TType _) = True
444− paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc
444+ paramty (Bind _ (Pi _ _ (TType _) _) sc) = paramty sc
445 paramty _ = False
445 paramty _ = False
446
446
447 -- TMP HACK unusable name so don't lift
447 -- TMP HACK unusable name so don't lift
@@ -450,7 +450,7 @@ makeLemma fn updatefile l n
450 _ -> False
450 _ -> False
451
451
452 guessInterfaces :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]
452 guessInterfaces :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]
453− guessInterfaces ist ctxt binders usednames (Bind n (Pi _ ty _) sc)
453+ guessInterfaces ist ctxt binders usednames (Bind n (Pi _ _ ty _) sc)
454 | isParamInterface ist ty && any (\x -> elem x usednames)
454 | isParamInterface ist ty && any (\x -> elem x usednames)
455 (paramNames binders ty)
455 (paramNames binders ty)
456 = n : guessInterfaces ist ctxt (n : binders) usednames sc
456 = n : guessInterfaces ist ctxt (n : binders) usednames sc
@@ -485,7 +485,7 @@ makeLemma fn updatefile l n
485 isConName f ctxt = any (guarded ctxt n) args
485 isConName f ctxt = any (guarded ctxt n) args
486-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows
486-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows
487-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc
487-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc
488− guarded ctxt n (Bind _ (Pi _ t _) sc)
488+ guarded ctxt n (Bind _ (Pi _ _ t _) sc)
489 = guarded ctxt n t || guarded ctxt n sc
489 = guarded ctxt n t || guarded ctxt n sc
490 guarded ctxt n _ = False
490 guarded ctxt n _ = False
491
491
src/Idris/Main.hs+5−2
@@ -68,7 +68,6 @@ idrisMain opts =
68 let nobanner = NoBanner `elem` opts
68 let nobanner = NoBanner `elem` opts
69 let idesl = Idemode `elem` opts || IdemodeSocket `elem` opts
69 let idesl = Idemode `elem` opts || IdemodeSocket `elem` opts
70 let runrepl = not (NoREPL `elem` opts)
70 let runrepl = not (NoREPL `elem` opts)
71− let verbose = runrepl || Verbose `elem` opts
72 let output = opt getOutput opts
71 let output = opt getOutput opts
73 let ibcsubdir = opt getIBCSubDir opts
72 let ibcsubdir = opt getIBCSubDir opts
74 let importdirs = opt getImportDir opts
73 let importdirs = opt getImportDir opts
@@ -116,13 +115,16 @@ idrisMain opts =
116 mapM_ addLangExt (opt getLanguageExt opts)
115 mapM_ addLangExt (opt getLanguageExt opts)
117 setREPL runrepl
116 setREPL runrepl
118 setQuiet (quiet || isJust script || not (null immediate))
117 setQuiet (quiet || isJust script || not (null immediate))
119− setVerbose verbose
118+
120 setCmdLine opts
119 setCmdLine opts
121 setOutputTy outty
120 setOutputTy outty
122 setNoBanner nobanner
121 setNoBanner nobanner
123 setCodegen cgn
122 setCodegen cgn
124 mapM_ (addFlag cgn) cgFlags
123 mapM_ (addFlag cgn) cgFlags
125 mapM_ makeOption opts
124 mapM_ makeOption opts
125+ vlevel <- verbose
126+ when (runrepl && vlevel == 0) $ setVerbose 1
127+
126 -- if we have the --bytecode flag, drop into the bytecode assembler
128 -- if we have the --bytecode flag, drop into the bytecode assembler
127 case bcs of
129 case bcs of
128 [] -> return ()
130 [] -> return ()
@@ -215,6 +217,7 @@ idrisMain opts =
215 where
217 where
216 makeOption (OLogging i) = setLogLevel i
218 makeOption (OLogging i) = setLogLevel i
217 makeOption (OLogCats cs) = setLogCats cs
219 makeOption (OLogCats cs) = setLogCats cs
220+ makeOption (Verbose v) = setVerbose v
218 makeOption TypeCase = setTypeCase True
221 makeOption TypeCase = setTypeCase True
219 makeOption TypeInType = setTypeInType True
222 makeOption TypeInType = setTypeInType True
220 makeOption NoCoverage = setCoverage False
223 makeOption NoCoverage = setCoverage False
src/Idris/Package.hs+42−37
@@ -71,14 +71,14 @@ buildPkg copts warnonly (install, fp) = do
71 make (makefile pkgdesc)
71 make (makefile pkgdesc)
72 case (execout pkgdesc) of
72 case (execout pkgdesc) of
73 Nothing -> do
73 Nothing -> do
74− case mergeOptions copts (idx : NoREPL : Verbose : idris_opts pkgdesc) of
74+ case mergeOptions copts (idx : NoREPL : Verbose 1 : idris_opts pkgdesc) of
75 Left emsg -> do
75 Left emsg -> do
76 putStrLn emsg
76 putStrLn emsg
77 exitWith (ExitFailure 1)
77 exitWith (ExitFailure 1)
78 Right opts -> buildMods opts (modules pkgdesc)
78 Right opts -> buildMods opts (modules pkgdesc)
79 Just o -> do
79 Just o -> do
80 let exec = dir </> o
80 let exec = dir </> o
81− case mergeOptions copts (idx : NoREPL : Verbose : Output exec : idris_opts pkgdesc) of
81+ case mergeOptions copts (idx : NoREPL : Verbose 1 : Output exec : idris_opts pkgdesc) of
82 Left emsg -> do
82 Left emsg -> do
83 putStrLn emsg
83 putStrLn emsg
84 exitWith (ExitFailure 1)
84 exitWith (ExitFailure 1)
@@ -115,7 +115,7 @@ checkPkg copts warnonly quit fpath = do
115 res <- inPkgDir pkgdesc $ do
115 res <- inPkgDir pkgdesc $ do
116 make (makefile pkgdesc)
116 make (makefile pkgdesc)
117
117
118− case mergeOptions copts (NoREPL : Verbose : idris_opts pkgdesc) of
118+ case mergeOptions copts (NoREPL : Verbose 1 : idris_opts pkgdesc) of
119 Left emsg -> do
119 Left emsg -> do
120 putStrLn emsg
120 putStrLn emsg
121 exitWith (ExitFailure 1)
121 exitWith (ExitFailure 1)
@@ -145,6 +145,7 @@ replPkg copts fp = do
145 case mergeOptions copts (idris_opts pkgdesc) of
145 case mergeOptions copts (idris_opts pkgdesc) of
146 Left emsg -> ifail emsg
146 Left emsg -> ifail emsg
147 Right opts -> do
147 Right opts -> do
148+
148 putIState orig
149 putIState orig
149 dir <- runIO getCurrentDirectory
150 dir <- runIO getCurrentDirectory
150 runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc
151 runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc
@@ -194,7 +195,7 @@ documentPkg copts (install,fp) = do
194 cd <- getCurrentDirectory
195 cd <- getCurrentDirectory
195 let pkgDir = cd </> takeDirectory fp
196 let pkgDir = cd </> takeDirectory fp
196 outputDir = cd </> pkgname pkgdesc ++ "_doc"
197 outputDir = cd </> pkgname pkgdesc ++ "_doc"
197− popts = NoREPL : Verbose : idris_opts pkgdesc
198+ popts = NoREPL : Verbose 1 : idris_opts pkgdesc
198 mods = modules pkgdesc
199 mods = modules pkgdesc
199 fs = map (foldl1' (</>) . splitOn "." . showCG) mods
200 fs = map (foldl1' (</>) . splitOn "." . showCG) mods
200 setCurrentDirectory $ pkgDir </> sourcedir pkgdesc
201 setCurrentDirectory $ pkgDir </> sourcedir pkgdesc
@@ -237,42 +238,45 @@ documentPkg copts (install,fp) = do
237-- | Build a package with a sythesized main function that runs the tests
238-- | Build a package with a sythesized main function that runs the tests
238testPkg :: [Opt] -- ^ Command line options.
239testPkg :: [Opt] -- ^ Command line options.
239 -> FilePath -- ^ Path to ipkg file.
240 -> FilePath -- ^ Path to ipkg file.
240− -> IO ()
241+ -> IO ExitCode
241testPkg copts fp = do
242testPkg copts fp = do
242 pkgdesc <- parseDesc fp
243 pkgdesc <- parseDesc fp
243 ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)
244 ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)
244− when (and ok) $ do
245+ if and ok
245− m_ist <- inPkgDir pkgdesc $ do
246+ then do
246− make (makefile pkgdesc)
247+ (m_ist, exitCode) <- inPkgDir pkgdesc $ do
247− -- Get a temporary file to save the tests' source in
248+ make (makefile pkgdesc)
248− (tmpn, tmph) <- tempfile ".idr"
249+ -- Get a temporary file to save the tests' source in
249− hPutStrLn tmph $
250+ (tmpn, tmph) <- tempfile ".idr"
250− "module Test_______\n" ++
251+ hPutStrLn tmph $
251− concat ["import " ++ show m ++ "\n" | m <- modules pkgdesc]
252+ "module Test_______\n" ++
252− ++ "namespace Main\n"
253+ concat ["import " ++ show m ++ "\n" | m <- modules pkgdesc]
253− ++ " main : IO ()\n"
254+ ++ "namespace Main\n"
254− ++ " main = do "
255+ ++ " main : IO ()\n"
255− ++ concat [ show t ++ "\n "
256+ ++ " main = do "
256− | t <- idris_tests pkgdesc]
257+ ++ concat [ show t ++ "\n "
257− hClose tmph
258+ | t <- idris_tests pkgdesc]
258− (tmpn', tmph') <- tempfile ""
259+ hClose tmph
259− hClose tmph'
260+ (tmpn', tmph') <- tempfile ""
260− let popts = (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)
261+ hClose tmph'
261− case mergeOptions copts popts of
262+ let popts = (Filename tmpn : NoREPL : Verbose 1 : Output tmpn' : idris_opts pkgdesc)
262− Left emsg -> do
263+ case mergeOptions copts popts of
263− putStrLn emsg
264+ Left emsg -> do
264− exitWith (ExitFailure 1)
265+ putStrLn emsg
265− Right opts -> do
266+ exitWith (ExitFailure 1)
266− m_ist <- idris opts
267+ Right opts -> do
267− rawSystem tmpn' []
268+ m_ist <- idris opts
268− return m_ist
269+ let texe = if isWindows then addExtension tmpn' ".exe" else tmpn'
269− case m_ist of
270+ exitCode <- rawSystem texe []
270− Nothing -> exitWith (ExitFailure 1)
271+ return (m_ist, exitCode)
271− Just ist -> do
272+ case m_ist of
272− -- Quit with error code if problem building
273+ Nothing -> exitWith (ExitFailure 1)
273− case errSpan ist of
274+ Just ist -> do
274− Just _ -> exitWith (ExitFailure 1)
275+ -- Quit with error code if problem building
275− _ -> return ()
276+ case errSpan ist of
277+ Just _ -> exitWith (ExitFailure 1)
278+ _ -> return exitCode
279+ else return (ExitFailure 1)
276
280
277-- ----------------------------------------------------------- [ Installation ]
281-- ----------------------------------------------------------- [ Installation ]
278
282
@@ -438,6 +442,7 @@ mergeOptions copts popts =
438 chkOpt o@(IBCSubDir _) = Right o
442 chkOpt o@(IBCSubDir _) = Right o
439 chkOpt o@(ImportDir _ ) = Right o
443 chkOpt o@(ImportDir _ ) = Right o
440 chkOpt o@(UseCodegen _) = Right o
444 chkOpt o@(UseCodegen _) = Right o
445+ chkOpt o@(Verbose _) = Right o
441 chkOpt o = Left (unwords ["\t", show o, "\n"])
446 chkOpt o = Left (unwords ["\t", show o, "\n"])
442
447
443 genErrMsg :: [String] -> String
448 genErrMsg :: [String] -> String
src/Idris/Parser.hs+15−8
@@ -763,7 +763,7 @@ Params ::=
763params :: SyntaxInfo -> IdrisParser [PDecl]
763params :: SyntaxInfo -> IdrisParser [PDecl]
764params syn =
764params syn =
765 do reservedHL "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'
765 do reservedHL "parameters"; lchar '('; ns <- typeDeclList syn; lchar ')'
766− let ns' = [(n, ty) | (n, _, ty) <- ns]
766+ let ns' = [(n, ty) | (_, n, _, ty) <- ns]
767 openBlock
767 openBlock
768 let pvars = syn_params syn
768 let pvars = syn_params syn
769 ds <- many (decl syn { syn_params = pvars ++ ns' })
769 ds <- many (decl syn { syn_params = pvars ++ ns' })
@@ -903,7 +903,7 @@ interface_ syn = do (doc, argDocs, acc)
903 return (doc, argDocs, acc))
903 return (doc, argDocs, acc))
904 fc <- getFC
904 fc <- getFC
905 cons <- constraintList syn
905 cons <- constraintList syn
906− let cons' = [(c, ty) | (c, _, ty) <- cons]
906+ let cons' = [(c, ty) | (_, c, _, ty) <- cons]
907 (n_in, nfc) <- fnName
907 (n_in, nfc) <- fnName
908 let n = expandNS syn n_in
908 let n = expandNS syn n_in
909 cs <- many carg
909 cs <- many carg
@@ -953,11 +953,11 @@ implementation kwopt syn
953 fc <- getFC
953 fc <- getFC
954 en <- optional implementationName
954 en <- optional implementationName
955 cs <- constraintList syn
955 cs <- constraintList syn
956− let cs' = [(c, ty) | (c, _, ty) <- cs]
956+ let cs' = [(c, ty) | (_, c, _, ty) <- cs]
957 (cn, cnfc) <- fnName
957 (cn, cnfc) <- fnName
958 args <- many (simpleExpr syn)
958 args <- many (simpleExpr syn)
959 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)
959 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)
960− let t = bindList (PPi constraint) cs sc
960+ let t = bindList (\r -> PPi constraint { pcount = r }) cs sc
961 pnames <- implementationUsing
961 pnames <- implementationUsing
962 ds <- implementationBlock syn
962 ds <- implementationBlock syn
963 return [PImplementation doc argDocs syn fc cs' pnames acc opts cn cnfc args [] t en ds]
963 return [PImplementation doc argDocs syn fc cs' pnames acc opts cn cnfc args [] t en ds]
@@ -1429,6 +1429,11 @@ directive syn = do try (lchar '%' *> reserved "lib")
1429pLangExt :: IdrisParser LanguageExt
1429pLangExt :: IdrisParser LanguageExt
1430pLangExt = (reserved "TypeProviders" >> return TypeProviders)
1430pLangExt = (reserved "TypeProviders" >> return TypeProviders)
1431 <|> (reserved "ErrorReflection" >> return ErrorReflection)
1431 <|> (reserved "ErrorReflection" >> return ErrorReflection)
1432+ <|> (reserved "UniquenessTypes" >> return UniquenessTypes)
1433+ <|> (reserved "LinearTypes" >> return LinearTypes)
1434+ <|> (reserved "DSLNotation" >> return DSLNotation)
1435+ <|> (reserved "ElabReflection" >> return ElabReflection)
1436+ <|> (reserved "FirstClassReflection" >> return FCReflection)
1432
1437
1433{-| Parses a totality
1438{-| Parses a totality
1434
1439
@@ -1696,6 +1701,7 @@ loadSource' lidr r maxline
1696loadSource :: Bool -> FilePath -> Maybe Int -> Idris ()
1701loadSource :: Bool -> FilePath -> Maybe Int -> Idris ()
1697loadSource lidr f toline
1702loadSource lidr f toline
1698 = do logParser 1 ("Reading " ++ f)
1703 = do logParser 1 ("Reading " ++ f)
1704+ iReport 2 ("Reading " ++ f)
1699 i <- getIState
1705 i <- getIState
1700 let def_total = default_total i
1706 let def_total = default_total i
1701 file_in <- runIO $ readSource f
1707 file_in <- runIO $ readSource f
@@ -1783,8 +1789,7 @@ loadSource lidr f toline
1783 logLvl 10 (show (toAlist (idris_implicits i)))
1789 logLvl 10 (show (toAlist (idris_implicits i)))
1784 logLvl 3 (show (idris_infixes i))
1790 logLvl 3 (show (idris_infixes i))
1785 -- Now add all the declarations to the context
1791 -- Now add all the declarations to the context
1786− v <- verbose
1792+ iReport 1 $ "Type checking " ++ f
1787− when v $ iputStrLn $ "Type checking " ++ f
1788 -- we totality check after every Mutual block, so if
1793 -- we totality check after every Mutual block, so if
1789 -- anything is a single definition, wrap it in a
1794 -- anything is a single definition, wrap it in a
1790 -- mutual block on its own
1795 -- mutual block on its own
@@ -1799,7 +1804,8 @@ loadSource lidr f toline
1799 setContext ctxt')
1804 setContext ctxt')
1800 (map snd (idris_totcheck i))
1805 (map snd (idris_totcheck i))
1801 -- build size change graph from simplified definitions
1806 -- build size change graph from simplified definitions
1802− logLvl 1 "Totality checking"
1807+ iReport 3 $ "Totality checking " ++ f
1808+ logLvl 1 $ "Totality checking " ++ f
1803 i <- getIState
1809 i <- getIState
1804 mapM_ buildSCG (idris_totcheck i)
1810 mapM_ buildSCG (idris_totcheck i)
1805 mapM_ checkDeclTotality (idris_totcheck i)
1811 mapM_ checkDeclTotality (idris_totcheck i)
@@ -1822,7 +1828,8 @@ loadSource lidr f toline
1822
1828
1823 logLvl 1 ("Finished " ++ f)
1829 logLvl 1 ("Finished " ++ f)
1824 ibcsd <- valIBCSubDir i
1830 ibcsd <- valIBCSubDir i
1825− logLvl 1 "Universe checking"
1831+ logLvl 1 $ "Universe checking " ++ f
1832+ iReport 3 $ "Universe checking " ++ f
1826 iucheck
1833 iucheck
1827 let ibc = ibcPathNoFallback ibcsd f
1834 let ibc = ibcPathNoFallback ibcsd f
1828 i <- getIState
1835 i <- getIState
src/Idris/Parser/Expr.hs+31−27
@@ -261,8 +261,8 @@ updateSynMatch = update
261 updTactic ns (TDocStr (Left n)) = TDocStr . Left . fst $ updateB ns (n, NoFC)
261 updTactic ns (TDocStr (Left n)) = TDocStr . Left . fst $ updateB ns (n, NoFC)
262 updTactic ns t = fmap (update ns) t
262 updTactic ns t = fmap (update ns) t
263
263
264− updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)
264+ updTacImp ns (TacImp o st scr r) = TacImp o st (update ns scr) r
265− updTacImp _ x = x
265+ updTacImp _ x = x
266
266
267 dropn :: Name -> [(Name, a)] -> [(Name, a)]
267 dropn :: Name -> [(Name, a)] -> [(Name, a)]
268 dropn n [] = []
268 dropn n [] = []
@@ -914,7 +914,7 @@ TypeExpr ::= ConstraintList? Expr;
914typeExpr :: SyntaxInfo -> IdrisParser PTerm
914typeExpr :: SyntaxInfo -> IdrisParser PTerm
915typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []
915typeExpr syn = do cs <- if implicitAllowed syn then constraintList syn else return []
916 sc <- expr (allowConstr syn)
916 sc <- expr (allowConstr syn)
917− return (bindList (PPi constraint) cs sc)
917+ return (bindList (\r -> PPi (constraint { pcount = r })) cs sc)
918 <?> "type signature"
918 <?> "type signature"
919
919
920{- | Parses a lambda expression
920{- | Parses a lambda expression
@@ -941,7 +941,7 @@ lambda syn = do lchar '\\' <?> "lambda expression"
941 ((do xt <- try $ tyOptDeclList (disallowImp syn)
941 ((do xt <- try $ tyOptDeclList (disallowImp syn)
942 fc <- getFC
942 fc <- getFC
943 sc <- lambdaTail
943 sc <- lambdaTail
944− return (bindList (PLam fc) xt sc))
944+ return (bindList (\r -> PLam fc) xt sc))
945 <|>
945 <|>
946 (do ps <- sepBy (do fc <- getFC
946 (do ps <- sepBy (do fc <- getFC
947 e <- simpleExpr (disallowImp (syn { inPattern = True }))
947 e <- simpleExpr (disallowImp (syn { inPattern = True }))
@@ -1072,13 +1072,13 @@ Pi' ::=
1072
1072
1073bindsymbol opts st syn
1073bindsymbol opts st syn
1074 = do symbol "->"
1074 = do symbol "->"
1075− return (Exp opts st False)
1075+ return (Exp opts st False RigW)
1076
1076
1077explicitPi opts st syn
1077explicitPi opts st syn
1078 = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')
1078 = do xt <- try (lchar '(' *> typeDeclList syn <* lchar ')')
1079 binder <- bindsymbol opts st syn
1079 binder <- bindsymbol opts st syn
1080 sc <- expr (allowConstr syn)
1080 sc <- expr (allowConstr syn)
1081− return (bindList (PPi binder) xt sc)
1081+ return (bindList (\r -> PPi (binder { pcount = r })) xt sc)
1082
1082
1083autoImplicit opts st syn
1083autoImplicit opts st syn
1084 = do kw <- reservedFC "auto"
1084 = do kw <- reservedFC "auto"
@@ -1088,8 +1088,8 @@ autoImplicit opts st syn
1088 symbol "->"
1088 symbol "->"
1089 sc <- expr (allowConstr syn)
1089 sc <- expr (allowConstr syn)
1090 highlightP kw AnnKeyword
1090 highlightP kw AnnKeyword
1091− return (bindList (PPi
1091+ return (bindList (\r -> PPi
1092− (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)
1092+ (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]) r)) xt sc)
1093
1093
1094defaultImplicit opts st syn = do
1094defaultImplicit opts st syn = do
1095 kw <- reservedFC "default"
1095 kw <- reservedFC "default"
@@ -1102,7 +1102,7 @@ defaultImplicit opts st syn = do
1102 symbol "->"
1102 symbol "->"
1103 sc <- expr (allowConstr syn)
1103 sc <- expr (allowConstr syn)
1104 highlightP kw AnnKeyword
1104 highlightP kw AnnKeyword
1105− return (bindList (PPi (TacImp [] Dynamic script)) xt sc)
1105+ return (bindList (\r -> PPi (TacImp [] Dynamic script r)) xt sc)
1106
1106
1107normalImplicit opts st syn = do
1107normalImplicit opts st syn = do
1108 xt <- typeDeclList syn <* lchar '}'
1108 xt <- typeDeclList syn <* lchar '}'
@@ -1111,19 +1111,19 @@ normalImplicit opts st syn = do
1111 sc <- expr syn
1111 sc <- expr syn
1112 let (im,cl)
1112 let (im,cl)
1113 = if implicitAllowed syn
1113 = if implicitAllowed syn
1114− then (Imp opts st False (Just (Impl False True False)) True,
1114+ then (Imp opts st False (Just (Impl False True False)) True RigW,
1115 constraint)
1115 constraint)
1116− else (Imp opts st False (Just (Impl False False False)) True,
1116+ else (Imp opts st False (Just (Impl False False False)) True RigW,
1117− Imp opts st False (Just (Impl True False False)) True)
1117+ Imp opts st False (Just (Impl True False False)) True RigW)
1118− return (bindList (PPi im) xt
1118+ return (bindList (\r -> PPi (im { pcount = r })) xt
1119− (bindList (PPi cl) cs sc))
1119+ (bindList (\r -> PPi (cl { pcount = r })) cs sc))
1120
1120
1121constraintPi opts st syn =
1121constraintPi opts st syn =
1122 do cs <- constraintList1 syn
1122 do cs <- constraintList1 syn
1123 sc <- expr syn
1123 sc <- expr syn
1124 if implicitAllowed syn
1124 if implicitAllowed syn
1125− then return (bindList (PPi constraint) cs sc)
1125+ then return (bindList (\r -> PPi constraint { pcount = r }) cs sc)
1126− else return (bindList (PPi (Imp opts st False (Just (Impl True False False)) True))
1126+ else return (bindList (\r -> PPi (Imp opts st False (Just (Impl True False False)) True r))
1127 cs sc)
1127 cs sc)
1128
1128
1129implicitPi opts st syn =
1129implicitPi opts st syn =
@@ -1181,11 +1181,11 @@ ConstraintList ::=
1181 ;
1181 ;
1182@
1182@
1183-}
1183-}
1184−constraintList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
1184+constraintList :: SyntaxInfo -> IdrisParser [(RigCount, Name, FC, PTerm)]
1185constraintList syn = try (constraintList1 syn)
1185constraintList syn = try (constraintList1 syn)
1186 <|> return []
1186 <|> return []
1187
1187
1188−constraintList1 :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
1188+constraintList1 :: SyntaxInfo -> IdrisParser [(RigCount, Name, FC, PTerm)]
1189constraintList1 syn = try (do lchar '('
1189constraintList1 syn = try (do lchar '('
1190 tys <- sepBy1 nexpr (lchar ',')
1190 tys <- sepBy1 nexpr (lchar ',')
1191 lchar ')'
1191 lchar ')'
@@ -1193,13 +1193,13 @@ constraintList1 syn = try (do lchar '('
1193 return tys)
1193 return tys)
1194 <|> try (do t <- opExpr (disallowImp syn)
1194 <|> try (do t <- opExpr (disallowImp syn)
1195 reservedOp "=>"
1195 reservedOp "=>"
1196− return [(defname, NoFC, t)])
1196+ return [(RigW, defname, NoFC, t)])
1197 <?> "type constraint list"
1197 <?> "type constraint list"
1198 where nexpr = try (do (n, fc) <- name; lchar ':'
1198 where nexpr = try (do (n, fc) <- name; lchar ':'
1199 e <- expr (disallowImp syn)
1199 e <- expr (disallowImp syn)
1200− return (n, fc, e))
1200+ return (RigW, n, fc, e))
1201 <|> do e <- expr (disallowImp syn)
1201 <|> do e <- expr (disallowImp syn)
1202− return (defname, NoFC, e)
1202+ return (RigW, defname, NoFC, e)
1203 defname = sMN 0 "constraint"
1203 defname = sMN 0 "constraint"
1204
1204
1205{- | Parses a type declaration list
1205{- | Parses a type declaration list
@@ -1217,17 +1217,21 @@ FunctionSignatureList ::=
1217 ;
1217 ;
1218@
1218@
1219-}
1219-}
1220−typeDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
1220+typeDeclList :: SyntaxInfo -> IdrisParser [(RigCount, Name, FC, PTerm)]
1221−typeDeclList syn = try (sepBy1 (do (x, xfc) <- fnName
1221+typeDeclList syn = try (sepBy1 (do rig <- option RigW rigCount
1222+ (x, xfc) <- fnName
1222 lchar ':'
1223 lchar ':'
1223 t <- typeExpr (disallowImp syn)
1224 t <- typeExpr (disallowImp syn)
1224− return (x, xfc, t))
1225+ return (rig, x, xfc, t))
1225 (lchar ','))
1226 (lchar ','))
1226 <|> do ns <- sepBy1 name (lchar ',')
1227 <|> do ns <- sepBy1 name (lchar ',')
1227 lchar ':'
1228 lchar ':'
1228 t <- typeExpr (disallowImp syn)
1229 t <- typeExpr (disallowImp syn)
1229− return (map (\(x, xfc) -> (x, xfc, t)) ns)
1230+ return (map (\(x, xfc) -> (RigW, x, xfc, t)) ns)
1230 <?> "type declaration list"
1231 <?> "type declaration list"
1232+ where
1233+ rigCount = do lchar '1'; return Rig1
1234+ <|> do lchar '0'; return Rig0
1231
1235
1232{- | Parses a type declaration list with optional parameters
1236{- | Parses a type declaration list with optional parameters
1233@
1237@
@@ -1241,11 +1245,11 @@ TypeOptDeclList ::=
1241NameOrPlaceHolder ::= Name | '_';
1245NameOrPlaceHolder ::= Name | '_';
1242@
1246@
1243-}
1247-}
1244−tyOptDeclList :: SyntaxInfo -> IdrisParser [(Name, FC, PTerm)]
1248+tyOptDeclList :: SyntaxInfo -> IdrisParser [(RigCount, Name, FC, PTerm)]
1245tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder
1249tyOptDeclList syn = sepBy1 (do (x, fc) <- nameOrPlaceholder
1246 t <- option Placeholder (do lchar ':'
1250 t <- option Placeholder (do lchar ':'
1247 expr syn)
1251 expr syn)
1248− return (x, fc, t))
1252+ return (RigW, x, fc, t))
1249 (lchar ',')
1253 (lchar ',')
1250 <?> "type declaration list"
1254 <?> "type declaration list"
1251 where nameOrPlaceholder :: IdrisParser (Name, FC)
1255 where nameOrPlaceholder :: IdrisParser (Name, FC)
src/Idris/Parser/Helpers.hs+3−3
@@ -455,9 +455,9 @@ getFC = do s <- position
455
455
456{-* Syntax helpers-}
456{-* Syntax helpers-}
457-- | Bind constraints to term
457-- | Bind constraints to term
458−bindList :: (Name -> FC -> PTerm -> PTerm -> PTerm) -> [(Name, FC, PTerm)] -> PTerm -> PTerm
458+bindList :: (RigCount -> Name -> FC -> PTerm -> PTerm -> PTerm) -> [(RigCount, Name, FC, PTerm)] -> PTerm -> PTerm
459−bindList b [] sc = sc
459+bindList b [] sc = sc
460−bindList b ((n, fc, t):bs) sc = b n fc t (bindList b bs sc)
460+bindList b ((r, n, fc, t):bs) sc = b r n fc t (bindList b bs sc)
461
461
462{- | @commaSeparated p@ parses one or more occurences of `p`,
462{- | @commaSeparated p@ parses one or more occurences of `p`,
463 separated by commas and optional whitespace. -}
463 separated by commas and optional whitespace. -}
src/Idris/PartialEval.hs+14−14
@@ -97,37 +97,37 @@ specType args ty = let (t, args') = runState (unifyEq args ty) [] in
97 where
97 where
98 -- Specialise static argument in type by let-binding provided value instead
98 -- Specialise static argument in type by let-binding provided value instead
99 -- of expecting it as a function argument
99 -- of expecting it as a function argument
100− st ((ExplicitS, v) : xs) (Bind n (Pi _ t _) sc)
100+ st ((ExplicitS, v) : xs) (Bind n (Pi _ _ t _) sc)
101 = Bind n (Let t v) (st xs sc)
101 = Bind n (Let t v) (st xs sc)
102− st ((ImplicitS _, v) : xs) (Bind n (Pi _ t _) sc)
102+ st ((ImplicitS _, v) : xs) (Bind n (Pi _ _ t _) sc)
103 = Bind n (Let t v) (st xs sc)
103 = Bind n (Let t v) (st xs sc)
104− st ((ConstraintS, v) : xs) (Bind n (Pi _ t _) sc)
104+ st ((ConstraintS, v) : xs) (Bind n (Pi _ _ t _) sc)
105 = Bind n (Let t v) (st xs sc)
105 = Bind n (Let t v) (st xs sc)
106 -- Erase argument from function type
106 -- Erase argument from function type
107− st ((UnifiedD, _) : xs) (Bind n (Pi _ t _) sc)
107+ st ((UnifiedD, _) : xs) (Bind n (Pi _ _ t _) sc)
108 = st xs sc
108 = st xs sc
109 -- Keep types as is
109 -- Keep types as is
110− st (_ : xs) (Bind n (Pi i t k) sc)
110+ st (_ : xs) (Bind n (Pi rig i t k) sc)
111− = Bind n (Pi i t k) (st xs sc)
111+ = Bind n (Pi rig i t k) (st xs sc)
112 st _ t = t
112 st _ t = t
113
113
114 -- Erase implicit dynamic argument if existing argument shares it value,
114 -- Erase implicit dynamic argument if existing argument shares it value,
115 -- by substituting the value of previous argument
115 -- by substituting the value of previous argument
116− unifyEq (imp@(ImplicitD _, v) : xs) (Bind n (Pi i t k) sc)
116+ unifyEq (imp@(ImplicitD _, v) : xs) (Bind n (Pi rig i t k) sc)
117 = do amap <- get
117 = do amap <- get
118 case lookup imp amap of
118 case lookup imp amap of
119 Just n' ->
119 Just n' ->
120 do put (amap ++ [((UnifiedD, Erased), n)])
120 do put (amap ++ [((UnifiedD, Erased), n)])
121 sc' <- unifyEq xs (subst n (P Bound n' Erased) sc)
121 sc' <- unifyEq xs (subst n (P Bound n' Erased) sc)
122− return (Bind n (Pi i t k) sc') -- erase later
122+ return (Bind n (Pi rig i t k) sc') -- erase later
123 _ -> do put (amap ++ [(imp, n)])
123 _ -> do put (amap ++ [(imp, n)])
124 sc' <- unifyEq xs sc
124 sc' <- unifyEq xs sc
125− return (Bind n (Pi i t k) sc')
125+ return (Bind n (Pi rig i t k) sc')
126− unifyEq (x : xs) (Bind n (Pi i t k) sc)
126+ unifyEq (x : xs) (Bind n (Pi rig i t k) sc)
127 = do args <- get
127 = do args <- get
128 put (args ++ [(x, n)])
128 put (args ++ [(x, n)])
129 sc' <- unifyEq xs sc
129 sc' <- unifyEq xs sc
130− return (Bind n (Pi i t k) sc')
130+ return (Bind n (Pi rig i t k) sc')
131 unifyEq xs t = do args <- get
131 unifyEq xs t = do args <- get
132 put (args ++ (zip xs (repeat (sUN "_"))))
132 put (args ++ (zip xs (repeat (sUN "_"))))
133 return t
133 return t
@@ -141,13 +141,13 @@ specType args ty = let (t, args') = runState (unifyEq args ty) [] in
141mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm
141mkPE_TyDecl :: IState -> [(PEArgType, Term)] -> Type -> PTerm
142mkPE_TyDecl ist args ty = mkty args ty
142mkPE_TyDecl ist args ty = mkty args ty
143 where
143 where
144− mkty ((ExplicitD, v) : xs) (Bind n (Pi _ t k) sc)
144+ mkty ((ExplicitD, v) : xs) (Bind n (Pi rig _ t k) sc)
145 = PPi expl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
145 = PPi expl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
146− mkty ((ConstraintD, v) : xs) (Bind n (Pi _ t k) sc)
146+ mkty ((ConstraintD, v) : xs) (Bind n (Pi rig _ t k) sc)
147 | concreteInterface ist t = mkty xs sc
147 | concreteInterface ist t = mkty xs sc
148 | interfaceConstraint ist t
148 | interfaceConstraint ist t
149 = PPi constraint n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
149 = PPi constraint n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
150− mkty ((ImplicitD _, v) : xs) (Bind n (Pi _ t k) sc)
150+ mkty ((ImplicitD _, v) : xs) (Bind n (Pi rig _ t k) sc)
151 = PPi impl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
151 = PPi impl n NoFC (delab ist (generaliseIn t)) (mkty xs sc)
152
152
153 mkty (_ : xs) t
153 mkty (_ : xs) t
src/Idris/Primitives.hs+5−5
@@ -32,7 +32,7 @@ data Prim = Prim { p_name :: Name,
32
32
33ty :: [Const] -> Const -> Type
33ty :: [Const] -> Const -> Type
34ty [] x = Constant x
34ty [] x = Constant x
35−ty (t:ts) x = Bind (sMN 0 "T") (Pi Nothing (Constant t) (TType (UVar [] (-3)))) (ty ts x)
35+ty (t:ts) x = Bind (sMN 0 "T") (Pi RigW Nothing (Constant t) (TType (UVar [] (-3)))) (ty ts x)
36
36
37total, partial, iopartial :: Totality
37total, partial, iopartial :: Totality
38total = Total []
38total = Total []
@@ -455,8 +455,8 @@ getInt _ = []
455
455
456strToInt :: IntTy -> [Const] -> Maybe Const
456strToInt :: IntTy -> [Const] -> Maybe Const
457strToInt ity [Str x] = case reads x of
457strToInt ity [Str x] = case reads x of
458− [(n,"")] -> Just $ toInt ity (n :: Integer)
458+ [(n,s)] -> Just $ if all isSpace s then toInt ity (n :: Integer) else I 0
459− _ -> Just $ I 0
459+ _ -> Just $ I 0
460strToInt _ _ = Nothing
460strToInt _ _ = Nothing
461
461
462intToFloat :: [Const] -> Maybe Const
462intToFloat :: [Const] -> Maybe Const
@@ -481,8 +481,8 @@ c_floatToStr :: [Const] -> Maybe Const
481c_floatToStr [Fl x] = Just $ Str (show x)
481c_floatToStr [Fl x] = Just $ Str (show x)
482c_floatToStr _ = Nothing
482c_floatToStr _ = Nothing
483c_strToFloat [Str x] = case reads x of
483c_strToFloat [Str x] = case reads x of
484− [(n,"")] -> Just $ Fl n
484+ [(n,s)] -> Just $ Fl (if all isSpace s then n else 0)
485− _ -> Just $ Fl 0
485+ _ -> Just $ Fl 0
486c_strToFloat _ = Nothing
486c_strToFloat _ = Nothing
487
487
488p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
488p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
src/Idris/ProofSearch.hs+8−8
@@ -49,7 +49,7 @@ trivialHoles psnames ok elab ist
49 return ()) True
49 return ()) True
50 where
50 where
51 tryAll [] = fail "No trivial solution"
51 tryAll [] = fail "No trivial solution"
52− tryAll ((x, b):xs)
52+ tryAll ((x, _, b):xs)
53 = do -- if type of x has any holes in it, move on
53 = do -- if type of x has any holes in it, move on
54 hs <- get_holes
54 hs <- get_holes
55 let badhs = hs -- filter (flip notElem holesOK) hs
55 let badhs = hs -- filter (flip notElem holesOK) hs
@@ -85,7 +85,7 @@ trivialTCs ok elab ist
85 return ()) True
85 return ()) True
86 where
86 where
87 tryAll [] = fail "No trivial solution"
87 tryAll [] = fail "No trivial solution"
88− tryAll ((x, b):xs)
88+ tryAll ((x, _, b):xs)
89 = do -- if type of x has any holes in it, move on
89 = do -- if type of x has any holes in it, move on
90 hs <- get_holes
90 hs <- get_holes
91 let badhs = hs -- filter (flip notElem holesOK) hs
91 let badhs = hs -- filter (flip notElem holesOK) hs
@@ -123,7 +123,7 @@ cantSolveGoal :: ElabD a
123cantSolveGoal = do g <- goal
123cantSolveGoal = do g <- goal
124 env <- get_env
124 env <- get_env
125 lift $ tfail $
125 lift $ tfail $
126− CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)
126+ CantSolveGoal g (map (\(n,_,b) -> (n, binderTy b)) env)
127
127
128proofSearch :: Bool -- ^ recursive search (False for 'refine')
128proofSearch :: Bool -- ^ recursive search (False for 'refine')
129 -> Bool -- ^ invoked from a tactic proof. If so, making new metavariables is meaningless, and there should be an error reported instead.
129 -> Bool -- ^ invoked from a tactic proof. If so, making new metavariables is meaningless, and there should be an error reported instead.
@@ -300,7 +300,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi
300 tryLocals d locs tys env
300 tryLocals d locs tys env
301
301
302 tryLocals d locs tys [] = fail "Locals failed"
302 tryLocals d locs tys [] = fail "Locals failed"
303− tryLocals d locs tys ((x, t) : xs)
303+ tryLocals d locs tys ((x, _, t) : xs)
304 | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs
304 | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs
305 | otherwise = try' (tryLocal d (x : locs) tys x t)
305 | otherwise = try' (tryLocal d (x : locs) tys x t)
306 (tryLocals d locs tys xs) True
306 (tryLocals d locs tys xs) True
@@ -346,7 +346,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi
346 TermPart ty,
346 TermPart ty,
347 TextPart "using proof search, but proof search only works on datatypes with constructors."] ++
347 TextPart "using proof search, but proof search only works on datatypes with constructors."] ++
348 case ty of
348 case ty of
349− (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]
349+ (Bind _ (Pi _ _ _ _) _) -> [TextPart "In particular, function types are not supported."]
350 _ -> []
350 _ -> []
351
351
352-- | Resolve interfaces. This will only pick up 'normal'
352-- | Resolve interfaces. This will only pick up 'normal'
@@ -475,9 +475,9 @@ resTC' tcs defaultOn openOK topholes depth topg fn elab ist
475
475
476 introImps = do g <- goal
476 introImps = do g <- goal
477 case g of
477 case g of
478− (Bind _ (Pi _ _ _) sc) -> do attack; intro Nothing
478+ (Bind _ (Pi _ _ _ _) sc) -> do attack; intro Nothing
479− num <- introImps
479+ num <- introImps
480− return (num + 1)
480+ return (num + 1)
481 _ -> return 0
481 _ -> return 0
482
482
483 solven n = replicateM_ n solve
483 solven n = replicateM_ n solve
src/Idris/Prover.hs+12−12
@@ -82,8 +82,8 @@ assumptionNames e
82 = case envAtFocus (proof e) of
82 = case envAtFocus (proof e) of
83 OK env -> names env
83 OK env -> names env
84 where names [] = []
84 where names [] = []
85− names ((MN _ _, _) : bs) = names bs
85+ names ((MN _ _, _, _) : bs) = names bs
86− names ((n, _) : bs) = show n : names bs
86+ names ((n, _, _) : bs) = show n : names bs
87
87
88prove :: Bool -> ElabInfo -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()
88prove :: Bool -> ElabInfo -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()
89prove mode info opt ctxt lit n ty
89prove mode info opt ctxt lit n ty
@@ -174,18 +174,18 @@ dumpState ist inElab menv ps | (h : hs) <- holes ps = do
174 delab ist t
174 delab ist t
175
175
176 assumptionNames :: Env -> [Name]
176 assumptionNames :: Env -> [Name]
177− assumptionNames = map fst
177+ assumptionNames = map fstEnv
178
178
179 prettyPs :: Bool -> Binder Type -> [(Name, Bool)] -> Env -> Doc OutputAnnotation
179 prettyPs :: Bool -> Binder Type -> [(Name, Bool)] -> Env -> Doc OutputAnnotation
180 prettyPs all g bnd [] = empty
180 prettyPs all g bnd [] = empty
181− prettyPs all g bnd ((n@(MN _ r), _) : bs)
181+ prettyPs all g bnd ((n@(MN _ r), _, _) : bs)
182 | not all && r == txt "rewrite_rule" = prettyPs all g ((n, False):bnd) bs
182 | not all && r == txt "rewrite_rule" = prettyPs all g ((n, False):bnd) bs
183− prettyPs all g bnd ((n@(MN _ _), _) : bs)
183+ prettyPs all g bnd ((n@(MN _ _), _, _) : bs)
184 | not (all || n `elem` freeEnvNames bs || n `elem` goalNames g) = prettyPs all g bnd bs
184 | not (all || n `elem` freeEnvNames bs || n `elem` goalNames g) = prettyPs all g bnd bs
185− prettyPs all g bnd ((n, Let t v) : bs) =
185+ prettyPs all g bnd ((n, _, Let t v) : bs) =
186 line <> bindingOf n False <+> text "=" <+> tPretty bnd v <+> colon <+>
186 line <> bindingOf n False <+> text "=" <+> tPretty bnd v <+> colon <+>
187 align (tPretty bnd t) <> prettyPs all g ((n, False):bnd) bs
187 align (tPretty bnd t) <> prettyPs all g ((n, False):bnd) bs
188− prettyPs all g bnd ((n, b) : bs) =
188+ prettyPs all g bnd ((n, _, b) : bs) =
189 line <> bindingOf n False <+> colon <+>
189 line <> bindingOf n False <+> colon <+>
190 align (tPretty bnd (binderTy b)) <> prettyPs all g ((n, False):bnd) bs
190 align (tPretty bnd (binderTy b)) <> prettyPs all g ((n, False):bnd) bs
191
191
@@ -227,7 +227,7 @@ dumpState ist inElab menv ps | (h : hs) <- holes ps = do
227 nest nestingSize (align . cat . punctuate (text ",") . map (`bindingOf` False) $ hs)
227 nest nestingSize (align . cat . punctuate (text ",") . map (`bindingOf` False) $ hs)
228
228
229 freeEnvNames :: Env -> [Name]
229 freeEnvNames :: Env -> [Name]
230− freeEnvNames = concatMap (\(n, b) -> freeNames (Bind n b Erased))
230+ freeEnvNames = concatMap (\(n, _, b) -> freeNames (Bind n b Erased))
231
231
232lifte :: ElabState EState -> ElabD a -> Idris a
232lifte :: ElabState EState -> ElabD a -> Idris a
233lifte st e = do (v, _) <- elabStep st e
233lifte st e = do (v, _) <- elabStep st e
@@ -468,7 +468,7 @@ ploop fn d prompt prf e h
468 (ploop fn d prompt prf e h')
468 (ploop fn d prompt prf e h')
469
469
470
470
471−envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env
471+envCtxt env ctxt = foldl (\c (n, _, b) -> addTyDecl n Bound (binderTy b) c) ctxt env
472
472
473checkNameType :: ElabState EState -> [String] -> Name -> Idris (Bool, ElabState EState, Bool, [String], Either Err (Idris ()))
473checkNameType :: ElabState EState -> [String] -> Name -> Idris (Bool, ElabState EState, Bool, [String], Either Err (Idris ()))
474checkNameType e prf n = do
474checkNameType e prf n = do
@@ -478,7 +478,7 @@ checkNameType e prf n = do
478 idrisCatch (do
478 idrisCatch (do
479 let OK env = envAtFocus (proof e)
479 let OK env = envAtFocus (proof e)
480 ctxt' = envCtxt env ctxt
480 ctxt' = envCtxt env ctxt
481− bnd = map (\x -> (fst x, False)) env
481+ bnd = map (\x -> (fstEnv x, False)) env
482 ist' = ist { tt_ctxt = ctxt' }
482 ist' = ist { tt_ctxt = ctxt' }
483 putIState ist'
483 putIState ist'
484 -- Unlike the REPL, metavars have no special treatment, to
484 -- Unlike the REPL, metavars have no special treatment, to
@@ -505,7 +505,7 @@ checkType e prf t = do
505 action = case tm of
505 action = case tm of
506 TType _ ->
506 TType _ ->
507 iPrintTermWithType (prettyImp ppo (PType emptyFC)) type1Doc
507 iPrintTermWithType (prettyImp ppo (PType emptyFC)) type1Doc
508− _ -> let bnd = map (\x -> (fst x, False)) env in
508+ _ -> let bnd = map (\x -> (fstEnv x, False)) env in
509 iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))
509 iPrintTermWithType (pprintPTerm ppo bnd [] infixes (delab ist tm))
510 (pprintPTerm ppo bnd [] infixes (delab ist ty))
510 (pprintPTerm ppo bnd [] infixes (delab ist ty))
511 putIState ist
511 putIState ist
@@ -522,7 +522,7 @@ evalTerm e prf t = withErrorReflection $
522 let OK env = envAtFocus (proof e)
522 let OK env = envAtFocus (proof e)
523 ctxt' = envCtxt env ctxt
523 ctxt' = envCtxt env ctxt
524 ist' = ist { tt_ctxt = ctxt' }
524 ist' = ist { tt_ctxt = ctxt' }
525− bnd = map (\x -> (fst x, False)) env
525+ bnd = map (\x -> (fstEnv x, False)) env
526 putIState ist'
526 putIState ist'
527 (tm, ty) <- elabVal (recinfo proverfc) ERHS t
527 (tm, ty) <- elabVal (recinfo proverfc) ERHS t
528 let tm' = force (normaliseAll ctxt' env tm)
528 let tm' = force (normaliseAll ctxt' env tm)
src/Idris/REPL.hs+25−15
@@ -194,7 +194,7 @@ processNetCmd orig i h fn cmd
194 setErrContext True
194 setErrContext True
195 setOutH h
195 setOutH h
196 setQuiet True
196 setQuiet True
197− setVerbose False
197+ setVerbose 0
198 mods <- loadInputs [f] toline
198 mods <- loadInputs [f] toline
199 ist <- getIState
199 ist <- getIState
200 return (ist, f)
200 return (ist, f)
@@ -396,10 +396,15 @@ runIdeModeCommand h id orig fn mods (IdeMode.SetOpt IdeMode.ErrContext b) =
396 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id
396 runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id
397runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) =
397runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) =
398 do ist <- getIState
398 do ist <- getIState
399− let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs
399+ let mvs = reverse $ [ (n, i)
400+ | (n, (_, i, _, _, _)) <- idris_metavars ist
401+ , not (n `elem` primDefs)
402+ ]
400 let ppo = ppOptionIst ist
403 let ppo = ppOptionIst ist
401 -- splitMvs is a list of pairs of names and their split types
404 -- splitMvs is a list of pairs of names and their split types
402− let splitMvs = mapSnd (splitPi ist) (mvTys ist mvs)
405+ let splitMvs = [ (n, (premises, concl, tm))
406+ | (n, i, ty) <- mvTys ist mvs
407+ , let (premises, concl, tm) = splitPi ist i ty]
403 -- mvOutput is the pretty-printed version ready for conversion to SExpr
408 -- mvOutput is the pretty-printed version ready for conversion to SExpr
404 let mvOutput = map (\(n, (hs, c)) -> (n, hs, c)) $
409 let mvOutput = map (\(n, (hs, c)) -> (n, hs, c)) $
405 mapPair show
410 mapPair show
@@ -413,20 +418,24 @@ runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) =
413 runIO . hPutStrLn h $
418 runIO . hPutStrLn h $
414 IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", mvOutput) id
419 IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", mvOutput) id
415 where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs)
420 where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs)
416− mapSnd f xs = zip (map fst xs) (map (f . snd) xs)
421+ firstOfThree (x, y, z) = x
422+ mapThird f xs = map (\(x, y, z) -> (x, y, f z)) xs
417
423
418 -- | Split a function type into a pair of premises, conclusion.
424 -- | Split a function type into a pair of premises, conclusion.
419 -- Each maintains both the original and delaborated versions.
425 -- Each maintains both the original and delaborated versions.
420− splitPi :: IState -> Type -> ([(Name, Type, PTerm)], Type, PTerm)
426+ splitPi :: IState -> Int -> Type -> ([(Name, Type, PTerm)], Type, PTerm)
421− splitPi ist (Bind n (Pi _ t _) rest) =
427+ splitPi ist i (Bind n (Pi _ _ t _) rest) | i > 0 =
422− let (hs, c, pc) = splitPi ist rest in
428+ let (hs, c, pc) = splitPi ist (i - 1) rest in
423 ((n, t, delabTy' ist [] t False False True):hs,
429 ((n, t, delabTy' ist [] t False False True):hs,
424 c, delabTy' ist [] c False False True)
430 c, delabTy' ist [] c False False True)
425− splitPi ist tm = ([], tm, delabTy' ist [] tm False False True)
431+ splitPi ist i tm = ([], tm, delabTy' ist [] tm False False True)
426
432
427 -- | Get the types of a list of metavariable names
433 -- | Get the types of a list of metavariable names
428− mvTys :: IState -> [Name] -> [(Name, Type)]
434+ mvTys :: IState -> [(Name, Int)] -> [(Name, Int, Type)]
429− mvTys ist = mapSnd vToP . mapMaybe (flip lookupTyNameExact (tt_ctxt ist))
435+ mvTys ist mvs = [ (n, i, ty)
436+ | (n, i) <- mvs
437+ , ty <- maybeToList (fmap (vToP . snd) (lookupTyNameExact n (tt_ctxt ist)))
438+ ]
430
439
431 -- | Show a type and its corresponding PTerm in a format suitable
440 -- | Show a type and its corresponding PTerm in a format suitable
432 -- for the IDE - that is, pretty-printed and annotated.
441 -- for the IDE - that is, pretty-printed and annotated.
@@ -1215,8 +1224,10 @@ process fn (WHNF t)
1215 = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t
1224 = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t
1216 ctxt <- getContext
1225 ctxt <- getContext
1217 ist <- getIState
1226 ist <- getIState
1218− let tm' = whnf ctxt tm
1227+ let tm' = whnf ctxt [] tm
1219− iPrintResult (show (delab ist tm'))
1228+ let tmArgs' = whnfArgs ctxt [] tm
1229+ iPrintResult $ "WHNF: " ++ (show (delab ist tm'))
1230+ iPrintResult $ "WHNF args: " ++ (show (delab ist tmArgs'))
1220process fn (TestInline t)
1231process fn (TestInline t)
1221 = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t
1232 = do (tm, ty) <- elabVal (recinfo (fileFC "toplevel")) ERHS t
1222 ctxt <- getContext
1233 ctxt <- getContext
@@ -1271,7 +1282,7 @@ process fn (Missing n)
1271 case lookupCtxt n (idris_patdefs i) of
1282 case lookupCtxt n (idris_patdefs i) of
1272 [] -> iPrintError $ "Unknown name " ++ show n
1283 [] -> iPrintError $ "Unknown name " ++ show n
1273 [(_, tms)] ->
1284 [(_, tms)] ->
1274− iRenderResult (vsep (map (pprintPTerm ppOpts {ppopt_impl = True}
1285+ iRenderResult (vsep (map (pprintPTerm ppOpts
1275 []
1286 []
1276 []
1287 []
1277 (idris_infixes i))
1288 (idris_infixes i))
@@ -1515,7 +1526,7 @@ pprintDef asCore n =
1515 ppMissing _ = empty
1526 ppMissing _ = empty
1516
1527
1517 ppTy :: Bool -> IState -> (Name, TypeInfo) -> Doc OutputAnnotation
1528 ppTy :: Bool -> IState -> (Name, TypeInfo) -> Doc OutputAnnotation
1518− ppTy amb ist (n, TI constructors isCodata _ _ _)
1529+ ppTy amb ist (n, TI constructors isCodata _ _ _ _)
1519 = kwd key <+> prettyName True amb [] n <+> colon <+>
1530 = kwd key <+> prettyName True amb [] n <+> colon <+>
1520 align (pprintDelabTy ist n) <+> kwd "where" <$>
1531 align (pprintDelabTy ist n) <+> kwd "where" <$>
1521 indent 2 (vsep (map (ppCon False ist) constructors))
1532 indent 2 (vsep (map (ppCon False ist) constructors))
@@ -1536,4 +1547,3 @@ replSettings :: Maybe FilePath -> Settings Idris
1536replSettings hFile = setComplete replCompletion $ defaultSettings {
1547replSettings hFile = setComplete replCompletion $ defaultSettings {
1537 historyFile = hFile
1548 historyFile = hFile
1538 }
1549 }
1539−
src/Idris/REPL/Commands.hs+1
@@ -32,6 +32,7 @@ data Command = Quit
32 | Universes
32 | Universes
33 | LogLvl Int
33 | LogLvl Int
34 | LogCategory [LogCat]
34 | LogCategory [LogCat]
35+ | Verbosity Int
35 | Spec PTerm
36 | Spec PTerm
36 | WHNF PTerm
37 | WHNF PTerm
37 | TestInline PTerm
38 | TestInline PTerm
src/Idris/REPL/Parser.hs+8−1
@@ -118,6 +118,7 @@ parserCommandsForHelp =
118 , (["pp", "pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg))
118 , (["pp", "pprint"], (SeqArgs OptionArg (SeqArgs NumberArg NameArg))
119 , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."
119 , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."
120 , cmd_pprint)
120 , cmd_pprint)
121+ , (["verbosity"], NumberArg, "Set verbosity level", cmd_verb)
121 ]
122 ]
122 where optionsList = intercalate ", " $ map fst setOptions
123 where optionsList = intercalate ", " $ map fst setOptions
123
124
@@ -146,7 +147,7 @@ parserCommands =
146 , proofArgCmd ["mc", "makecase"] MakeCase
147 , proofArgCmd ["mc", "makecase"] MakeCase
147 ":mc <line> <name> adds a case block for the definition of the metavariable on the line"
148 ":mc <line> <name> adds a case block for the definition of the metavariable on the line"
148 , proofArgCmd ["ml", "makelemma"] MakeLemma "?"
149 , proofArgCmd ["ml", "makelemma"] MakeLemma "?"
149− , (["log"], NumberArg, "Set logging verbosity level", cmd_log)
150+ , (["log"], NumberArg, "Set logging level", cmd_log)
150 , ( ["logcats"]
151 , ( ["logcats"]
151 , ManyArgs NameArg
152 , ManyArgs NameArg
152 , "Set logging categories"
153 , "Set logging categories"
@@ -405,6 +406,12 @@ cmd_log name = do
405 eof
406 eof
406 return (Right (LogLvl i))
407 return (Right (LogLvl i))
407
408
409+cmd_verb :: String -> P.IdrisParser (Either String Command)
410+cmd_verb name = do
411+ i <- fmap (fromIntegral . fst) P.natural
412+ eof
413+ return (Right (Verbosity i))
414+
408cmd_cats :: String -> P.IdrisParser (Either String Command)
415cmd_cats :: String -> P.IdrisParser (Either String Command)
409cmd_cats name = do
416cmd_cats name = do
410 cs <- sepBy pLogCats (P.whiteSpace)
417 cs <- sepBy pLogCats (P.whiteSpace)
src/Idris/Reflection.hs+20−13
@@ -314,9 +314,9 @@ reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)
314
314
315reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)
315reifyTTBinderApp :: (Term -> ElabD a) -> Name -> [Term] -> ElabD (Binder a)
316reifyTTBinderApp reif f [t]
316reifyTTBinderApp reif f [t]
317− | f == reflm "Lam" = liftM Lam (reif t)
317+ | f == reflm "Lam" = liftM (Lam RigW) (reif t)
318reifyTTBinderApp reif f [t, k]
318reifyTTBinderApp reif f [t, k]
319− | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)
319+ | f == reflm "Pi" = liftM2 (Pi RigW Nothing) (reif t) (reif k)
320reifyTTBinderApp reif f [x, y]
320reifyTTBinderApp reif f [x, y]
321 | f == reflm "Let" = liftM2 Let (reif x) (reif y)
321 | f == reflm "Let" = liftM2 Let (reif x) (reif y)
322reifyTTBinderApp reif f [t]
322reifyTTBinderApp reif f [t]
@@ -326,7 +326,7 @@ reifyTTBinderApp reif f [t]
326reifyTTBinderApp reif f [x, y]
326reifyTTBinderApp reif f [x, y]
327 | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)
327 | f == reflm "Guess" = liftM2 Guess (reif x) (reif y)
328reifyTTBinderApp reif f [t]
328reifyTTBinderApp reif f [t]
329− | f == reflm "PVar" = liftM PVar (reif t)
329+ | f == reflm "PVar" = liftM (PVar RigW) (reif t)
330reifyTTBinderApp reif f [t]
330reifyTTBinderApp reif f [t]
331 | f == reflm "PVTy" = liftM PVTy (reif t)
331 | f == reflm "PVTy" = liftM PVTy (reif t)
332reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))
332reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))
@@ -491,6 +491,9 @@ reflectTTQuotePattern unq Erased
491reflectTTQuotePattern unq Impossible
491reflectTTQuotePattern unq Impossible
492 = lift . tfail . InternalMsg $
492 = lift . tfail . InternalMsg $
493 "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."
493 "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."
494+reflectTTQuotePattern unq (Inferred t)
495+ = lift . tfail . InternalMsg $
496+ "Phase error! The Inferred constructor is for coverage checking only and should not have been reflected during elaboration."
494reflectTTQuotePattern unq (TType exp)
497reflectTTQuotePattern unq (TType exp)
495 = do ue <- getNameFrom (sMN 0 "uexp")
498 = do ue <- getNameFrom (sMN 0 "uexp")
496 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))
499 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))
@@ -574,12 +577,12 @@ reflectRawQuotePattern unq (RConstant c) =
574 fill (reflectConstant c); solve
577 fill (reflectConstant c); solve
575
578
576reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> Raw -> [Name] -> Binder a -> ElabD ()
579reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> Raw -> [Name] -> Binder a -> ElabD ()
577−reflectBinderQuotePattern q ty unq (Lam t)
580+reflectBinderQuotePattern q ty unq (Lam _ t)
578 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
581 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
579 fill $ reflCall "Lam" [ty, Var t']
582 fill $ reflCall "Lam" [ty, Var t']
580 solve
583 solve
581 focus t'; q unq t
584 focus t'; q unq t
582−reflectBinderQuotePattern q ty unq (Pi _ t k)
585+reflectBinderQuotePattern q ty unq (Pi _ _ t k)
583 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
586 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
584 k' <- claimTy (sMN 0 "k") ty; movelast k';
587 k' <- claimTy (sMN 0 "k") ty; movelast k';
585 fill $ reflCall "Pi" [ty, Var t', Var k']
588 fill $ reflCall "Pi" [ty, Var t', Var k']
@@ -616,7 +619,7 @@ reflectBinderQuotePattern q ty unq (Guess x y)
616 solve
619 solve
617 focus x'; q unq x
620 focus x'; q unq x
618 focus y'; q unq y
621 focus y'; q unq y
619−reflectBinderQuotePattern q ty unq (PVar t)
622+reflectBinderQuotePattern q ty unq (PVar _ t)
620 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
623 = do t' <- claimTy (sMN 0 "ty") ty; movelast t'
621 fill $ reflCall "PVar" [ty, Var t']
624 fill $ reflCall "PVar" [ty, Var t']
622 solve
625 solve
@@ -654,6 +657,8 @@ reflectTTQuote _ (Proj _ _) =
654reflectTTQuote unq Erased = Var (reflm "Erased")
657reflectTTQuote unq Erased = Var (reflm "Erased")
655reflectTTQuote _ Impossible =
658reflectTTQuote _ Impossible =
656 error "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."
659 error "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."
660+reflectTTQuote _ (Inferred tm) =
661+ error "Phase error! The Inferred constructor is for coverage checking only and should not have been reflected during elaboration."
657
662
658reflectRawQuote :: [Name] -> Raw -> Raw
663reflectRawQuote :: [Name] -> Raw -> Raw
659reflectRawQuote unq (Var n)
664reflectRawQuote unq (Var n)
@@ -744,9 +749,9 @@ reflectBinder :: Binder Term -> Raw
744reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []
749reflectBinder = reflectBinderQuote reflectTTQuote (reflm "TT") []
745
750
746reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw
751reflectBinderQuote :: ([Name] -> a -> Raw) -> Name -> [Name] -> Binder a -> Raw
747−reflectBinderQuote q ty unq (Lam t)
752+reflectBinderQuote q ty unq (Lam _ t)
748 = reflCall "Lam" [Var ty, q unq t]
753 = reflCall "Lam" [Var ty, q unq t]
749−reflectBinderQuote q ty unq (Pi _ t k)
754+reflectBinderQuote q ty unq (Pi _ _ t k)
750 = reflCall "Pi" [Var ty, q unq t, q unq k]
755 = reflCall "Pi" [Var ty, q unq t, q unq k]
751reflectBinderQuote q ty unq (Let x y)
756reflectBinderQuote q ty unq (Let x y)
752 = reflCall "Let" [Var ty, q unq x, q unq y]
757 = reflCall "Let" [Var ty, q unq x, q unq y]
@@ -758,7 +763,7 @@ reflectBinderQuote q ty unq (GHole _ _ t)
758 = reflCall "GHole" [Var ty, q unq t]
763 = reflCall "GHole" [Var ty, q unq t]
759reflectBinderQuote q ty unq (Guess x y)
764reflectBinderQuote q ty unq (Guess x y)
760 = reflCall "Guess" [Var ty, q unq x, q unq y]
765 = reflCall "Guess" [Var ty, q unq x, q unq y]
761−reflectBinderQuote q ty unq (PVar t)
766+reflectBinderQuote q ty unq (PVar _ t)
762 = reflCall "PVar" [Var ty, q unq t]
767 = reflCall "PVar" [Var ty, q unq t]
763reflectBinderQuote q ty unq (PVTy t)
768reflectBinderQuote q ty unq (PVTy t)
764 = reflCall "PVTy" [Var ty, q unq t]
769 = reflCall "PVTy" [Var ty, q unq t]
@@ -799,7 +804,7 @@ reflectUExp (UVal i) = reflCall "UVal" [RConstant (I i)]
799
804
800-- | Reflect the environment of a proof into a List (TTName, Binder TT)
805-- | Reflect the environment of a proof into a List (TTName, Binder TT)
801reflectEnv :: Env -> Raw
806reflectEnv :: Env -> Raw
802−reflectEnv = foldr consToEnvList emptyEnvList
807+reflectEnv = foldr consToEnvList emptyEnvList . envBinders
803 where
808 where
804 consToEnvList :: (Name, Binder Term) -> Raw -> Raw
809 consToEnvList :: (Name, Binder Term) -> Raw -> Raw
805 consToEnvList (n, b) l
810 consToEnvList (n, b) l
@@ -818,8 +823,10 @@ reflectEnv = foldr consToEnvList emptyEnvList
818 emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))
823 emptyEnvList = raw_apply (Var (sNS (sUN "Nil") ["List", "Prelude"]))
819 [envTupleType]
824 [envTupleType]
820
825
826+-- Reflected environments don't get the RigCount (for the moment, at least)
821reifyEnv :: Term -> ElabD Env
827reifyEnv :: Term -> ElabD Env
822−reifyEnv = reifyList (reifyPair reifyTTName (reifyTTBinder reifyTT (reflm "TT")))
828+reifyEnv tm = do preEnv <- reifyList (reifyPair reifyTTName (reifyTTBinder reifyTT (reflm "TT"))) tm
829+ return $ map (\(n, b) -> (n, RigW, b)) preEnv
823
830
824-- | Reflect an error into the internal datatype of Idris -- TODO
831-- | Reflect an error into the internal datatype of Idris -- TODO
825rawBool :: Bool -> Raw
832rawBool :: Bool -> Raw
@@ -1083,7 +1090,7 @@ reflectList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"
1083-- come from a lookup in idris_implicits on IState.
1090-- come from a lookup in idris_implicits on IState.
1084getArgs :: [PArg] -> Raw -> ([RFunArg], Raw)
1091getArgs :: [PArg] -> Raw -> ([RFunArg], Raw)
1085getArgs [] r = ([], r)
1092getArgs [] r = ([], r)
1086−getArgs (a:as) (RBind n (Pi _ ty _) sc) =
1093+getArgs (a:as) (RBind n (Pi _ _ ty _) sc) =
1087 let (args, res) = getArgs as sc
1094 let (args, res) = getArgs as sc
1088 erased = if InaccessibleArg `elem` argopts a then RErased else RNotErased
1095 erased = if InaccessibleArg `elem` argopts a then RErased else RNotErased
1089 arg' = case a of
1096 arg' = case a of
@@ -1114,7 +1121,7 @@ buildFunDefns ist n =
1114 mkFunClause ([], lhs, rhs) = RMkFunClause lhs rhs
1121 mkFunClause ([], lhs, rhs) = RMkFunClause lhs rhs
1115 mkFunClause (((n, ty) : ns), lhs, rhs) = mkFunClause (ns, bind lhs, bind rhs) where
1122 mkFunClause (((n, ty) : ns), lhs, rhs) = mkFunClause (ns, bind lhs, bind rhs) where
1116 bind Impossible = Impossible
1123 bind Impossible = Impossible
1117− bind tm = Bind n (PVar ty) tm
1124+ bind tm = Bind n (PVar RigW ty) tm
1118
1125
1119-- | Build the reflected datatype definition(s) that correspond(s) to
1126-- | Build the reflected datatype definition(s) that correspond(s) to
1120-- a provided unqualified name
1127-- a provided unqualified name
src/Idris/Termination.hs+10−10
@@ -1,6 +1,6 @@
1{-|
1{-|
2−Module : Idris.Coverage
2+Module : Idris.Termination
3−Description : The coverage and totality checkers for Idris are in this module.
3+Description : The termination checker for Idris
4Copyright :
4Copyright :
5License : BSD3
5License : BSD3
6Maintainer : The Idris Community.
6Maintainer : The Idris Community.
@@ -112,13 +112,13 @@ checkPositive mut_ns (cn, ty')
112 where
112 where
113 args t = [0..length (getArgTys t)-1]
113 args t = [0..length (getArgTys t)-1]
114
114
115− cp i (Bind n (Pi _ aty _) sc)
115+ cp i (Bind n (Pi _ _ aty _) sc)
116 = posArg i aty && cp i sc
116 = posArg i aty && cp i sc
117 cp i t | (P _ n' _ , args) <- unApply t,
117 cp i t | (P _ n' _ , args) <- unApply t,
118 n' `elem` mut_ns = all noRec args
118 n' `elem` mut_ns = all noRec args
119 cp i _ = True
119 cp i _ = True
120
120
121− posArg ist (Bind _ (Pi _ nty _) sc) = noRec nty && posArg ist sc
121+ posArg ist (Bind _ (Pi _ _ nty _) sc) = noRec nty && posArg ist sc
122 posArg ist t = posParams ist t
122 posArg ist t = posParams ist t
123
123
124 noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg)
124 noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg)
@@ -185,7 +185,7 @@ checkTotality path fc n
185 case unApply (getRetTy ty) of
185 case unApply (getRetTy ty) of
186 (P _ tyn _, _) -> do
186 (P _ tyn _, _) -> do
187 let ms = case lookupCtxt tyn (idris_datatypes i) of
187 let ms = case lookupCtxt tyn (idris_datatypes i) of
188− [TI _ _ _ _ xs@(_:_)] -> xs
188+ [TI _ _ _ _ xs@(_:_) _] -> xs
189 ts -> [tyn]
189 ts -> [tyn]
190 checkPositive ms (n, ty)
190 checkPositive ms (n, ty)
191 _-> return $ Total []
191 _-> return $ Total []
@@ -429,8 +429,8 @@ buildSCG' ist topfn pats args = nub $ concatMap scgPat pats where
429 = case lookupTy n (tt_ctxt ist) of
429 = case lookupTy n (tt_ctxt ist) of
430 [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args
430 [ty] -> expand 0 (normalise (tt_ctxt ist) [] ty) args
431 _ -> args
431 _ -> args
432− where expand i (Bind n (Pi _ _ _) sc) (x : xs) = x : expand (i + 1) sc xs
432+ where expand i (Bind n (Pi _ _ _ _) sc) (x : xs) = x : expand (i + 1) sc xs
433− expand i (Bind n (Pi _ _ _) sc) [] = Just (i, Same) : expand (i + 1) sc []
433+ expand i (Bind n (Pi _ _ _ _) sc) [] = Just (i, Same) : expand (i + 1) sc []
434 expand i _ xs = xs
434 expand i _ xs = xs
435
435
436 mkChange n args pargs = [(n, expandToArity n (sizes args))]
436 mkChange n args pargs = [(n, expandToArity n (sizes args))]
@@ -471,15 +471,15 @@ buildSCG' ist topfn pats args = nub $ concatMap scgPat pats where
471
471
472 isInductive (P _ nty _) (P _ nty' _) =
472 isInductive (P _ nty _) (P _ nty' _) =
473 let (co, muts) = case lookupCtxt nty (idris_datatypes ist) of
473 let (co, muts) = case lookupCtxt nty (idris_datatypes ist) of
474− [TI _ x _ _ muts] -> (x, muts)
474+ [TI _ x _ _ muts _] -> (x, muts)
475 _ -> (False, []) in
475 _ -> (False, []) in
476 (nty == nty' || any (== nty') muts) && not co
476 (nty == nty' || any (== nty') muts) && not co
477 isInductive _ _ = False
477 isInductive _ _ = False
478
478
479− dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)
479+ dePat (Bind x (PVar _ ty) sc) = dePat (instantiate (P Bound x ty) sc)
480 dePat t = t
480 dePat t = t
481
481
482− patvars (Bind x (PVar _) sc) = x : patvars sc
482+ patvars (Bind x (PVar _ _) sc) = x : patvars sc
483 patvars _ = []
483 patvars _ = []
484
484
485 allGuarded n ist = case lookupCtxtExact n (idris_flags ist) of
485 allGuarded n ist = case lookupCtxtExact n (idris_flags ist) of
src/Idris/Transforms.hs+2−2
@@ -86,7 +86,7 @@ applyRule (lhs, rhs) tm
86-- (In general, this would not be true, but when we elaborate transformation
86-- (In general, this would not be true, but when we elaborate transformation
87-- rules we mangle the names so that it is true. While this feels a bit
87-- rules we mangle the names so that it is true. While this feels a bit
88-- hacky, it's much easier to think about than mangling de Bruijn indices).
88-- hacky, it's much easier to think about than mangling de Bruijn indices).
89− where depat ms (Bind n (PVar t) sc)
89+ where depat ms (Bind n (PVar _ t) sc)
90 = case lookup n ms of
90 = case lookup n ms of
91 Just tm -> depat ms (subst n tm sc)
91 Just tm -> depat ms (subst n tm sc)
92 _ -> depat ms sc -- no occurrence? Shouldn't happen
92 _ -> depat ms sc -- no occurrence? Shouldn't happen
@@ -95,7 +95,7 @@ applyRule (lhs, rhs) tm
95matchTerm :: Term -> Term -> Maybe [(Name, Term)]
95matchTerm :: Term -> Term -> Maybe [(Name, Term)]
96matchTerm lhs tm = matchVars [] lhs tm
96matchTerm lhs tm = matchVars [] lhs tm
97 where
97 where
98− matchVars acc (Bind n (PVar t) sc) tm
98+ matchVars acc (Bind n (PVar _ t) sc) tm
99 = matchVars (n : acc) (instantiate (P Bound n t) sc) tm
99 = matchVars (n : acc) (instantiate (P Bound n t) sc) tm
100 matchVars acc sc tm
100 matchVars acc sc tm
101 = -- trace (show acc ++ ": " ++ show (sc, tm)) $
101 = -- trace (show acc ++ ": " ++ show (sc, tm)) $
src/Idris/TypeSearch.hs+4−4
@@ -104,8 +104,8 @@ searchPred istate ty1 = matcher where
104 matcher = matchTypesBulk istate maxScore ty1
104 matcher = matchTypesBulk istate maxScore ty1
105
105
106
106
107−typeFromDef :: (Def, i, b, c, d) -> Maybe Type
107+typeFromDef :: (Def, r, i, b, c, d) -> Maybe Type
108−typeFromDef (def, _, _, _, _) = get def where
108+typeFromDef (def, _, _, _, _, _) = get def where
109 get :: Def -> Maybe Type
109 get :: Def -> Maybe Type
110 get (Function ty _) = Just ty
110 get (Function ty _) = Just ty
111 get (TyDecl _ ty) = Just ty
111 get (TyDecl _ ty) = Just ty
@@ -142,7 +142,7 @@ computeDagP removePred t = (reverse (map f arguments), reverse theRemovedArgs ,
142 (arguments, theRemovedArgs, retTy) = go [] [] t
142 (arguments, theRemovedArgs, retTy) = go [] [] t
143
143
144 -- NOTE : args are in reverse order
144 -- NOTE : args are in reverse order
145− go args removedArgs (Bind n (Pi _ ty _) sc) = let arg = (n, ty) in
145+ go args removedArgs (Bind n (Pi _ _ ty _) sc) = let arg = (n, ty) in
146 if removePred ty
146 if removePred ty
147 then go args (arg : removedArgs) sc
147 then go args (arg : removedArgs) sc
148 else go (arg : args) removedArgs sc
148 else go (arg : args) removedArgs sc
@@ -439,7 +439,7 @@ matchTypesBulk istate maxScore type1 types = getAllResults startQueueOfQueues wh
439 unifyQueue state [] = return state
439 unifyQueue state [] = return state
440 unifyQueue state ((ty1, ty2) : queue) = do
440 unifyQueue state ((ty1, ty2) : queue) = do
441 --trace ("go: \n" ++ show state) True `seq` return ()
441 --trace ("go: \n" ++ show state) True `seq` return ()
442− res <- tcToMaybe $ match_unify ctxt [ (n, Pi Nothing ty (TType (UVar [] 0))) | (n, ty) <- holes state]
442+ res <- tcToMaybe $ match_unify ctxt [ (n, RigW, Pi RigW Nothing ty (TType (UVar [] 0))) | (n, ty) <- holes state]
443 (ty1, Nothing)
443 (ty1, Nothing)
444 (ty2, Nothing) [] (map fst $ holes state) []
444 (ty2, Nothing) [] (map fst $ holes state) []
445 (state', queueAdditions) <- resolveUnis res state
445 (state', queueAdditions) <- resolveUnis res state
stack-shell.nix+1−1
@@ -2,7 +2,7 @@ with (import <nixpkgs> {});
2
2
3let
3let
4 # MUST match resolver in stack.yaml
4 # MUST match resolver in stack.yaml
5− resolver = haskell.packages.lts-7_10.ghc;
5+ resolver = haskell.packages.lts-7_14.ghc;
6
6
7 native_libs = [
7 native_libs = [
8 libffi
8 libffi
stack.yaml+2−2
@@ -1,4 +1,4 @@
1−resolver: lts-7.10
1+resolver: lts-7.14
2
2
3packages:
3packages:
4 - location: .
4 - location: .
@@ -10,7 +10,7 @@ flags:
10
10
11extra-deps:
11extra-deps:
12 - libffi-0.1
12 - libffi-0.1
13− - safe-0.3.9
13+
14nix:
14nix:
15 enable: false
15 enable: false
16 shell-file: stack-shell.nix
16 shell-file: stack-shell.nix
test/TestData.hs+6−3
@@ -70,7 +70,8 @@ testFamiliesData = [
70 ( 15, ANY ),
70 ( 15, ANY ),
71 ( 16, ANY ),
71 ( 16, ANY ),
72 ( 17, ANY ),
72 ( 17, ANY ),
73− ( 18, ANY )]),
73+ ( 18, ANY ),
74+ ( 19, ANY )]),
74 ("bignum", "Bignum",
75 ("bignum", "Bignum",
75 [ ( 1, ANY ),
76 [ ( 1, ANY ),
76 ( 2, ANY )]),
77 ( 2, ANY )]),
@@ -178,7 +179,8 @@ testFamiliesData = [
178 ( 4, ANY ),
179 ( 4, ANY ),
179 ( 5, ANY ),
180 ( 5, ANY ),
180 ( 6, ANY ),
181 ( 6, ANY ),
181− ( 7, ANY )]),
182+ ( 7, ANY ),
183+ ( 8, ANY )]),
182 ("prelude", "Prelude",
184 ("prelude", "Prelude",
183 [ ( 1, ANY )]),
185 [ ( 1, ANY )]),
184 ("primitives", "Primitive types",
186 ("primitives", "Primitive types",
@@ -276,7 +278,8 @@ testFamiliesData = [
276 ( 15, ANY ),
278 ( 15, ANY ),
277 ( 16, ANY ),
279 ( 16, ANY ),
278 ( 17, ANY ),
280 ( 17, ANY ),
279− ( 18, ANY )]),
281+ ( 18, ANY ),
282+ ( 19, ANY )]),
280 ("tutorial", "Tutorial examples",
283 ("tutorial", "Tutorial examples",
281 [ ( 1, ANY ),
284 [ ( 1, ANY ),
282 ( 2, ANY ),
285 ( 2, ANY ),
test/TestRun.hs+14−8
@@ -107,11 +107,17 @@ runTest path flags = do
107 normalise [] = []
107 normalise [] = []
108
108
109main :: IO ()
109main :: IO ()
110−main =
110+main = do
111− defaultMainWithIngredients ingredients $
111+ node <- findExecutable "node"
112− askOption $ \(NodeOpt node) ->
112+ case node of
113− let (codegen, flags) = if node then (JS, ["--codegen", "node"])
113+ Nothing -> do
114− else (C , [])
114+ putStrLn "For running the test suite against Node, node must be installed."
115− in
115+ exitFailure
116− mkGoldenTests (testFamiliesForCodegen codegen)
116+ Just _ -> do
117− (flags ++ idrisFlags)
117+ defaultMainWithIngredients ingredients $
118+ askOption $ \(NodeOpt node) ->
119+ let (codegen, flags) = if node then (JS, ["--codegen", "node"])
120+ else (C , [])
121+ in
122+ mkGoldenTests (testFamiliesForCodegen codegen)
123+ (flags ++ idrisFlags)
test/basic018/expected+1−1
@@ -8,7 +8,7 @@ basic018.idr:13:6:When checking right hand side of test with expected type
8Type mismatch between
8Type mismatch between
9 42 = 42 (Type of Refl)
9 42 = 42 (Type of Refl)
10and
10and
11− thing = 42 (Expected type)
11+ thing = S (fromIntegerNat 41) (Expected type)
12
12
13Specifically:
13Specifically:
14 Type mismatch between
14 Type mismatch between
test/basic019/basic019.idrnew file+10
@@ -0,0 +1,10 @@
1+printRange : (t : Type) -> (Show t, Num t, Enum t) => IO ()
2+printRange t = do printLn [(the t 1)..10]
3+ printLn [(the t 10),9..1]
4+ printLn (take 10 [(the t 1)..])
5+ printLn (take 10 [(the t 1),3..])
6+
7+main : IO ()
8+main = do printRange Nat
9+ printRange Int
10+ printRange Integer
test/basic019/expectednew file+12
@@ -0,0 +1,12 @@
1+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
2+[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]
3+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
4+[1, 3, 5, 7, 9, 11, 13, 15, 17, 19]
5+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
6+[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]
7+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
8+[1, 3, 5, 7, 9, 11, 13, 15, 17, 19]
9+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
10+[10, 9, 8, 7, 6, 5, 4, 3, 2, 1]
11+[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]
12+[1, 3, 5, 7, 9, 11, 13, 15, 17, 19]
test/basic019/runnew file+4
@@ -0,0 +1,4 @@
1+#!/usr/bin/env bash
2+${IDRIS:-idris} $@ basic019.idr -o basic019
3+./basic019
4+rm -f basic019 *.ibc
test/dsl001/expected+4−4
@@ -1,13 +1,13 @@
124
124
212
212
3testFac : Int
3testFac : Int
4−testFac = PE_interp_f79b3e31 [] (PE_fromInteger_d6648df 4)
4+testFac = PE_interp_e04a79ff [] (PE_fromInteger_d6648df 4)
5−PE_interp_f79b3e31 : Env G -> Int -> Int
5+PE_interp_e04a79ff : Env G -> Int -> Int
6−PE_interp_f79b3e31 (3arg) = \x =>
6+PE_interp_e04a79ff (3arg) = \x =>
7 ifThenElse (PE_==_ba2f651f x
7 ifThenElse (PE_==_ba2f651f x
8 (PE_fromInteger_d6648df 0))
8 (PE_fromInteger_d6648df 0))
9 (Delay (PE_fromInteger_d6648df 1))
9 (Delay (PE_fromInteger_d6648df 1))
10− (Delay (PE_*_ba2f651f (PE_interp_f79b3e31 (x ::
10+ (Delay (PE_*_ba2f651f (PE_interp_e04a79ff (x ::
11 (3arg))
11 (3arg))
12 (PE_-_ba2f651f x
12 (PE_-_ba2f651f x
13 (PE_fromInteger_d6648df 1)))
13 (PE_fromInteger_d6648df 1)))
test/dsl001/input+1−1
@@ -1,2 +1,2 @@
1:printdef testFac
1:printdef testFac
2−:printdef PE_interp_f79b3e31
2+:printdef PE_interp_e04a79ff
test/dsl001/test001.idr+2
@@ -3,6 +3,8 @@ module Main
3import Data.Vect
3import Data.Vect
4import Data.Fin
4import Data.Fin
5
5
6+%language DSLNotation
7+
6data Ty = TyInt | TyBool| TyFun Ty Ty
8data Ty = TyInt | TyBool| TyFun Ty Ty
7
9
8interpTy : Ty -> Type
10interpTy : Ty -> Type
test/dsl002/Resimp.idr+1
@@ -3,6 +3,7 @@ module Resimp
3import public Data.Vect
3import public Data.Vect
4import public Data.Fin
4import public Data.Fin
5
5
6+%language DSLNotation
6%access public export
7%access public export
7
8
8-- IO operations which read a resource
9-- IO operations which read a resource
test/dsl003/DSLPi.idr+2
@@ -3,6 +3,8 @@ module DSLPi
3import Data.Fin
3import Data.Fin
4import Data.Vect
4import Data.Vect
5
5
6+%language DSLNotation
7+
6data Ty = BOOL | INT | UNIT | ARR Ty Ty
8data Ty = BOOL | INT | UNIT | ARR Ty Ty
7
9
8arr_ : _ -> Ty -> Ty -> Ty
10arr_ : _ -> Ty -> Ty -> Ty
test/dsl004/Door0.idr+3−1
@@ -1,6 +1,8 @@
1import IOu
1import IOu
2
2
3−data Result : (a : Type) -> (a -> Type) -> Type* where
3+%language UniquenessTypes
4+
5+data Result : (a : Type) -> (a -> Type) -> AnyType where
4 Res : {k : a -> Type} -> (val : a) -> k val -> Result a k
6 Res : {k : a -> Type} -> (val : a) -> k val -> Result a k
5
7
6
8
test/dsl004/Door1.idr+2
@@ -2,6 +2,8 @@ import IOu
2
2
3import Data.Vect
3import Data.Vect
4
4
5+%language UniquenessTypes
6+
5data Result : (a : AnyType) -> (a -> AnyType) -> AnyType where
7data Result : (a : AnyType) -> (a -> AnyType) -> AnyType where
6 Res : {k : a -> AnyType} -> (val : a) -> (h : k val) -> Result a k
8 Res : {k : a -> AnyType} -> (val : a) -> (h : k val) -> Result a k
7
9
test/dsl004/Door2.idr+2
@@ -1,5 +1,7 @@
1import IOu
1import IOu
2
2
3+%language UniquenessTypes
4+
3data DoorState = OPEN | CLOSED
5data DoorState = OPEN | CLOSED
4
6
5data DoorH : DoorState -> UniqueType where
7data DoorH : DoorState -> UniqueType where
test/dsl004/Door3.idr+2
@@ -1,5 +1,7 @@
1import IOu
1import IOu
2
2
3+%language UniquenessTypes
4+
3data DoorState = OPEN | CLOSED
5data DoorState = OPEN | CLOSED
4
6
5data DoorH : DoorState -> UniqueType where
7data DoorH : DoorState -> UniqueType where
test/dsl004/IOu.idr+2
@@ -1,5 +1,7 @@
1module IOu
1module IOu
2
2
3+%language UniquenessTypes
4+
3-------- An IO type supporting possibly unique values
5-------- An IO type supporting possibly unique values
4
6
5data IOu : AnyType -> AnyType where
7data IOu : AnyType -> AnyType where
test/interactive010/expected+2−2
@@ -4,9 +4,9 @@ a is not an implicit argument of Prelude.Interfaces./
4Usage is :doc <functionname>
4Usage is :doc <functionname>
5Usage is :wc <functionname>
5Usage is :wc <functionname>
6Usage is :printdef <functionname>
6Usage is :printdef <functionname>
7−pat {ty504} : Type toplevel.u. pat {__interface505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__interface505}
7+pat {ty503} : Type toplevel.u. pat {__interface504} : Prelude.Interfaces.Fractional {ty503}. Prelude.Interfaces./ {ty503} {__interface504}
8
8
9− : pty {ty504} : Type toplevel.u. pty {__interface505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}
9+ : pty {ty503} : Type toplevel.u. pty {__interface504} : Prelude.Interfaces.Fractional {ty503}. {ty503} -> {ty503} -> {ty503}
10(input):1:1: error: expected: ":",
10(input):1:1: error: expected: ":",
11 dependent type signature,
11 dependent type signature,
12 end of input
12 end of input
test/meta001/Finite.idr+2
@@ -4,6 +4,8 @@ import Data.Fin
4import Language.Reflection.Elab
4import Language.Reflection.Elab
5import Language.Reflection.Utils
5import Language.Reflection.Utils
6
6
7+%language ElabReflection
8+
7-- Test various features of reflected elaboration, including looking
9-- Test various features of reflected elaboration, including looking
8-- up datatypes, defining functions, and totality checking
10-- up datatypes, defining functions, and totality checking
9
11
test/meta002/AgdaStyleReflection.idr+1−1
@@ -13,7 +13,7 @@ import Language.Reflection.Utils
13import Pruviloj
13import Pruviloj
14
14
15%default total
15%default total
16−
16+%language ElabReflection
17
17
18
18
19||| Function arguments as provided at the application site
19||| Function arguments as provided at the application site
test/meta002/DataDef.idr+2
@@ -1,5 +1,7 @@
1module DataDef
1module DataDef
2
2
3+%language ElabReflection
4+
3foo : Elab ()
5foo : Elab ()
4foo = do declareDatatype $ Declare `{{DataDef.N}} [MkFunArg `{{n}} `(Nat) Explicit NotErased] `(Type)
6foo = do declareDatatype $ Declare `{{DataDef.N}} [MkFunArg `{{n}} `(Nat) Explicit NotErased] `(Type)
5 defineDatatype $ DefineDatatype `{{DataDef.N}} [
7 defineDatatype $ DefineDatatype `{{DataDef.N}} [
test/meta002/Deriving.idr+2
@@ -1,6 +1,8 @@
1||| Test some deriving features
1||| Test some deriving features
2module Deriving
2module Deriving
3
3
4+%language ElabReflection
5+
4-- NB: test disabled due to excess memory consumption
6-- NB: test disabled due to excess memory consumption
5
7
6import Pruviloj
8import Pruviloj
test/meta002/Tacs.idr+1
@@ -16,6 +16,7 @@ import Language.Reflection.Utils
16import Pruviloj.Core
16import Pruviloj.Core
17
17
18%default total
18%default total
19+%language ElabReflection
19
20
20-- Tactics can now query the elaborator and bind variables
21-- Tactics can now query the elaborator and bind variables
21
22
test/meta002/expected+2−2
@@ -1,7 +1,7 @@
1−DataDef.idr:72:1-9:
1+DataDef.idr:74:1-9:
2While running an elaboration script, the following error occurred:
2While running an elaboration script, the following error occurred:
3Prelude.Either.Either is already defined as a datatype.
3Prelude.Either.Either is already defined as a datatype.
4−Tacs.idr:298:15:
4+Tacs.idr:299:15:
5When checking right hand side of testElab3 with expected type
5When checking right hand side of testElab3 with expected type
6 DPair Ty (Tm [])
6 DPair Ty (Tm [])
7
7
test/meta003/BadDef.idr+2
@@ -2,6 +2,8 @@ module BadDef
2
2
3import Language.Reflection.Elab
3import Language.Reflection.Elab
4
4
5+%language ElabReflection
6+
5mkN : String -> TTName
7mkN : String -> TTName
6mkN n = NS (UN n) ["BadDef"]
8mkN n = NS (UN n) ["BadDef"]
7
9
test/meta003/expected+1−1
@@ -1,4 +1,4 @@
1−BadDef.idr:12:1-9:
1+BadDef.idr:14:1-9:
2While running an elaboration script, the following error occurred:
2While running an elaboration script, the following error occurred:
3Type mismatch between
3Type mismatch between
4 ()
4 ()
test/meta004/expected+1−1
@@ -1,3 +1,3 @@
1−meta004.idr:48:1-9:
1+meta004.idr:50:1-9:
2While running an elaboration script, the following error occurred:
2While running an elaboration script, the following error occurred:
3Not an impossible case
3Not an impossible case
test/meta004/meta004.idr+2
@@ -2,6 +2,8 @@ import Data.Fin
2import Language.Reflection.Utils
2import Language.Reflection.Utils
3import Pruviloj.Core
3import Pruviloj.Core
4
4
5+%language ElabReflection
6+
5rename : TTName -> TTName -> Raw -> Raw
7rename : TTName -> TTName -> Raw -> Raw
6rename old new (RBind name b body) = RBind name (map (rename old new) b) (rename old new body)
8rename old new (RBind name b body) = RBind name (map (rename old new) b) (rename old new body)
7rename old new (RApp f arg) = RApp (rename old new f) (rename old new arg)
9rename old new (RApp f arg) = RApp (rename old new f) (rename old new arg)
test/pkg008/expectednew file+13
@@ -0,0 +1,13 @@
1+Entering directory `./src'
2+Type checking ./NumOps.idr
3+Type checking ./Test.idr
4+Leaving directory `./src'
5+Test Passed
6+Test Passed
7+Entering directory `./src'
8+Leaving directory `./src'
9+Entering directory `./src'
10+Removed: NumOps.ibc
11+Removed: Test.ibc
12+Removed: 00maths-idx.ibc
13+Leaving directory `./src'
test/pkg008/maths.ipkgnew file+9
@@ -0,0 +1,9 @@
1+package maths
2+
3+sourcedir = src
4+
5+modules = NumOps
6+ , Test
7+
8+tests = Test.testDouble
9+ , Test.testTriple
test/pkg008/runnew file+9
@@ -0,0 +1,9 @@
1+#!/usr/bin/env bash
2+
3+${IDRIS:-idris} $@ --build maths.ipkg
4+${IDRIS:-idris} $@ --testpkg maths.ipkg | grep -v -e "idris"
5+
6+# Idris only appears in the randomly generated name of test so we grep
7+# to remove it to make output consistent.
8+
9+${IDRIS:-idris} $@ --clean maths.ipkg
test/pkg008/src/NumOps.idrnew file+9
@@ -0,0 +1,9 @@
1+module NumOps
2+
3+%access export -- to make functions under test visible
4+
5+double : Num a => a -> a
6+double a = a + a
7+
8+triple : Num a => a -> a
9+triple a = a + double a
test/pkg008/src/Test.idrnew file+21
@@ -0,0 +1,21 @@
1+module Test
2+
3+import NumOps
4+
5+%access export -- to make the test functions visible
6+
7+assertEq : Eq a => (given : a) -> (expected : a) -> IO ()
8+assertEq g e = if g == e
9+ then putStrLn "Test Passed"
10+ else putStrLn "Test Failed"
11+
12+assertNotEq : Eq a => (given : a) -> (expected : a) -> IO ()
13+assertNotEq g e = if not (g == e)
14+ then putStrLn "Test Passed"
15+ else putStrLn "Test Failed"
16+
17+testDouble : IO ()
18+testDouble = assertEq (double 2) 4
19+
20+testTriple : IO ()
21+testTriple = assertNotEq (triple 2) 5
test/proof002/Reflect.idr+1
@@ -4,6 +4,7 @@ import Decidable.Equality
4
4
5%access public export
5%access public export
6%default total
6%default total
7+%language FirstClassReflection
7
8
8using (xs : List a, ys : List a, G : List (List a))
9using (xs : List a, ys : List a, G : List (List a))
9
10
test/proof002/expected+3−3
@@ -1,8 +1,8 @@
1−Reflect.idr:174:21-26:
1+Reflect.idr:175:21-26:
2This style of tactic proof is deprecated. See %runElab for the replacement.
2This style of tactic proof is deprecated. See %runElab for the replacement.
3−Reflect.idr:183:21-26:
3+Reflect.idr:184:21-26:
4This style of tactic proof is deprecated. See %runElab for the replacement.
4This style of tactic proof is deprecated. See %runElab for the replacement.
5−Reflect.idr:191:15-20:
5+Reflect.idr:192:15-20:
6This style of tactic proof is deprecated. See %runElab for the replacement.
6This style of tactic proof is deprecated. See %runElab for the replacement.
7test030a.idr:12:26-14:1:
7test030a.idr:12:26-14:1:
8When checking right hand side of testReflect1 with expected type
8When checking right hand side of testReflect1 with expected type
test/pruviloj001/pruviloj001.idr+1
@@ -5,6 +5,7 @@ import Pruviloj
5import Pruviloj.Induction
5import Pruviloj.Induction
6
6
7%default total
7%default total
8+%language ElabReflection
8
9
9||| Try some simplification and rewriting heuristics, then attempt to
10||| Try some simplification and rewriting heuristics, then attempt to
10||| solve the goal
11||| solve the goal
test/regression001/coverage001.idrnew file+79
@@ -0,0 +1,79 @@
1+module Data.AVL.Tree
2+
3+%default total
4+%access export
5+
6+data Balance : Nat -> Nat -> Type where
7+ LHeavy : Balance (S n) n
8+ RHeavy : Balance n (S n)
9+ Balanced : Balance n n
10+
11+%name Balance b, bal
12+
13+height : Balance n m -> Nat
14+height b = S (height' b)
15+ where
16+ height' : Balance n m -> Nat
17+ height' (LHeavy {n}) = S n
18+ height' (RHeavy {n}) = S n
19+ height' {n} (Balanced {n}) = n
20+
21+public export
22+data Tree : (keyTy : Type) -> (valTy : Type) -> Type
23+ where
24+ ||| An empty Tree node.
25+ Empty : Tree k v
26+
27+ Node : (key : k)
28+ -> (val : v)
29+ -> (left : Tree k v)
30+ -> (right : Tree k v)
31+ -> Tree k v
32+
33+%name Tree t, tree
34+
35+public export
36+data AVLInvariant : (height : Nat)
37+ -> (tree : Tree k v)
38+ -> Type
39+ where
40+ AVLEmpty : AVLInvariant 0 Empty
41+
42+ AVLNode : (left : AVLInvariant n l) ->
43+ (right : AVLInvariant m r) ->
44+ (b : Balance n m) ->
45+ AVLInvariant (height b) (Node k v l r)
46+
47+%name AVLInvariant inv
48+
49+public export
50+AVLTree : (height : Nat) -> (keyTy : Type) -> (valueTy : Type) -> Type
51+AVLTree n k v = Subset (Tree k v) (AVLInvariant n)
52+
53+-- --------------------------------------------------------------- [ Rotations ]
54+private
55+data InsertRes : Nat -> (k : Type) -> Type -> Type where
56+ Same : AVLTree n k v -> InsertRes n k v
57+ Grew : AVLTree (S n) k v -> InsertRes n k v
58+
59+%name InsertRes res, r
60+
61+private
62+runInsertRes : InsertRes n k v -> (n : Nat ** AVLTree n k v)
63+runInsertRes (Same t) = (_ ** t)
64+runInsertRes (Grew t) = (_ ** t)
65+
66+||| Perform a Left roation.
67+private
68+rotLeft : k
69+ -> v
70+ -> AVLTree n k v
71+ -> AVLTree (S (S n)) k v
72+ -> InsertRes (S (S n)) k v
73+-- Impossible because Empty has depth 0 and we know the depth is at least 2 from the type
74+rotLeft key val l (Element Empty AVLEmpty) impossible
75+rotLeft key val (Element l invl) (Element (Node key' val' rl rr) (AVLNode invrl invrr Balanced)) = ?rl1
76+rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr LHeavy) invrr LHeavy)) = ?rl2
77+rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr RHeavy) invrr LHeavy)) = ?rl3
78+rotLeft key val (Element l invl) (Element (Node key' val' (Node key'' val'' rll rlr) rr) (AVLNode (AVLNode invrll invrlr Balanced) invrr LHeavy)) = ?rl4
79+rotLeft key val (Element l invl) (Element (Node key' val' rl rr) (AVLNode invrl invrr RHeavy)) = ?rl5
test/regression001/eff001.idrnew file+39
@@ -0,0 +1,39 @@
1+module Test.Random
2+
3+import Effects
4+import Effect.Random
5+
6+genKVPair : (genA : Eff a [RND])
7+ -> (genB : Eff b [RND])
8+ -> Eff (Pair a b) [RND]
9+genKVPair f g = pure (!f, !g)
10+
11+genRndListKVUE : (Eq a, Eq b) =>
12+ (seed : Integer)
13+ -> (len : Nat)
14+ -> (genA : Eff a [RND])
15+ -> (genB : Eff b [RND])
16+ -> Eff (List (Pair a b)) [RND]
17+genRndListKVUE s l f g = do srand s; pure !(doGen l (genKVPair f g))
18+ where
19+ genElem : (Eq a, Eq b)
20+ => (generator : Eff (Pair a b) [RND])
21+ -> (existing : List (Pair a b))
22+ -> Eff (Pair a b) [RND]
23+ genElem j xs = do
24+ x <- j
25+ if elem x xs
26+ then genElem j xs
27+ else if isJust $ lookup (fst x) xs
28+ then genElem j xs
29+ else pure x
30+
31+ doGen : (Eq a, Eq b)
32+ => (count : Nat)
33+ -> (generator : Eff (Pair a b) [RND])
34+ -> Eff (List (Pair a b)) [RND]
35+ doGen Z j = pure Nil
36+ doGen (S n) j = do
37+ xs <- doGen n j
38+ x <- genElem j xs
39+ pure (x::xs)
test/regression001/run+5−1
@@ -3,7 +3,11 @@ ${IDRIS:-idris} $@ --check \
3 reg001.idr reg036.idr reg037.idr reg038.idr reg046.idr \
3 reg001.idr reg036.idr reg037.idr reg038.idr reg046.idr \
4 reg047a.idr reg053.idr reg057.idr reg058.idr reg058a.idr \
4 reg047a.idr reg053.idr reg057.idr reg058.idr reg058a.idr \
5 reg059.idr reg060.idr reg061.idr reg062.idr reg063.idr \
5 reg059.idr reg060.idr reg061.idr reg062.idr reg063.idr \
6− reg064.idr reg065.idr reg066.idr reg071.idr reg074.idr
6+ reg064.idr reg065.idr reg066.idr reg071.idr reg074.idr \
7+ coverage001.idr
8+
9+${IDRIS:-idris} $@ --check \
10+ eff001.idr -p effects
7
11
8${IDRIS:-idris} $@ --check --nobuiltins reg047.idr
12${IDRIS:-idris} $@ --check --nobuiltins reg047.idr
9
13
test/sourceLocation001/SourceLoc.idr+1
@@ -6,6 +6,7 @@ import Language.Reflection
6import Language.Reflection.Utils
6import Language.Reflection.Utils
7
7
8%default total
8%default total
9+%language DSLNotation
9
10
10||| A "function" that returns where it is called in the source
11||| A "function" that returns where it is called in the source
11getLoc : {default tactics { sourceLocation } x : SourceLocation} -> SourceLocation
12getLoc : {default tactics { sourceLocation } x : SourceLocation} -> SourceLocation
test/sourceLocation001/expected+8−8
@@ -1,19 +1,19 @@
1−SourceLoc.idr:11:19-26:
1+SourceLoc.idr:12:19-26:
2This style of tactic proof is deprecated. See %runElab for the replacement.
2This style of tactic proof is deprecated. See %runElab for the replacement.
3−SourceLoc.idr:20:19-24:
3+SourceLoc.idr:21:19-24:
4This style of tactic proof is deprecated. See %runElab for the replacement.
4This style of tactic proof is deprecated. See %runElab for the replacement.
5−SourceLoc.idr:40:20-27:
5+SourceLoc.idr:41:20-27:
6This style of tactic proof is deprecated. See %runElab for the replacement.
6This style of tactic proof is deprecated. See %runElab for the replacement.
7−SourceLoc.idr:98:18-23:
7+SourceLoc.idr:99:18-23:
8This style of tactic proof is deprecated. See %runElab for the replacement.
8This style of tactic proof is deprecated. See %runElab for the replacement.
9Testing using definition
9Testing using definition
10−FileLoc "SourceLoc.idr" (16, 11) (16, 17)
10+FileLoc "SourceLoc.idr" (17, 11) (17, 17)
11Testing using inline tactics
11Testing using inline tactics
12−FileLoc "SourceLoc.idr" (20, 17) (20, 17)
12+FileLoc "SourceLoc.idr" (21, 17) (21, 17)
13Testing using metavariable with later definition
13Testing using metavariable with later definition
14−FileLoc "SourceLoc.idr" (98, 16) (98, 16)
14+FileLoc "SourceLoc.idr" (99, 16) (99, 16)
15-----------------------
15-----------------------
16Success!
16Success!
17−Error at FileLoc "SourceLoc.idr" (72, 23) (72, 26)
17+Error at FileLoc "SourceLoc.idr" (73, 23) (73, 26)
18Success!
18Success!
19Success!
19Success!
test/tactics001/Tactics.idr+5−3
@@ -4,7 +4,7 @@ import Language.Reflection.Elab
4
4
5import Data.Vect
5import Data.Vect
6
6
7−
7+%language ElabReflection
8%default total
8%default total
9
9
10-- Test that basic proofs with new-style tactics work
10-- Test that basic proofs with new-style tactics work
@@ -18,14 +18,16 @@ refl t x = RApp (RApp (Var (UN "Refl")) t) x
18plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n
18plusZeroRightNeutralNew : (n : Nat) -> plus n 0 = n
19plusZeroRightNeutralNew Z = Refl
19plusZeroRightNeutralNew Z = Refl
20plusZeroRightNeutralNew (S k) =
20plusZeroRightNeutralNew (S k) =
21− %runElab (do rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var `{k}))
21+ %runElab (do compute
22+ rewriteWith `(sym $ plusZeroRightNeutralNew ~(Var `{k}))
22 fill $ refl `(Nat : Type) `(S ~(Var `{k}))
23 fill $ refl `(Nat : Type) `(S ~(Var `{k}))
23 solve)
24 solve)
24
25
25plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k)
26plusSuccRightSuccNew : (j, k : Nat) -> plus j (S k) = S (plus j k)
26plusSuccRightSuccNew Z k = Refl
27plusSuccRightSuccNew Z k = Refl
27plusSuccRightSuccNew (S j) k =
28plusSuccRightSuccNew (S j) k =
28− %runElab (do rewriteWith `(sym $ plusSuccRightSuccNew ~(Var `{j}) ~(Var `{k}))
29+ %runElab (do compute
30+ rewriteWith `(sym $ plusSuccRightSuccNew ~(Var `{j}) ~(Var `{k}))
29 fill $ refl `(Nat : Type) `(S (S (plus ~(Var `{j}) ~(Var `{k}))))
31 fill $ refl `(Nat : Type) `(S (S (plus ~(Var `{j}) ~(Var `{k}))))
30 solve)
32 solve)
31
33
test/totality019/expectednew file+2
@@ -0,0 +1,2 @@
1+totality019.idr:8:1:Main.testCov is not total as there are missing cases
2+totality019.idr:12:1:Main.testCov' is not total as there are missing cases
test/totality019/runnew file+4
@@ -0,0 +1,4 @@
1+#!/usr/bin/env bash
2+${IDRIS:-idris} $@ totality019.idr --check
3+${IDRIS:-idris} $@ totality019a.idr --check
4+rm -f *.ibc
test/totality019/totality019.idrnew file+14
@@ -0,0 +1,14 @@
1+%default total
2+
3+MkThing : Bool -> Type
4+MkThing True = Nat
5+MkThing False = Bool
6+
7+testCov : (x : Bool) -> MkThing x -> Nat
8+testCov False False = ?testCov_rhs_3
9+testCov False True = ?testCov_rhs_4
10+
11+testCov' : (x : Bool ** MkThing x) -> Nat
12+testCov' (False ** False) = ?testCov_rhs_3
13+testCov' (False ** True) = ?testCov_rhs_4
14+
test/totality019/totality019a.idrnew file+81
@@ -0,0 +1,81 @@
1+module Test
2+
3+import Data.Vect
4+%default total
5+
6+genT : Vect n Type -> Type
7+genT [] = Type
8+genT (x :: xs) = x -> genT xs
9+
10+data FunLang: Type where
11+ Atom : {dt : Vect n Type} -> genT dt -> FunLang
12+ And : FunLang -> FunLang -> FunLang
13+ Uor : FunLang -> FunLang -> FunLang
14+ Xor : FunLang -> FunLang -> FunLang -- d decides on that
15+
16+data IndexFL : FunLang -> FunLang -> Type where
17+ LHere : IndexFL fl fl
18+ LLeftAnd : IndexFL x rfl -> IndexFL (And x y) rfl
19+ LRightAnd : IndexFL y rfl -> IndexFL (And x y) rfl
20+ LLeftUor : IndexFL x rfl -> IndexFL (Uor x y) rfl
21+ LRightUor : IndexFL y rfl -> IndexFL (Uor x y) rfl
22+ LLeftXor : IndexFL x rfl -> IndexFL (Xor x y) rfl
23+ LRightXor : IndexFL y rfl -> IndexFL (Xor x y) rfl
24+
25+data SetFL : FunLang -> Type where
26+ SEmpty : SetFL fl
27+ SElem : SetFL fl
28+ SLeftAnd : SetFL x -> SetFL (And x y)
29+ SRightAnd : SetFL y -> SetFL (And x y)
30+ SBothAnd : SetFL x -> SetFL y -> SetFL (And x y)
31+ SLeftUor : SetFL x -> SetFL (Uor x y)
32+ SRightUor : SetFL y -> SetFL (Uor x y)
33+ SBothUor : SetFL x -> SetFL y -> SetFL (Uor x y)
34+ SLeftXor : SetFL x -> SetFL (Xor x y)
35+ SRightXor : SetFL y -> SetFL (Xor x y)
36+ SBothXor : SetFL x -> SetFL y -> SetFL (Xor x y)
37+
38+addIndexFLEmpty : IndexFL fl _ -> SetFL fl
39+addIndexFLEmpty LHere = SElem
40+addIndexFLEmpty (LLeftAnd z) = SLeftAnd $ addIndexFLEmpty z
41+addIndexFLEmpty (LRightAnd z) = SRightAnd $ addIndexFLEmpty z
42+addIndexFLEmpty (LLeftUor z) = SLeftUor $ addIndexFLEmpty z
43+addIndexFLEmpty (LRightUor z) = SRightUor $ addIndexFLEmpty z
44+addIndexFLEmpty (LLeftXor z) = SLeftXor $ addIndexFLEmpty z
45+addIndexFLEmpty (LRightXor z) = SRightXor $ addIndexFLEmpty z
46+
47+addIndexFL : SetFL fl -> IndexFL fl _ -> SetFL fl
48+addIndexFL SEmpty y = addIndexFLEmpty y
49+addIndexFL SElem y = SElem
50+addIndexFL x LHere = SElem
51+addIndexFL (SLeftAnd x) (LLeftAnd w) = SLeftAnd $ addIndexFL x w
52+addIndexFL (SLeftAnd SElem) (LRightAnd LHere) = SElem
53+addIndexFL (SLeftAnd x) (LRightAnd w) = SBothAnd x (addIndexFLEmpty w)
54+addIndexFL (SRightAnd SElem) (LLeftAnd LHere) = SElem
55+addIndexFL (SRightAnd x) (LLeftAnd w) = SBothAnd (addIndexFLEmpty w) x
56+addIndexFL (SRightAnd x) (LRightAnd w) = SRightAnd $ addIndexFL x w
57+addIndexFL (SBothAnd x SElem) (LLeftAnd LHere) = SElem
58+addIndexFL (SBothAnd SElem y) (LRightAnd LHere) = SElem
59+addIndexFL (SBothAnd x y) (LLeftAnd w) = SBothAnd (addIndexFL x w) y
60+addIndexFL (SBothAnd x y) (LRightAnd w) = SBothAnd x (addIndexFL y w)
61+addIndexFL (SLeftUor x) (LLeftUor w) = SLeftUor $ addIndexFL x w
62+addIndexFL (SLeftUor SElem) (LRightUor LHere) = SElem
63+addIndexFL (SLeftUor x) (LRightUor w) = SBothUor x (addIndexFLEmpty w)
64+addIndexFL (SRightUor SElem) (LLeftUor LHere) = SElem
65+addIndexFL (SRightUor x) (LLeftUor w) = SBothUor (addIndexFLEmpty w) x
66+addIndexFL (SRightUor x) (LRightUor w) = SRightUor $ addIndexFL x w
67+addIndexFL (SBothUor x SElem) (LLeftUor LHere) = SElem
68+addIndexFL (SBothUor SElem y) (LRightUor LHere) = SElem
69+addIndexFL (SBothUor x y) (LLeftUor w) = SBothUor (addIndexFL x w) y
70+addIndexFL (SBothUor x y) (LRightUor w) = SBothUor x (addIndexFL y w)
71+addIndexFL (SLeftXor x) (LLeftXor w) = SLeftXor $ addIndexFL x w
72+addIndexFL (SLeftXor SElem) (LRightXor LHere) = SElem
73+addIndexFL (SLeftXor x) (LRightXor w) = SBothXor x (addIndexFLEmpty w)
74+addIndexFL (SRightXor SElem) (LLeftXor LHere) = SElem
75+addIndexFL (SRightXor x) (LLeftXor w) = SBothXor (addIndexFLEmpty w) x
76+addIndexFL (SRightXor x) (LRightXor w) = SRightXor $ addIndexFL x w
77+addIndexFL (SBothXor x SElem) (LLeftXor LHere) = SElem
78+addIndexFL (SBothXor SElem y) (LRightXor LHere) = SElem
79+addIndexFL (SBothXor x y) (LLeftXor w) = SBothXor (addIndexFL x w) y
80+addIndexFL (SBothXor x y) (LRightXor w) = SBothXor x (addIndexFL y w)
81+
test/unique001/unique001.idr+2
@@ -1,5 +1,7 @@
1module Main
1module Main
2
2
3+%language UniquenessTypes
4+
3data UList : Type -> UniqueType where
5data UList : Type -> UniqueType where
4 Nil : UList a
6 Nil : UList a
5 (::) : a -> UList a -> UList a
7 (::) : a -> UList a -> UList a
test/unique004/expected+10−10
@@ -1,26 +1,26 @@
1−unique001a.idr:33:11:Type mismatch between
1+unique001a.idr:35:11:Type mismatch between
2 Int -> String
2 Int -> String
3and
3and
4 UniqueType (Int -> String)
4 UniqueType (Int -> String)
5−unique001a.idr:44:12:Type mismatch between
5+unique001a.idr:46:12:Type mismatch between
6 Int -> String
6 Int -> String
7and
7and
8 UniqueType (Int -> String)
8 UniqueType (Int -> String)
9−unique001a.idr:55:12:Type mismatch between
9+unique001a.idr:57:12:Type mismatch between
10 UniqueType (Int -> String)
10 UniqueType (Int -> String)
11and
11and
12 Int -> String
12 Int -> String
13−unique001b.idr:16:7:Borrowed name xs must not be used on RHS
13+unique001b.idr:18:7:Borrowed name xs must not be used on RHS
14−unique001c.idr:46:6:Unique name f is used more than once
14+unique001c.idr:47:6:Unique name f is used more than once
15−unique001d.idr:3:7:Borrowed name x must not be used on RHS
15+unique001d.idr:4:7:Borrowed name x must not be used on RHS
16−unique001e.idr:3:10:
16+unique001e.idr:4:10:
17Constructor Main.Nil has a UniqueType, but the data type does not
17Constructor Main.Nil has a UniqueType, but the data type does not
18−unique002.idr:15:5:Unique name xs is used more than once
18+unique002.idr:17:5:Unique name xs is used more than once
19−unique002a.idr:15:5:Type mismatch between
19+unique002a.idr:17:5:Type mismatch between
20 Int -> String
20 Int -> String
21and
21and
22 UniqueType (Int -> String)
22 UniqueType (Int -> String)
23−unique003.idr:18:5:Type mismatch between
23+unique003.idr:20:5:Type mismatch between
24 Int -> String
24 Int -> String
25and
25and
26 UniqueType (Int -> String)
26 UniqueType (Int -> String)
test/unique004/unique001a.idr+2
@@ -1,5 +1,7 @@
1module Main
1module Main
2
2
3+%language UniquenessTypes
4+
3data UList : Type -> UniqueType where
5data UList : Type -> UniqueType where
4 Nil : UList a
6 Nil : UList a
5 (::) : a -> UList a -> UList a
7 (::) : a -> UList a -> UList a
test/unique004/unique001b.idr+2
@@ -1,5 +1,7 @@
1module Main
1module Main
2
2
3+%language UniquenessTypes
4+
3data UList : Type -> UniqueType where
5data UList : Type -> UniqueType where
4 Nil : UList a
6 Nil : UList a
5 (::) : a -> UList a -> UList a
7 (::) : a -> UList a -> UList a
test/unique004/unique001c.idr+1
@@ -1,3 +1,4 @@
1+%language UniquenessTypes
1
2
2data UList : Type -> UniqueType where
3data UList : Type -> UniqueType where
3 UNil : UList a
4 UNil : UList a
test/unique004/unique001d.idr+1
@@ -1,3 +1,4 @@
1+%language UniquenessTypes
1
2
2steal : {a : UniqueType} -> Borrowed a -> a
3steal : {a : UniqueType} -> Borrowed a -> a
3steal (Read x) = x
4steal (Read x) = x
test/unique004/unique001e.idr+1
@@ -1,3 +1,4 @@
1+%language UniquenessTypes
1
2
2data BadList : UniqueType -> Type where
3data BadList : UniqueType -> Type where
3 Nil : {a : UniqueType} -> BadList a
4 Nil : {a : UniqueType} -> BadList a
test/unique004/unique002.idr+2
@@ -1,3 +1,5 @@
1+%language UniquenessTypes
2+
1data UList : Type -> UniqueType where
3data UList : Type -> UniqueType where
2 Nil : UList a
4 Nil : UList a
3 (::) : a -> UList a -> UList a
5 (::) : a -> UList a -> UList a
test/unique004/unique002a.idr+2
@@ -1,3 +1,5 @@
1+%language UniquenessTypes
2+
1data UList : Type -> UniqueType where
3data UList : Type -> UniqueType where
2 Nil : UList a
4 Nil : UList a
3 (::) : a -> UList a -> UList a
5 (::) : a -> UList a -> UList a
test/unique004/unique003.idr+2
@@ -1,5 +1,7 @@
1module Main
1module Main
2
2
3+%language UniquenessTypes
4+
3data UList : Type -> UniqueType where
5data UList : Type -> UniqueType where
4 Nil : UList a
6 Nil : UList a
5 (::) : a -> UList a -> UList a
7 (::) : a -> UList a -> UList a