d77753d · Idris-dev · git.iko.soy

.travis.yml+99−29

compare with master

unifiedsplit

@@ -1,23 +1,95 @@

1+sudo: false

2+

1−language: haskell

3+language: c

4+

5+addons:

6+ apt:

7+ sources:

2−ghc:

8+ - hvr-ghc

3− # Idris won't build on 7.4 and earlier due to dependency

9+ packages:

4− # problems. 7.10 isn't yet supported on Travis.

10+ - ghc-7.6.3

5− - 7.6

11+ - ghc-7.8.4

6− - 7.8

12+ - ghc-7.10.2

13+ - cabal-install-1.20

14+ - cabal-install-1.22

15+ # test dependencies

16+ - expect

17+ - cppcheck

18+ - hscolour

19+

20+matrix:

21+ include:

22+ - env: CABALVER="1.20" GHCVER="7.6.3" TESTS="test_c"

23+ # separate caches for different compiler versions

24+ # until https://github.com/travis-ci/travis-ci/issues/4393 is resolved

25+ compiler: ": #GHC 7.6.3"

26+ - env: CABALVER="1.20" GHCVER="7.8.4" TESTS="lib_doc doc"

27+ compiler: ": #GHC 7.8.4"

28+ - env: CABALVER="1.20" GHCVER="7.8.4" TESTS="test_js"

29+ compiler: ": #GHC 7.8.4"

30+ - env: CABALVER="1.20" GHCVER="7.8.4" TESTS="test_c"

31+ compiler: ": #GHC 7.8.4"

32+ - env: CABALVER="1.22" GHCVER="7.10.2" TESTS="lib_doc doc"

33+ compiler: ": #GHC 7.10.2"

34+ - env: CABALVER="1.22" GHCVER="7.10.2" TESTS="test_js"

35+ compiler: ": #GHC 7.10.2"

36+ - env: CABALVER="1.22" GHCVER="7.10.2" TESTS="test_c"

37+ compiler: ": #GHC 7.10.2"

38+

39+cache:

40+ directories:

41+ - $HOME/.cabsnap

42+ - $HOME/.cabal/packages

43+

44+before_cache:

45+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

46+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

7

47

8before_install:

48before_install:

9− - sudo apt-get update -qq

49+ - unset CC

10− - sudo apt-get install -qq libghc-unordered-containers-dev libghc-mtl-dev libghc-network-dev libghc-transformers-dev libghc-text-dev libghc-utf8-string-dev libghc-vector-dev libghc-split-dev libghc-ansi-terminal-dev libghc-ansi-wl-pprint-dev

50+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH

11− # trifecta dependencies

51+ - env

12− - sudo apt-get install -qq libghc-blaze-builder-dev libghc-blaze-html-dev libghc-bifunctors-dev libghc-hashable-dev libghc-semigroups-dev libghc-semigroupoids-dev libghc-parallel-dev libghc-comonad-dev libghc-terminfo-dev libghc-keys-dev

52+

13− # Haddock dependencies

14− - sudo apt-get install hscolour

15− # test dependency

16− - sudo apt-get install -qq expect

17− - sudo apt-get install -qq cppcheck

18install:

53install:

19− - cabal install -f FFI --enable-tests --dependencies-only --max-backjumps=-1

54+ - cabal --version

20− - ghc-pkg list

55+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

56+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];

57+ then

58+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >

59+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

60+ fi

61+ - travis_retry cabal update -v

62+ # Run build with 2 parallel jobs

63+ # The container environment reports 16 cores,

64+ # causing cabal's default configuration (jobs: $ncpus)

65+ # to run into the GHC #9221 bug which can result in longer build-times.

66+ - sed -i -r 's/(^jobs:).*/\1 2/' $HOME/.cabal/config

67+ - cabal install -f FFI --only-dependencies --enable-tests --dry -v > installplan.txt

68+ - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt

69+

70+ # check whether current requested install-plan matches cached package-db snapshot

71+ - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;

72+ then

73+ echo "cabal build-cache HIT";

74+ rm -rfv .ghc;

75+ cp -a $HOME/.cabsnap/ghc $HOME/.ghc;

76+ cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;

77+ else

78+ echo "cabal build-cache MISS";

79+ rm -rf $HOME/.cabsnap;

80+ mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;

81+ cabal install -f FFI --only-dependencies --enable-tests;

82+ fi

83+

84+ # snapshot package-db on cache miss

85+ - if [ ! -d $HOME/.cabsnap ];

86+ then

87+ echo "snapshotting package-db to build-cache";

88+ mkdir $HOME/.cabsnap;

89+ cp -a $HOME/.ghc $HOME/.cabsnap/ghc;

90+ cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

91+ fi

92+

21before_script:

93before_script:

22 - cabal sdist

94 - cabal sdist

23 - cd ..

95 - cd ..

@@ -25,15 +97,13 @@ before_script:

25 - cd idris*

97 - cd idris*

26script:

98script:

27 - cabal configure -f FFI -f CI

99 - cabal configure -f FFI -f CI

28− - if [[ "$TESTS" != "doc" ]]; then cabal build; fi

100+ - cabal build

29− - if [[ "$TESTS" != "doc" ]]; then cabal copy; fi

101+ - cabal copy

30− - if [[ "$TESTS" != "doc" ]]; then cabal register; fi

102+ - cabal register

31− - if [[ "$TESTS" == "test_c" ]]; then cppcheck -j 2 --error-exitcode=1 ./rts/idris_bitstring.c ./rts/idris_bitstring.h ./rts/idris_gc.h ./rts/idris_gc.c ./rts/idris_gmp.h ./rts/idris_gmp.c ./rts/idris_heap.h ./rts/idris_heap.c ./rts/idris_main.c ./rts/idris_net.h ./rts/idris_net.c ./rts/idris_opts.h ./rts/idris_opts.c ./rts/idris_rts.h ./rts/idris_rts.c ./rts/idris_stats.h ./rts/idris_stats.c ./rts/idris_stdfgn.h ./rts/idris_stdfgn.c ./rts/libtest.c ; fi

103+ - if [[ "$TESTS" == "test_c" ]]; then

32− - if [[ "$TESTS" == "test_llvm" ]]; then git clone --depth 1 https://github.com/idris-hackers/idris-llvm.git ; cd idris-llvm ; cabal install ; cd .. ; fi

104+ cppcheck -i 'mini-gmp.c' rts;

105+ fi

106+ - for test in $TESTS; do

33− - make -j2 $TESTS

107+ echo "make -j2 $test";

34−env:

108+ make -j2 $test;

35− - TESTS="doc"

109+ done

36− - TESTS="lib_doc"

37− - TESTS="test_c"

38− #- TESTS="test_llvm"

39− - TESTS="test_js"

CHANGELOG+33−5

@@ -1,3 +1,17 @@

1+New in 0.9.21:

2+==============

3+

4+* Idris' logging infrastructure has been categorised. Command line and repl

5+ are available. For command line the option `--logging-categories CATS`

6+ is used to pass in the categories. Here `CATS` is a colon separated quoted

7+ string containing the categories to log. The REPL command is `logcats CATS`.

8+ Where `CATS` is a whitespace separated list of categoriese. Default is for

9+ all categories to be logged.

10+* New flag `--listlogcats` to list logging categories.`

11+* Dependent pairs now can be specified using a telescope-style syntax, without

12+ requirement of nesting, e.g. it is possible to now write the following:

13+ (a : Type ** n : Nat ** Vect n a)

14+

1New in 0.9.20:

15New in 0.9.20:

2==============

16==============

3

17

@@ -16,10 +30,11 @@ Language updates

16 valid unbound implicit is now *always* an unbound implicit. This is much

30 valid unbound implicit is now *always* an unbound implicit. This is much

17 more resilient to changes in inputs, but does require that function names

31 more resilient to changes in inputs, but does require that function names

18 be explicitly qualified when in argument position.

32 be explicitly qualified when in argument position.

19−* Dependent pairs now can be specified using a telescope-style syntax, without

33+* Name binding in patterns follows the same rule as name binding for implicits

20− requirement of nesting, e.g. it is possible to now write the following:

34+ in types: names which begin with lower case letters, not applied to any

21− (a : Type ** n : Nat ** Vect n a)

35+ arguments, are treated as bound pattern variables.

22−

36+* Added %deprecate directive, which gives a warning and a message when a

37+ deprecated name is referenced.

23

38

24Library updates

39Library updates

25---------------

40---------------

@@ -34,6 +49,13 @@ Library updates

34 programmes.

49 programmes.

35* Elaborator reflection is now a part of the prelude. It is no longer

50* Elaborator reflection is now a part of the prelude. It is no longer

36 necessary to import Language.Reflection.Elab.

51 necessary to import Language.Reflection.Elab.

52+* The `PERF` effect allows for simple performance metrics to be collected

53+ from Effectful programs.

54+* Some constructors that never actually occurred have been removed from

55+ the TT and Raw reflection datatypes in Language.Reflection.

56+* File IO operations (for example openFile/fread/fwrite) now return

57+ 'Either FileError ty' where the return type was previously 'ty' to indicate

58+ that they may fail.

37

59

38Tool updates

60Tool updates

39------------

61------------

@@ -41,7 +63,13 @@ Tool updates

41 datatype

63 datatype

42* iPKG files have a new option `pkgs` which takes a comma-separated list

64* iPKG files have a new option `pkgs` which takes a comma-separated list

43 of package names that the idris project depends on. This reduces bloat

65 of package names that the idris project depends on. This reduces bloat

44− in the `opts` option with mutliple package declarations.

66+ in the `opts` option with multiple package declarations.

67+* iPKG files now allow `executable = "your filename here"` in addition to

68+ the existing `executable = yourFilenameHere` style. While the unquoted

69+ version is limited to filenames that look like namespaced Idris identifiers

70+ (`your.filename.here`), the quoted version accepts any valid filename.

71+* Add definition command (\d in Vim, Ctrl-Alt-A in Atom, C-c C-s in Emacs) now

72+ adds missing clauses if there is already a definition.

45

73

46Miscellaneous updates

74Miscellaneous updates

47---------------------

75---------------------

CONTRIBUTING.md+1−1

@@ -166,4 +166,4 @@ To help increase the chance of your pull request being accepted:

166* [General GitHub Documentation](https://help.github.com/).

167

168

169−Adapted from the most excellent contributing files from the [Puppet project](https://github.com/puppetlabs/puppet) and [Factroy Girl Rails](https://github.com/thoughtbot/factory_girl_rails/blob/master/CONTRIBUTING.md)

169+Adapted from the most excellent contributing files from the [Puppet project](https://github.com/puppetlabs/puppet) and [Factory Girl Rails](https://github.com/thoughtbot/factory_girl_rails/blob/master/CONTRIBUTING.md)

CONTRIBUTORS+2

@@ -15,6 +15,7 @@ Jason Dagit

15Guglielmo Fachini

16Simon Fowler

17Google

18+Zack Grannan

18Cezar Ionescu

19Cezar Ionescu

19Heath Johns

20Heath Johns

20Irene Knapp

21Irene Knapp

@@ -35,6 +36,7 @@ Adam Sandberg Eriksson

35Seo Sanghyeon

36Seo Sanghyeon

36Benjamin Saunders

37Benjamin Saunders

37Alexander Shabalin

38Alexander Shabalin

39+Jeremy W. Sherman

38Timo Petteri Sinnemäki

40Timo Petteri Sinnemäki

39JP Smith

41JP Smith

40startling

42startling

INSTALL.mdnew file+99

@@ -0,0 +1,99 @@

1+# Idris Installation Guide

2+

4+

5+## Installing Idris from Hackage

6+

7+This repository represents the latest development version of the

8+language, and may contain bugs that are being actively worked on. For

9+those who wish to use a more stable version of Idris please consider

10+installing the latest version that has been released on Hackage.

11+Installation instructions for various platforms can be

12+[found on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installation-Instructions).

13+

14+## Installing Development Versions

15+

16+If you like to work against the latest development version, please

17+consider using Cabal Sandboxes to minimise disruption to your local

18+Haskell setup. Instructions for installing Idris HEAD within a cabal

19+sandbox are

20+[available on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installing-an-Idris-Development-version-in-a-sandbox).

21+

22+To configure, edit config.mk. The default values should work for most

23+people.

24+

25+Idris is built using a Makefile common targets include:

26+

27+* `make` This will install everything using cabal and typecheck the

28+ libraries.

29+* `make test` This target execute the test suite.

30+* `make relib` This target will typecheck and recompile the standard

31+ library.

32+

33+Idris has an optional dependency on the `C` library `libffi`. If you

34+would like to use the features that it enables, make sure that it is

35+compiled for the same architecture as your Haskell compiler (e.g. 64

36+bit libraries for 64 bit ghc). By default, Idris builds without it. To

37+build with it, pass the flag `-f FFI`.

38+

39+A secondary optional dependency is on `libGMP`, this allows better

40+support for numeric operations. As with `libFFI` Idris builds with out

41+it, to enable `GMP` support use the flag `-f GMP`

42+

43+To build with `libffi` and `libGMP` by default, create a `custom.mk`

44+file and add the following line to it:

45+

46+`CABALFLAGS += -f FFI -f GMP`

47+

48+The file `custom.mk-alldeps` is a suitable example.

49+

50+The continuous integration builds on travis-ci.org are built using the

51+ghc-flag -Werror. To enable this behaviour locally also, please

52+compile using `make CI=true` or adding the following line into

53+`custom.mk`:

54+

55+`CI = true`

56+

57+If you are only compiling for installing the most current version, you

58+can omit the CI flag, but please make sure you use it if you want to

59+contribute.

60+

61+## Experimental Support for Building with Stack

62+

63+[Stack](https://github.com/commercialhaskell/stack) is a new

64+cross-platform program for developing Haskell projects, that enhances

65+the functionality provided by Cabal. There is experimental support for

66+building Idris from source using with stack, that uses the LTS 3.16

67+resolver. This installation has been tested on Ubuntu 14.04.2 LTS,

68+only.

69+

70+To build Idris with stack the following commands are recommended:

71+

72+* `stack build`

73+

74+This will install Idris (and related executables) into `./local/bin/`

75+on Unix based systems and an appropriate place on Windows. If you

76+haven't used stack before this will also setup the related

77+infrastructure. For more information about Stack please visit the

78+[Stack website](https://github.com/commercialhaskell/stack).

79+

80+### System GHC

81+

82+The flag `--system-ghc` can be added to enforce use of your system's

83+version of GHC.

84+

85+### `libGMP` and `libFFI`

86+

87+By default the stack configuration in `stack.yaml` will build with

88+support for `libGMP` and `libFFI`. To turn this support off, the

89+option flags needs to be fully commented out.

90+

91+There have been reports in the past over building Idris on Mac OS X,

92+using stack, and linking to a HomeBrew installation of `libFFI`. The

93+build has failed to find the correct `libFFI` installation. If you

94+encounter this then the fix is to augment the `PKG_CONFIG_PATH` when

95+running the stack build:

96+

97+```

98+PKG_CONFIG_PATH=/usr/local/Cellar/libffi/3.0.13/lib/pkgconfig stack build

99+```

Makefile+4−1

@@ -36,6 +36,9 @@ test_all:

36 $(MAKE) test_llvm

37 $(MAKE) test_java

38

39+test_timed:

40+ $(MAKE) -C test IDRIS=../dist/build/idris time

41+

39lib_clean:

42lib_clean:

40 $(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean

43 $(MAKE) -C libs IDRIS=../../dist/build/idris/idris RTS=../../dist/build/rts/libidris_rts clean

41

44

@@ -43,7 +46,7 @@ relib: lib_clean

43 $(CABAL) install $(CABALFLAGS)

46 $(CABAL) install $(CABALFLAGS)

44

47

45linecount:

48linecount:

46− wc -l src/Idris/*.hs src/Idris/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs

49+ wc -l src/Idris/*.hs src/Idris/Elab/*.hs src/Idris/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs src/Util/*.hs

47

50

48#Note: this doesn't yet link to Hackage properly

51#Note: this doesn't yet link to Hackage properly

49doc: dist/setup-config

52doc: dist/setup-config

README.md+8−42

@@ -7,50 +7,16 @@

7Idris (http://idris-lang.org/) is a general-purpose functional programming

8language with dependent types.

9

10−## Standard Installation Instructions

10+## Installation Guides.

11−This repository represents the latest development version of the language,

12−and may contain bugs that are being actively worked on.

13−For those who wish to use a more stable version of Idris please consider

14−installing the latest version that has been released on Hackage.

15−Installation instructions for various platforms can be [found on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installation-Instructions).

16−

17−## Installing Development Versions

18−

19−If you like to work against the latest development version, please consider

20−using Cabal Sandboxes to minimise disruption to your local Haskell setup.

21−Instructions for installing Idris HEAD within a cabal sandbox are

22−[available on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installing-an-Idris-Development-version-in-a-sandbox).

23−

24−To configure, edit config.mk. The default values should work for most people.

25−

26−Idris is built using a Makefile common targets include:

27−

28−* `make` This will install everything using cabal and

29−typecheck the libraries.

30−* `make test` This target execute the test suite.

31−* `make relib` This target will typecheck and recompile the standard library.

32

11

33−Idris has an optional buildtime dependency on the C library `libffi`. If you

12+This repository represents the latest development version of the

34−would like to use the features that it enables, make sure that it is compiled

13+language, and may contain bugs that are being actively worked on. For

35−for the same architecture as your Haskell compiler (e.g. 64 bit libraries

14+those who wish to use a more stable version of Idris please consider

36−for 64 bit ghc). By default, Idris builds without it. To build with it, pass

15+installing the latest version that has been released on Hackage.

37−the flag `-f FFI`.

16+Installation instructions for various platforms can be

38−

17+[found on the Idris Wiki](https://github.com/idris-lang/Idris-dev/wiki/Installation-Instructions).

39−To build with `libffi` by default, create a `custom.mk` file and add the

40−following line to it:

41−

42−`CABALFLAGS += -f FFI`

43−

44−The file custom.mk-alldeps is a suitable example.

45−

46−The continuous integration builds on travis-ci.org are built using the

47−ghc-flag -Werror. To enable this behaviour locally also, please compile

48−using `make CI=true` or adding the following line into `custom.mk`:

49−

50−`CI = true`

51

18

52−If you are only compiling for installing the most current version, you can

19+More information about building Idris from source has been detailed in the [Installation Guide](INSTALL.md)

53−omit the CI flag, but please make sure you use it if you want to contribute.

54

20

55## Code Generation

21## Code Generation

56

22

docs/conf.py+2−2

@@ -59,9 +59,9 @@ author = u'The Idris Community'

59# built documents.

60#

61# The short X.Y version.

62−version = '0.9.18'

62+version = '0.9.19'

63# The full version, including alpha/beta/rc tags.

64−release = '0.9.18'

64+release = '0.9.19.1'

65

66# The language for content autogenerated by Sphinx. Refer to documentation

67# for a list of supported languages.

docs/effects/depeff.rst+2−2

@@ -48,7 +48,7 @@ express this as follows:

48 readInt = do let x = trim !getStr

49 putM (cast x :: !get)

50

51−The notation ``{ xs ==> xs’ } Eff a`` in a type means that the operation

51+The type ``Eff a xs xs'`` means that the operation

52begins with effects ``xs`` available, and ends with effects ``xs’``

53available. We have used ``putM`` to update the state, where the ``M``

54suffix indicates that the *type* is being updated as well as the value.

@@ -96,7 +96,7 @@ value read from the user was valid. We can express this in the type:

96 else [STATE (Vect n Int), STDIO])

97 readInt = do let x = trim !getStr

98 case all isDigit (unpack x) of

99− False => pure False

99+ False => pureM False

100 True => do putM (cast x :: !get)

101 pureM True

102

docs/effects/hangman.rst+8−9

@@ -108,16 +108,15 @@ effect signature:

108 Guess : (x : Char) ->

109 sig MysteryRules Bool

110 (Mystery (Running (S g) (S w)))

111− (\inword =>

111+ (\inword => if inword

112− Mystery (case inword of

113− True => (Running (S g) w)

112+ then Mystery (Running (S g) w)

114− False => (Running g (S w))))

113+ else Mystery (Running g (S w)))

115 Won : sig MysteryRules () (Mystery (Running g 0))

114 Won : sig MysteryRules () (Mystery (Running g 0))

116 (Mystery NotRunning)

115 (Mystery NotRunning)

117 Lost : sig MysteryRules () (Mystery (Running 0 g))

116 Lost : sig MysteryRules () (Mystery (Running 0 g))

118 (Mystery NotRunning)

117 (Mystery NotRunning)

119 NewWord : (w : String) ->

118 NewWord : (w : String) ->

120− sig MysteryRules () h (Mystery (Running 6 (length (letters w))))

119+ sig MysteryRules () (Mystery NotRunning) (Mystery (Running 6 (length (letters w))))

121 Get : sig MysteryRules String (Mystery h)

120 Get : sig MysteryRules String (Mystery h)

122

121

123This description says nothing about how the rules are implemented. In

122This description says nothing about how the rules are implemented. In

@@ -243,11 +242,11 @@ running ``game``:

243.. code-block:: idris

242.. code-block:: idris

244

243

245 runGame : Eff () [MYSTERY NotRunning, RND, SYSTEM, STDIO]

244 runGame : Eff () [MYSTERY NotRunning, RND, SYSTEM, STDIO]

246− runGame = do srand (cast !time)

245+ runGame = do srand !time

247− let w = index !(rndFin WEWEWE) words

246+ let w = index !(rndFin _) words

248− NewWord w

247+ call $ NewWord w

249 game

248 game

250− putStrLn !Get

249+ putStrLn !(call Get)

251

250

252We use the system time (``time`` from the ``SYSTEM`` effect; see

251We use the system time (``time`` from the ``SYSTEM`` effect; see

253Appendix :ref:`sect-appendix`) to initialise the random number

252Appendix :ref:`sect-appendix`) to initialise the random number

docs/effects/impleff.rst+1−1

@@ -282,7 +282,7 @@ value.

282Here, the continuation is called multiple times in each handler, for

283each value in the list of possible values. In the ``List`` handler, we

284accumulate all successful results, and in the ``Maybe`` handler we try

285−the first value in the last, and try later values only if that fails.

285+the first value in the list, and try later values only if that fails.

286

287File Management

288===============

docs/effects/simpleeff.rst+23−22

@@ -382,7 +382,7 @@ definition:

382

383 vadd : Vect n Int -> Vect n Int -> Vect n Int

384 vadd [] [] = []

385− vadd (x :: idris xs) (y :: ys) = x + y :: vadd xs ys

385+ vadd (x :: xs) (y :: ys) = x + y :: vadd xs ys

386

387Using , we can set up a program so that it reads input from a user,

388checks that the input is valid (i.e both vectors contain integers, and

@@ -410,10 +410,28 @@ following type:

410

411This returns a dependent pair of a length, and a vector of that

412length, because we cannot know in advance how many integers the user

413−is going to input. One way to implement this function, using ``-1`` to

414−indicate the end of input, is shown in Listing [readvec]. This uses a

413+is going to input. We can use ``-1`` to indicate the end of input:

414+

415+.. code-block:: idris

416+

417+ read_vec : Eff (p ** Vect p Int) [STDIO]

418+ read_vec = do putStr "Number (-1 when done): "

419+ case run (parseNumber (trim !getStr)) of

420+ Nothing => do putStrLn "Input error"

421+ read_vec

422+ Just v => if (v /= -1)

423+ then do (_ ** xs) <- read_vec

424+ pure (_ ** v :: xs)

425+ else pure (_ ** [])

426+ where

427+ parseNumber : String -> Eff Int [EXCEPTION String]

428+ parseNumber str

429+ = if all (\x => isDigit x || x == '-') (unpack str)

430+ then pure (cast str)

431+ else raise "Not a number"

432+

415−variation on ``parseNumber`` which does not require a number to be

433+This uses a variation on ``parseNumber`` which does not require a

416−within range.

434+number to be within range.

417

435

418Finally, we write a program which reads two vectors and prints the

436Finally, we write a program which reads two vectors and prints the

419result of pairwise addition of them, throwing an exception if the

437result of pairwise addition of them, throwing an exception if the

@@ -434,23 +452,6 @@ equal. This does not stop us reading vectors from user input, but it

434does require that the lengths are checked and any discrepancy is dealt

452does require that the lengths are checked and any discrepancy is dealt

435with gracefully.

453with gracefully.

436

454

437−.. code-block:: idris

438−

439− read_vec : Eff (p ** Vect p Int) [STDIO]

440− read_vec = do putStr "Number (-1 when done): "

441− case run (parseNumber (trim !getStr)) of

442− Nothing => do putStrLn "Input error"

443− read_vec

444− Just v => if (v /= -1)

445− then do (_ ** xs) <- read_vec

446− pure (_ ** v :: xs)

447− else pure (_ ** [])

448− where

449− parseNumber : String -> Eff Int [EXCEPTION String]

450− parseNumber str

451− = if all (\x => isDigit x || x == '-') (unpack str)

452− then pure (cast str)

453− else raise "Not a number"

454

455

455Example: An Expression Calculator

456Example: An Expression Calculator

456=================================

457=================================

docs/faq/faq.rst+53

@@ -103,6 +103,59 @@ the difference between:

103 Idris> \n, m => n + (S m)

104 \n => \m => plus n (S m) : Nat -> Nat -> Nat

105

106+

107+Why can't I use a function with no arguments in a type?

108+=======================================================

109+

110+If you use a name in a type which begins with a lower case letter, and which is

111+not applied to any arguments, then Idris will treat it as an implicitly

112+bound argument. For example:

113+

114+.. code-block:: idris

115+

116+ append : Vect n ty -> Vect m ty -> Vect (n + m) ty

117+

118+Here, ``n``, ``m``, and ``ty`` are implicitly bound. This rule applies even

119+if there are functions defined elsewhere with any of these names. For example,

120+you may also have:

121+

122+.. code-block:: idris

123+

124+ ty : Type

125+ ty = String

126+

127+Even in this case, ``ty`` is still considered implicitly bound in the definition

128+of ``append``, rather than making the type of ``append`` equivalent to...

129+

130+.. code-block:: idris

131+

132+ append : Vect n String -> Vect m String -> Vect (n + m) String

133+

134+...which is probably not what was intended! The reason for this rule is so

135+that it is clear just from looking at the type of ``append``, and no other

136+context, what the implicitly bound names are.

137+

138+If you want to use an unapplied name in a type, you have two options. You

139+can either explicitly qualify it, for example, if ``ty`` is defined in the

140+namespace ``Main`` you can do the following:

141+

142+.. code-block:: idris

143+

144+ append : Vect n Main.ty -> Vect m Main.ty -> Vect (n + m) Main.ty

145+

146+Alternatively, you can use a name which does not begin with a lower case

147+letter, which will never be implicitly bound:

148+

149+.. code-block:: idris

150+

151+ Ty : Type

152+ Ty = String

153+

154+ append : Vect n Ty -> Vect m Ty -> Vect (n + m) Ty

155+

156+As a convention, if a name is intended to be used as a type synonym, it is

157+best for it to begin with a capital letter to avoid this restriction.

158+

106I have an obviously terminating program, but Idris says it possibly isn't total. Why is that?

159I have an obviously terminating program, but Idris says it possibly isn't total. Why is that?

107=============================================================================================

160=============================================================================================

108

161

docs/index.rst+5−108

@@ -16,115 +16,12 @@ Documentation for the Idris Language

16 More information concerning the CC0 can be found online at: http://creativecommons.org/publicdomain/zero/1.0/

17

18

19−* :ref:`tutorial-index`

20−* :ref:`eff-tutorial-index`

21−* :ref:`faq-index`

22−* :ref:`proofs-index`

23−* :ref:`reference-index`

24−* :ref:`guides-index`

25−

26−

27−.. _tutorial:

28−

29−###################

30−The Idris Tutorial

31−###################

32−

33−.. toctree::

34− :maxdepth: 1

35−

36− tutorial/introduction

37− tutorial/starting

38− tutorial/typesfuns

39− tutorial/classes

40− tutorial/modules

41− tutorial/packages

42− tutorial/testing

43− tutorial/interp

44− tutorial/views

45− tutorial/theorems

46− tutorial/provisional

47− tutorial/interactive

48− tutorial/syntax

49− tutorial/miscellany

50− tutorial/conclusions

51−

52−.. _faq:

53−

54−##########################

55−Frequently Asked Questions

56−##########################

57−

58.. toctree::

19.. toctree::

59 :maxdepth: 1

20 :maxdepth: 1

60

21

22+ tutorial/index

61 faq/faq

23 faq/faq

62−

63−.. _effects:

64−

65−################

66−Learning Effects

67−################

68−

69−.. toctree::

70− :maxdepth: 1

71−

72− effects/introduction

24+ effects/index

73− effects/state

74− effects/simpleeff

75− effects/depeff

76− effects/impleff

77− effects/hangman

78− effects/conclusions

79− effects/summary

80−

81−.. _proofs:

82−

83−###############

84−Theorem Proving

85−###############

86−

87−.. toctree::

88− :maxdepth: 1

89−

90− proofs/pluscomm

91− proofs/inductive

92− proofs/patterns

93− proofs/interactive

25+ proofs/index

94−

95−.. _reference:

96−

97−##################

98−Language Reference

99−##################

100−

101−.. toctree::

102− :maxdepth: 1

103−

104− reference/documenting

105− reference/packages

106− reference/uniqueness-types

107− reference/ffi

108− reference/syntax-guide

109− reference/erasure

110− reference/ide-protocol

111− reference/semantic-highlighting

112− reference/repl

113− reference/tactics

114− reference/compilation

115− reference/language-features

116− reference/language-extensions

117− reference/elaborator-reflection

118− reference/misc

26+ reference/index

119−

27+ guides/index

120−.. _guides:

121−

122−############

123−Short Guides

124−############

125−

126−.. toctree::

127− :maxdepth: 1

128−

129− guides/type-providers-ffi

130− guides/theorem-prover

docs/reference/compilation.rst+21−2

@@ -45,8 +45,27 @@ Use of this option will still result in the generation of the Idris binary ``.ib

45Logging Output

46==============

47

48−Logging of the Idris output can be used to diagnose problems with the compilation of your program.

48+The internal operation of Idris is captured using a category based logger.

49−Idris supports the logging at various different levels of verbosity: 1 to 10.

49+Currently, the logging infrastructure has support for the following categories:

50+

51++ Parser

52++ Elaborator

53++ Code generation

54++ Erasure

55++ Coverage Checking

56++ IBC generation

57+

58+

59+These categories are specified using the command-line option:

60+``--logging-categories CATS``, where ``CATS`` is a quoted colon

61+seperated string of the categories you want to see. By default if this

62+option is not specified all categories are allowed. Sub-categories

63+have yet to be defined but will be in the future, especially for the

64+elaborator.

65+

66+Further, the verbosity of logging can be controlled by specifying a

67+logging level between: 1 to 10 using the command-line option: ``--log

68+<level>``.

50

69

51+ Level 0: Show no logging output. Default level

70+ Level 0: Show no logging output. Default level

52+ Level 1: High level details of the compilation process.

71+ Level 1: High level details of the compilation process.

docs/reference/elaborator-reflection.rst+47−11

@@ -74,17 +74,53 @@ We can generate identity functions at any concrete type using the same script:

74Interactively Building Elab Scripts

75===================================

76

77−To build an ``Elab`` script interactively, use the ``:elab`` command at the REPL.

77+You can build an ``Elab`` script interactively at the REPL.

78−It takes the name of a hole as an argument.

78+Use the command ``:metavars``, or ``:m`` for short, to list the available holes.

79−To list all available holes, use the command ``:m``.

79+Then, issue the ``:elab <hole>`` command at the REPL

80+to enter the elaboration shell.

80

81

82+At the shell, you can enter proof tactics to alter the proof state.

83+You can view the system-provided tactics prior to entering the shell

84+by issuing the REPL command ``:browse Language.Reflection.Elab.Tactics``.

85+When you have discharged all goals, you can complete the proof

86+using the ``:qed`` command and receive in return an elaboration script

87+that fills the hole.

88+

81−In interactive elaboration shell, the following commands are available:

89+The interactive elaboration shell accepts a limited number of commands,

82−- ``:q`` - Quits the elaboration shell (gives up on proving current lemma).

90+including a subset of the commands understood by the normal Idris REPL

83−- ``:abandon`` - Same as :q

91+as well as some elaboration-specific commands.

92+

93+General-purpose commands:

94+

95+- ``:eval <EXPR>``, or ``:e <EXPR>`` for short, evaluates the provided expression

96+ and prints the result.

97+

98+- ``:type <EXPR>``, or ``:t <EXPR>`` for short, prints the provided expression

99+ together with its type.

100+

101+- ``:search <TYPE>`` searches for definitions having the provided type.

102+

103+- ``:doc <NAME>`` searches for definitions with the provided name and prints their

104+ documentation.

105+

106+

107+Commands for viewing the proof state:

108+

84−- ``:state`` - Displays the current state of the term being constructed.

109+- ``:state`` displays the current state of the term being constructed. It lists both

110+ other goals and the current goal.

111+

85−- ``:term`` - Displays the current proof term complete with its yet-to-be-filled holes.

112+- ``:term`` displays the current proof term as well as its yet-to-be-filled holes.

113+

114+

115+Commands for manipulating the proof state:

116+

86−- ``:undo`` - Undoes the last tactic.

117+- ``:undo`` undoes the effects of the last tactic.

87−- ``:qed`` - Once the elaboration shell tells you "No more goals," you get to type this in celebration! (Completes the construction and exits the shell)

118+

119+- ``:abandon`` gives up on proving the current lemma and quits the elaboration shell.

120+

121+- ``:qed`` finishes the script and exits the elaboration shell. The shell will only accept

122+ this command once it reports, "No more goals." On exit, it will print out the finished

123+ elaboration script for you to copy into your program.

88

124

89

125

90Failure

126Failure

@@ -127,7 +163,7 @@ If the goal type turns out to have been the unit type, we fill using the unit co

127Otherwise, we fail with an error message informing the user that the current goal is not trivial.

163Otherwise, we fail with an error message informing the user that the current goal is not trivial.

128

164

129Additionally, the elaboration state can be dumped into an error message with the ``debug`` tactic.

165Additionally, the elaboration state can be dumped into an error message with the ``debug`` tactic.

130−A variant, ``debugMessage``, allows arbitrary messages to be included with the state, allowing for a kind of "``printf`` debuggging" of elaboration scripts.

166+A variant, ``debugMessage``, allows arbitrary messages to be included with the state, allowing for a kind of "``printf`` debugging" of elaboration scripts.

131The message format used by ``debugMessage`` is the same for errors produced by the error reflection mechanism, allowing the re-use of the Idris pretty-printer when rendering messages.

167The message format used by ``debugMessage`` is the same for errors produced by the error reflection mechanism, allowing the re-use of the Idris pretty-printer when rendering messages.

132

168

133Changing the Global Context

169Changing the Global Context

docs/reference/repl.rst+2−1

@@ -128,7 +128,8 @@ The current set of supported commands are:

128+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

129|:? :h :help | | Display this help text |

130+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

131−|:set | <option> | Set an option (errorcontext, showimplicits) |

131+|:set | <option> | Set an option (errorcontext, showimplicits, originalerrors, autosolve, nobanner, warnreach, evaltypes, |

132+| | | desugarnats) |

132+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

133+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

133|:unset | <option> | Unset an option |

134|:unset | <option> | Unset an option |

134+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

135+----------------+------------------------------+----------------------------------------------------------------------------------------------------------+

docs/reference/syntax-guide.rst+4−1

@@ -112,7 +112,7 @@ Types

112

113In Idris, types are first class values. So a type declaration is the

114same as just declaration of a variable whose type is ``Type``. In Idris,

115−variables that denote a type must begin with a capital letter. Example:

115+variables that denote a type need not be capitalised. Example:

116

117.. code:: idris

118

@@ -126,6 +126,9 @@ a more interesting example:

126 MyListType : Type

127 MyListType = List Int

128

129+While capitalising types is not required, the rules for generating implicit

130+arguments mean it is often a good idea.

131+

129.. _syntax-data-types:

132.. _syntax-data-types:

130

133

131Data types

134Data types

docs/reference/tactics.rst+2−2

@@ -1,6 +1,6 @@

1−***************************

1+****************************************

2DEPRECATED: Tactics and Theorem Proving

3−***************************

3+****************************************

4

5.. warning::

6 The interactive theorem-proving interface documented here has been

docs/tutorial/interp.rst+9−6

@@ -32,11 +32,14 @@ calculated just like any other value:

32 interpTy TyBool = Bool

33 interpTy (TyFun A T) = interpTy A -> interpTy T

34

35−We’re going to define a representation of our language in such a way

35+We're going to define a representation of our language in such a way

36−that only well-typed programs can be represented. We’ll index the

36+that only well-typed programs can be represented. We'll index the

37−representations of expressions by their type and the types of local

37+representations of expressions by their type, **and** the types of

38−variables (the context), which we’ll be using regularly as an implicit

38+local variables (the context). The context can be represented using

39+the ``Vect`` data type, and as it will be used regularly it will be

39−argument, so we define everything in a ``using`` block:

40+represented as an implicit argument. To do so we define everything in

41+a ``using`` block (keep in mind that everything after this point needs

42+to be indented so as to be inside the ``using`` block):

40

43

41.. code-block:: idris

44.. code-block:: idris

42

45

@@ -151,7 +154,7 @@ that only the branch which is taken need be evaluated:

151Writing the Interpreter

154Writing the Interpreter

152=======================

155=======================

153

156

154−When we evaluate an ``Expr``, we’ll need to know the values in scope,

157+When we evaluate an ``Expr``, we'll need to know the values in scope,

155as well as their types. ``Env`` is an environment, indexed over the

158as well as their types. ``Env`` is an environment, indexed over the

156types in scope. Since an environment is just another form of list,

159types in scope. Since an environment is just another form of list,

157albeit with a strongly specified connection to the vector of local

160albeit with a strongly specified connection to the vector of local

docs/tutorial/introduction.rst+1−1

@@ -15,7 +15,7 @@ respectively:

15Correspondingly, the following values are examples of inhabitants of

16those types:

17

18−- ``42``, ``’a’``, ``Hello world!``, ``[2,3,4,5,6]``

18+- ``42``, ``’a’``, ``"Hello world!"``, ``[2,3,4,5,6]``

19

20In a language with *dependent types*, however, the distinction is less

21clear. Dependent types allow types to “depend” on values — in other

docs/tutorial/modules.rst+12−2

@@ -212,14 +212,24 @@ using a ``parameters`` declaration, for example:

212 addAll z = x + y + z

213

214The effect of a ``parameters`` block is to add the declared parameters

215−to every function, type and data constructor within the block. Outside

215+to every function, type and data constructor within the

216+block. Specifically, adding the parameters to the front of the

216−the block, the parameters must be given explicitly:

217+argument list. Outside the block, the parameters must be given

218+explicitly. The ``addAll`` function, when called from the REPL, will

219+thus have the following type signature.

217

220

218::

221::

219

222

220 *params> :t addAll

223 *params> :t addAll

221 addAll : Nat -> Nat -> Nat -> Nat

224 addAll : Nat -> Nat -> Nat -> Nat

222

225

226+and the following definition.

227+

228+.. code-block:: idris

229+

230+ addAll : (x : Nat) -> (y : Nat) -> (z : Nat) -> Nat

231+ addAll x y z = x + y + z

232+

223Parameters blocks can be nested, and can also include data declarations,

233Parameters blocks can be nested, and can also include data declarations,

224in which case the parameters are added explicitly to all type and data

234in which case the parameters are added explicitly to all type and data

225constructors. They may also be dependent types with implicit arguments:

235constructors. They may also be dependent types with implicit arguments:

docs/tutorial/provisional.rst+12−12

@@ -213,11 +213,11 @@ representation (in this case ``Binary``) with a meaning (in this case

213.. code-block:: idris

214

215 data Binary : Nat -> Type where

216− bEnd : Binary Z

216+ BEnd : Binary Z

217− bO : Binary n -> Binary (n + n)

217+ BO : Binary n -> Binary (n + n)

218− bI : Binary n -> Binary (S (n + n))

218+ BI : Binary n -> Binary (S (n + n))

219

220−``bO`` and ``bI`` take a binary number as an argument and effectively

220+``BO`` and ``BI`` take a binary number as an argument and effectively

221shift it one bit left, adding either a zero or one as the new least

222significant bit. The index, ``n + n`` or ``S (n + n)`` states the result

223that this left shift then add will have to the meaning of the number.

@@ -234,17 +234,17 @@ original Nat:

234

235The ``Parity`` view makes the definition fairly simple — halving the

236number is effectively a right shift after all — although we need to use

237−a provisional definition in the odd case:

237+a provisional definition in the Odd case:

238

239.. code-block:: idris

240

241 natToBin : (n:Nat) -> Binary n

242− natToBin Z = bEnd

242+ natToBin Z = BEnd

243 natToBin (S k) with (parity k)

244− natToBin (S (j + j)) | even = bI (natToBin j)

244+ natToBin (S (j + j)) | Even = BI (natToBin j)

245− natToBin (S (S (j + j))) | odd ?= bO (natToBin (S j))

245+ natToBin (S (S (j + j))) | Odd ?= BO (natToBin (S j))

246

247−The problem with the odd case is the same as in the definition of

247+The problem with the Odd case is the same as in the definition of

248``parity``, and the proof proceeds in the same way:

249

250.. code-block:: idris

@@ -272,6 +272,6 @@ For this to work, of course, we need a ``Show`` instance for

272.. code-block:: idris

273

274 instance Show (Binary n) where

275− show (bO x) = show x ++ "0"

275+ show (BO x) = show x ++ "0"

276− show (bI x) = show x ++ "1"

276+ show (BI x) = show x ++ "1"

277− show bEnd = ""

277+ show BEnd = ""

docs/tutorial/syntax.rst+3−3

@@ -122,7 +122,7 @@ hard to program this way in practice. Recall the factorial program in

122

123 fact : Expr G (TyFun TyInt TyInt)

124 fact = Lam (If (Op (==) (Var Stop) (Val 0))

125− (Val 1) (Op (*) (app fact (Op (-) (Var Stop) (Val 1)))

125+ (Val 1) (Op (*) (App fact (Op (-) (Var Stop) (Val 1)))

126 (Var Stop)))

127

128Since this is a particularly useful pattern, Idris provides syntax

@@ -162,8 +162,8 @@ declaring:

162

163.. code-block:: idris

164

165− (<$>) : (f : Lazy (Expr G (TyFun a t))) -> Expr G a -> Expr G t

165+ (<*>) : (f : Lazy (Expr G (TyFun a t))) -> Expr G a -> Expr G t

166− (<$>) f a = App f a

166+ (<*>) f a = App f a

167

168 pure : Expr G a -> Expr G a

169 pure = id

docs/tutorial/typesfuns.rst+29−17

@@ -56,7 +56,7 @@ answer. For example:

56::

57

58 *prims> 6*6+6

59− 42 : Int

59+ 42 : Integer

60 *prims> x == 6*6+6

61 True : Bool

62

@@ -445,7 +445,8 @@ are not given in applications of ``index``; their values can be

445inferred from the types of the ``Fin n`` and ``Vect n a``

446arguments. Any name beginning with a lower case letter which appears

447as a parameter or index in a

448−type declaration, but which is otherwise unbound, will be automatically

448+type declaration, which is not applied to any arguments, will

449+*always* be automatically

449bound as an implicit argument. Implicit arguments can still be given

450bound as an implicit argument. Implicit arguments can still be given

450explicitly in applications, using ``{a=value}`` and ``{n=value}``, for

451explicitly in applications, using ``{a=value}`` and ``{n=value}``, for

451example:

452example:

@@ -791,12 +792,12 @@ providing a default value:

791

792

792.. code-block:: idris

793.. code-block:: idris

793

794

794− maybe : Lazy b -> (a -> b) -> Maybe a -> b

795+ maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b

795

796

796−Note that the type of the first argument is ``Lazy b`` rather than

797+Note that the types of the first two arguments are wrapped in

797−simply ``b``. Since the default value might not be used, we mark it as

798+``Lazy``. Since only one of the two arguments will actually be used,

798−``Lazy`` in case it is a large expression where evaluating it then

799+we mark them as ``Lazy`` in case they are large expressions where it

799−discarding it would be wasteful.

800+would be wasteful to compute and then discard them.

800

801

801Tuples

802Tuples

802------

803------

@@ -819,6 +820,15 @@ contain an arbitrary number of values, represented as nested pairs:

819 jim : (String, Int, String)

820 jim : (String, Int, String)

820 jim = ("Jim", 25, "Cambridge")

821 jim = ("Jim", 25, "Cambridge")

821

822

823+::

824+

825+ *usefultypes> fst jim

826+ "Jim" : String

827+ *usefultypes> snd jim

828+ (25, "Cambridge") : (Int, String)

829+ *usefultypes> jim == ("Jim", (25, "Cambridge"))

830+ True : Bool

831+

822Dependent Pairs

832Dependent Pairs

823---------------

833---------------

824

834

@@ -1013,7 +1023,7 @@ name. For example, a pair type could be defined as follows:

1013Using the class record from the original introduction to records. The

1023Using the class record from the original introduction to records. The

1014size of the class can be restricted using a ``Vect`` and the size

1024size of the class can be restricted using a ``Vect`` and the size

1015promoted to the type level by parameterising the record with the size.

1025promoted to the type level by parameterising the record with the size.

1016−Foe example:

1026+For example:

1017

1027

1018

1028

1019.. code-block:: idris

1029.. code-block:: idris

@@ -1024,7 +1034,11 @@ Foe example:

1024 className : String

1034 className : String

1025

1035

1026**Note** that it is no longer possible to use the ``addStudent``

1036**Note** that it is no longer possible to use the ``addStudent``

1027−method from earlier as that would change the size of the class. To provide an add student the function must specify in the type that the size of the class has been increased by one. As the size if specified using natural numbers, the new value can be incremented using the successor constructor.

1037+function from earlier, since that would change the size of the class. A

1038+function to add a student must now specify in the type that the

1039+size of the class has been increased by one. As the size is specified

1040+using natural numbers, the new value can be incremented using the

1041+``S`` constructor.

1028

1042

1029.. code-block:: idris

1043.. code-block:: idris

1030

1044

@@ -1043,11 +1057,9 @@ Intermediate values can be calculated using ``let`` bindings:

1043

1057

1044.. code-block:: idris

1058.. code-block:: idris

1045

1059

1046− data Person = MkPerson String Int

1060+ mirror : List a -> List a

1047−

1061+ mirror xs = let xs' = reverse xs in

1048− showPerson : Person -> String

1062+ xs ++ xs'

1049− showPerson p = let MkPerson name age = p in

1050− name ++ " is " ++ show age ++ " years old"

1051

1063

1052We can do simple pattern matching in ``let`` bindings too. For

1064We can do simple pattern matching in ``let`` bindings too. For

1053example, we can extract fields from a record as follows, as well as by

1065example, we can extract fields from a record as follows, as well as by

@@ -1136,8 +1148,8 @@ auxiliary functions, and is also used internally to implement pattern

1136matching ``let`` and lambda bindings. It will *only* work if:

1148matching ``let`` and lambda bindings. It will *only* work if:

1137

1149

1138- Each branch *matches* a value of the same type, and *returns* a

1150- Each branch *matches* a value of the same type, and *returns* a

1139− value of the same type.

1151+ value of the same type.

1140

1152

1141- The type of the result is "known". i.e. the type of the expression

1153- The type of the result is "known". i.e. the type of the expression

1142− can be determined *without* type checking the ``case``-expression

1154+ can be determined *without* type checking the ``case``-expression

1143− itself.

1155+ itself.

idris.cabal+28−3

@@ -1,5 +1,5 @@

1Name: idris

2−Version: 0.9.19.1

2+Version: 0.9.20.2

3License: BSD3

4License-file: LICENSE

5Author: Edwin Brady

@@ -115,6 +115,7 @@ Extra-source-files:

115 libs/base/Control/*.idr

116 libs/base/Control/Monad/*.idr

117 libs/base/Data/*.idr

118+ libs/base/Data/List/*.idr

118 libs/base/Data/Vect/*.idr

119 libs/base/Data/Vect/*.idr

119 libs/base/Debug/*.idr

120 libs/base/Debug/*.idr

120 libs/base/Language/Reflection/*.idr

121 libs/base/Language/Reflection/*.idr

@@ -309,6 +310,9 @@ Extra-source-files:

309 test/reg066/run

310 test/reg066/run

310 test/reg066/*.idr

311 test/reg066/*.idr

311 test/reg066/expected

312 test/reg066/expected

313+ test/reg067/run

314+ test/reg067/*.idr

315+ test/reg067/expected

312

316

313 test/basic001/run

317 test/basic001/run

314 test/basic001/*.idr

318 test/basic001/*.idr

@@ -356,6 +360,9 @@ Extra-source-files:

356 test/basic015/run

360 test/basic015/run

357 test/basic015/*.idr

361 test/basic015/*.idr

358 test/basic015/expected

362 test/basic015/expected

363+ test/basic016/run

364+ test/basic016/*.idr

365+ test/basic016/expected

359

366

360 test/bignum001/run

367 test/bignum001/run

361 test/bignum001/*.idr

368 test/bignum001/*.idr

@@ -535,6 +542,17 @@ Extra-source-files:

535 test/interactive009/input

542 test/interactive009/input

536 test/interactive009/*.idr

543 test/interactive009/*.idr

537 test/interactive009/expected

544 test/interactive009/expected

545+ test/interactive010/expected

546+ test/interactive010/input

547+ test/interactive010/run

548+ test/interactive011/expected

549+ test/interactive011/input

550+ test/interactive011/run

551+ test/interactive011/*.idr

552+ test/interactive012/expected

553+ test/interactive012/input

554+ test/interactive012/run

555+ test/interactive012/*.idr

538

556

539 test/io001/run

557 test/io001/run

540 test/io001/*.idr

558 test/io001/*.idr

@@ -556,6 +574,9 @@ Extra-source-files:

556 test/meta002/run

574 test/meta002/run

557 test/meta002/*.idr

575 test/meta002/*.idr

558 test/meta002/expected

576 test/meta002/expected

577+ test/meta004/run

578+ test/meta004/*.idr

579+ test/meta004/expected

559

580

560 test/primitives001/run

581 test/primitives001/run

561 test/primitives001/*.idr

582 test/primitives001/*.idr

@@ -954,11 +975,14 @@ Library

954 , uniplate >=1.6 && < 1.7

975 , uniplate >=1.6 && < 1.7

955 , unordered-containers < 0.3

976 , unordered-containers < 0.3

956 , utf8-string < 1.1

977 , utf8-string < 1.1

957− , vector < 0.11

978+ , vector < 0.12

958 , vector-binary-instances < 0.3

979 , vector-binary-instances < 0.3

959 , zip-archive > 0.2.3.5 && < 0.2.4

980 , zip-archive > 0.2.3.5 && < 0.2.4

960− , zlib < 0.6

961 , safe

981 , safe

982+ -- zlib >= 0.6.1 is broken with GHC < 7.10.3

983+ if impl(ghc < 7.10.3)

984+ build-depends: zlib < 0.6.1

985+

962 Extensions: MultiParamTypeClasses

986 Extensions: MultiParamTypeClasses

963 , DeriveFoldable

987 , DeriveFoldable

964 , DeriveTraversable

988 , DeriveTraversable

@@ -990,6 +1014,7 @@ Library

990 cpp-options: -DIDRIS_FFI

1014 cpp-options: -DIDRIS_FFI

991 if flag(GMP)

1015 if flag(GMP)

992 build-depends: libffi < 0.2

1016 build-depends: libffi < 0.2

1017+ extra-libraries: gmp

993 cpp-options: -DIDRIS_GMP

1018 cpp-options: -DIDRIS_GMP

994 if flag(curses)

1019 if flag(curses)

995 build-depends: hscurses < 1.5

1020 build-depends: hscurses < 1.5

iif/adder.iifdeleted−30

@@ -1,30 +0,0 @@

1−data O 0

2−data S 1

3−

4−fun plus(x, y) = case x of {

5− O => y

6− | S(k) => S (plus(k, y))

7− }

8−

9−fun natToInt(x) = case x of {

10− O => 0

11− | S(k) => let y = natToInt(k) in y + 1

12− }

13−

14−fun adder(arity, acc) = case arity of {

15− O => acc

16− | S(k) => adderAux(k, acc)

17− }

18−

19−fun adderAux(k, acc, n) = adder(k, plus(acc, n))

20−

21−fun zero() = O

22−fun one() = S(zero)

23−fun two() = S(one)

24−fun three() = S(two)

25−fun four() = S(three)

26−fun five() = S(four)

27−

28−fun main() = %WriteInt(natToInt(adder(three, two, three, four, five)))

29−

30−

iif/big.iifdeleted−7

@@ -1,7 +0,0 @@

1−fun fact(x) = case (x ==: 0:) of {

2− 0 => x *: fact(x - 1)

3− | _ => 1:

4− }

5−

6−fun main() = let f = fact(200:) in

7− %WriteString(%BigString(f) ++ "\n")

iif/ctest.cdeleted−106

@@ -1,106 +0,0 @@

1−#include <idris_rts.h>

2−

3−void plus(VM* vm, VAL* oldbase) {

4− INITFRAME;

5− RESERVE(2);

6− ADDTOP(2);

7−

8− switch(TAG(LOC(0))) {

9− case 0:

10− PROJECT(vm, LOC(0), 2, 0);

11− RVAL = LOC(1);

12− TOPBASE(0);

13− REBASE;

14− break;

15− case 1:

16− PROJECT(vm, LOC(0), 2, 1);

17− RESERVE(2);

18− TOP(0) = LOC(2);

19− TOP(1) = LOC(1);

20− STOREOLD;

21− BASETOP(0);

22− ADDTOP(2);

23− CALL(plus);

24− LOC(3) = RVAL;

25− RVAL = MKCON(vm, 1, 1, LOC(3));

26− TOPBASE(0);

27− REBASE;

28− break;

29− }

30−}

31−

32−void natToInt(VM* vm, VAL* oldbase) {

33− INITFRAME;

34− RESERVE(3);

35− ADDTOP(3);

36−

37− switch(TAG(LOC(0))) {

38− case 0:

39− PROJECT(vm, LOC(0), 2, 0);

40− RVAL = MKINT(0);

41− TOPBASE(0);

42− REBASE;

43− break;

44− case 1:

45− PROJECT(vm, LOC(0), 1, 1);

46− RESERVE(1);

47− TOP(0) = LOC(1);

48− STOREOLD;

49− BASETOP(0);

50− ADDTOP(1);

51− CALL(natToInt);

52− LOC(2) = RVAL;

53− RVAL = ADD(LOC(2), MKINT(1));

54− TOPBASE(0);

55− REBASE;

56− break;

57− }

58−}

59−

60−int do_main(VM* vm, VAL* oldbase) {

61− INITFRAME;

62− RESERVE(2);

63− ADDTOP(2);

64−

65− LOC(0) = MKCON(vm, 0, 0);

66− LOC(0) = MKCON(vm, 1, 1, LOC(0));

67− LOC(0) = MKCON(vm, 1, 1, LOC(0));

68−

69− dumpVal(LOC(0));

70− printf("\n");

71−

72− LOC(1) = MKCON(vm, 0, 0);

73− LOC(1) = MKCON(vm, 1, 1, LOC(1));

74− LOC(1) = MKCON(vm, 1, 1, LOC(1));

75−

76− RESERVE(2);

77− TOP(0) = LOC(0);

78− TOP(1) = LOC(1);

79−

80− STOREOLD;

81− BASETOP(0);

82− ADDTOP(2);

83− CALL(plus);

84− LOC(0) = RVAL;

85−

86− RESERVE(1);

87− TOP(0) = LOC(0);

88− SLIDE(vm, 1);

89− TOPBASE(1);

90− TAILCALL(natToInt);

91−/* STOREOLD;

92− BASETOP(0);

93− ADDTOP(1);

94− CALL(natToInt);

95− TOPBASE(0);

96− REBASE; */

97−}

98−

99−int main() {

100− VM* vm = init_vm(100,100);

101−

102− do_main(vm, NULL);

103− printf("%ld\n", GETINT(RVAL));

104−

105− printf("%d %d %d\n", vm->valstack, vm->valstack_base, vm->valstack_top);

106−}

iif/lazy.iifdeleted−21

@@ -1,21 +0,0 @@

1−data Nil 0

2−data Cons 2

3−

4−fun countFrom(x) = Cons(x, countFrom@(x+1))

5−

6−fun take(n, xs) = case n of {

7− 0 => Nil

8− | _ => case xs of {

9− Nil => Nil

10− | Cons(y, ys) => Cons(y, take(n-1, ys))

11− }

12− }

13−

14−fun dumpList(xs) = case xs of {

15− Nil => "END"

16− | Cons(y, ys) => %IntString(y) ++ ", " ++ dumpList(ys)

17− }

18−

19−fun double(x) = x + x

20−

21−fun main() = %WriteString(dumpList(take(5, countFrom(10))))

iif/testmap.iifdeleted−30

@@ -1,30 +0,0 @@

1−data Nil 0

2−data Cons 2

3−

4−fun twice(f, x) = f(f(x))

5−

6−fun map(f, xs) = case xs of {

7− Nil => Nil

8− | Cons(y, ys) => Cons(f(y), map(f, ys))

9− }

10−

11−fun dumpList(xs) = case xs of {

12− Nil => "END"

13− | Cons(y, ys) => %IntString(y) ++ ", " ++ dumpList(ys)

14− }

15−

16−fun countFrom(x) = Cons(x, countFrom@(x+1))

17−

18−fun take(n, xs) = case n of {

19− 0 => Nil

20− | _ => case xs of {

21− Nil => Nil

22− | Cons(y, ys) => Cons(y, take(n-1, ys))

23− }

24− }

25−

26−fun double(x) = x + x

27−

28−fun main() = let mult = 2 in

29− %WriteString(dumpList(map(twice(\ x => x*mult), take(1010, countFrom(10)))))

30−

iif/testvm.iifdeleted−32

@@ -1,32 +0,0 @@

1−data O 0

2−data S 1

3−

4−fun plus(x, y) = case x of {

5− O => y

6− | S(k) => S (plus(k, y))

7− }

8−

9−fun fact(x) = factAux(x, 1)

10−

11−fun factAux(x, acc) = case (x == 1) of {

12− 0 => factAux(x-1, acc * x)

13− | 1 => acc

14− }

15−

16−fun natToInt(x) = case x of {

17− O => 0

18− | S(k) => let y = natToInt(k) in y + 1

19− }

20−

21−fun intToNat(x) = case x of {

22− 0 => O

23− | _ => S (intToNat (x - 1))

24− }

25−

26−fun sin(x) = foreign C Float "sin" (Float x)

27−

28−fun main() = let val = natToInt(plus(intToNat(fact(6)), S(S(O)))) in

29− let sval = sin(1.0) in

30− %WriteString("Answer: " ++ %IntString(val)

31− ++ " " ++ %FloatString(sval))

32−

libs/base/Control/Catchable.idr+4−4

@@ -16,14 +16,14 @@ instance Catchable (Either a) a where

16 catch (Left err) h = h err

17 catch (Right x) h = (Right x)

18

19− throw x = Left x

19+ throw = Left

20

21instance Catchable (IOExcept err) err where

22− catch (ioM prog) h = ioM (do p' <- prog

22+ catch (IOM prog) h = IOM (do p' <- prog

23 case p' of

24− Left e => let ioM he = h e in he

24+ Left e => let IOM he = h e in he

25 Right val => return (Right val))

26− throw x = ioM (return (Left x))

26+ throw = ioe_fail

27

28instance Catchable List () where

29 catch [] h = h ()

libs/base/Control/IOExcept.idr+10−19

@@ -2,34 +2,25 @@ module Control.IOExcept

2

3-- An IO monad with exception handling

4

5−data IOExcept : Type -> Type -> Type where

5+record IOExcept err a where

6+ constructor IOM

6− ioM : IO (Either err a) -> IOExcept err a

7+ runIOExcept : IO (Either err a)

7

8

8instance Functor (IOExcept e) where

9instance Functor (IOExcept e) where

9− map f (ioM fn) = ioM (map (map f) fn)

10+ map f (IOM fn) = IOM (map (map f) fn)

10

11

11instance Applicative (IOExcept e) where

12instance Applicative (IOExcept e) where

12− pure x = ioM (pure (pure x))

13+ pure x = IOM (pure (pure x))

13− (ioM f) <*> (ioM a) = ioM (do f' <- f; a' <- a

14+ (IOM f) <*> (IOM a) = IOM [| f <*> a |]

14− return (f' <*> a'))

15

16instance Monad (IOExcept e) where

17− (ioM x) >>= k = ioM (do x' <- x;

17+ (IOM x) >>= f = IOM $ x >>= either (pure . Left) (runIOExcept . f)

18− case x' of

19− Right a => let (ioM ka) = k a in

20− ka

21− Left err => return (Left err))

22

18

23ioe_lift : IO a -> IOExcept err a

19ioe_lift : IO a -> IOExcept err a

24−ioe_lift op = ioM (do op' <- op

20+ioe_lift op = IOM $ map Right op

25− return (Right op'))

26

21

27ioe_fail : err -> IOExcept err a

22ioe_fail : err -> IOExcept err a

28−ioe_fail e = ioM (return (Left e))

23+ioe_fail e = IOM $ pure (Left e)

29

24

30ioe_run : IOExcept err a -> (err -> IO b) -> (a -> IO b) -> IO b

25ioe_run : IOExcept err a -> (err -> IO b) -> (a -> IO b) -> IO b

31−ioe_run (ioM act) err ok = do act' <- act

26+ioe_run (IOM act) err ok = either err ok !act

32− case act' of

33− Left e => err e

34− Right v => ok v

35−

libs/base/Data/Complex.idr+8−8

@@ -25,7 +25,7 @@ instance Show a => Show (Complex a) where

25 plus_i = User 6

26

27

28−-- when we have a type class 'Fractional' (which contains Float and Double),

28+-- when we have a type class 'Fractional' (which contains Double),

29-- we can do:

30{-

31instance Fractional a => Fractional (Complex a) where

@@ -40,16 +40,16 @@ instance Fractional a => Fractional (Complex a) where

40

41------------------------------ Polarform

42

43−mkPolar : Float -> Float -> Complex Float

43+mkPolar : Double -> Double -> Complex Double

44mkPolar radius angle = radius * cos angle :+ radius * sin angle

45

46−cis : Float -> Complex Float

46+cis : Double -> Complex Double

47cis angle = cos angle :+ sin angle

48

49−magnitude : Complex Float -> Float

49+magnitude : Complex Double -> Double

50magnitude (r:+i) = sqrt (r*r+i*i)

51

52−phase : Complex Float -> Float

52+phase : Complex Double -> Double

53phase (x:+y) = atan2 y x

54

55

@@ -62,13 +62,13 @@ instance Functor Complex where

62 map f (r :+ i) = f r :+ f i

63

64-- We can't do "instance Num a => Num (Complex a)" because

65−-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float

65+-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Double

66−instance Num (Complex Float) where

66+instance Num (Complex Double) where

67 (+) (a:+b) (c:+d) = ((a+c):+(b+d))

68 (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))

69 fromInteger x = (fromInteger x:+0)

70

71−instance Neg (Complex Float) where

71+instance Neg (Complex Double) where

72 negate = map negate

73 (-) (a:+b) (c:+d) = ((a-c):+(b-d))

74 abs (a:+b) = (magnitude (a:+b):+0)

libs/base/Data/HVect.idr+9−9

@@ -73,17 +73,17 @@ instance (Shows k ts) => Show (HVect ts) where

73

74||| Extract an arbitrary element of the correct type.

75||| @ t the goal type

76−get : {auto p : Elem t ts} -> HVect ts -> t

76+get : HVect ts -> {auto p : Elem t ts} -> t

77−get {p = Here} (x::xs) = x

77+get (x :: xs) {p = Here} = x

78−get {p = There p'} (x::xs) = get {p = p'} xs

78+get (x :: xs) {p = There p'} = get {p = p'} xs

79

80||| Replace an element with the correct type.

81−put : {auto p : Elem t ts} -> t -> HVect ts -> HVect ts

81+put : t -> HVect ts -> {auto p : Elem t ts} -> HVect ts

82−put {p = Here} y (x::xs) = y :: xs

82+put y (x::xs) {p = Here} = y :: xs

83−put {p = There p'} y (x::xs) = x :: put {p = p'} y xs

83+put y (x::xs) {p = There p'} = x :: put {p = p'} y xs

84

85||| Update an element with the correct type.

86−update : {auto p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u)

86+update : (t -> u) -> HVect ts -> {auto p : Elem t ts} -> HVect (replaceByElem ts p u)

87−update {p = Here} f (x::xs) = f x :: xs

87+update f (x::xs) {p = Here} = f x :: xs

88−update {p = There p'} f (x::xs) = x :: update {p = p'} f xs

88+update f (x::xs) {p = There p'} = x :: update {p = p'} f xs

89

libs/base/Data/List/Quantifiers.idrnew file+75

@@ -0,0 +1,75 @@

1+module Data.List.Quantifiers

2+

3+import Data.List

4+

5+||| A proof that some element of a list satisfies some property

6+|||

7+||| @ P the property to be satsified

8+data Any : (P : a -> Type) -> List a -> Type where

9+ ||| A proof that the satisfying element is the first one in the `List`

10+ Here : {P : a -> Type} -> {xs : List a} -> P x -> Any P (x :: xs)

11+ ||| A proof that the satsifying element is in the tail of the `List`

12+ There : {P : a -> Type} -> {xs : List a} -> Any P xs -> Any P (x :: xs)

13+

14+||| No element of an empty list satisfies any property

15+anyNilAbsurd : {P : a -> Type} -> Any P Nil -> Void

16+anyNilAbsurd (Here _) impossible

17+anyNilAbsurd (There _) impossible

18+

19+instance Uninhabited (Any p Nil) where

20+ uninhabited = anyNilAbsurd

21+

22+||| Eliminator for `Any`

23+anyElim : {xs : List a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b

24+anyElim _ f (Here p) = f p

25+anyElim f _ (There p) = f p

26+

27+||| Given a decision procedure for a property, determine if an element of a

28+||| list satisfies it.

29+|||

30+||| @ P the property to be satisfied

31+||| @ dec the decision procedure

32+||| @ xs the list to examine

33+any : {P : a -> Type} -> (dec : (x : a) -> Dec (P x)) -> (xs : List a) -> Dec (Any P xs)

34+any _ Nil = No anyNilAbsurd

35+any p (x::xs) with (p x)

36+ | Yes prf = Yes (Here prf)

37+ | No prf =

38+ case any p xs of

39+ Yes prf' => Yes (There prf')

40+ No prf' => No (anyElim prf' prf)

41+

42+||| A proof that all elements of a list satisfy a property. It is a list of

43+||| proofs, corresponding element-wise to the `List`.

44+data All : (P : a -> Type) -> List a -> Type where

45+ Nil : {P : a -> Type} -> All P Nil

46+ (::) : {P : a -> Type} -> {xs : List a} -> P x -> All P xs -> All P (x :: xs)

47+

48+||| If there does not exist an element that satifies the property, then it is

49+||| the case that all elements do not satisfy.

50+negAnyAll : {P : a -> Type} -> {xs : List a} -> Not (Any P xs) -> All (\x => Not (P x)) xs

51+negAnyAll {xs=Nil} _ = Nil

52+negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x))

53+

54+notAllHere : {P : a -> Type} -> {xs : List a} -> Not (P x) -> All P (x :: xs) -> Void

55+notAllHere _ Nil impossible

56+notAllHere np (p :: _) = np p

57+

58+notAllThere : {P : a -> Type} -> {xs : List a} -> Not (All P xs) -> All P (x :: xs) -> Void

59+notAllThere _ Nil impossible

60+notAllThere np (_ :: ps) = np ps

61+

62+||| Given a decision procedure for a property, decide whether all elements of

63+||| a list satisfy it.

64+|||

65+||| @ P the property

66+||| @ dec the decision procedure

67+||| @ xs the list to examine

68+all : {P : a -> Type} -> (dec : (x : a) -> Dec (P x)) -> (xs : List a) -> Dec (All P xs)

69+all _ Nil = Yes Nil

70+all d (x::xs) with (d x)

71+ | No prf = No (notAllHere prf)

72+ | Yes prf =

73+ case all d xs of

74+ Yes prf' => Yes (prf :: prf')

75+ No prf' => No (notAllThere prf')

libs/base/Data/String.idrnew file+110

@@ -0,0 +1,110 @@

1+module Data.String

2+

3+private

4+parseNumWithoutSign : List Char -> Integer -> Maybe Integer

5+parseNumWithoutSign [] acc = Just acc

6+parseNumWithoutSign (c :: cs) acc =

7+ if (c >= '0' && c <= '9')

8+ then parseNumWithoutSign cs ((acc * 10) + (cast ((ord c) - (ord '0'))))

9+ else Nothing

10+

11+

12+||| Convert a positive number string to a Num.

13+|||

14+||| ```idris example

15+||| parsePositive "123"

16+||| ```

17+||| ```idris example

18+||| parsePositive {a=Int} " +123"

19+||| ```

20+parsePositive : Num a => String -> Maybe a

21+parsePositive s = parsePosTrimmed (trim s)

22+ where

23+ parsePosTrimmed s with (strM s)

24+ parsePosTrimmed "" | StrNil = Nothing

25+ parsePosTrimmed (strCons x xs) | (StrCons x xs) =

26+ if (x == '+')

27+ then map fromInteger (parseNumWithoutSign (unpack xs) 0)

28+ else map fromInteger (parseNumWithoutSign (unpack xs) (cast (ord x - ord '0')))

29+

30+

31+||| Convert a number string to a Num.

32+|||

33+||| ```idris example

34+||| parseInteger " 123"

35+||| ```

36+||| ```idris example

37+||| parseInteger {a=Int} " -123"

38+||| ```

39+parseInteger : (Num a, Neg a) => String -> Maybe a

40+parseInteger s = parseIntTrimmed (trim s)

41+ where

42+ parseIntTrimmed s with (strM s)

43+ parseIntTrimmed "" | StrNil = Nothing

44+ parseIntTrimmed (strCons x xs) | (StrCons x xs) =

45+ if (x == '-')

46+ then map (\y => negate (fromInteger y)) (parseNumWithoutSign (unpack xs) 0)

47+ else if (x == '+')

48+ then map fromInteger (parseNumWithoutSign (unpack xs) (cast {from=Int} 0))

49+ else map fromInteger (parseNumWithoutSign (unpack xs) (cast (ord x - ord '0')))

50+

51+

52+||| Convert a number string to a Double.

53+|||

54+||| ```idris example

55+||| parseDouble "+123.123e-2"

56+||| ```

57+||| ```idris example

58+||| parseDouble {a=Int} " -123.123E+2"

59+||| ```

60+||| ```idris example

61+||| parseDouble {a=Int} " +123.123"

62+||| ```

63+parseDouble : String -> Maybe Double

64+parseDouble = mkDouble . wfe . trim

65+ where

66+ mkDouble (Just (w, f, e)) = let ex = intPow 10 e in

67+ Just $ (w * ex + f * ex)

68+ mkDouble Nothing = Nothing

69+

70+ %assert_total

71+ intPow : Integer -> Integer -> Double

72+ intPow base exp = if exp > 0 then (num base exp) else 1 / (num base exp)

73+ where

74+ num base 0 = 1

75+ num base e = if e < 0

76+ then cast base * num base (e + 1)

77+ else cast base * num base (e - 1)

78+

79+ wfe : String -> Maybe (Double, Double, Integer)

80+ wfe cs = case split (== '.') cs of

81+ (wholeAndExp :: []) =>

82+ case split (\c => c == 'e' || c == 'E') wholeAndExp of

83+ (whole::exp::[]) =>

84+ do

85+ w <- cast <$> parseInteger whole

86+ e <- parseInteger exp

87+ return (w, 0, e)

88+ (whole::[]) =>

89+ do

90+ w <- cast <$> parseInteger whole

91+ return (w, 0, 0)

92+ _ => Nothing

93+ (whole::fracAndExp::[]) =>

94+ case split (\c => c == 'e' || c == 'E') fracAndExp of

95+ (""::exp::[]) => Nothing

96+ (frac::exp::[]) =>

97+ do

98+ w <- cast <$> parseInteger whole

99+ f <- (/ (pow 10 (length frac))) <$>

100+ (cast <$> parseNumWithoutSign (unpack frac) 0)

101+ e <- parseInteger exp

102+ return (w, if w < 0 then (-f) else f, e)

103+ (frac::[]) =>

104+ do

105+ w <- cast <$> parseInteger whole

106+ f <- (/ (pow 10 (length frac))) <$>

107+ (cast <$> parseNumWithoutSign (unpack frac) 0)

108+ return (w, if w < 0 then (-f) else f, 0)

109+ _ => Nothing

110+ _ => Nothing

libs/base/Data/Vect.idr+5−5

@@ -614,11 +614,11 @@ mapElem (There e) = There (mapElem e)

614||| @xs the vector with the desired length

615-- Needs to be Maybe rather than Dec, because if 'n' is unequal to m, we

616-- only know we don't know how to make a Vect n a, not that one can't exist.

617−isLength : {m : Nat} -> -- expected at run-time

617+exactLength : {m : Nat} -> -- expected at run-time

618− (len : Nat) -> (xs : Vect m a) -> Maybe (Vect len a)

618+ (len : Nat) -> (xs : Vect m a) -> Maybe (Vect len a)

619−isLength {m} len xs with (decEq m len)

619+exactLength {m} len xs with (decEq m len)

620− isLength {m = m} m xs | (Yes Refl) = Just xs

620+ exactLength {m = m} m xs | (Yes Refl) = Just xs

621− isLength {m = m} len xs | (No contra) = Nothing

621+ exactLength {m = m} len xs | (No contra) = Nothing

622

623||| If the given Vect is at least the required length, return a Vect with

624||| at least that length in its type, otherwise return Nothing

libs/base/Data/Vect/Quantifiers.idr+1

@@ -19,6 +19,7 @@ anyNilAbsurd (There _) impossible

19instance Uninhabited (Any p Nil) where

20 uninhabited = anyNilAbsurd

21

22+||| Eliminator for `Any`

22anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b

23anyElim : {xs : Vect n a} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b

23anyElim _ f (Here p) = f p

24anyElim _ f (Here p) = f p

24anyElim f _ (There p) = f p

25anyElim f _ (There p) = f p

libs/base/Language/Reflection/Utils.idr+21−21

@@ -55,13 +55,18 @@ binderTy : Binder t -> t

55binderTy (Lam t) = t

56binderTy (Pi t _) = t

57binderTy (Let t1 t2) = t1

58−binderTy (NLet t1 t2) = t1

59binderTy (Hole t) = t

58binderTy (Hole t) = t

60binderTy (GHole t) = t

59binderTy (GHole t) = t

61binderTy (Guess t1 t2) = t1

60binderTy (Guess t1 t2) = t1

62binderTy (PVar t) = t

61binderTy (PVar t) = t

63binderTy (PVTy t) = t

62binderTy (PVTy t) = t

64

63

64+instance Show SourceLocation where

65+ showPrec d (FileLoc filename line col) = showCon d "FileLoc" $ showArg filename ++ showArg line ++ showArg col

66+

67+instance Eq SourceLocation where

68+ (FileLoc fn s e) == (FileLoc fn' s' e') = fn == fn' && s == s' && e == e'

69+

65mutual

70mutual

66 instance Show SpecialName where

71 instance Show SpecialName where

67 showPrec d (WhereN i n1 n2) = showCon d "WhereN" $ showArg i ++

72 showPrec d (WhereN i n1 n2) = showCon d "WhereN" $ showArg i ++

@@ -70,7 +75,7 @@ mutual

70 showPrec d (InstanceN i ss) = showCon d "InstanceN" $ showArg i ++ showArg ss

75 showPrec d (InstanceN i ss) = showCon d "InstanceN" $ showArg i ++ showArg ss

71 showPrec d (ParentN n s) = showCon d "ParentN" $ showArg n ++ showArg s

76 showPrec d (ParentN n s) = showCon d "ParentN" $ showArg n ++ showArg s

72 showPrec d (MethodN n) = showCon d "MethodN" $ showArg n

77 showPrec d (MethodN n) = showCon d "MethodN" $ showArg n

73− showPrec d (CaseN n) = showCon d "CaseN" $ showArg n

78+ showPrec d (CaseN fc n) = showCon d "CaseN" $ showArg fc ++ showArg n

74 showPrec d (ElimN n) = showCon d "ElimN" $ showArg n

79 showPrec d (ElimN n) = showCon d "ElimN" $ showArg n

75 showPrec d (InstanceCtorN n) = showCon d "InstanceCtorN" $ showArg n

80 showPrec d (InstanceCtorN n) = showCon d "InstanceCtorN" $ showArg n

76 showPrec d (MetaN parent meta) = showCon d "MetaN" $ showArg parent ++ showArg meta

81 showPrec d (MetaN parent meta) = showCon d "MetaN" $ showArg parent ++ showArg meta

@@ -80,14 +85,12 @@ mutual

80 showPrec d (NS n ns) = showCon d "NS" $ showArg n ++ showArg ns

85 showPrec d (NS n ns) = showCon d "NS" $ showArg n ++ showArg ns

81 showPrec d (MN i str) = showCon d "MN" $ showArg i ++ showArg str

86 showPrec d (MN i str) = showCon d "MN" $ showArg i ++ showArg str

82 showPrec d (SN sn) = showCon d "SN" $ assert_total (showArg sn)

87 showPrec d (SN sn) = showCon d "SN" $ assert_total (showArg sn)

83− showPrec d NErased = "NErased"

84

88

85mutual

89mutual

86 instance Eq TTName where

90 instance Eq TTName where

87 (UN str1) == (UN str2) = str1 == str2

91 (UN str1) == (UN str2) = str1 == str2

88 (NS n ns) == (NS n' ns') = n == n' && ns == ns'

92 (NS n ns) == (NS n' ns') = n == n' && ns == ns'

89 (MN i str) == (MN i' str') = i == i' && str == str'

93 (MN i str) == (MN i' str') = i == i' && str == str'

90− NErased == NErased = True

91 (SN sn) == (SN sn') = assert_total $ sn == sn'

94 (SN sn) == (SN sn') = assert_total $ sn == sn'

92 x == y = False

95 x == y = False

93

96

@@ -97,7 +100,7 @@ mutual

97 (InstanceN i ss) == (InstanceN i' ss') = i == i' && ss == ss'

100 (InstanceN i ss) == (InstanceN i' ss') = i == i' && ss == ss'

98 (ParentN n s) == (ParentN n' s') = n == n' && s == s'

101 (ParentN n s) == (ParentN n' s') = n == n' && s == s'

99 (MethodN n) == (MethodN n') = n == n'

102 (MethodN n) == (MethodN n') = n == n'

100− (CaseN n) == (CaseN n') = n == n'

103+ (CaseN fc n) == (CaseN fc' n') = fc == fc' && n == n'

101 (ElimN n) == (ElimN n') = n == n'

104 (ElimN n) == (ElimN n') = n == n'

102 (InstanceCtorN n) == (InstanceCtorN n') = n == n'

105 (InstanceCtorN n) == (InstanceCtorN n') = n == n'

103 (MetaN parent meta) == (MetaN parent' meta') = parent == parent' && meta == meta'

106 (MetaN parent meta) == (MetaN parent' meta') = parent == parent' && meta == meta'

@@ -126,7 +129,7 @@ instance Show IntTy where

126

129

127instance Show ArithTy where

130instance Show ArithTy where

128 showPrec d (ATInt t) = showCon d "ATInt" $ showArg t

131 showPrec d (ATInt t) = showCon d "ATInt" $ showArg t

129− showPrec d ATFloat = "ATFloat"

132+ showPrec d ATDouble = "ATDouble"

130

133

131instance Show Const where

134instance Show Const where

132 showPrec d (I i) = showCon d "I" $ showArg i

135 showPrec d (I i) = showCon d "I" $ showArg i

@@ -159,7 +162,7 @@ instance Eq Reflection.IntTy where

159

162

160instance Eq ArithTy where

163instance Eq ArithTy where

161 (ATInt x) == (ATInt y) = x == y

164 (ATInt x) == (ATInt y) = x == y

162− ATFloat == ATFloat = True

165+ ATDouble == ATDouble = True

163 _ == _ = False

166 _ == _ = False

164

167

165instance Eq Const where

168instance Eq Const where

@@ -196,7 +199,6 @@ instance (Show a) => Show (Binder a) where

196 showPrec d (Lam t) = showCon d "Lam" $ showArg t

199 showPrec d (Lam t) = showCon d "Lam" $ showArg t

197 showPrec d (Pi t1 t2) = showCon d "Pi" $ showArg t1 ++ showArg t2

200 showPrec d (Pi t1 t2) = showCon d "Pi" $ showArg t1 ++ showArg t2

198 showPrec d (Let t1 t2) = showCon d "Let" $ showArg t1 ++ showArg t2

201 showPrec d (Let t1 t2) = showCon d "Let" $ showArg t1 ++ showArg t2

199− showPrec d (NLet t1 t2) = showCon d "NLet" $ showArg t1 ++ showArg t2

200 showPrec d (Hole t) = showCon d "Hole" $ showArg t

202 showPrec d (Hole t) = showCon d "Hole" $ showArg t

201 showPrec d (GHole t) = showCon d "GHole" $ showArg t

203 showPrec d (GHole t) = showCon d "GHole" $ showArg t

202 showPrec d (Guess t1 t2) = showCon d "Guess" $ showArg t1 ++ showArg t2

204 showPrec d (Guess t1 t2) = showCon d "Guess" $ showArg t1 ++ showArg t2

@@ -207,7 +209,6 @@ instance (Eq a) => Eq (Binder a) where

207 (Lam t) == (Lam t') = t == t'

209 (Lam t) == (Lam t') = t == t'

208 (Pi t k) == (Pi t' k') = t == t' && k == k'

210 (Pi t k) == (Pi t' k') = t == t' && k == k'

209 (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2'

211 (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2'

210− (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2'

211 (Hole t) == (Hole t') = t == t'

212 (Hole t) == (Hole t') = t == t'

212 (GHole t) == (GHole t') = t == t'

213 (GHole t) == (GHole t') = t == t'

213 (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2'

214 (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2'

@@ -223,9 +224,7 @@ instance Show TT where

223 my_show d (Bind n b t) = showCon d "Bind" $ showArg n ++ showArg b ++ showArg t

224 my_show d (Bind n b t) = showCon d "Bind" $ showArg n ++ showArg b ++ showArg t

224 my_show d (App t1 t2) = showCon d "App" $ showArg t1 ++ showArg t2

225 my_show d (App t1 t2) = showCon d "App" $ showArg t1 ++ showArg t2

225 my_show d (TConst c) = showCon d "TConst" $ showArg c

226 my_show d (TConst c) = showCon d "TConst" $ showArg c

226− my_show d (Proj tm i) = showCon d "Proj" $ showArg tm ++ showArg i

227 my_show d Erased = "Erased"

228− my_show d Impossible = "Impossible"

229 my_show d (TType u) = showCon d "TType" $ showArg u

228 my_show d (TType u) = showCon d "TType" $ showArg u

230

229

231instance Eq TT where

230instance Eq TT where

@@ -236,9 +235,7 @@ instance Eq TT where

236 equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t'

235 equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t'

237 equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2'

236 equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2'

238 equalp (TConst c) (TConst c') = c == c'

237 equalp (TConst c) (TConst c') = c == c'

239− equalp (Proj tm i) (Proj tm' i') = tm == tm' && i == i'

240 equalp Erased Erased = True

238 equalp Erased Erased = True

241− equalp Impossible Impossible = True

242 equalp (TType u) (TType u') = u == u'

239 equalp (TType u) (TType u') = u == u'

243 equalp x y = False

240 equalp x y = False

244

241

@@ -260,17 +257,17 @@ forget tm = fe [] tm

260 LT => Nothing

257 LT => Nothing

261 GT => atIndex xs (n-1)

258 GT => atIndex xs (n-1)

262

259

263− %assert_total

264 fe : List TTName -> TT -> Maybe Raw

260 fe : List TTName -> TT -> Maybe Raw

265 fe env (P _ n _) = Just $ Var n

261 fe env (P _ n _) = Just $ Var n

266− fe env (V i) = map Var (atIndex env i)

262+ fe env (V i) = [| Var (atIndex env i) |]

267− fe env (Bind n b sc) = [| RBind (pure n) (traverse (fe env) b) (fe (n::env) sc) |]

263+ fe env (Bind n b sc) = [| RBind (pure n)

264+ (assert_total $ traverse (fe env) b)

265+ (fe (n::env) sc) |]

268 fe env (App f a) = [| RApp (fe env f) (fe env a) |]

266 fe env (App f a) = [| RApp (fe env f) (fe env a) |]

269 fe env (TConst c) = Just $ RConstant c

267 fe env (TConst c) = Just $ RConstant c

270− fe env (Proj tm i) = Nothing -- runtime only, not useful for metaprogramming

271 fe env (TType i) = Just RType

268 fe env (TType i) = Just RType

269+ fe env (UType uni) = Just (RUType uni)

272 fe env Erased = Just $ RConstant Forgot

270 fe env Erased = Just $ RConstant Forgot

273− fe env Impossible = Nothing

274

271

275instance Show Raw where

272instance Show Raw where

276 showPrec = my_show

273 showPrec = my_show

@@ -279,11 +276,8 @@ instance Show Raw where

279 my_show d (RBind n b tm) = showCon d "RBind" $ showArg n ++ showArg b ++ " " ++ my_show App tm

276 my_show d (RBind n b tm) = showCon d "RBind" $ showArg n ++ showArg b ++ " " ++ my_show App tm

280 my_show d (RApp tm tm') = showCon d "RApp" $ " " ++ my_show App tm ++ " " ++ my_show App tm'

277 my_show d (RApp tm tm') = showCon d "RApp" $ " " ++ my_show App tm ++ " " ++ my_show App tm'

281 my_show d RType = "RType"

278 my_show d RType = "RType"

282− my_show d (RForce tm) = showCon d "RForce" $ " " ++ my_show App tm

283 my_show d (RConstant c) = showCon d "RConstant" $ showArg c

279 my_show d (RConstant c) = showCon d "RConstant" $ showArg c

284

280

285−instance Show SourceLocation where

286− showPrec d (FileLoc filename line col) = showCon d "FileLoc" $ showArg filename ++ showArg line ++ showArg col

287

281

288instance Show Err where

282instance Show Err where

289 showPrec d (Msg x) = showCon d "Msg" $ showArg x

283 showPrec d (Msg x) = showCon d "Msg" $ showArg x

@@ -355,3 +349,9 @@ instance Show CtorArg where

355instance Show TyDecl where

349instance Show TyDecl where

356 showPrec d (Declare fn args ret) = showCon d "Declare" $ showArg fn ++

350 showPrec d (Declare fn args ret) = showCon d "Declare" $ showArg fn ++

357 showArg args ++ showArg ret

351 showArg args ++ showArg ret

352+

353+instance Show tm => Show (FunClause tm) where

354+ showPrec d (MkFunClause lhs rhs) =

355+ showCon d "MkFunClause" $ showArg lhs ++ showArg rhs

356+ showPrec d (MkImpossibleClause lhs) =

357+ showCon d "MkImpossibleClause" $ showArg lhs

libs/base/System.idr+1−1

@@ -56,7 +56,7 @@ getEnvironment = getAllPairs 0 []

56exit : Int -> IO ()

57exit code = foreign FFI_C "exit" (Int -> IO ()) code

58

59−||| Get the Unix time

59+||| Get the numbers of sections since 1st January 1970, 00:00 UTC

60time : IO Integer

61time = do MkRaw t <- foreign FFI_C "idris_time" (IO (Raw Integer))

62 return t

libs/base/base.ipkg+2−1

@@ -17,7 +17,8 @@ modules = System,

17 Data.HVect, Data.Vect.Quantifiers,

18 Data.Complex,

19 Data.Erased, Data.List,

20− Data.So,

20+ Data.List.Quantifiers,

21+ Data.So, Data.String,

21

22

22 Control.Isomorphism,

23 Control.Isomorphism,

23 Control.Monad.Identity,

24 Control.Monad.Identity,

libs/contrib/Control/Algebra/NumericInstances.idr+7−7

@@ -44,24 +44,24 @@ instance RingWithUnity Int where

44 unity = 1

45

46

47−instance Semigroup Float where

47+instance Semigroup Double where

48 (<+>) = (+)

49

50−instance Monoid Float where

50+instance Monoid Double where

51 neutral = 0

52

53−instance Group Float where

53+instance Group Double where

54 inverse = (* -1)

55

56−instance AbelianGroup Float

56+instance AbelianGroup Double

57

58−instance Ring Float where

58+instance Ring Double where

59 (<.>) = (*)

60

61−instance RingWithUnity Float where

61+instance RingWithUnity Double where

62 unity = 1

63

64−instance Field Float where

64+instance Field Double where

65 inverseM f _ = 1 / f

66

67

libs/contrib/Network/Socket.idr−4

@@ -143,10 +143,6 @@ record Socket where

143 socketType : SocketType

144 protocalNumber : ProtocolNumber

145

146−||| Get the C error number

147−getErrno : IO Int

148−getErrno = foreign FFI_C "idrnet_errno" (IO Int)

149−

150||| Creates a UNIX socket with the given family, socket type and protocol

146||| Creates a UNIX socket with the given family, socket type and protocol

151||| number. Returns either a socket or an error.

147||| number. Returns either a socket or an error.

152socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket)

148socket : SocketFamily -> SocketType -> ProtocolNumber -> IO (Either SocketError Socket)

libs/effects/Effect/Default.idr+1−1

@@ -11,7 +11,7 @@ instance Default Int where

11instance Default Integer where

12 default = 0

13

14−instance Default Float where

14+instance Default Double where

15 default = 0

16

17instance Default Nat where

libs/effects/Effect/Exception.idr+2−1

@@ -18,7 +18,7 @@ instance Show a => Handler (Exception a) IO where

18 believe_me (exit 1)

19

20instance Handler (Exception a) (IOExcept a) where

21− handle _ (Raise e) k = ioM (return (Left e))

21+ handle _ (Raise e) k = ioe_fail e

22

23instance Handler (Exception a) (Either a) where

24 handle _ (Raise e) k = Left e

@@ -28,3 +28,4 @@ EXCEPTION t = MkEff () (Exception t)

28

29raise : a -> Eff b [EXCEPTION a]

30raise err = call $ Raise err

31+

libs/effects/Effect/File.idr+76−31

@@ -8,8 +8,8 @@ import Control.IOExcept

8||| A Dependent type to describe File Handles. File handles are

9||| parameterised with the current state of the file: Closed; Open for

10||| reading; and Open for writing.

11−|||

11+|||

12−||| @ m The file mode.

12+||| @ m The file mode.

13data OpenFile : (m : Mode) -> Type where

14 FH : File -> OpenFile m

15

@@ -21,27 +21,27 @@ openOK m False = ()

21

22||| Here the protocol for resource access is defined as an effect.

23||| The state transitions diagram for the protocol is as follows:

24−|||

24+|||

25||| digraph G {

26−|||

26+|||

27||| empty; read; write; // States

28−|||

28+|||

29||| empty -> read [label="Open R"];

30||| read -> empty [label="Close"];

31||| read -> read [label="ReadLine"];

32||| read -> read [label="EOF"];

33−|||

33+|||

34||| empty -> write [label="Open W"];

35||| write -> empty [label="Close"];

36||| write -> write [label="WriteLine"];

37−|||

37+|||

38||| }

39data FileIO : Effect where

40 ||| Open a file with the specified mode.

41− |||

41+ |||

42 ||| Opening a file successful moves the state from 'empty' to the

43 ||| specified mode. If not successful the state is still 'empty'.

44− |||

44+ |||

45 ||| @ fname The file name to be opened.

46 ||| @ m The file mode.

47 Open : (fname: String)

@@ -51,22 +51,22 @@ data FileIO : Effect where

51 False => ())

52

53 ||| Close a file.

54− |||

54+ |||

55 ||| Closing a file moves the state from Open to closed.

56− Close : sig FileIO () (OpenFile m) ()

56+ Close : sig FileIO () (OpenFile m) ()

57

58 ||| Read a line from the file.

59− |||

59+ |||

60 ||| Only files that are open for reading can be read.

61 ReadLine : sig FileIO String (OpenFile Read)

62−

62+

63 ||| Write a string to a file.

64− |||

64+ |||

65 ||| Only file that are open for writing can be written to.

66 WriteString : String -> sig FileIO () (OpenFile Write)

67

68 ||| End of file?

69− |||

69+ |||

70 ||| Only files open for reading can be tested for EOF

71 EOF : sig FileIO Bool (OpenFile Read)

72

@@ -74,31 +74,35 @@ data FileIO : Effect where

74

75--- An implementation of the resource access protocol for the IO Context.

76instance Handler FileIO IO where

77− handle () (Open fname m) k = do h <- openFile fname m

77+ handle () (Open fname m) k = do Right h <- openFile fname m

78− valid <- validFile h

78+ | Left err => k False ()

79− if valid then k True (FH h)

79+ k True (FH h)

80− else k False ()

81 handle (FH h) Close k = do closeFile h

80 handle (FH h) Close k = do closeFile h

82 k () ()

81 k () ()

83− handle (FH h) ReadLine k = do str <- fread h

82+ handle (FH h) ReadLine k = do Right str <- fGetLine h

83+ -- Need proper error handling!

84+ | Left err => k "" (FH h)

84 k str (FH h)

85 k str (FH h)

85− handle (FH h) (WriteString str) k = do fwrite h str

86+ handle (FH h) (WriteString str) k = do Right () <- fPutStr h str

87+ | Left err => k () (FH h)

86 k () (FH h)

88 k () (FH h)

87− handle (FH h) EOF k = do e <- feof h

89+ handle (FH h) EOF k = do e <- fEOF h

88 k e (FH h)

90 k e (FH h)

89

91

90instance Handler FileIO (IOExcept a) where

92instance Handler FileIO (IOExcept a) where

91− handle () (Open fname m) k = do h <- ioe_lift $ openFile fname m

93+ handle () (Open fname m) k = do Right h <- ioe_lift $ openFile fname m

92− valid <- ioe_lift $ validFile h

94+ | Left err => k False ()

93− if valid then k True (FH h)

95+ k True (FH h)

94− else k False ()

95 handle (FH h) Close k = do ioe_lift $ closeFile h

96 handle (FH h) Close k = do ioe_lift $ closeFile h

96 k () ()

97 k () ()

97− handle (FH h) ReadLine k = do str <- ioe_lift $ fread h

98+ handle (FH h) ReadLine k = do Right str <- ioe_lift $ fGetLine h

99+ -- Need proper error handling!

100+ | Left err => k "" (FH h)

98 k str (FH h)

101 k str (FH h)

99− handle (FH h) (WriteString str) k = do ioe_lift $ fwrite h str

102+ handle (FH h) (WriteString str) k = do Right () <- ioe_lift $ fPutStr h str

103+ | Left err => k () (FH h)

100 k () (FH h)

104 k () (FH h)

101− handle (FH h) EOF k = do e <- ioe_lift $ feof h

105+ handle (FH h) EOF k = do e <- ioe_lift $ fEOF h

102 k e (FH h)

106 k e (FH h)

103

107

104-- -------------------------------------------------------------- [ The Effect ]

108-- -------------------------------------------------------------- [ The Effect ]

@@ -112,12 +116,12 @@ FILE_IO t = MkEff t FileIO

112--

116--

113

117

114||| Open a file with the specified mode.

118||| Open a file with the specified mode.

115−|||

119+|||

116||| @ fname The file name to be opened.

120||| @ fname The file name to be opened.

117||| @ m The file mode.

121||| @ m The file mode.

118open : (fname : String)

122open : (fname : String)

119 -> (m : Mode)

123 -> (m : Mode)

120− -> Eff Bool [FILE_IO ()]

124+ -> Eff Bool [FILE_IO ()]

121 (\res => [FILE_IO (case res of

125 (\res => [FILE_IO (case res of

122 True => OpenFile m

126 True => OpenFile m

123 False => ())])

127 False => ())])

@@ -144,4 +148,45 @@ writeLine str = call $ WriteString (str ++ "\n")

144eof : Eff Bool [FILE_IO (OpenFile Read)]

148eof : Eff Bool [FILE_IO (OpenFile Read)]

145eof = call $ EOF

149eof = call $ EOF

146

150

151+||| Read a complete file, returning a user defined error if

152+||| unsuccesful.

153+|||

154+readFile : (errFunc : String -> e)

155+ -> (fname : String)

156+ -> Eff (Either e String) [FILE_IO ()]

157+readFile errFunc fname = do

158+ case !(open fname Read) of

159+ False => pure $ Left (errFunc fname)

160+ True => do

161+ src <- readAcc ""

162+ close

163+ pure $ Right src

164+ where

165+ readAcc : String -> Eff String [FILE_IO (OpenFile Read)]

166+ readAcc acc = if (not !(eof))

167+ then readAcc (acc ++ !(readLine))

168+ else pure acc

169+

170+||| Write a file containing the provided string, returning a user

171+||| defined error if unsuccesful.

172+|||

173+writeFile : (errFunc : String -> e)

174+ -> (fname : String)

175+ -> (content : String)

176+ -> Eff (Either e ()) [FILE_IO ()]

177+writeFile errFunc fname content = do

178+ case !(open fname Write) of

179+ True => do

180+ writeString content

181+ close

182+ pure $ Right ()

183+ False => pure $ Left (errFunc fname)

184+

185+

186+namespace Default

187+ readFile : String -> Eff (Either String String) [FILE_IO ()]

188+ readFile = File.readFile id

189+

190+ writeFile : String -> String -> Eff (Either String ()) [FILE_IO ()]

191+ writeFile = File.writeFile id

147-- --------------------------------------------------------------------- [ EOF ]

192-- --------------------------------------------------------------------- [ EOF ]

libs/effects/Effect/Logging/Category.idr−3

@@ -25,9 +25,6 @@ record LogRes (a : Type) where

25 getLevel : LogLevel n

26 getCategories : List a

27

28−instance (Show a) => Show (LogRes a) where

29− show (MkLogRes l cs) = unwords ["Log Settings:", show l, show cs]

30−

31instance Default (LogRes a) where

28instance Default (LogRes a) where

32 default = MkLogRes OFF Nil

29 default = MkLogRes OFF Nil

33

30

libs/effects/Effect/Perf.idrnew file+230

@@ -0,0 +1,230 @@

1+-- ---------------------------------------------------------------- [ Perf.idr ]

2+-- Module : Perf.idr

3+-- Copyright : (c) Jan de Muijnck-Hughes

4+-- License : see LICENSE

5+-- --------------------------------------------------------------------- [ EOH ]

6+||| A naive performance effect for gathering data about the

7+||| performance of effectful programmes.

8+module Effect.Perf

9+

10+import System

11+

12+import Effects

13+import Effect.Default

14+

15+%access public

16+

17+-- ---------------------------------------------------- [ Timer Data Structure ]

18+

19+||| A Simple timer.

20+record Timer where

21+ constructor MkTimer

22+ desc : String

23+ start : Integer

24+ stop : Integer

25+ splits : List (Integer, Maybe String)

26+

27+displayTimer : Timer -> String

28+displayTimer (MkTimer d a z bcd) = unlines

29+ [ unwords ["Timer:", d]

30+ , unwords ["\tStart:\t", show a, (displaySplits bcd)]

31+ , unwords ["\tStop:\t", show z]

32+ , unwords ["\tDifference:\t", show (z - a)]

33+ ]

34+ where

35+ displaySplit : (Integer, Maybe String) -> String

36+ displaySplit (v, Nothing) = with List unwords ["\tSplit:\t",show v]

37+ displaySplit (v, Just msg) = with List unwords ["\tSplit:\t",show v, show msg]

38+

39+ displaySplits : List (Integer, Maybe String) -> String

40+ displaySplits Nil = ""

41+ displaySplits ss = "\n" ++ unlines (map displaySplit $ reverse ss)

42+

43+

44+defaultTimer : String -> Timer

45+defaultTimer n = MkTimer n 0 0 Nil

46+

47+-- ---------------------------------------------------------------- [ Resource ]

48+

49+||| Performance Metrics to keep during program lifetime.

50+record PMetrics where

51+ constructor MkPMetrics

52+ canPerf : Bool

53+ livePerf : Bool

54+ counters : List (String, Nat)

55+ timers : List (String, Timer)

56+ stime : Integer

57+ stamps : List (String, Integer)

58+

59+

60+instance Default PMetrics where

61+ default = MkPMetrics False False Nil Nil 0 Nil

62+

63+displayPerfMetrics : PMetrics -> String

64+displayPerfMetrics (MkPMetrics c l cs ts _ ss) =

65+ unlines [ "Perf Data:"

66+ , unlines $ map displayMarker cs

67+ , unlines $ map (\(x,y) => displayTimer y) ts

68+ , unlines $ map displayMarker ss]

69+ where

70+ displayMarker : Show a => Pair String a -> String

71+ displayMarker (d,v) = unwords [show v, "\t<==\t", show d]

72+

73+-- ------------------------------------------------------- [ Utility functions ]

74+

75+incCounter' : String -> PMetrics -> PMetrics

76+incCounter' x st = record {counters = cs} st

77+ where

78+ cs : List (String, Nat)

79+ cs = map (\(y,c) => if x == y then (y,S c) else (y,c)) (counters st)

80+

81+

82+data TOpt = START | STOP | SPLIT

83+

84+displayTimerOpt : TOpt -> String

85+displayTimerOpt START = "Starting"

86+displayTimerOpt STOP = "Stopping"

87+displayTimerOpt SPLIT = "Splitting"

88+

89+timerStuff' : TOpt -> Integer -> String -> Maybe String -> PMetrics -> PMetrics

90+timerStuff' opt val x msg st = record {timers = ts} st

91+ where

92+ doThing : (String,Timer) -> (String,Timer)

93+ doThing (y,t) =

94+ if not (x == y)

95+ then (y, t)

96+ else case opt of

97+ START => MkPair y $ record {start = val} t

98+ STOP => MkPair y $ record {stop = val} t

99+ SPLIT => MkPair y $ record {splits = (val, msg) :: splits t} t

100+

101+ ts : List (String, Timer)

102+ ts = map doThing (timers st)

103+

104+

105+perfLog : PMetrics -> String -> IO ()

106+perfLog res msg =

107+ if livePerf res

108+ then putStrLn $ unwords ["PERF:", msg]

109+ else return ()

110+

111+-- ------------------------------------------------------- [ Effect Definition ]

112+

113+data Perf : Effect where

114+ GetMetrics : sig Perf (PMetrics) (PMetrics)

115+ TurnOn : Bool -> sig Perf () (PMetrics) (PMetrics)

116+ MkCounter : String -> sig Perf () (PMetrics) (PMetrics)

117+ IncCounter : String -> sig Perf () (PMetrics) (PMetrics)

118+ Timestamp : String -> sig Perf () (PMetrics) (PMetrics)

119+ MkStopWatch : String -> sig Perf () (PMetrics) (PMetrics)

120+ TimerStuff : TOpt -> String -> Maybe String -> sig Perf () (PMetrics) (PMetrics)

121+

122+-- ---------------------------------------------------------- [ Handler for IO ]

123+

124+instance Handler Perf IO where

125+ handle res (TurnOn b) k = do

126+ v <- time

127+ let res' = record {canPerf = True, livePerf = b, stime = v} res

128+ perfLog res' $ unwords [ "Turning on Perf with at", show v]

129+ k () (res')

130+

131+ handle res (GetMetrics) k = k res res

132+

133+ handle res (MkCounter n) k = do

134+ if not (canPerf res)

135+ then k () res

136+ else do

137+ let res' = record {counters = (n,Z) :: counters res} res

138+ perfLog res' $ unwords ["Creating counter:", show n]

139+ k () (res')

140+

141+ handle res (IncCounter n) k = do

142+ if not (canPerf res)

143+ then k () res

144+ else do

145+ let res' = incCounter' n res

146+ perfLog res' $ unwords ["Incriminating counter:", show n]

147+ k () (res')

148+

149+ handle res (MkStopWatch n) k = do

150+ if not (canPerf res)

151+ then k () res

152+ else do

153+ let res' = record {timers = (n, defaultTimer n) :: timers res} res

154+ perfLog res' $ unwords ["Creating Timer:", show n]

155+ k () (res')

156+

157+ handle res (TimerStuff opt n msg) k = do

158+ v <- time

159+ if not (canPerf res)

160+ then k () res

161+ else do

162+ let res' = timerStuff' opt v n msg res

163+ perfLog res' $ unwords [displayTimerOpt opt, "timer", show n, "at", show v, fromMaybe "" msg]

164+ k () (res')

165+

166+ handle res (Timestamp s) k = do

167+ v <- time

168+ let stamp = v - (stime res)

169+ if not (canPerf res)

170+ then k () res

171+ else do

172+ let res' = record {stamps = (s,stamp) :: stamps res} res

173+ perfLog res' $ unlines [ "Creating Timestamp:"

174+ , "\tTIMESTAMP:", show v

175+ , "\tMESSAGE:", show s]

176+ k () (res')

177+

178+-- ------------------------------------------------------- [ Effect Descriptor ]

179+

180+PERF : EFFECT

181+PERF = MkEff PMetrics Perf

182+

183+-- --------------------------------------------------------------------- [ API ]

184+

185+||| Turn on performance metrics.

186+collectPMetricsOnly : Eff () [PERF]

187+collectPMetricsOnly = call $ TurnOn False

188+

189+collectPMetrics : Bool -> Eff () [PERF]

190+collectPMetrics b = call $ TurnOn b

191+

192+||| Turn on performance metrics and show during operation

193+collectPMetricsAndShow : Eff () [PERF]

194+collectPMetricsAndShow = call $ TurnOn True

195+

196+||| Return gatheres metrics

197+getPerfMetrics : Eff PMetrics [PERF]

198+getPerfMetrics = call $ GetMetrics

199+

200+||| Create a counter

201+mkCounter : String -> Eff () [PERF]

202+mkCounter n = call $ MkCounter n

203+

204+||| Increment the counter

205+incCounter : String -> Eff () [PERF]

206+incCounter n = call $ IncCounter n

207+

208+mkTimer : String -> Eff () [PERF]

209+mkTimer n = call $ MkStopWatch n

210+

211+||| Stop a timer

212+stopTimer : String -> Eff () [PERF]

213+stopTimer n = call $ TimerStuff STOP n Nothing

214+

215+||| Start a timer

216+startTimer : String -> Eff () [PERF]

217+startTimer n = call $ TimerStuff START n Nothing

218+

219+||| Split a timer

220+splitTimer : String -> Eff () [PERF]

221+splitTimer n = call $ TimerStuff SPLIT n Nothing

222+

223+splitTimerMsg : String -> String -> Eff () [PERF]

224+splitTimerMsg n msg = call $ TimerStuff SPLIT n (Just msg)

225+

226+||| Create a time stamp.

227+timestamp : String -> Eff () [PERF]

228+timestamp msg = call $ Timestamp msg

229+

230+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/Effect/Random.idr+7−7

@@ -4,28 +4,28 @@ import Effects

4import Data.Vect

5

6data Random : Effect where

7− getRandom : sig Random Integer Integer

7+ GetRandom : sig Random Integer Integer

8− setSeed : Integer -> sig Random () Integer

8+ SetSeed : Integer -> sig Random () Integer

9

10instance Handler Random m where

11− handle seed getRandom k

11+ handle seed GetRandom k

12 = let seed' = assert_total ((1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32)) in

13 k seed' seed'

14− handle seed (setSeed n) k = k () n

14+ handle seed (SetSeed n) k = k () n

15

16RND : EFFECT

17RND = MkEff Integer Random

18

19||| Generates a random Integer in a given range

20rndInt : Integer -> Integer -> Eff Integer [RND]

21−rndInt lower upper = do v <- call $ getRandom

21+rndInt lower upper = do v <- call $ GetRandom

22 return ((v `prim__sremBigInt` (upper - lower)) + lower)

23

24||| Generate a random number in Fin (S `k`)

25|||

26||| Note that rndFin k takes values 0, 1, ..., k.

27rndFin : (k : Nat) -> Eff (Fin (S k)) [RND]

28−rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))

28+rndFin k = do let v = assert_total $ !(call GetRandom) `prim__sremBigInt` (cast (S k))

29 return (toFin v)

30 where toFin : Integer -> Fin (S k)

31 toFin x = case integerToFin x (S k) of

@@ -43,5 +43,5 @@ rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))

43

44||| Sets the random seed

45srand : Integer -> Eff () [RND]

46−srand n = call $ setSeed n

46+srand n = call $ SetSeed n

47

libs/effects/Effects.idr+31−19

@@ -12,9 +12,9 @@ import Data.Vect

12||| The Effect type describes effectful computations.

13|||

14||| This type is parameterised by:

15−||| + The input resource.

16||| + The return type of the computation.

15||| + The return type of the computation.

16+||| + The input resource.

17−||| + The computation to run on the resource.

17+||| + The computation to run on the resource given the return value.

18Effect : Type

19Effect = (x : Type) -> Type -> (x -> Type) -> Type

20

@@ -159,17 +159,17 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

159data EffM : (m : Type -> Type) -> (x : Type)

160 -> (es : List EFFECT)

161 -> (ce : x -> List EFFECT) -> Type where

162− value : (val : a) -> EffM m a (xs val) xs

162+ Value : (val : a) -> EffM m a (xs val) xs

163− ebind : EffM m a xs xs' ->

163+ EBind : EffM m a xs xs' ->

164 ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

165− callP : (prf : EffElem e a xs) ->

165+ CallP : (prf : EffElem e a xs) ->

166 (eff : e t a b) ->

167 EffM m t xs (\v => updateResTy v xs prf eff)

168

169− liftP : (prf : SubList ys xs) ->

169+ LiftP : (prf : SubList ys xs) ->

170 EffM m t ys ys' -> EffM m t xs (\v => updateWith (ys' v) xs prf)

171

172− new : Handler e' m => (e : EFFECT) -> resTy ->

172+ New : Handler e' m => (e : EFFECT) -> resTy ->

173 {auto prf : e = MkEff resTy e'} ->

174 EffM m t (e :: es) (\v => e :: es) ->

175 EffM m t es (\v => es)

@@ -211,12 +211,12 @@ namespace DepEff

211%no_implicit

212(>>=) : EffM m a xs xs' ->

213 ((val : a) -> EffM m b (xs' val) xs'') -> EffM m b xs xs''

214−(>>=) = ebind

214+(>>=) = EBind

215

216-- namespace SimpleBind

217-- (>>=) : Eff m a xs (\v => xs) ->

218-- ((val : a) -> Eff m b xs xs') -> Eff m b xs xs'

219−-- (>>=) = ebind

219+-- (>>=) = EBind

220

221||| Run a subprogram which results in an effect state the same as the input.

222staticEff : EffM m a xs (\v => xs) -> EffM m a xs (\v => xs)

@@ -228,17 +228,17 @@ toEff : .(xs' : List EFFECT) -> EffM m a xs (\v => xs') -> EffM m a xs (\v => xs

228toEff xs' = id

229

230return : a -> EffM m a xs (\v => xs)

231−return x = value x

231+return x = Value x

232

233-- ------------------------------------------------------ [ for idiom brackets ]

234

235infixl 2 <*>

236

237pure : a -> EffM m a xs (\v => xs)

238−pure = value

238+pure = Value

239

240pureM : (val : a) -> EffM m a (xs val) xs

241−pureM = value

241+pureM = Value

242

243(<*>) : EffM m (a -> b) xs (\v => xs) ->

244 EffM m a xs (\v => xs) -> EffM m b xs (\v => xs)

@@ -246,6 +246,17 @@ pureM = value

246 arg <- v

247 return (fn arg)

248

249+(*>) : EffM m a xs (\v => xs) ->

250+ EffM m b xs (\v => xs) -> EffM m b xs (\v => xs)

251+a *> b = do a

252+ b

253+

254+new : Handler e' m => (e : EFFECT) -> resTy ->

255+ {auto prf : e = MkEff resTy e'} ->

256+ EffM m t (e :: es) (\v => e :: es) ->

257+ EffM m t es (\v => es)

258+new = New

259+

249-- ---------------------------------------------------------- [ an interpreter ]

260-- ---------------------------------------------------------- [ an interpreter ]

250

261

251private

262private

@@ -261,14 +272,14 @@ execEff (val :: env) (There p) eff k

261-- updates can be propagated even through failing computations?

272-- updates can be propagated even through failing computations?

262

273

263eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

274eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

264−eff env (value x) k = k x env

275+eff env (Value x) k = k x env

265−eff env (prog `ebind` c) k

276+eff env (prog `EBind` c) k

266 = eff env prog (\p', env' => eff env' (c p') k)

277 = eff env prog (\p', env' => eff env' (c p') k)

267−eff env (callP prf effP) k = execEff env prf effP k

278+eff env (CallP prf effP) k = execEff env prf effP k

268−eff env (liftP prf effP) k

279+eff env (LiftP prf effP) k

269 = let env' = dropEnv env prf in

280 = let env' = dropEnv env prf in

270 eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

281 eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

271−eff env (new (MkEff resTy newEff) res {prf=Refl} effP) k

282+eff env (New (MkEff resTy newEff) res {prf=Refl} effP) k

272 = eff (res :: env) effP (\p', (val :: envk) => k p' envk)

283 = eff (res :: env) effP (\p', (val :: envk) => k p' envk)

273eff env (l :- prog) k

284eff env (l :- prog) k

274 = let env' = unlabel env in

285 = let env' = unlabel env in

@@ -286,17 +297,18 @@ syntax MkDefaultEnv = with Env

286 [default, default, default, default, default, default, default],

297 [default, default, default, default, default, default, default],

287 [default, default, default, default, default, default, default, default] |)

298 [default, default, default, default, default, default, default, default] |)

288

299

300+%no_implicit

289call : {a, b: _} -> {e : Effect} ->

301call : {a, b: _} -> {e : Effect} ->

290 (eff : e t a b) ->

302 (eff : e t a b) ->

291 {auto prf : EffElem e a xs} ->

303 {auto prf : EffElem e a xs} ->

292 EffM m t xs (\v => updateResTy v xs prf eff)

304 EffM m t xs (\v => updateResTy v xs prf eff)

293−call e {prf} = callP prf e

305+call e {prf} = CallP prf e

294

306

295implicit

307implicit

296lift : EffM m t ys ys' ->

308lift : EffM m t ys ys' ->

297 {auto prf : SubList ys xs} ->

309 {auto prf : SubList ys xs} ->

298 EffM m t xs (\v => updateWith (ys' v) xs prf)

310 EffM m t xs (\v => updateWith (ys' v) xs prf)

299−lift e {prf} = liftP prf e

311+lift e {prf} = LiftP prf e

300

312

301

313

302-- --------------------------------------------------------- [ Running Effects ]

314-- --------------------------------------------------------- [ Running Effects ]

libs/effects/effects.ipkg+1

@@ -18,3 +18,4 @@ modules = Effects

18 , Effect.Logging.Level

19 , Effect.Logging.Default

20 , Effect.Logging.Category

21+ , Effect.Perf

libs/oldeffects/Effect/Default.idr+1−1

@@ -9,7 +9,7 @@ instance Default Int where

9instance Default Integer where

10 default = 0

11

12−instance Default Float where

12+instance Default Double where

13 default = 0

14

15instance Default Nat where

libs/prelude/Builtins.idr+17−2

@@ -19,6 +19,10 @@ namespace Builtins

19 ||| @b the right element of the pair

20 MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B

21

22+ -- Usage hints for erasure analysis

23+ %used MkPair a

24+ %used MkPair b

25+

22 ||| The non-dependent pair type, also known as conjunction, usable with

26 ||| The non-dependent pair type, also known as conjunction, usable with

23 ||| UniqueTypes.

27 ||| UniqueTypes.

24 ||| @A the type of the left elements in the pair

28 ||| @A the type of the left elements in the pair

@@ -29,6 +33,10 @@ namespace Builtins

29 ||| @b the right element of the pair

33 ||| @b the right element of the pair

30 MkUPair : {A, B : AnyType} -> (a : A) -> (b : B) -> UPair A B

34 MkUPair : {A, B : AnyType} -> (a : A) -> (b : B) -> UPair A B

31

35

36+ -- Usage hints for erasure analysis

37+ %used MkUPair a

38+ %used MkUPair b

39+

32 ||| Dependent pairs

40 ||| Dependent pairs

33 |||

41 |||

34 ||| Dependent pairs represent existential quantification - they consist of a

42 ||| Dependent pairs represent existential quantification - they consist of a

@@ -48,7 +56,12 @@ namespace Builtins

48

56

49||| The eliminator for the `Void` type.

57||| The eliminator for the `Void` type.

50void : Void -> a

58void : Void -> a

51−void {a} v = elim_for Void (\_ => a) v

59+-- We can't define void yet. We can't define a function with no clauses without

60+-- elaborator reflection, and we can't do elaborator reflection without

61+-- Language.Reflection.Elab, and Language.Reflection.Elab depends on Builtins.

62+-- We can't delay the declaration of void, because Prelude.Uninhabited depends on

63+-- it, Prelude.Nat depends on Prelude.Uninhabited, and Language.Reflection.Elab

64+-- depends on Prelude.Nat. Instead, void is defined in Prelude.idr

52

65

53||| For 'symbol syntax. 'foo becomes Symbol_ "foo"

66||| For 'symbol syntax. 'foo becomes Symbol_ "foo"

54data Symbol_ : String -> Type where

67data Symbol_ : String -> Type where

@@ -152,9 +165,11 @@ public %assert_total

152really_believe_me : a -> b

165really_believe_me : a -> b

153really_believe_me x = prim__believe_me _ _ x

166really_believe_me x = prim__believe_me _ _ x

154

167

155−-- Deprecated - for backward compatibility

168+||| Deprecated alias for `Double`, for the purpose of backwards

169+||| compatibility. Idris does not support 32 bit floats at present.

156Float : Type

170Float : Type

157Float = Double

171Float = Double

172+%deprecate Float

158

173

159-- Pointers as external primitive; there's no literals for these, so no

174-- Pointers as external primitive; there's no literals for these, so no

160-- need for them to be part of the compiler.

175-- need for them to be part of the compiler.

libs/prelude/Decidable/Equality.idr+1−1

@@ -178,7 +178,7 @@ instance DecEq Char where

178instance DecEq Integer where

179 decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

180 where primitiveEq : x = y

181− primitiveEq = believe_me (Refl {x})

181+ primitiveEq = really_believe_me (Refl {x})

182 postulate primitiveNotEq : x = y -> Void

183

184

libs/prelude/IO.idr+17−8

@@ -8,7 +8,7 @@ import Prelude.List

8||| Idris's primitive IO, for building abstractions on top of

9abstract

10data PrimIO : Type -> Type where

11− prim__IO : a -> PrimIO a

11+ Prim__IO : a -> PrimIO a

12

13||| A token representing the world, for use in `IO`

14abstract data World = TheWorld prim__WorldType

@@ -93,14 +93,14 @@ foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

93

94abstract

95prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b

96−prim_io_bind (prim__IO v) k = k v

96+prim_io_bind (Prim__IO v) k = k v

97

98unsafePerformPrimIO : PrimIO a -> a

99-- compiled as primitive

100

101abstract

102prim_io_return : a -> PrimIO a

103−prim_io_return x = prim__IO x

103+prim_io_return x = Prim__IO x

104

105abstract

106io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

@@ -116,11 +116,11 @@ io_return x = MkIO (\w => prim_io_return x)

116liftPrimIO : (World -> PrimIO a) -> IO' l a

117liftPrimIO = MkIO

118

119−call__IO : IO' l a -> PrimIO a

119+call__IO : IO' ffi a -> PrimIO a

120call__IO (MkIO f) = f (TheWorld prim__TheWorld)

121

122-- Concrete type makes it easier to elaborate at top level

123−run__IO : IO' l () -> PrimIO ()

123+run__IO : IO' ffi () -> PrimIO ()

124run__IO f = call__IO f

125

126unsafePerformIO : IO' ffi a -> a

@@ -162,7 +162,7 @@ namespace FFI_C

162 ||| Supported C foreign types

163 data C_Types : Type -> Type where

164 C_Str : C_Types String

165− C_Float : C_Types Float

165+ C_Float : C_Types Double

166 C_Ptr : C_Types Ptr

167 C_MPtr : C_Types ManagedPtr

168 C_Unit : C_Types ()

@@ -171,10 +171,14 @@ namespace FFI_C

171

172 ||| A descriptor for the C FFI. See the constructors of `C_Types`

173 ||| and `C_IntTypes` for the concrete types that are available.

174+ %error_reverse

174 FFI_C : FFI

175 FFI_C : FFI

175 FFI_C = MkFFI C_Types String String

176 FFI_C = MkFFI C_Types String String

176

177

178+||| Interactive programs, describing I/O actions and returning a value.

179+||| @res The result type of the program

180+%error_reverse

177−IO : Type -> Type

181+IO : (res : Type) -> Type

178IO = IO' FFI_C

182IO = IO' FFI_C

179

183

180-- Cannot be relaxed as is used by type providers and they expect IO a

184-- Cannot be relaxed as is used by type providers and they expect IO a

@@ -195,6 +199,9 @@ namespace IO

195 forceGC : IO ()

199 forceGC : IO ()

196 forceGC = foreign FFI_C "idris_forceGC" (Ptr -> IO ()) prim__vm

200 forceGC = foreign FFI_C "idris_forceGC" (Ptr -> IO ()) prim__vm

197

201

202+ getErrno : IO Int

203+ getErrno = foreign FFI_C "idris_errno" (IO Int)

204+

198--------- The Javascript/Node FFI

205--------- The Javascript/Node FFI

199

206

200

207

@@ -214,7 +221,7 @@ mutual

214

221

215 data JS_Types : Type -> Type where

222 data JS_Types : Type -> Type where

216 JS_Str : JS_Types String

223 JS_Str : JS_Types String

217− JS_Float : JS_Types Float

224+ JS_Float : JS_Types Double

218 JS_Ptr : JS_Types Ptr

225 JS_Ptr : JS_Types Ptr

219 JS_Unit : JS_Types ()

226 JS_Unit : JS_Types ()

220 JS_FnT : JS_FnTypes a -> JS_Types (JsFn a)

227 JS_FnT : JS_FnTypes a -> JS_Types (JsFn a)

@@ -228,9 +235,11 @@ mutual

228||| The JavaScript FFI. The strings naming functions in this API are

235||| The JavaScript FFI. The strings naming functions in this API are

229||| JavaScript code snippets, into which the arguments are substituted

236||| JavaScript code snippets, into which the arguments are substituted

230||| for the placeholders `%0`, `%1`, etc.

237||| for the placeholders `%0`, `%1`, etc.

238+%error_reverse

231FFI_JS : FFI

239FFI_JS : FFI

232FFI_JS = MkFFI JS_Types String String

240FFI_JS = MkFFI JS_Types String String

233

241

242+%error_reverse

234JS_IO : Type -> Type

243JS_IO : Type -> Type

235JS_IO = IO' FFI_JS

244JS_IO = IO' FFI_JS

236

245

libs/prelude/Language/Reflection.idr+99−64

@@ -11,6 +11,22 @@ import Prelude.Traversable

11

12%access public

13

14+||| A source location in an Idris file

15+record SourceLocation where

16+ ||| Either a source span or a source location. `start` and `end`

17+ ||| will be the same if it's a point location.

18+ constructor FileLoc

19+

20+ ||| The file name of the source location

21+ filename : String

22+ ||| The line and column of the beginning of the source span

23+ start : (Int, Int)

24+ ||| The line and column of the end of the source span

25+ end : (Int, Int)

26+

27+%name SourceLocation loc

28+

29+

14mutual

30mutual

15 data TTName =

31 data TTName =

16 ||| A user-provided name

32 ||| A user-provided name

@@ -24,9 +40,7 @@ mutual

24 MN Int String |

40 MN Int String |

25 ||| Special names, to make conflicts impossible and language features

41 ||| Special names, to make conflicts impossible and language features

26 ||| predictable

42 ||| predictable

27− SN SpecialName |

43+ SN SpecialName

28− ||| Name of something which is never used in scope

29− NErased

30 %name TTName n, n'

44 %name TTName n, n'

31

45

32 data SpecialName = WhereN Int TTName TTName

46 data SpecialName = WhereN Int TTName TTName

@@ -34,7 +48,7 @@ mutual

34 | InstanceN TTName (List String)

48 | InstanceN TTName (List String)

35 | ParentN TTName String

49 | ParentN TTName String

36 | MethodN TTName

50 | MethodN TTName

37− | CaseN TTName

51+ | CaseN SourceLocation TTName

38 | ElimN TTName

52 | ElimN TTName

39 | InstanceCtorN TTName

53 | InstanceCtorN TTName

40 | MetaN TTName TTName

54 | MetaN TTName TTName

@@ -56,10 +70,10 @@ data NativeTy = IT8 | IT16 | IT32 | IT64

56

70

57data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar

71data IntTy = ITFixed NativeTy | ITNative | ITBig | ITChar

58

72

59−data ArithTy = ATInt Language.Reflection.IntTy | ATFloat

73+data ArithTy = ATInt Language.Reflection.IntTy | ATDouble

60

74

61||| Primitive constants

75||| Primitive constants

62−data Const = I Int | BI Integer | Fl Float | Ch Char | Str String

76+data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

63 | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64

77 | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64

64 | AType ArithTy | StrType

78 | AType ArithTy | StrType

65 | VoidType | Forgot

79 | VoidType | Forgot

@@ -75,7 +89,7 @@ instance ReflConst Int where

75instance ReflConst Integer where

89instance ReflConst Integer where

76 toConst = BI

90 toConst = BI

77

91

78−instance ReflConst Float where

92+instance ReflConst Double where

79 toConst = Fl

93 toConst = Fl

80

94

81instance ReflConst Char where

95instance ReflConst Char where

@@ -116,22 +130,62 @@ data NameType =

116

130

117||| Types annotations for bound variables in different

131||| Types annotations for bound variables in different

118||| binding contexts

132||| binding contexts

133+|||

134+||| @ tmTy the terms that can occur inside the binder, as type

135+||| annotations or bound values

119−data Binder a = Lam a

136+data Binder : (tmTy : Type) -> Type where

137+ ||| Lambdas

138+ |||

139+ ||| @ ty the type of the argument

140+ Lam : (ty : a) -> Binder a

141+

142+ ||| Function types.

143+ |||

144+ ||| @ kind The kind of arrow. Only relevant when dealing with

145+ ||| uniqueness, so you can usually pretend that this

146+ ||| field doesn't exist. For ordinary functions, use the

147+ ||| type of types here.

120− | Pi a a

148+ Pi : (ty, kind : a) -> Binder a

149+

150+ ||| A let binder

151+ |||

152+ ||| @ ty the type of the bound variable

153+ ||| @ val the bound value

121− | Let a a

154+ Let : (ty, val : a) -> Binder a

122− | NLet a a

155+

156+ ||| A hole that can occur during elaboration, and must be filled

157+ |||

158+ ||| @ ty the type of the value that will eventually be put into the hole

123− | Hole a

159+ Hole : (ty : a) -> Binder a

160+

161+ ||| A hole that will later become a top-level metavariable

124− | GHole a

162+ GHole : (ty : a) -> Binder a

163+

164+ ||| A hole with a solution in it. Computationally inert.

165+ |||

166+ ||| @ ty the type of the value in the hole

167+ ||| @ val the value in the hole

125− | Guess a a

168+ Guess : (ty, val : a) -> Binder a

169+

170+ ||| A pattern variable. These bindings surround the terms that make

171+ ||| up the left and right sides of pattern-matching definition

172+ ||| clauses.

173+ |||

174+ ||| @ ty the type of the pattern variable

126− | PVar a

175+ PVar : (ty : a) -> Binder a

176+

177+ ||| The type of a pattern binding. This is to `PVar` as `Pi` is to

178+ ||| `Lam`.

179+ |||

180+ ||| @ ty the type of the pattern variable

127− | PVTy a

181+ PVTy : (ty : a) -> Binder a

182+

128%name Binder b, b'

183%name Binder b, b'

129

184

130instance Functor Binder where

185instance Functor Binder where

131 map f (Lam x) = Lam (f x)

186 map f (Lam x) = Lam (f x)

132 map f (Pi x k) = Pi (f x) (f k)

187 map f (Pi x k) = Pi (f x) (f k)

133 map f (Let x y) = Let (f x) (f y)

188 map f (Let x y) = Let (f x) (f y)

134− map f (NLet x y) = NLet (f x) (f y)

135 map f (Hole x) = Hole (f x)

189 map f (Hole x) = Hole (f x)

136 map f (GHole x) = GHole (f x)

190 map f (GHole x) = GHole (f x)

137 map f (Guess x y) = Guess (f x) (f y)

191 map f (Guess x y) = Guess (f x) (f y)

@@ -142,7 +196,6 @@ instance Foldable Binder where

142 foldr f z (Lam x) = f x z

196 foldr f z (Lam x) = f x z

143 foldr f z (Pi x k) = f x (f k z)

197 foldr f z (Pi x k) = f x (f k z)

144 foldr f z (Let x y) = f x (f y z)

198 foldr f z (Let x y) = f x (f y z)

145− foldr f z (NLet x y) = f x (f y z)

146 foldr f z (Hole x) = f x z

199 foldr f z (Hole x) = f x z

147 foldr f z (GHole x) = f x z

200 foldr f z (GHole x) = f x z

148 foldr f z (Guess x y) = f x (f y z)

201 foldr f z (Guess x y) = f x (f y z)

@@ -153,14 +206,13 @@ instance Traversable Binder where

153 traverse f (Lam x) = [| Lam (f x) |]

206 traverse f (Lam x) = [| Lam (f x) |]

154 traverse f (Pi x k) = [| Pi (f x) (f k) |]

207 traverse f (Pi x k) = [| Pi (f x) (f k) |]

155 traverse f (Let x y) = [| Let (f x) (f y) |]

208 traverse f (Let x y) = [| Let (f x) (f y) |]

156− traverse f (NLet x y) = [| NLet (f x) (f y) |]

157 traverse f (Hole x) = [| Hole (f x) |]

209 traverse f (Hole x) = [| Hole (f x) |]

158 traverse f (GHole x) = [| GHole (f x) |]

210 traverse f (GHole x) = [| GHole (f x) |]

159 traverse f (Guess x y) = [| Guess (f x) (f y) |]

211 traverse f (Guess x y) = [| Guess (f x) (f y) |]

160 traverse f (PVar x) = [| PVar (f x) |]

212 traverse f (PVar x) = [| PVar (f x) |]

161 traverse f (PVTy x) = [| PVTy (f x) |]

213 traverse f (PVTy x) = [| PVTy (f x) |]

162

214

163−||| Universes

215+||| The various universes involved in the uniqueness mechanism

164data Universe = NullType | UniqueType | AllTypes

216data Universe = NullType | UniqueType | AllTypes

165

217

166||| Reflection of the well typed core language

218||| Reflection of the well typed core language

@@ -175,14 +227,11 @@ data TT =

175 App TT TT |

227 App TT TT |

176 ||| Embed a constant

228 ||| Embed a constant

177 TConst Const |

229 TConst Const |

178− ||| Argument projection; runtime only

179− Proj TT Int |

180 ||| Erased terms

230 ||| Erased terms

181 Erased |

231 Erased |

182− ||| Impossible terms

183− Impossible |

184 ||| The type of types along (with universe constraints)

232 ||| The type of types along (with universe constraints)

185 TType TTUExp |

233 TType TTUExp |

234+ ||| Alternative universes for dealing with uniqueness

186 UType Universe

235 UType Universe

187%name TT tm, tm'

236%name TT tm, tm'

188

237

@@ -196,17 +245,12 @@ data Raw =

196 RApp Raw Raw |

245 RApp Raw Raw |

197 ||| The type of types

246 ||| The type of types

198 RType |

247 RType |

248+ ||| Alternative universes for dealing with uniqueness

199 RUType Universe |

249 RUType Universe |

200− RForce Raw |

201 ||| Embed a constant

250 ||| Embed a constant

202 RConstant Const

251 RConstant Const

203%name Raw tm, tm'

252%name Raw tm, tm'

204

253

205−data SourceLocation : Type where

206− FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation

207−

208−%name SourceLocation loc

209−

210||| Error reports are a list of report parts

254||| Error reports are a list of report parts

211data ErrorReportPart =

255data ErrorReportPart =

212 ||| A human-readable string

256 ||| A human-readable string

@@ -221,7 +265,7 @@ data ErrorReportPart =

221 SubReport (List ErrorReportPart)

265 SubReport (List ErrorReportPart)

222%name ErrorReportPart part, p

266%name ErrorReportPart part, p

223

267

224−||| A representation of Idris's tactics that can be returned from custom

268+||| A representation of Idris's old tactics that can be returned from custom

225||| tactic implementations. Generate these using `applyTactic`.

269||| tactic implementations. Generate these using `applyTactic`.

226data Tactic =

270data Tactic =

227 ||| Try the first tactic and resort to the second one on failure

271 ||| Try the first tactic and resort to the second one on failure

@@ -280,6 +324,7 @@ data Tactic =

280 Fail (List ErrorReportPart) |

324 Fail (List ErrorReportPart) |

281 ||| Attempt to fill the hole with source code information

325 ||| Attempt to fill the hole with source code information

282 SourceFC

326 SourceFC

327+

283%name Tactic tac, tac'

328%name Tactic tac, tac'

284

329

285

330

@@ -321,12 +366,12 @@ instance Quotable Int Raw where

321 quotedTy = `(Int)

366 quotedTy = `(Int)

322 quote x = RConstant (I x)

367 quote x = RConstant (I x)

323

368

324−instance Quotable Float TT where

369+instance Quotable Double TT where

325− quotedTy = `(Float)

370+ quotedTy = `(Double)

326 quote x = TConst (Fl x)

371 quote x = TConst (Fl x)

327

372

328−instance Quotable Float Raw where

373+instance Quotable Double Raw where

329− quotedTy = `(Float)

374+ quotedTy = `(Double)

330 quote x = RConstant (Fl x)

375 quote x = RConstant (Fl x)

331

376

332instance Quotable Char TT where

377instance Quotable Char TT where

@@ -409,6 +454,21 @@ instance Quotable a Raw => Quotable (List a) Raw where

409 quote [] = `(List.Nil {elem=~(quotedTy {a})})

454 quote [] = `(List.Nil {elem=~(quotedTy {a})})

410 quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs))

455 quote (x :: xs) = `(List.(::) {elem=~(quotedTy {a})} ~(quote x) ~(quote xs))

411

456

457+instance Quotable SourceLocation TT where

458+ quotedTy = `(SourceLocation)

459+ quote (FileLoc fn (sl, sc) (el, ec)) =

460+ `(FileLoc ~(quote fn)

461+ (~(quote sl), ~(quote sc))

462+ (~(quote el), ~(quote ec)))

463+

464+instance Quotable SourceLocation Raw where

465+ quotedTy = `(SourceLocation)

466+ quote (FileLoc fn (sl, sc) (el, ec)) =

467+ `(FileLoc ~(quote {t=Raw} fn)

468+ (~(quote {t=Raw} sl), ~(quote {t=Raw} sc))

469+ (~(quote {t=Raw} el), ~(quote {t=Raw} ec)))

470+

471+

412mutual

472mutual

413 instance Quotable TTName TT where

473 instance Quotable TTName TT where

414 quotedTy = `(TTName)

474 quotedTy = `(TTName)

@@ -416,7 +476,6 @@ mutual

416 quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

476 quote (NS n xs) = `(NS ~(quote n) ~(quote xs))

417 quote (MN x y) = `(MN ~(quote x) ~(quote y))

477 quote (MN x y) = `(MN ~(quote x) ~(quote y))

418 quote (SN sn) = `(SN ~(assert_total $ quote sn))

478 quote (SN sn) = `(SN ~(assert_total $ quote sn))

419− quote NErased = `(NErased)

420

479

421 instance Quotable SpecialName TT where

480 instance Quotable SpecialName TT where

422 quotedTy = `(SpecialName)

481 quotedTy = `(SpecialName)

@@ -425,7 +484,7 @@ mutual

425 quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

484 quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

426 quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

485 quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

427 quote (MethodN n) = `(MethodN ~(quote n))

486 quote (MethodN n) = `(MethodN ~(quote n))

428− quote (CaseN n) = `(CaseN ~(quote n))

487+ quote (CaseN fc n) = `(CaseN ~(quote fc) ~(quote n))

429 quote (ElimN n) = `(ElimN ~(quote n))

488 quote (ElimN n) = `(ElimN ~(quote n))

430 quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

489 quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

431 quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

490 quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

@@ -437,7 +496,6 @@ mutual

437 quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))

496 quote (NS n xs) = `(NS ~(quote {t=Raw} n) ~(quote {t=Raw} xs))

438 quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))

497 quote (MN x y) = `(MN ~(quote {t=Raw} x) ~(quote {t=Raw} y))

439 quote (SN sn) = `(SN ~(assert_total $ quote sn))

498 quote (SN sn) = `(SN ~(assert_total $ quote sn))

440− quote NErased = `(NErased)

441

499

442 instance Quotable SpecialName Raw where

500 instance Quotable SpecialName Raw where

443 quotedTy = `(SpecialName)

501 quotedTy = `(SpecialName)

@@ -446,7 +504,7 @@ mutual

446 quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

504 quote (InstanceN i ss) = `(InstanceN ~(quote i) ~(quote ss))

447 quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

505 quote (ParentN n s) = `(ParentN ~(quote n) ~(quote s))

448 quote (MethodN n) = `(MethodN ~(quote n))

506 quote (MethodN n) = `(MethodN ~(quote n))

449− quote (CaseN n) = `(CaseN ~(quote n))

507+ quote (CaseN fc n) = `(CaseN ~(quote fc) ~(quote n))

450 quote (ElimN n) = `(ElimN ~(quote n))

508 quote (ElimN n) = `(ElimN ~(quote n))

451 quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

509 quote (InstanceCtorN n) = `(InstanceCtorN ~(quote n))

452 quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

510 quote (MetaN parent meta) = `(MetaN ~(quote parent) ~(quote meta))

@@ -483,12 +541,12 @@ instance Quotable Reflection.IntTy Raw where

483instance Quotable ArithTy TT where

541instance Quotable ArithTy TT where

484 quotedTy = `(ArithTy)

542 quotedTy = `(ArithTy)

485 quote (ATInt x) = `(ATInt ~(quote x))

543 quote (ATInt x) = `(ATInt ~(quote x))

486− quote ATFloat = `(ATFloat)

544+ quote ATDouble = `(ATDouble)

487

545

488instance Quotable ArithTy Raw where

546instance Quotable ArithTy Raw where

489 quotedTy = `(ArithTy)

547 quotedTy = `(ArithTy)

490 quote (ATInt x) = `(ATInt ~(quote {t=Raw} x))

548 quote (ATInt x) = `(ATInt ~(quote {t=Raw} x))

491− quote ATFloat = `(ATFloat)

549+ quote ATDouble = `(ATDouble)

492

550

493instance Quotable Const TT where

551instance Quotable Const TT where

494 quotedTy = `(Const)

552 quotedTy = `(Const)

@@ -556,9 +614,7 @@ mutual

556 quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm))

614 quote (Bind n b tm) = `(Bind ~(quote n) ~(assert_total (quote b)) ~(quote tm))

557 quote (App f x) = `(App ~(quote f) ~(quote x))

615 quote (App f x) = `(App ~(quote f) ~(quote x))

558 quote (TConst c) = `(TConst ~(quote c))

616 quote (TConst c) = `(TConst ~(quote c))

559− quote (Proj tm x) = `(Proj ~(quote tm) ~(quote x))

560 quote Erased = `(Erased)

617 quote Erased = `(Erased)

561− quote Impossible = `(Impossible)

562 quote (TType uexp) = `(TType ~(quote uexp))

618 quote (TType uexp) = `(TType ~(quote uexp))

563 quote (UType u) = `(UType ~(quote u))

619 quote (UType u) = `(UType ~(quote u))

564

620

@@ -569,8 +625,6 @@ mutual

569 ~(assert_total (quote k)))

625 ~(assert_total (quote k)))

570 quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x))

626 quote (Let x y) = `(Let {a=TT} ~(assert_total (quote x))

571 ~(assert_total (quote y)))

627 ~(assert_total (quote y)))

572− quote (NLet x y) = `(NLet {a=TT} ~(assert_total (quote x))

573− ~(assert_total (quote y)))

574 quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x)))

628 quote (Hole x) = `(Hole {a=TT} ~(assert_total (quote x)))

575 quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x)))

629 quote (GHole x) = `(GHole {a=TT} ~(assert_total (quote x)))

576 quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x))

630 quote (Guess x y) = `(Guess {a=TT} ~(assert_total (quote x))

@@ -585,14 +639,12 @@ mutual

585 quoteRawTT (RApp tm tm') = `(RApp ~(quoteRawTT tm) ~(quoteRawTT tm'))

639 quoteRawTT (RApp tm tm') = `(RApp ~(quoteRawTT tm) ~(quoteRawTT tm'))

586 quoteRawTT RType = `(RType)

640 quoteRawTT RType = `(RType)

587 quoteRawTT (RUType u) = `(RUType ~(quote u))

641 quoteRawTT (RUType u) = `(RUType ~(quote u))

588− quoteRawTT (RForce tm) = `(RForce ~(quoteRawTT tm))

589 quoteRawTT (RConstant c) = `(RConstant ~(quote c))

642 quoteRawTT (RConstant c) = `(RConstant ~(quote c))

590

643

591 quoteRawBinderTT : Binder Raw -> TT

644 quoteRawBinderTT : Binder Raw -> TT

592 quoteRawBinderTT (Lam x) = `(Lam {a=Raw} ~(quoteRawTT x))

645 quoteRawBinderTT (Lam x) = `(Lam {a=Raw} ~(quoteRawTT x))

593 quoteRawBinderTT (Pi x k) = `(Pi {a=Raw} ~(quoteRawTT x) ~(quoteRawTT k))

646 quoteRawBinderTT (Pi x k) = `(Pi {a=Raw} ~(quoteRawTT x) ~(quoteRawTT k))

594 quoteRawBinderTT (Let x y) = `(Let {a=Raw} ~(quoteRawTT x) ~(quoteRawTT y))

647 quoteRawBinderTT (Let x y) = `(Let {a=Raw} ~(quoteRawTT x) ~(quoteRawTT y))

595− quoteRawBinderTT (NLet x y) = `(NLet {a=Raw} ~(quoteRawTT x) ~(quoteRawTT y))

596 quoteRawBinderTT (Hole x) = `(Hole {a=Raw} ~(quoteRawTT x))

648 quoteRawBinderTT (Hole x) = `(Hole {a=Raw} ~(quoteRawTT x))

597 quoteRawBinderTT (GHole x) = `(GHole {a=Raw} ~(quoteRawTT x))

649 quoteRawBinderTT (GHole x) = `(GHole {a=Raw} ~(quoteRawTT x))

598 quoteRawBinderTT (Guess x y) = `(Guess {a=Raw} ~(quoteRawTT x) ~(quoteRawTT y))

650 quoteRawBinderTT (Guess x y) = `(Guess {a=Raw} ~(quoteRawTT x) ~(quoteRawTT y))

@@ -614,14 +666,12 @@ mutual

614 quoteRawRaw (RApp tm tm') = `(RApp ~(quoteRawRaw tm) ~(quoteRawRaw tm'))

666 quoteRawRaw (RApp tm tm') = `(RApp ~(quoteRawRaw tm) ~(quoteRawRaw tm'))

615 quoteRawRaw RType = `(RType)

667 quoteRawRaw RType = `(RType)

616 quoteRawRaw (RUType u) = `(RUType ~(quote u))

668 quoteRawRaw (RUType u) = `(RUType ~(quote u))

617− quoteRawRaw (RForce tm) = `(RForce ~(quoteRawRaw tm))

618 quoteRawRaw (RConstant c) = `(RConstant ~(quote c))

669 quoteRawRaw (RConstant c) = `(RConstant ~(quote c))

619

670

620 quoteRawBinderRaw : Binder Raw -> Raw

671 quoteRawBinderRaw : Binder Raw -> Raw

621 quoteRawBinderRaw (Lam x) = `(Lam {a=Raw} ~(quoteRawRaw x))

672 quoteRawBinderRaw (Lam x) = `(Lam {a=Raw} ~(quoteRawRaw x))

622 quoteRawBinderRaw (Pi x k) = `(Pi {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw k))

673 quoteRawBinderRaw (Pi x k) = `(Pi {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw k))

623 quoteRawBinderRaw (Let x y) = `(Let {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw y))

674 quoteRawBinderRaw (Let x y) = `(Let {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw y))

624− quoteRawBinderRaw (NLet x y) = `(NLet {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw y))

625 quoteRawBinderRaw (Hole x) = `(Hole {a=Raw} ~(quoteRawRaw x))

675 quoteRawBinderRaw (Hole x) = `(Hole {a=Raw} ~(quoteRawRaw x))

626 quoteRawBinderRaw (GHole x) = `(GHole {a=Raw} ~(quoteRawRaw x))

676 quoteRawBinderRaw (GHole x) = `(GHole {a=Raw} ~(quoteRawRaw x))

627 quoteRawBinderRaw (Guess x y) = `(Guess {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw y))

677 quoteRawBinderRaw (Guess x y) = `(Guess {a=Raw} ~(quoteRawRaw x) ~(quoteRawRaw y))

@@ -673,18 +723,3 @@ instance Quotable Tactic TT where

673 quote Skip = `(Skip)

723 quote Skip = `(Skip)

674 quote (Fail xs) = `(Fail ~(quote xs))

724 quote (Fail xs) = `(Fail ~(quote xs))

675 quote SourceFC = `(SourceFC)

725 quote SourceFC = `(SourceFC)

676−

677−

678−instance Quotable SourceLocation TT where

679− quotedTy = `(SourceLocation)

680− quote (FileLoc fn (sl, sc) (el, ec)) =

681− `(FileLoc ~(quote fn)

682− (~(quote sl), ~(quote sc))

683− (~(quote el), ~(quote ec)))

684−

685−instance Quotable SourceLocation Raw where

686− quotedTy = `(SourceLocation)

687− quote (FileLoc fn (sl, sc) (el, ec)) =

688− `(FileLoc ~(quote {t=Raw} fn)

689− (~(quote {t=Raw} sl), ~(quote {t=Raw} sc))

690− (~(quote {t=Raw} el), ~(quote {t=Raw} ec)))

libs/prelude/Language/Reflection/Elab.idr+204−157

@@ -34,11 +34,13 @@ data Plicity =

34||| Function arguments

35|||

36||| These are the simplest representation of argument lists, and are

37−||| used for functions.

37+||| used for functions. Additionally, because a FunArg provides enough

38+||| information to build an application, a generic type lookup of a

39+||| top-level identifier will return its FunArgs, if applicable.

38record FunArg where

40record FunArg where

39 constructor MkFunArg

41 constructor MkFunArg

40− argName : TTName

42+ name : TTName

41− argTy : Raw

43+ type : Raw

42 plicity : Plicity

44 plicity : Plicity

43 erasure : Erasure

45 erasure : Erasure

44

46

@@ -54,25 +56,29 @@ data TyConArg =

54 TyConIndex FunArg

56 TyConIndex FunArg

55

57

56||| A type declaration

58||| A type declaration

57−data TyDecl : Type where

59+record TyDecl where

58− ||| A type declaration.

60+ constructor Declare

59− |||

61+

62+ ||| The name of the function being declared.

63+ name : TTName

64+

60− ||| Each argument is in the scope of the names of previous

65+ ||| Each argument is in the scope of the names of previous arguments.

61− ||| arguments, and the return type is in the scope of all the

66+ arguments : List FunArg

62− ||| argument names.

67+

63− |||

68+ ||| The return type is in the scope of all the argument names.

64− ||| @ fn the name to be declared, fully-qualified

69+ returnType : Raw

65− ||| @ args the arguments to the function

70+

66− ||| @ ret the final return type

67− Declare : (fn : TTName) -> (args : List FunArg) -> (ret : Raw) -> TyDecl

68

71

69||| A single pattern-matching clause

72||| A single pattern-matching clause

70−data FunClause : Type where

73+data FunClause : Type -> Type where

71− MkFunClause : (lhs, rhs : Raw) -> FunClause

74+ MkFunClause : (lhs, rhs : a) -> FunClause a

75+ MkImpossibleClause : (lhs : a) -> FunClause a

72

76

73||| A reflected function definition.

77||| A reflected function definition.

74−data FunDefn : Type where

78+record FunDefn a where

79+ constructor DefineFun

80+ name : TTName

75− DefineFun : TTName -> List FunClause -> FunDefn

81+ clauses : List (FunClause a)

76

82

77

83

78data CtorArg = CtorParameter FunArg | CtorField FunArg

84data CtorArg = CtorParameter FunArg | CtorField FunArg

@@ -82,7 +88,7 @@ record Datatype where

82 constructor MkDatatype

88 constructor MkDatatype

83

89

84 ||| The name of the type constructor

90 ||| The name of the type constructor

85− familyName : TTName

91+ name : TTName

86

92

87 ||| The arguments to the type constructor

93 ||| The arguments to the type constructor

88 tyConArgs : List TyConArg

94 tyConArgs : List TyConArg

@@ -97,62 +103,63 @@ record Datatype where

97abstract

103abstract

98data Elab : Type -> Type where

104data Elab : Type -> Type where

99 -- obligatory control stuff

105 -- obligatory control stuff

100− prim__PureElab : a -> Elab a

106+ Prim__PureElab : a -> Elab a

101− prim__BindElab : {a, b : Type} -> Elab a -> (a -> Elab b) -> Elab b

107+ Prim__BindElab : {a, b : Type} -> Elab a -> (a -> Elab b) -> Elab b

102−

103− prim__Try : {a : Type} -> Elab a -> Elab a -> Elab a

104− prim__Fail : {a : Type} -> List ErrorReportPart -> Elab a

105

108

106− prim__Env : Elab (List (TTName, Binder TT))

109+ Prim__Try : {a : Type} -> Elab a -> Elab a -> Elab a

107− prim__Goal : Elab (TTName, TT)

110+ Prim__Fail : {a : Type} -> List ErrorReportPart -> Elab a

108− prim__Holes : Elab (List TTName)

109− prim__Guess : Elab (Maybe TT)

110− prim__LookupTy : TTName -> Elab (List (TTName, NameType, TT))

111− prim__LookupDatatype : TTName -> Elab (List Datatype)

112

111

113− prim__Check : Raw -> Elab (TT, TT)

112+ Prim__Env : Elab (List (TTName, Binder TT))

113+ Prim__Goal : Elab (TTName, TT)

114+ Prim__Holes : Elab (List TTName)

115+ Prim__Guess : Elab TT

116+ Prim__LookupTy : TTName -> Elab (List (TTName, NameType, TT))

117+ Prim__LookupDatatype : TTName -> Elab (List Datatype)

118+ Prim__LookupFunDefn : TTName -> Elab (List (FunDefn TT))

119+ Prim__LookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

114

120

115− prim__SourceLocation : Elab SourceLocation

121+ Prim__Check : List (TTName, Binder TT) -> Raw -> Elab (TT, TT)

116− prim__Namespace : Elab (List String)

117

122

118− prim__Forget : TT -> Elab Raw

123+ Prim__SourceLocation : Elab SourceLocation

124+ Prim__Namespace : Elab (List String)

119

125

120− prim__Gensym : String -> Elab TTName

126+ Prim__Gensym : String -> Elab TTName

121

127

122− prim__Solve : Elab ()

128+ Prim__Solve : Elab ()

123− prim__Fill : Raw -> Elab ()

129+ Prim__Fill : Raw -> Elab ()

124− prim__Apply : Raw -> List (Bool, Int) -> Elab (List (TTName, TTName))

130+ Prim__Apply : Raw -> List Bool -> Elab (List (TTName, TTName))

125− prim__MatchApply : Raw -> List (Bool, Int) -> Elab (List (TTName, TTName))

131+ Prim__MatchApply : Raw -> List Bool -> Elab (List (TTName, TTName))

126− prim__Focus : TTName -> Elab ()

132+ Prim__Focus : TTName -> Elab ()

127− prim__Unfocus : TTName -> Elab ()

133+ Prim__Unfocus : TTName -> Elab ()

128− prim__Attack : Elab ()

134+ Prim__Attack : Elab ()

129

135

130− prim__Rewrite : Raw -> Elab ()

136+ Prim__Rewrite : Raw -> Elab ()

131

137

132− prim__Claim : TTName -> Raw -> Elab ()

138+ Prim__Claim : TTName -> Raw -> Elab ()

133− prim__Intro : Maybe TTName -> Elab ()

139+ Prim__Intro : Maybe TTName -> Elab ()

134− prim__Forall : TTName -> Raw -> Elab ()

140+ Prim__Forall : TTName -> Raw -> Elab ()

135− prim__PatVar : TTName -> Elab ()

141+ Prim__PatVar : TTName -> Elab ()

136− prim__PatBind : TTName -> Elab ()

142+ Prim__PatBind : TTName -> Elab ()

137− prim__LetBind : TTName -> Raw -> Raw -> Elab ()

143+ Prim__LetBind : TTName -> Raw -> Raw -> Elab ()

138

144

139− prim__Compute : Elab ()

145+ Prim__Compute : Elab ()

140− prim__Normalise : (List (TTName, Binder TT)) -> TT -> Elab TT

146+ Prim__Normalise : (List (TTName, Binder TT)) -> TT -> Elab TT

141− prim__Whnf : TT -> Elab TT

147+ Prim__Whnf : TT -> Elab TT

142− prim__Converts : (List (TTName, Binder TT)) -> TT -> TT -> Elab ()

148+ Prim__Converts : (List (TTName, Binder TT)) -> TT -> TT -> Elab ()

143

149

144− prim__DeclareType : TyDecl -> Elab ()

150+ Prim__DeclareType : TyDecl -> Elab ()

145− prim__DefineFunction : FunDefn -> Elab ()

151+ Prim__DefineFunction : FunDefn Raw -> Elab ()

146− prim__AddInstance : TTName -> TTName -> Elab ()

152+ Prim__AddInstance : TTName -> TTName -> Elab ()

153+ Prim__IsTCName : TTName -> Elab Bool

147

154

148− prim__ResolveTC : TTName -> Elab ()

155+ Prim__ResolveTC : TTName -> Elab ()

149− prim__Search : Int -> List TTName -> Elab ()

156+ Prim__Search : Int -> List TTName -> Elab ()

150− prim__RecursiveElab : Raw -> Elab () -> Elab (TT, TT)

157+ Prim__RecursiveElab : Raw -> Elab () -> Elab (TT, TT)

151

158

152− prim__Fixity : String -> Elab Fixity

159+ Prim__Fixity : String -> Elab Fixity

153

160

154− prim__Debug : {a : Type} -> List ErrorReportPart -> Elab a

161+ Prim__Debug : {a : Type} -> List ErrorReportPart -> Elab a

155− prim__Metavar : TTName -> Elab ()

162+ Prim__Metavar : TTName -> Elab ()

156

163

157-------------

164-------------

158-- Public API

165-- Public API

@@ -160,49 +167,50 @@ data Elab : Type -> Type where

160%access public

167%access public

161namespace Tactics

168namespace Tactics

162 instance Functor Elab where

169 instance Functor Elab where

163− map f t = prim__BindElab t (\x => prim__PureElab (f x))

170+ map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

164

171

165 instance Applicative Elab where

172 instance Applicative Elab where

166− pure x = prim__PureElab x

173+ pure x = Prim__PureElab x

167− f <*> x = prim__BindElab f $ \g =>

174+ f <*> x = Prim__BindElab f $ \g =>

168− prim__BindElab x $ \y =>

175+ Prim__BindElab x $ \y =>

169− prim__PureElab $ g y

176+ Prim__PureElab $ g y

170

177

171 ||| The Alternative instance on Elab represents left-biased error

178 ||| The Alternative instance on Elab represents left-biased error

172 ||| handling. In other words, `t <|> t'` will run `t`, and if it

179 ||| handling. In other words, `t <|> t'` will run `t`, and if it

173 ||| fails, roll back the elaboration state and run `t'`.

180 ||| fails, roll back the elaboration state and run `t'`.

174 instance Alternative Elab where

181 instance Alternative Elab where

175− empty = prim__Fail [TextPart "empty"]

182+ empty = Prim__Fail [TextPart "empty"]

176− x <|> y = prim__Try x y

183+ x <|> y = Prim__Try x y

177

184

178 instance Monad Elab where

185 instance Monad Elab where

179− x >>= f = prim__BindElab x f

186+ x >>= f = Prim__BindElab x f

180

187

181 ||| Halt elaboration with an error

188 ||| Halt elaboration with an error

182 fail : List ErrorReportPart -> Elab a

189 fail : List ErrorReportPart -> Elab a

183− fail err = prim__Fail err

190+ fail err = Prim__Fail err

184

191

185− ||| Look up the lexical binding at the focused hole

192+ ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

186 getEnv : Elab (List (TTName, Binder TT))

193 getEnv : Elab (List (TTName, Binder TT))

187− getEnv = prim__Env

194+ getEnv = Prim__Env

188

195

189− ||| Get the name and type of the focused hole

196+ ||| Get the name and type of the focused hole. Fails if not holes are present.

190 getGoal : Elab (TTName, TT)

197 getGoal : Elab (TTName, TT)

191− getGoal = prim__Goal

198+ getGoal = Prim__Goal

192

199

193− ||| Get the hole queue, in order

200+ ||| Get the hole queue, in order.

194 getHoles : Elab (List TTName)

201 getHoles : Elab (List TTName)

195− getHoles = prim__Holes

202+ getHoles = Prim__Holes

196

203

197− ||| If the current hole contains a guess, return it

204+ ||| If the current hole contains a guess, return it. Otherwise, fail.

198− getGuess : Elab (Maybe TT)

205+ getGuess : Elab TT

199− getGuess = prim__Guess

206+ getGuess = Prim__Guess

200

207

201− ||| Look up the types of every overloading of a name

208+ ||| Look up the types of every overloading of a name.

202 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

209 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

203− lookupTy n = prim__LookupTy n

210+ lookupTy n = Prim__LookupTy n

204

211

205− ||| Get the type of a fully-qualified name

212+ ||| Get the type of a fully-qualified name. Fail if it doesn not

213+ ||| resolve uniquely.

206 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

214 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

207 lookupTyExact n = case !(lookupTy n) of

215 lookupTyExact n = case !(lookupTy n) of

208 [res] => return res

216 [res] => return res

@@ -210,31 +218,51 @@ namespace Tactics

210 xs => fail [NamePart n, TextPart "is ambiguous."]

218 xs => fail [NamePart n, TextPart "is ambiguous."]

211

219

212 ||| Find the reflected representation of all datatypes whose names

220 ||| Find the reflected representation of all datatypes whose names

213− ||| are overloadings of some name

221+ ||| are overloadings of some name.

214 lookupDatatype : TTName -> Elab (List Datatype)

222 lookupDatatype : TTName -> Elab (List Datatype)

215− lookupDatatype n = prim__LookupDatatype n

223+ lookupDatatype n = Prim__LookupDatatype n

216

224

217 ||| Find the reflected representation of a datatype, given its

225 ||| Find the reflected representation of a datatype, given its

218− ||| fully-qualified name.

226+ ||| fully-qualified name. Fail if the name does not uniquely resolve

227+ ||| to a datatype.

219 lookupDatatypeExact : TTName -> Elab Datatype

228 lookupDatatypeExact : TTName -> Elab Datatype

220 lookupDatatypeExact n = case !(lookupDatatype n) of

229 lookupDatatypeExact n = case !(lookupDatatype n) of

221 [res] => return res

230 [res] => return res

222 [] => fail [TextPart "No datatype named", NamePart n]

231 [] => fail [TextPart "No datatype named", NamePart n]

223 xs => fail [TextPart "More than one datatype named", NamePart n]

232 xs => fail [TextPart "More than one datatype named", NamePart n]

224

233

225− ||| Attempt to type-check a term, getting back itself and its type

234+ ||| Find the reflected function definition of all functions whose names

226− check : (tm : Raw) -> Elab (TT, TT)

235+ ||| are overloadings of some name.

227− check tm = prim__Check tm

236+ lookupFunDefn : TTName -> Elab (List (FunDefn TT))

237+ lookupFunDefn n = Prim__LookupFunDefn n

238+

239+ ||| Find the reflected function definition of a function, given its

240+ ||| fully-qualified name. Fail if the name does not uniquely resolve

241+ ||| to a function.

242+ lookupFunDefnExact : TTName -> Elab (FunDefn TT)

243+ lookupFunDefnExact n = case !(lookupFunDefn n) of

244+ [res] => return res

245+ [] => fail [TextPart "No function named", NamePart n]

246+ xs => fail [TextPart "More than one function named", NamePart n]

247+

248+ ||| Get the argument specification for each overloading of a name.

249+ lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

250+ lookupArgs n = Prim__LookupArgs n

228

251

229− ||| Convert a type-annotated reflected term to its untyped

252+ ||| Get the argument specification for a name. Fail if the name does

230− ||| equivalent

253+ ||| not uniquely resolve.

231− forgetTypes : TT -> Elab Raw

254+ lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

232− forgetTypes tt = prim__Forget tt

255+ lookupArgsExact n = case !(lookupArgs n) of

256+ [res] => return res

257+ [] => fail [NamePart n, TextPart "is not defined."]

258+ xs => fail [NamePart n, TextPart "is ambiguous."]

233

259

234− ||| Get the goal type as a Raw term

260+ ||| Attempt to type-check a term, getting back itself and its type.

235− goalType : Elab Raw

261+ |||

236− goalType = do g <- getGoal

262+ ||| @ env the environment within which to check the type

237− forgetTypes (snd g)

263+ ||| @ tm the term to check

264+ check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

265+ check env tm = Prim__Check env tm

238

266

239

267

240 ||| Generate a unique name based on some hint.

268 ||| Generate a unique name based on some hint.

@@ -242,23 +270,22 @@ namespace Tactics

242 ||| **NB**: the generated name is unique _for this run of the

270 ||| **NB**: the generated name is unique _for this run of the

243 ||| elaborator_. Do not assume that they are globally unique.

271 ||| elaborator_. Do not assume that they are globally unique.

244 gensym : (hint : String) -> Elab TTName

272 gensym : (hint : String) -> Elab TTName

245− gensym hint = prim__Gensym hint

273+ gensym hint = Prim__Gensym hint

246

274

247 ||| Substitute a guess into a hole.

275 ||| Substitute a guess into a hole.

248 solve : Elab ()

276 solve : Elab ()

249− solve = prim__Solve

277+ solve = Prim__Solve

250

278

251− ||| Place a term into a hole, unifying its type

279+ ||| Place a term into a hole, unifying its type. Fails if the focus

280+ ||| is not a hole.

252 fill : Raw -> Elab ()

281 fill : Raw -> Elab ()

253− fill tm = prim__Fill tm

282+ fill tm = Prim__Fill tm

254

283

255 ||| Attempt to apply an operator to fill the current hole,

284 ||| Attempt to apply an operator to fill the current hole,

256 ||| potentially solving arguments by unification.

285 ||| potentially solving arguments by unification.

257 |||

286 |||

258− ||| The return value is a list of pairs of names, one for each input

287+ ||| The return value is the list of holes established for the

259− ||| argument. The first projection of these pairs is the original

288+ ||| arguments to the function.

260− ||| name of the argument, from the type declaration, and the second

261− ||| projection is the hole into which it is placed.

262 |||

289 |||

263 ||| Note that not all of the returned hole names still exist, as

290 ||| Note that not all of the returned hole names still exist, as

264 ||| they may have been solved.

291 ||| they may have been solved.

@@ -267,20 +294,15 @@ namespace Tactics

267 |||

294 |||

268 ||| @ argSpec instructions for finding the arguments to the term,

295 ||| @ argSpec instructions for finding the arguments to the term,

269 ||| where the Boolean states whether or not to attempt to solve

296 ||| where the Boolean states whether or not to attempt to solve

270− ||| the argument and the Int gives the priority in which to do

297+ ||| the argument by unification.

271− ||| so

272− apply : (op : Raw) ->

273− (argSpec : List (Bool, Int)) ->

298+ apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

274− Elab (List (TTName, TTName))

275− apply tm argSpec = prim__Apply tm argSpec

299+ apply tm argSpec = map snd <$> Prim__Apply tm argSpec

276

300

277 ||| Attempt to apply an operator to fill the current hole,

301 ||| Attempt to apply an operator to fill the current hole,

278− ||| potentially solving arugments by matching.

302+ ||| potentially solving arguments by matching.

279 |||

303 |||

280− ||| The return value is a list of pairs of names, one for each input

304+ ||| The return value is the list of holes established for the

281− ||| argument. The first projection of these pairs is the original

305+ ||| arguments to the function.

282− ||| name of the argument, from the type declaration, and the second

283− ||| projection is the hole into which it is placed.

284 |||

306 |||

285 ||| Note that not all of the returned hole names still exist, as

307 ||| Note that not all of the returned hole names still exist, as

286 ||| they may have been solved.

308 ||| they may have been solved.

@@ -289,39 +311,41 @@ namespace Tactics

289 |||

311 |||

290 ||| @ argSpec instructions for finding the arguments to the term,

312 ||| @ argSpec instructions for finding the arguments to the term,

291 ||| where the Boolean states whether or not to attempt to solve

313 ||| where the Boolean states whether or not to attempt to solve

292− ||| the argument and the Int gives the priority in which to do

314+ ||| the argument by matching.

293− ||| so

315+

294− matchApply : (op : Raw) ->

316+ matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

295− (argSpec : List (Bool, Int)) ->

296− Elab (List (TTName, TTName))

297− matchApply tm argSpec = prim__Apply tm argSpec

317+ matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec

298

318

299− ||| Move the focus to the specified hole

319+ ||| Move the focus to the specified hole. Fails if the hole does not

320+ ||| exist.

300 |||

321 |||

301 ||| @ hole the hole to focus on

322 ||| @ hole the hole to focus on

302 focus : (hole : TTName) -> Elab ()

323 focus : (hole : TTName) -> Elab ()

303− focus hole = prim__Focus hole

324+ focus hole = Prim__Focus hole

304

325

305 ||| Send the currently-focused hole to the end of the hole queue and

326 ||| Send the currently-focused hole to the end of the hole queue and

306 ||| focus on the next hole.

327 ||| focus on the next hole.

307 unfocus : TTName -> Elab ()

328 unfocus : TTName -> Elab ()

308− unfocus hole = prim__Unfocus hole

329+ unfocus hole = Prim__Unfocus hole

309

330

310− ||| Convert a hole to make it suitable for bindings.

331+ ||| Convert a hole to make it suitable for bindings - that is,

332+ ||| transform it such that it has the form `?h : t . h` as opposed to

333+ ||| `?h : t . f h`.

311 |||

334 |||

312 ||| The binding tactics require that a hole be directly under its

335 ||| The binding tactics require that a hole be directly under its

313 ||| binding, or else the scopes of the generated terms won't make

336 ||| binding, or else the scopes of the generated terms won't make

314 ||| sense. This tactic creates a new hole of the proper form, and

337 ||| sense. This tactic creates a new hole of the proper form, and

315 ||| points the old hole at it.

338 ||| points the old hole at it.

316 attack : Elab ()

339 attack : Elab ()

317− attack = prim__Attack

340+ attack = Prim__Attack

318

341

319 ||| Introduce a new hole with a specified name and type.

342 ||| Introduce a new hole with a specified name and type.

320 |||

343 |||

321 ||| The new hole will be focused, and the previously-focused hole

344 ||| The new hole will be focused, and the previously-focused hole

322− ||| will be immediately after it in the hole queue.

345+ ||| will be immediately after it in the hole queue. Because this

346+ ||| tactic introduces a new binding, you may need to `attack` first.

323 claim : TTName -> Raw -> Elab ()

347 claim : TTName -> Raw -> Elab ()

324− claim n ty = prim__Claim n ty

348+ claim n ty = Prim__Claim n ty

325

349

326 ||| Introduce a lambda binding around the current hole and focus on

350 ||| Introduce a lambda binding around the current hole and focus on

327 ||| the body. Requires that the hole be in binding form (use

351 ||| the body. Requires that the hole be in binding form (use

@@ -329,50 +353,63 @@ namespace Tactics

329 |||

353 |||

330 ||| @ n the name to use for the argument

354 ||| @ n the name to use for the argument

331 intro : (n : TTName) -> Elab ()

355 intro : (n : TTName) -> Elab ()

332− intro n = prim__Intro (Just n)

356+ intro n = Prim__Intro (Just n)

333

357

334 ||| Introduce a lambda binding around the current hole and focus on

358 ||| Introduce a lambda binding around the current hole and focus on

335− ||| the body, using the name provided by the type of the hole.

359+ ||| the body, using the name provided by the type of the

360+ ||| hole.

361+ |||

362+ ||| Requires that the hole be immediately under its binder (use

363+ ||| `attack` if it might not be).

336 intro' : Elab ()

364 intro' : Elab ()

337− intro' = prim__Intro Nothing

365+ intro' = Prim__Intro Nothing

338

366

339 ||| Introduce a dependent function type binding into the current hole,

367 ||| Introduce a dependent function type binding into the current hole,

340 ||| and focus on the body.

368 ||| and focus on the body.

369+ |||

370+ ||| Requires that the hole be immediately under its binder (use

371+ ||| `attack` if it might not be).

341 forall : TTName -> Raw -> Elab ()

372 forall : TTName -> Raw -> Elab ()

342− forall n ty = prim__Forall n ty

373+ forall n ty = Prim__Forall n ty

343

374

344 ||| Convert a hole into a pattern variable.

375 ||| Convert a hole into a pattern variable.

345 patvar : TTName -> Elab ()

376 patvar : TTName -> Elab ()

346− patvar n = prim__PatVar n

377+ patvar n = Prim__PatVar n

347

378

348 ||| Introduce a new pattern binding.

379 ||| Introduce a new pattern binding.

380+ |||

381+ ||| Requires that the hole be immediately under its binder (use

382+ ||| `attack` if it might not be).

349 patbind : TTName -> Elab ()

383 patbind : TTName -> Elab ()

350− patbind n = prim__PatBind n

384+ patbind n = Prim__PatBind n

351

385

352− ||| Introduce a new let binding

386+ ||| Introduce a new let binding.

387+ |||

388+ ||| Requires that the hole be immediately under its binder (use

389+ ||| `attack` if it might not be).

353 |||

390 |||

354 ||| @ n the name to let bind

391 ||| @ n the name to let bind

355 ||| @ ty the type of the term to be let-bound

392 ||| @ ty the type of the term to be let-bound

356 ||| @ tm the term to be bound

393 ||| @ tm the term to be bound

357 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

394 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

358− letbind n ty tm = prim__LetBind n ty tm

395+ letbind n ty tm = Prim__LetBind n ty tm

359

396

360 ||| Normalise the goal.

397 ||| Normalise the goal.

361 compute : Elab ()

398 compute : Elab ()

362− compute = prim__Compute

399+ compute = Prim__Compute

363

400

364 ||| Normalise a term in some lexical environment

401 ||| Normalise a term in some lexical environment

365 |||

402 |||

366 ||| @ env the environment in which to compute (get one of these from `getEnv`)

403 ||| @ env the environment in which to compute (get one of these from `getEnv`)

367 ||| @ term the term to normalise

404 ||| @ term the term to normalise

368 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

405 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

369− normalise env term = prim__Normalise env term

406+ normalise env term = Prim__Normalise env term

370

407

371 ||| Reduce a closed term to weak-head normal form

408 ||| Reduce a closed term to weak-head normal form

372 |||

409 |||

373 ||| @ term the term to reduce

410 ||| @ term the term to reduce

374 whnf : (term : TT) -> Elab TT

411 whnf : (term : TT) -> Elab TT

375− whnf term = prim__Whnf term

412+ whnf term = Prim__Whnf term

376

413

377 ||| Check that two terms are convertable in the current context and

414 ||| Check that two terms are convertable in the current context and

378 ||| in some environment.

415 ||| in some environment.

@@ -381,7 +418,7 @@ namespace Tactics

381 ||| @ term1 the first term to convert

418 ||| @ term1 the first term to convert

382 ||| @ term2 the second term to convert

419 ||| @ term2 the second term to convert

383 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

420 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

384− convertsInEnv env term1 term2 = prim__Converts env term1 term2

421+ convertsInEnv env term1 term2 = Prim__Converts env term1 term2

385

422

386 ||| Check that two terms are convertable in the current context and environment

423 ||| Check that two terms are convertable in the current context and environment

387 |||

424 |||

@@ -392,7 +429,7 @@ namespace Tactics

392

429

393 ||| Find the source context for the elaboration script

430 ||| Find the source context for the elaboration script

394 getSourceLocation : Elab SourceLocation

431 getSourceLocation : Elab SourceLocation

395− getSourceLocation = prim__SourceLocation

432+ getSourceLocation = Prim__SourceLocation

396

433

397 ||| Attempt to solve the current goal with the source code location

434 ||| Attempt to solve the current goal with the source code location

398 sourceLocation : Elab ()

435 sourceLocation : Elab ()

@@ -406,7 +443,7 @@ namespace Tactics

406 ||| The namespace is represented as a reverse-order list of strings,

443 ||| The namespace is represented as a reverse-order list of strings,

407 ||| just as in the representation of names.

444 ||| just as in the representation of names.

408 currentNamespace : Elab (List String)

445 currentNamespace : Elab (List String)

409− currentNamespace = prim__Namespace

446+ currentNamespace = Prim__Namespace

410

447

411 ||| Attempt to rewrite the goal using an equality.

448 ||| Attempt to rewrite the goal using an equality.

412 |||

449 |||

@@ -414,43 +451,53 @@ namespace Tactics

414 ||| constructs a context for `replace` using them. In some cases,

451 ||| constructs a context for `replace` using them. In some cases,

415 ||| this is not possible, and `replace` must be called manually with

452 ||| this is not possible, and `replace` must be called manually with

416 ||| an appropriate context.

453 ||| an appropriate context.

454+ |||

455+ ||| Because this tactic internally introduces a `let` binding, it

456+ ||| requires that the hole be immediately under its binder (use

457+ ||| `attack` if it might not be).

417 rewriteWith : Raw -> Elab ()

458 rewriteWith : Raw -> Elab ()

418− rewriteWith rule = prim__Rewrite rule

459+ rewriteWith rule = Prim__Rewrite rule

419

460

420 ||| Add a type declaration to the global context.

461 ||| Add a type declaration to the global context.

421 declareType : TyDecl -> Elab ()

462 declareType : TyDecl -> Elab ()

422− declareType decl = prim__DeclareType decl

463+ declareType decl = Prim__DeclareType decl

423

464

424 ||| Define a function in the global context. The function must have

465 ||| Define a function in the global context. The function must have

425 ||| already been declared, either in ordinary Idris code or using

466 ||| already been declared, either in ordinary Idris code or using

426 ||| `declareType`.

467 ||| `declareType`.

427− defineFunction : FunDefn -> Elab ()

468+ defineFunction : FunDefn Raw -> Elab ()

428− defineFunction defun = prim__DefineFunction defun

469+ defineFunction defun = Prim__DefineFunction defun

429

470

430− ||| Register a new instance for type class resolution

471+ ||| Register a new instance for type class resolution.

431 |||

472 |||

432 ||| @ className the name of the class for which an instance is being registered

473 ||| @ className the name of the class for which an instance is being registered

433 ||| @ instName the name of the definition to use in instance search

474 ||| @ instName the name of the definition to use in instance search

434 addInstance : (className, instName : TTName) -> Elab ()

475 addInstance : (className, instName : TTName) -> Elab ()

435− addInstance className instName = prim__AddInstance className instName

476+ addInstance className instName = Prim__AddInstance className instName

477+

478+ ||| Determine whether a name denotes a class.

479+ |||

480+ ||| @ name a name that might denote a class.

481+ isTCName : (name : TTName) -> Elab Bool

482+ isTCName name = Prim__IsTCName name

436

483

437 ||| Attempt to solve the current goal with a type class dictionary

484 ||| Attempt to solve the current goal with a type class dictionary

438 |||

485 |||

439 ||| @ fn the name of the definition being elaborated (to prevent Idris

486 ||| @ fn the name of the definition being elaborated (to prevent Idris

440 ||| from looping)

487 ||| from looping)

441 resolveTC : (fn : TTName) -> Elab ()

488 resolveTC : (fn : TTName) -> Elab ()

442− resolveTC fn = prim__ResolveTC fn

489+ resolveTC fn = Prim__ResolveTC fn

443

490

444 ||| Use Idris's internal proof search.

491 ||| Use Idris's internal proof search.

445 search : Elab ()

492 search : Elab ()

446− search = prim__Search 100 []

493+ search = Prim__Search 100 []

447

494

448 ||| Use Idris's internal proof search, with more control.

495 ||| Use Idris's internal proof search, with more control.

449 |||

496 |||

450 ||| @ depth the search depth

497 ||| @ depth the search depth

451 ||| @ hints additional names to try

498 ||| @ hints additional names to try

452 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

499 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

453− search' depth hints = prim__Search depth hints

500+ search' depth hints = Prim__Search depth hints

454

501

455 ||| Look up the declared fixity for an operator.

502 ||| Look up the declared fixity for an operator.

456 |||

503 |||

@@ -459,14 +506,14 @@ namespace Tactics

459 |||

506 |||

460 ||| @ operator the operator string to look up

507 ||| @ operator the operator string to look up

461 operatorFixity : (operator : String) -> Elab Fixity

508 operatorFixity : (operator : String) -> Elab Fixity

462− operatorFixity operator = prim__Fixity operator

509+ operatorFixity operator = Prim__Fixity operator

463

510

464 ||| Halt elaboration, dumping the internal state for inspection.

511 ||| Halt elaboration, dumping the internal state for inspection.

465 |||

512 |||

466 ||| This is intended for elaboration script developers, not for

513 ||| This is intended for elaboration script developers, not for

467 ||| end-users. Use `fail` for final scripts.

514 ||| end-users. Use `fail` for final scripts.

468 debug : Elab a

515 debug : Elab a

469− debug = prim__Debug []

516+ debug = Prim__Debug []

470

517

471 ||| Halt elaboration, dumping the internal state and displaying a

518 ||| Halt elaboration, dumping the internal state and displaying a

472 ||| message.

519 ||| message.

@@ -476,17 +523,17 @@ namespace Tactics

476 |||

523 |||

477 ||| @ msg the message to display

524 ||| @ msg the message to display

478 debugMessage : (msg : List ErrorReportPart) -> Elab a

525 debugMessage : (msg : List ErrorReportPart) -> Elab a

479− debugMessage msg = prim__Debug msg

526+ debugMessage msg = Prim__Debug msg

480

527

481 ||| Create a new top-level metavariable to solve the current hole.

528 ||| Create a new top-level metavariable to solve the current hole.

482 |||

529 |||

483 ||| @ name the name for the top-level variable

530 ||| @ name the name for the top-level variable

484 metavar : (name : TTName) -> Elab ()

531 metavar : (name : TTName) -> Elab ()

485− metavar name = prim__Metavar name

532+ metavar name = Prim__Metavar name

486

533

487 ||| Recursively invoke the reflected elaborator with some goal.

534 ||| Recursively invoke the reflected elaborator with some goal.

488 |||

535 |||

489 ||| The result is the final term and its type.

536 ||| The result is the final term and its type.

490 runElab : Raw -> Elab () -> Elab (TT, TT)

537 runElab : Raw -> Elab () -> Elab (TT, TT)

491− runElab goal script = prim__RecursiveElab goal script

538+ runElab goal script = Prim__RecursiveElab goal script

492

539

libs/prelude/Prelude.idr+10

@@ -37,6 +37,10 @@ import public Language.Reflection.Errors

37%default total

38

39-- Things that can't be elsewhere for import cycle reasons

40+-- See comment after declaration of void in Builtins.idr

41+-- for explanation of this definition's location

42+%runElab (defineFunction $ DefineFun `{void} [])

43+

40decAsBool : Dec p -> Bool

44decAsBool : Dec p -> Bool

41decAsBool (Yes _) = True

45decAsBool (Yes _) = True

42decAsBool (No _) = False

46decAsBool (No _) = False

@@ -203,6 +207,12 @@ instance Enum Int where

203 go [] = []

207 go [] = []

204 go (x :: xs) = n + (cast x * inc) :: go xs

208 go (x :: xs) = n + (cast x * inc) :: go xs

205

209

210+instance Enum Char where

211+ toNat c = toNat (ord c)

212+ fromNat n = chr (fromNat n)

213+

214+ pred c = fromNat (pred (toNat c))

215+

206syntax "[" [start] ".." [end] "]"

216syntax "[" [start] ".." [end] "]"

207 = enumFromTo start end

217 = enumFromTo start end

208syntax "[" [start] "," [next] ".." [end] "]"

218syntax "[" [start] "," [next] ".." [end] "]"

libs/prelude/Prelude/Classes.idr+6−6

@@ -37,7 +37,7 @@ instance Eq Int where

37instance Eq Integer where

38 (==) = boolOp prim__eqBigInt

39

40−instance Eq Float where

40+instance Eq Double where

41 (==) = boolOp prim__eqFloat

42

43instance Eq Char where

@@ -118,7 +118,7 @@ instance Ord Integer where

118 GT

119

120

121−instance Ord Float where

121+instance Ord Double where

122 compare x y = if (x == y) then EQ else

123 if (boolOp prim__sltFloat x y) then LT else

124 GT

@@ -170,7 +170,7 @@ instance Num Int where

170 fromInteger = prim__truncBigInt_Int

171

172

173−instance Num Float where

173+instance Num Double where

174 (+) = prim__addFloat

175 (*) = prim__mulFloat

176

@@ -215,7 +215,7 @@ instance Neg Int where

215 (-) = prim__subInt

216 abs x = if x < (prim__truncBigInt_Int 0) then -x else x

217

218−instance Neg Float where

218+instance Neg Double where

219 negate x = prim__negFloat x

220 (-) = prim__subFloat

221 abs x = if x < (prim__toFloatBigInt 0) then -x else x

@@ -306,8 +306,8 @@ instance MaxBound Bits64 where

306

307-- ------------------------------------------------------------- [ Fractionals ]

308

309−||| Fractional division of two Floats.

309+||| Fractional division of two Doubles.

310−(/) : Float -> Float -> Float

310+(/) : Double -> Double -> Double

311(/) = prim__divFloat

312

313

libs/prelude/Prelude/Either.idr+7−3

@@ -9,11 +9,15 @@ import Prelude.Maybe

9import Prelude.List

10

11||| A sum type

12−%elim data Either a b =

12+%elim data Either : (a, b : Type) -> Type where

13 ||| One possibility of the sum, conventionally used to represent errors

14− Left a |

14+ Left : (l : a) -> Either a b

15 ||| The other possibility, conventionally used to represent success

16− Right b

16+ Right : (r : b) -> Either a b

17+

18+-- Usage hints for erasure analysis

19+%used Left l

20+%used Right r

17

21

18--------------------------------------------------------------------------------

22--------------------------------------------------------------------------------

19-- Syntactic tests

23-- Syntactic tests

libs/prelude/Prelude/File.idr+114−49

@@ -10,14 +10,43 @@ import Prelude.Cast

10import Prelude.Bool

11import Prelude.Basics

12import Prelude.Classes

13−import Prelude.Monad

13+import Prelude.Either

14+import Prelude.Show

14import IO

15import IO

15

16

16%access public

17%access public

17

18

18||| A file handle

19||| A file handle

19abstract

20abstract

20−data File = FHandle Ptr

21+data File : Type where

22+ FHandle : (p : Ptr) -> File

23+

24+-- Usage hints for erasure analysis

25+%used FHandle p

26+

27+||| An error from a file operation

28+-- This is built in idris_mkFileError() in rts/idris_stdfgn.c. Make sure

29+-- the values correspond!

30+data FileError = FileReadError

31+ | FileWriteError

32+ | FileNotFound

33+ | PermissionDenied

34+ | GenericFileError Int -- errno

35+

36+private

37+strError : Int -> String

38+strError err = unsafePerformIO -- yeah, yeah...

39+ (foreign FFI_C "idris_showerror" (Int -> IO String) err)

40+

41+getFileError : IO FileError

42+getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

43+ (Ptr -> IO (Raw FileError)) prim__vm

44+ return err

45+

46+instance Show FileError where

47+ show FileNotFound = "File Not Found"

48+ show PermissionDenied = "Permission Denied"

49+ show (GenericFileError errno) = strError errno

21

50

22||| Standard input

51||| Standard input

23stdin : File

52stdin : File

@@ -31,6 +60,13 @@ stdout = FHandle prim__stdout

31stderr : File

60stderr : File

32stderr = FHandle prim__stderr

61stderr = FHandle prim__stderr

33

62

63+do_ferror : Ptr -> IO Int

64+do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

65+

66+ferror : File -> IO Bool

67+ferror (FHandle h) = do err <- do_ferror h

68+ return (not (err == 0))

69+

34||| Call the RTS's file opening function

70||| Call the RTS's file opening function

35do_fopen : String -> String -> IO Ptr

71do_fopen : String -> String -> IO Ptr

36do_fopen f m

72do_fopen f m

@@ -39,12 +75,14 @@ do_fopen f m

39||| Open a file

75||| Open a file

40||| @ f the filename

76||| @ f the filename

41||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

77||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

42−fopen : (f : String) -> (m : String) -> IO File

78+fopen : (f : String) -> (m : String) -> IO (Either FileError File)

43fopen f m = do h <- do_fopen f m

79fopen f m = do h <- do_fopen f m

80+ if !(nullPtr h)

81+ then do err <- getFileError

44− return (FHandle h)

82+ return (Left err)

83+ else return (Right (FHandle h))

45

84

46||| Check whether a file handle is actually a null pointer

85||| Check whether a file handle is actually a null pointer

47−partial

48validFile : File -> IO Bool

86validFile : File -> IO Bool

49validFile (FHandle h) = do x <- nullPtr h

87validFile (FHandle h) = do x <- nullPtr h

50 return (not x)

88 return (not x)

@@ -54,34 +92,27 @@ data Mode = Read | Write | ReadWrite

54

92

55||| Open a file

93||| Open a file

56||| @ f the filename

94||| @ f the filename

57−||| @ m the mode

95+||| @ m the mode; either Read, Write, or ReadWrite

58−partial

59−openFile : (f : String) -> (m : Mode) -> IO File

96+openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

60openFile f m = fopen f (modeStr m) where

97openFile f m = fopen f (modeStr m) where

61 modeStr Read = "r"

98 modeStr Read = "r"

62 modeStr Write = "w"

99 modeStr Write = "w"

63 modeStr ReadWrite = "r+"

100 modeStr ReadWrite = "r+"

64

101

65−partial

66do_fclose : Ptr -> IO ()

102do_fclose : Ptr -> IO ()

67do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

103do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

68

104

69−partial

70closeFile : File -> IO ()

105closeFile : File -> IO ()

71closeFile (FHandle h) = do_fclose h

106closeFile (FHandle h) = do_fclose h

72

107

73−partial

74do_fread : Ptr -> IO' l String

108do_fread : Ptr -> IO' l String

75do_fread h = prim_fread h

109do_fread h = prim_fread h

76

110

77−fgetc : File -> IO Char

111+fgetc : File -> IO (Either FileError Char)

78−fgetc (FHandle h) = return (cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h))

79−

80−fgetc' : File -> IO (Maybe Char)

81−fgetc' (FHandle h)

82− = do x <- foreign FFI_C "fgetc" (Ptr -> IO Int) h

112+fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

113+ if !(ferror (FHandle h))

83− if (x < 0) then return Nothing

114+ then return (Left FileReadError)

84− else return (Just (cast x))

115+ else return (Right c)

85

116

86fflush : File -> IO ()

117fflush : File -> IO ()

87fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

118fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

@@ -89,9 +120,12 @@ fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

89do_popen : String -> String -> IO Ptr

120do_popen : String -> String -> IO Ptr

90do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

121do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

91

122

92−popen : String -> Mode -> IO File

123+popen : String -> Mode -> IO (Either FileError File)

93popen f m = do ptr <- do_popen f (modeStr m)

124popen f m = do ptr <- do_popen f (modeStr m)

125+ if !(nullPtr ptr)

126+ then do err <- getFileError

127+ return (Left err)

94− return (FHandle ptr)

128+ else return (Right (FHandle ptr))

95 where

129 where

96 modeStr Read = "r"

130 modeStr Read = "r"

97 modeStr Write = "w"

131 modeStr Write = "w"

@@ -103,54 +137,85 @@ pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

103-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

137-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

104-- prim__vm h

138-- prim__vm h

105

139

106−partial

107−fread : File -> IO' l String

140+fread : File -> IO (Either FileError String)

108−fread (FHandle h) = do_fread h

141+fread (FHandle h) = do str <- do_fread h

142+ if !(ferror (FHandle h))

143+ then return (Left FileReadError)

144+ else return (Right str)

145+

146+||| Read a line from a file

147+||| @h a file handle which must be open for reading

148+fGetLine : (h : File) -> IO (Either FileError String)

149+fGetLine = fread

150+

151+%deprecate fread "Use fGetLine instead"

152+

153+do_fwrite : Ptr -> String -> IO (Either FileError ())

154+do_fwrite h s = do res <- prim_fwrite h s

155+ if (res /= 0)

156+ then do errno <- getErrno

157+ if errno == 0

158+ then return (Left FileWriteError)

159+ else do err <- getFileError

160+ return (Left err)

161+ else return (Right ())

162+

163+fwrite : File -> String -> IO (Either FileError ())

164+fwrite (FHandle h) s = do_fwrite h s

109

165

110−partial

166+||| Write a line to a file

111−do_fwrite : Ptr -> String -> IO ()

167+||| @h a file handle which must be open for writing

112−do_fwrite h s = do prim_fwrite h s

168+||| @str the line to write to the file

113− return ()

169+fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

170+fPutStr (FHandle h) s = do_fwrite h s

114

171

115−partial

116−fwrite : File -> String -> IO ()

172+fPutStrLn : File -> String -> IO (Either FileError ())

117−fwrite (FHandle h) s = do_fwrite h s

173+fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

174+

175+%deprecate fwrite "Use fPutStr instead"

118

176

119−partial

120do_feof : Ptr -> IO Int

177do_feof : Ptr -> IO Int

121do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

178do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

122

179

123||| Check if a file handle has reached the end

180||| Check if a file handle has reached the end

124−feof : File -> IO Bool

181+fEOF : File -> IO Bool

125−feof (FHandle h) = do eof <- do_feof h

182+fEOF (FHandle h) = do eof <- do_feof h

126 return (not (eof == 0))

183 return (not (eof == 0))

127

184

128−partial

185+||| Check if a file handle has reached the end

129−do_ferror : Ptr -> IO Int

186+feof : File -> IO Bool

130−do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

187+feof = fEOF

131

188

132−ferror : File -> IO Bool

189+%deprecate feof "Use fEOF instead"

133−ferror (FHandle h) = do err <- do_ferror h

134− return (not (err == 0))

135

190

136fpoll : File -> IO Bool

191fpoll : File -> IO Bool

137fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

192fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

138 return (p > 0)

193 return (p > 0)

139

194

140||| Read the contents of a file into a string

195||| Read the contents of a file into a string

141−partial -- no error checking!

196+partial -- might be reading something infinitely long like /dev/null ...

197+covering

142−readFile : String -> IO String

198+readFile : String -> IO (Either FileError String)

143−readFile fn = do h <- openFile fn Read

199+readFile fn = do Right h <- openFile fn Read

200+ | Left err => return (Left err)

144 c <- readFile' h ""

201 c <- readFile' h ""

145 closeFile h

202 closeFile h

146 return c

203 return c

147 where

204 where

148 partial

205 partial

149− readFile' : File -> String -> IO String

206+ readFile' : File -> String -> IO (Either FileError String)

150 readFile' h contents =

207 readFile' h contents =

151− do x <- feof h

208+ do x <- fEOF h

152− if not x then do l <- fread h

209+ if not x then do Right l <- fGetLine h

210+ | Left err => return (Left err)

153 readFile' h (contents ++ l)

211 readFile' h (contents ++ l)

154− else return contents

212+ else return (Right contents)

155−

213+

156−

214+||| Write a string to a file

215+writeFile : (filepath : String) -> (contents : String) ->

216+ IO (Either FileError ())

217+writeFile fn contents = do

218+ Right h <- openFile fn Write | Left err => return (Left err)

219+ Right () <- fPutStr h contents | Left err => return (Left err)

220+ closeFile h

221+ return (Right ())

libs/prelude/Prelude/Functor.idr+10−8

@@ -2,19 +2,21 @@ module Prelude.Functor

2

3import Prelude.Basics

4

5−||| Functors

5+||| Functors allow a uniform action over a parameterised type.

6−||| @ f the action of the functor on objects

6+||| @ f a parameterised type

7class Functor (f : Type -> Type) where

8− ||| The action of the functor on morphisms

8+ ||| Apply a function across everything of type 'a' in a

9− ||| @ f the functor

9+ ||| parameterised type

10− ||| @ m the morphism

10+ ||| @ f the parameterised type

11+ ||| @ m the function to apply

11 map : (m : a -> b) -> f a -> f b

12 map : (m : a -> b) -> f a -> f b

12

13

13infixl 4 <$>

14infixl 4 <$>

14

15

15−||| An infix alias for `map`: the action of a functor on morphisms.

16+||| An infix alias for `map`, applying a function across everything of

16−||| @ f the functor

17+||| type 'a' in a parameterised type

17−||| @ m the morphism

18+||| @ f the parameterised type

19+||| @ m the function to apply

18(<$>) : Functor f => (m : a -> b) -> f a -> f b

20(<$>) : Functor f => (m : a -> b) -> f a -> f b

19m <$> x = map m x

21m <$> x = map m x

20

22

libs/prelude/Prelude/Interactive.idr+43−16

@@ -17,6 +17,7 @@ import Prelude.Show

17import Prelude.Cast

18import Prelude.Maybe

19import Prelude.Functor

20+import Prelude.Either

20import Prelude.Monad

21import Prelude.Monad

21import IO

22import IO

22

23

@@ -24,33 +25,58 @@ import IO

24

25

25---- some basic io

26---- some basic io

26

27

28+||| Output a string to stdout without a trailing newline, for any FFI

29+||| descriptor

30+putStr' : String -> IO' ffi ()

31+putStr' x = do prim_write x

32+ return ()

33+

27||| Output a string to stdout without a trailing newline

34||| Output a string to stdout without a trailing newline

28−putStr : String -> IO' ffi ()

35+putStr : String -> IO ()

29−putStr x = do prim_write x

36+putStr = putStr'

30− return ()

37+

38+||| Output a string to stdout with a trailing newline, for any FFI

39+||| descriptor

40+putStrLn' : String -> IO' ffi ()

41+putStrLn' x = putStr' (x ++ "\n")

31

42

32||| Output a string to stdout with a trailing newline

43||| Output a string to stdout with a trailing newline

33−putStrLn : String -> IO' ffi ()

44+putStrLn : String -> IO ()

45+putStrLn = putStrLn'

46+

47+||| Output something showable to stdout, without a trailing newline, for any FFI

48+||| descriptor

49+print' : Show a => a -> IO' ffi ()

34−putStrLn x = putStr (x ++ "\n")

50+print' x = putStr' (show x)

35

51

36||| Output something showable to stdout, without a trailing newline

52||| Output something showable to stdout, without a trailing newline

37−print : Show a => a -> IO' ffi ()

53+print : Show a => a -> IO ()

38−print x = putStr (show x)

54+print = print'

39

55

40−||| Output something showable to stdout, with a trailing newline

56+||| Output something showable to stdout, with a trailing newline, for any FFI

57+||| descriptor

41−printLn : Show a => a -> IO' ffi ()

58+printLn' : Show a => a -> IO' ffi ()

42−printLn x = putStrLn (show x)

59+printLn' x = putStrLn' (show x)

43

60

61+||| Output something showable to stdout, with a trailing newline

62+printLn : Show a => a -> IO ()

63+printLn = printLn'

64+

44−||| Read one line of input from stdin, without the trailing newline

65+||| Read one line of input from stdin, without the trailing newline, for any FFI

66+||| descriptor

45−getLine : IO' ffi String

67+getLine' : IO' ffi String

46−getLine = do x <- prim_read

68+getLine' = do x <- prim_read

47− return (reverse (trimNL (reverse x)))

69+ return (reverse (trimNL (reverse x)))

48 where trimNL : String -> String

70 where trimNL : String -> String

49 trimNL str with (strM str)

71 trimNL str with (strM str)

50 trimNL "" | StrNil = ""

72 trimNL "" | StrNil = ""

51 trimNL (strCons '\n' xs) | StrCons _ _ = xs

73 trimNL (strCons '\n' xs) | StrCons _ _ = xs

52 trimNL (strCons x xs) | StrCons _ _ = strCons x xs

74 trimNL (strCons x xs) | StrCons _ _ = strCons x xs

53

75

76+||| Read one line of input from stdin, without the trailing newline

77+getLine : IO String

78+getLine = getLine'

79+

54||| Write a single character to stdout

80||| Write a single character to stdout

55putChar : Char -> IO ()

81putChar : Char -> IO ()

56putChar c = foreign FFI_C "putchar" (Int -> IO ()) (cast c)

82putChar c = foreign FFI_C "putchar" (Int -> IO ()) (cast c)

@@ -95,9 +121,10 @@ processHandle : File ->

95 (onEOF : a -> String) ->

121 (onEOF : a -> String) ->

96 IO ()

122 IO ()

97processHandle h acc onRead onEOF

123processHandle h acc onRead onEOF

98− = if !(feof h)

124+ = if !(fEOF h)

99 then putStr (onEOF acc)

125 then putStr (onEOF acc)

100− else do x <- fread h

126+ else do Right x <- fGetLine h

127+ | Left err => putStr (onEOF acc)

101 let (out, acc') = onRead acc x

128 let (out, acc') = onRead acc x

102 putStr out

129 putStr out

103 processHandle h acc' onRead onEOF

130 processHandle h acc' onRead onEOF

libs/prelude/Prelude/List.idr+7−3

@@ -19,16 +19,20 @@ infix 5 \\

19infixr 7 ::,++

20

21||| Generic lists

22−%elim data List elem =

22+%elim data List : (elem : Type) -> Type where

23 ||| Empty list

24− Nil |

24+ Nil : List elem

25 ||| A non-empty list, consisting of a head element and the rest of

26 ||| the list.

27− (::) elem (List elem)

27+ (::) : (x : elem) -> (xs : List elem) -> List elem

28

29-- Name hints for interactive editing

30%name List xs, ys, zs, ws

31

32+-- Usage hints for erasure analysis

33+%used List.(::) x

34+%used List.(::) xs

35+

32--------------------------------------------------------------------------------

36--------------------------------------------------------------------------------

33-- Syntactic tests

37-- Syntactic tests

34--------------------------------------------------------------------------------

38--------------------------------------------------------------------------------

libs/prelude/Prelude/Maybe.idr+8−5

@@ -13,11 +13,14 @@ import Prelude.Foldable

13

14||| An optional value. This can be used to represent the possibility of

15||| failure, where a function may return a value, or not.

16−data Maybe a

16+data Maybe : (a : Type) -> Type where

17− = ||| No value stored

17+ ||| No value stored

18− Nothing

18+ Nothing : Maybe a

19− | ||| A value of type `a` is stored

19+ ||| A value of type `a` is stored

20− Just a

20+ Just : (x : a) -> Maybe a

21+

22+-- Used hints for erasure analysis

23+%used Just x

21

24

22--------------------------------------------------------------------------------

25--------------------------------------------------------------------------------

23-- Syntactic tests

26-- Syntactic tests

libs/prelude/Prelude/Monad.idr+1−1

@@ -13,7 +13,7 @@ import IO

13infixl 5 >>=

14

15class Applicative m => Monad (m : Type -> Type) where

16− (>>=) : m a -> (a -> m b) -> m b

16+ (>>=) : m a -> ((result : a) -> m b) -> m b

17

18||| Also called `join` or mu

19flatten : Monad m => m (m a) -> m a

libs/prelude/Prelude/Nat.idr+13−10

@@ -214,47 +214,50 @@ instance MinBound Nat where

214instance Cast Integer Nat where

215 cast = fromInteger

216

217+instance Cast String Nat where

218+ cast str = cast (the Integer (cast str))

219+

217||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)

220||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)

218record Multiplicative where

221record Multiplicative where

219− constructor getMultiplicative

222+ constructor GetMultiplicative

220 _ : Nat

223 _ : Nat

221

224

222||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)

225||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)

223record Additive where

226record Additive where

224− constructor getAdditive

227+ constructor GetAdditive

225 _ : Nat

228 _ : Nat

226

229

227instance Semigroup Multiplicative where

230instance Semigroup Multiplicative where

228− (<+>) left right = getMultiplicative $ left' * right'

231+ (<+>) left right = GetMultiplicative $ left' * right'

229 where

232 where

230 left' : Nat

233 left' : Nat

231 left' =

234 left' =

232 case left of

235 case left of

233− getMultiplicative m => m

236+ GetMultiplicative m => m

234

237

235 right' : Nat

238 right' : Nat

236 right' =

239 right' =

237 case right of

240 case right of

238− getMultiplicative m => m

241+ GetMultiplicative m => m

239

242

240instance Semigroup Additive where

243instance Semigroup Additive where

241− left <+> right = getAdditive $ left' + right'

244+ left <+> right = GetAdditive $ left' + right'

242 where

245 where

243 left' : Nat

246 left' : Nat

244 left' =

247 left' =

245 case left of

248 case left of

246− getAdditive m => m

249+ GetAdditive m => m

247

250

248 right' : Nat

251 right' : Nat

249 right' =

252 right' =

250 case right of

253 case right of

251− getAdditive m => m

254+ GetAdditive m => m

252

255

253instance Monoid Multiplicative where

256instance Monoid Multiplicative where

254− neutral = getMultiplicative $ S Z

257+ neutral = GetMultiplicative $ S Z

255

258

256instance Monoid Additive where

259instance Monoid Additive where

257− neutral = getAdditive Z

260+ neutral = GetAdditive Z

258

261

259||| Casts negative `Ints` to 0.

262||| Casts negative `Ints` to 0.

260instance Cast Int Nat where

263instance Cast Int Nat where

libs/prelude/Prelude/Show.idr+5

@@ -10,6 +10,7 @@ import Prelude.Chars

10import Prelude.Classes

11import Prelude.List

12import Prelude.Maybe

13+import Prelude.Either

13import Prelude.Nat

14import Prelude.Nat

14import Prelude.Strings

15import Prelude.Strings

15

16

@@ -185,6 +186,10 @@ instance Show a => Show (Maybe a) where

185 showPrec d Nothing = "Nothing"

186 showPrec d Nothing = "Nothing"

186 showPrec d (Just x) = showCon d "Just" $ showArg x

187 showPrec d (Just x) = showCon d "Just" $ showArg x

187

188

189+instance (Show a, Show b) => Show (Either a b) where

190+ showPrec d (Left x) = showCon d "Left" $ showArg x

191+ showPrec d (Right x) = showCon d "Right" $ showArg x

192+

188instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

193instance (Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

189 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

194 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

190

195

libs/prelude/Prelude/Stream.idr+4−1

@@ -14,11 +14,14 @@ import Prelude.List

14

15||| An infinite stream

16codata Stream : Type -> Type where

17− (::) : a -> Stream a -> Stream a

17+ (::) : (e : a) -> Stream a -> Stream a

18

19-- Hints for interactive editing

20%name Stream xs,ys,zs,ws

21

22+-- Usage hints for erasure analysis

23+%used Stream.(::) e

24+

22instance Functor Stream where

25instance Functor Stream where

23 map f (x::xs) = f x :: map f xs

26 map f (x::xs) = f x :: map f xs

24

27

libs/pruviloj/Pruviloj.idr+5

@@ -1,3 +1,8 @@

1+||| Provides the whole public interface of the proof tools. Import

2+||| `Pruviloj.Core` for just the simplest tactics.

1module Pruviloj

3module Pruviloj

2

4

3import public Pruviloj.Core

5import public Pruviloj.Core

6+import public Pruviloj.Disjoint

7+import public Pruviloj.Induction

8+import public Pruviloj.Injective

libs/pruviloj/Pruviloj/Core.idr+135−11

@@ -3,13 +3,8 @@

3||| eventual Prelude inclusion.

4module Pruviloj.Core

5

6−

7−import Language.Reflection.Elab

8import Language.Reflection.Utils

6import Language.Reflection.Utils

9

7

10−data Infer : Type where

11− MkInfer : (a : Type) -> a -> Infer

12−

13||| Run something for effects, throwing away the return value

8||| Run something for effects, throwing away the return value

14ignore : Functor f => f a -> f ()

9ignore : Functor f => f a -> f ()

15ignore x = map (const ()) x

10ignore x = map (const ()) x

@@ -22,6 +17,34 @@ skip = pure ()

22try : Alternative f => f a -> f ()

17try : Alternative f => f a -> f ()

23try tac = ignore tac <|> pure ()

18try tac = ignore tac <|> pure ()

24

19

20+||| Remove type information from a `TT` term, in a context. Fails if

21+||| de Bruijn indices are out of scope.

22+forget' : List TTName -> TT -> Elab Raw

23+forget' env (P nt n tm) = pure (Var n)

24+forget' env (V x) = Var <$> getName x env

25+ where getName : Int -> List a -> Elab a

26+ getName _ [] = fail [TextPart "Scope error when forget'ting types"]

27+ getName i (n::ns) = if i <= 0 then pure n else getName (i-1) ns

28+forget' env (Bind n b tm) =

29+ [| (RBind n)

30+ (assert_total $ traverse (forget' env) b)

31+ (forget' (n::env) tm) |]

32+forget' env (App tm tm') = [| RApp (forget' env tm) (forget' env tm') |]

33+forget' env (TConst c) = pure (RConstant c)

34+forget' env Erased = pure (RConstant Forgot)

35+forget' env (TType uexp) = pure RType

36+forget' env (UType uni) = pure (RUType uni)

37+

38+||| Remove type information from a `TT` term. Fails if de Bruijn

39+||| indices are out of scope.

40+forget : TT -> Elab Raw

41+forget tm = forget' [] tm

42+

43+||| Get the goal type as a Raw term. Fails if there are no holes.

44+goalType : Elab Raw

45+goalType = do g <- getGoal

46+ forget (snd g)

47+

25||| Solve the goal using the most recent applicable hypothesis

48||| Solve the goal using the most recent applicable hypothesis

26hypothesis : Elab ()

49hypothesis : Elab ()

27hypothesis =

50hypothesis =

@@ -46,7 +69,6 @@ nameFrom (MN x n) =

46 then "n"

69 then "n"

47 else n

70 else n

48nameFrom (SN x) = gensym "SN"

71nameFrom (SN x) = gensym "SN"

49−nameFrom NErased = gensym "wasErased"

50

72

51||| Get the name at the head of the term, if it exists.

73||| Get the name at the head of the term, if it exists.

52headName : Raw -> Maybe TTName

74headName : Raw -> Maybe TTName

@@ -69,7 +91,7 @@ newHole hint ty =

69|||

91|||

70||| @ tm the term that has the right type for the hole

92||| @ tm the term that has the right type for the hole

71exact : (tm : Raw) -> Elab ()

93exact : (tm : Raw) -> Elab ()

72−exact tm = do apply tm []

94+exact tm = do fill tm

73 solve

95 solve

74

96

75||| Introduce as many names as possible, returning them.

97||| Introduce as many names as possible, returning them.

@@ -85,11 +107,11 @@ intros = do g <- snd <$> getGoal

85

107

86||| Run a tactic inside of a particular hole, if it still exists. If

108||| Run a tactic inside of a particular hole, if it still exists. If

87||| it has been solved, do nothing.

109||| it has been solved, do nothing.

88−inHole : TTName -> Elab () -> Elab ()

110+inHole : TTName -> Elab a -> Elab (Maybe a)

89inHole h todo =

111inHole h todo =

90− when (h `elem` !getHoles) $

112+ if (h `elem` !getHoles)

91− do focus h

113+ then do focus h; Just <$> todo

92− todo

114+ else return Nothing

93

115

94||| Restrict a polymorphic type to () for contexts where it doesn't

116||| Restrict a polymorphic type to () for contexts where it doesn't

95||| matter. This is nice for sticking `debug` in a context where

117||| matter. This is nice for sticking `debug` in a context where

@@ -142,3 +164,105 @@ bindPat = do compute

142 case g of

164 case g of

143 Bind n (PVTy _) _ => patbind n

165 Bind n (PVTy _) _ => patbind n

144 _ => fail [TermPart g, TextPart "isn't looking for a pattern."]

166 _ => fail [TermPart g, TextPart "isn't looking for a pattern."]

167+

168+||| The underlying implementation type for the inferType operator.

169+data Infer : Type where

170+ MkInfer : (a : Type) -> a -> Infer

171+

172+||| Run a tactic script in a context where the type of the resulting

173+||| expression must be solvable via unification. Return the term and

174+||| its type.

175+|||

176+||| @ tac a tactic script that will be run with focus on the hole

177+||| whose type is to be inferred.

178+total

179+inferType : (tac : Elab ()) -> Elab (TT, TT)

180+inferType tac =

181+ case fst !(runElab `(Infer) (do startInfer; tac)) of

182+ `(MkInfer ~ty ~tm) => return (tm, ty)

183+ _ => fail [TextPart "Not infer"]

184+ where

185+ startInfer : Elab ()

186+ startInfer = do [_, tmH] <- apply (Var `{MkInfer}) [True, False]

187+ | err => fail [TextPart "Type inference failure"]

188+ solve

189+ focus tmH

190+

191+||| Given one tactic that produces a list of subgoal names and another

192+||| that produces some result, run the second tactic in each hole

193+||| produced by the first and return the resulting values.

194+|||

195+||| Elab has no built-in notion of "subgoals", so this simulates the

196+||| Coq or JonPRL semicolon operators.

197+|||

198+||| @ first run this tactic to produce subgoals

199+||| @ after run this tactic in each subgoal

200+andThen : (first : Elab (List TTName)) -> (after : Elab a) -> Elab (List a)

201+andThen first after =

202+ do hs <- first

203+ catMaybes <$> for hs (flip inHole after)

204+

205+||| Refine the current goal using some term, constructing holes for

206+||| all arguments that can't be inferred. Return the list of generated

207+||| holes.

208+|||

209+||| @ tm the term to apply to some number of goals

210+refine : (tm : Raw) -> Elab (List TTName)

211+refine tm =

212+ do ty <- (snd <$> check !getEnv tm) >>= forget

213+ g <- goalType

214+

215+ -- we don't care about negative results because it'll just fail anyway

216+ let argCount = minus (countPi ty) (countPi g)

217+ newHoles <- apply tm (replicate argCount True)

218+ solve

219+ actualHoles <- getHoles

220+ return (filter (flip elem actualHoles) newHoles)

221+

222+ where countPi : Raw -> Nat

223+ countPi (RBind _ (Pi _ _) body) = S (countPi body)

224+ countPi _ = Z

225+

226+

227+||| Split a pair into its projections, binding them in the context

228+||| with the supplied names. A special case of Coq's `inversion`.

229+both : Raw -> TTName -> TTName -> Elab ()

230+both tm n1 n2 =

231+ do -- We don't know that the term is canonical, so let-bind projections applied to it

232+ (A, B) <- isPairTy (snd !(check !getEnv tm))

233+ remember n1 A; apply `(fst {a=~A} {b=~B} ~tm) []; solve

234+ remember n2 B; apply `(snd {a=~A} {b=~B} ~tm) []; solve

235+ where

236+ isPairTy : TT -> Elab (Raw, Raw)

237+ isPairTy `((~A, ~B) : Type) = [| MkPair (forget A) (forget B) |]

238+ isPairTy tm = fail [TermPart tm, TextPart "is not a pair"]

239+

240+||| Let-bind all results of completely destructuring nested tuples.

241+|||

242+||| This makes them available to the `hypothesis` tactic, among others.

243+|||

244+||| @ tm the nested tuple to destructure

245+covering

246+unproduct : (tm : Raw) -> Elab ()

247+unproduct tm =

248+ do n1 <- gensym "left"

249+ n2 <- gensym "right"

250+ both tm n1 n2

251+ try (unproduct (Var n1))

252+ try (unproduct (Var n2))

253+

254+

255+||| A special-purpose tactic that attempts to solve a goal using

256+||| `Refl`. This is useful for ensuring that goals in fact are trivial

257+||| when developing or testing other tactics; otherwise, consider

258+||| using `search`.

259+reflexivity : Elab ()

260+reflexivity =

261+ case !goalType of

262+ `((=) {A=~A} {B=~_} ~x ~_) =>

263+ do fill `(Refl {A=~A} {x=~x})

264+ solve

265+ _ => fail [ TextPart "The goal is not an equality, so"

266+ , NamePart `{reflexivity}

267+ , TextPart "is not applicable."

268+ ]

libs/pruviloj/Pruviloj/Derive/DecEq.idrnew file+196

@@ -0,0 +1,196 @@

1+||| Derive implementations of decidable equality.

2+module Pruviloj.Derive.DecEq

3+

4+import Data.Fin

5+import Data.Vect

6+

7+import Language.Reflection.Utils

8+

9+import Pruviloj.Core

10+

11+import Pruviloj.Renamers

12+import Pruviloj.Internals

13+

14+import Pruviloj.Derive.Eliminators

15+

16+import Pruviloj.Disjoint

17+import Pruviloj.Induction

18+import Pruviloj.Injective

19+

20+%default total

21+%access private

22+

23+

24+covering

25+noCase : TTName -> Elab ()

26+noCase contra =

27+ do [_, nope] <- apply (Var `{No}) [True, False]

28+ | _ => fail [TextPart "Bad holes from", NamePart `{Tactics.apply}]

29+ solve

30+ focus nope

31+

32+ -- Construct a lambda binding an assumption from which we can

33+ -- derive the contradiction

34+ h <- gensym "h"

35+ inj <- gensym "inj"

36+ attack

37+ intro h

38+ injective (Var h) inj

39+ unproduct (Var inj)

40+ ignore $ refine (Var contra) `andThen` hypothesis

41+ solve -- attack

42+

43+partial -- TODO make covering/total

44+matchCase : List Raw -> Elab ()

45+matchCase [] = search

46+matchCase (tm :: tms) =

47+ do (y :: n :: _) <- induction tm

48+

49+ focus n; compute

50+ contra <- gensym "contra"

51+ attack; intro contra

52+ noCase contra; solve

53+

54+ focus y; compute

55+ prf <- gensym "prf"

56+ attack; intro prf

57+ rewriteWith (Var prf)

58+ matchCase tms

59+ solve

60+

61+spanM : (Monad m) => (a -> m Bool) -> List a -> m (List a, List a)

62+spanM p [] = pure ([], [])

63+spanM p (x::xs) =

64+ if !(p x)

65+ then do (yes, no) <- spanM p xs

66+ pure (x :: yes, no)

67+ else pure ([], x::xs)

68+

69+partitionM : Monad m => (a -> m Bool) -> List a -> m (List a, List a)

70+partitionM p [] = pure ([], [])

71+partitionM p (x :: xs) =

72+ do (y, n) <- partitionM p xs

73+ if !(p x) then pure (x :: y, n) else pure (y, x :: n)

74+

75+perhaps : (Alternative f) => (f a) -> (f (Maybe a))

76+perhaps x = (Just <$> x) <|> pure Nothing

77+

78+headIs : Raw -> TTName -> Bool

79+headIs tm n = maybe False (==n) (headName tm)

80+

81+partial

82+mkRhs : (fn, fam : TTName) -> Nat -> Elab ()

83+mkRhs fn fam k =

84+ case snd !getGoal of

85+ `(Dec ((=) {A=~A} {B=~_} ~x ~y)) =>

86+ let (c1, args1) = unApply x

87+ (c2, args2) = unApply y

88+ in if c1 /= c2

89+ then do (h :: _) <- refine (Var `{No})

90+ | _ => empty

91+ focus h

92+ disjoint

93+ else do let toMakeEqual = List.filter (uncurry (/=)) (zip args1 args2)

94+ tms <- for {b=Raw} toMakeEqual $ \(tm1, tm2) =>

95+ do env <- getEnv

96+ (tm1', ty1') <- forget tm1 >>= check env

97+ (tm2', ty2') <- forget tm2 >>= check env

98+ -- assume they have the same type here -

99+ -- reasonable due to same constructor, but

100+ -- this means order is important when

101+ -- traversing

102+ eq <- gensym "eq"

103+ rTy <- forget ty1'

104+ rTm1 <- forget tm1'

105+ rTm2 <- forget tm2'

106+ remember eq `(Dec ((=) {A=~rTy} {B=~rTy} ~rTm1 ~rTm2))

107+ simple $

108+ if headIs rTy fam

109+ then do (a2::a1::hs) <- reverse <$> apply (Var fn) (replicate k True ++ [False, False])

110+ solve

111+ focus a1; fill rTm1; solve

112+ focus a2; fill rTm2; solve

113+ for_ hs $ \h => inHole h (resolveTC fn)

114+ else do [_, dH, a1, a2] <- apply (Var `{decEq}) [True, False, False, False]

115+ solve

116+ focus a1; fill rTm1; solve

117+ focus a2; fill rTm2; solve

118+ focus dH; resolveTC fn

119+ return (Var eq)

120+ matchCase tms

121+ _ => fail [TextPart "Inapplicable"]

122+

123+||| Attempt to derive the body of an implementation of decidable

124+||| equality based on an existing type signature.

125+|||

126+||| The function signature must provide enough information for the

127+||| deriving to occur. It must consist of zero or more non-constraint

128+||| arguments followed by zero or more constraint arguments, followed

129+||| by the two values to compare. The constraint arguments must

130+||| provide sufficient instances of `DecEq` to decide the equality of

131+||| each constructor field. The final two arguments to the function

132+||| declaration must be the two values that will be compared for

133+||| equality.

134+|||

135+||| @ fn the name of the function whose type has been declared

136+abstract partial -- because of mkRhs

137+deriveDecEq : (fn : TTName) -> Elab ()

138+deriveDecEq fn =

139+ do (_, Ref, sig') <- lookupTyExact fn

140+ sig <- forget sig'

141+ (args, `(Dec ((=) {A=~A} {B=~_} ~(Var x) ~(Var y)))) <- stealBindings sig noRenames

142+ | other => fail [ TextPart "Return type"

143+ , RawPart (snd other)

144+ , TextPart "isn't decidable equality"

145+ ]

146+

147+ datatype <- maybe (fail [ RawPart A

148+ , TextPart "is not an application of a TC"

149+ ])

150+ lookupDatatypeExact

151+ (headName A)

152+

153+ -- the signature must be like this:

154+ -- 1. a collection of variable bindings (will be implicit)

155+ -- 2. a collection of constraints

156+ -- 3. the arguments x and y from the return type

157+ (bindings, constrs, arg1, arg2) <-

158+ the (Elab (List (TTName, Binder Raw),

159+ List (TTName, Binder Raw),

160+ (TTName, Binder Raw),

161+ (TTName, Binder Raw))) $

162+ case reverse args of

163+ [] => fail [TextPart "Invalid signature"]

164+ [_] => fail [TextPart "Invalid signaure"]

165+ (a2 :: a1 :: rest) =>

166+ do (constrs, bindings) <- partitionM (\x => isConstr (binderTy (snd x)))

167+ (reverse rest)

168+ return (bindings, constrs, a1, a2)

169+ let todo = [(c1, c2) | c1 <- constructors datatype

170+ , c2 <- constructors datatype]

171+ clauses <- for todo

172+ (uncurry $ mkCase (length bindings + length constrs)

173+ (name datatype))

174+ defineFunction $ DefineFun fn (catMaybes clauses)

175+ skip

176+

177+ where

178+ isConstr : Raw -> Elab Bool

179+ isConstr tm = case headName tm of

180+ Just n => isTCName n

181+ Nothing => return False

182+

183+ partial -- mkRhs

184+ mkCase : Nat -> TTName -> (x, y : (TTName, List CtorArg, Raw)) -> Elab (Maybe (FunClause Raw))

185+ mkCase k fam (cn1, args1, _) (cn2, args2, _) =

186+ perhaps $ elabPatternClause

187+ (do (h2 :: h1 :: _) <- reverse <$>

188+ apply (Var fn) (replicate k True ++ [False, False])

189+ solve

190+ focus h1

191+ apply (Var cn1) (replicate (length args1) True)

192+ solve

193+ focus h2

194+ apply (Var cn2) (replicate (length args2) True)

195+ solve)

196+ (mkRhs fn fam k)

libs/pruviloj/Pruviloj/Derive/Eliminators.idr+32−41

@@ -18,7 +18,7 @@ bindParams info = traverse_ (uncurry forall) (getParams info)

18||| rewrite an application of something to their designated global

19||| names

20bindIndices : TyConInfo -> Elab Renamer

21−bindIndices info = bind' (getIndices info) (const Nothing)

21+bindIndices info = bind' (getIndices info) noRenames

22 where bind' : List (TTName, Raw) -> Renamer -> Elab Renamer

23 bind' [] ren = return ren

24 bind' ((n, t) :: ixs) ren = do n' <- nameFrom n

@@ -54,7 +54,7 @@ headsMatch x y =

54||| Make an induction hypothesis if one is called for

55mkIh : TyConInfo -> (motiveName : TTName) -> (recArg : TTName) -> (argty, fam : Raw) -> Elab ()

56mkIh info motiveName recArg argty fam =

57− case !(stealBindings argty (const Nothing)) of

57+ case !(stealBindings argty noRenames) of

58 (argArgs, argRes) =>

59 if headsMatch argRes fam

60 then do ih <- gensym "ih"

@@ -65,12 +65,12 @@ mkIh info motiveName recArg argty fam =

65 for_ {b=()} argArgs $ \(n, b) =>

66 forall n (getBinderTy b)

67 let argTm : Raw = mkApp (Var recArg) (map (Var . fst) argArgs)

68− argTmTy <- forgetTypes (snd !(check argTm))

68+ argTmTy <- forget (snd !(check !getEnv argTm))

69 argHoles <- apply (Var motiveName)

70 (replicate (length (getIndices info))

71− (True, 0) ++

71+ True ++

72− [(False,1)])

72+ [False])

73− argH <- snd <$> last argHoles

73+ argH <- last argHoles

74 focus argH

75 fill argTm; solve

76 solve -- attack

@@ -80,35 +80,29 @@ mkIh info motiveName recArg argty fam =

80elabMethodTy : TyConInfo -> TTName -> List CtorArg -> Raw -> Raw -> Elab ()

81elabMethodTy info motiveName [] res ctorApp =

82 do argHoles <- apply (Var motiveName)

83− (replicate (length (getIndices info)) (True, 0) ++

83+ (replicate (length (getIndices info)) True ++

84− [(False, 1)])

84+ [False])

85− argH <- snd <$> last argHoles

85+ argH <- last argHoles

86 focus argH; fill ctorApp; solve

87 solve

88elabMethodTy info motiveName (CtorParameter arg :: args) res ctorApp =

89− elabMethodTy info motiveName args res (RApp ctorApp (Var (argName arg)))

89+ elabMethodTy info motiveName args res (RApp ctorApp (Var (name arg)))

90elabMethodTy info motiveName (CtorField arg :: args) res ctorApp =

91− do let n = argName arg

91+ do let n = name arg

92− let t = argTy arg

92+ let t = type arg

93 attack; forall n t

94 mkIh info motiveName n t (result info)

95 elabMethodTy info motiveName args res (RApp ctorApp (Var n))

96 solve

97

98

99−

100−elabMethod : TyConInfo -> (motiveName, ctorN : TTName) -> List CtorArg -> Raw -> Elab ()

101−elabMethod info motiveName ctorN ctorArgs resTy =

102− do elabMethodTy info motiveName ctorArgs resTy (Var ctorN)

103−

104−

105||| Bind a method for a constructor

99||| Bind a method for a constructor

106bindMethod : TyConInfo -> (motiveName, cn : TTName) -> List CtorArg -> Raw -> Elab ()

100bindMethod : TyConInfo -> (motiveName, cn : TTName) -> List CtorArg -> Raw -> Elab ()

107bindMethod info motiveName cn cargs cty =

101bindMethod info motiveName cn cargs cty =

108 do n <- nameFrom cn

102 do n <- nameFrom cn

109 h <- newHole "methTy" `(Type)

103 h <- newHole "methTy" `(Type)

110 forall n (Var h)

104 forall n (Var h)

111− focus h; elabMethod info motiveName cn cargs cty

105+ focus h; elabMethodTy info motiveName cargs cty (Var cn)

112

106

113getElimTy : TyConInfo -> List (TTName, List CtorArg, Raw) -> Elab Raw

107getElimTy : TyConInfo -> List (TTName, List CtorArg, Raw) -> Elab Raw

114getElimTy info ctors =

108getElimTy info ctors =

@@ -129,7 +123,7 @@ getElimTy info ctors =

129 [Var scrut])

123 [Var scrut])

130 apply (alphaRaw iren ret) []

124 apply (alphaRaw iren ret) []

131 solve

125 solve

132− forgetTypes (fst ty)

126+ forget (fst ty)

133

127

134

128

135

129

@@ -140,7 +134,7 @@ instance Show ElimArg where

140 show (NormalArgument x) = "NormalArgument " ++ show x

134 show (NormalArgument x) = "NormalArgument " ++ show x

141

135

142getElimClause : TyConInfo -> (elimn : TTName) -> (methCount : Nat) ->

136getElimClause : TyConInfo -> (elimn : TTName) -> (methCount : Nat) ->

143− (TTName, List CtorArg, Raw) -> Nat -> Elab FunClause

137+ (TTName, List CtorArg, Raw) -> Nat -> Elab (FunClause Raw)

144getElimClause info elimn methCount (cn, args, resTy) whichCon =

138getElimClause info elimn methCount (cn, args, resTy) whichCon =

145 elabPatternClause

139 elabPatternClause

146 (do -- Establish a hole for each parameter

140 (do -- Establish a hole for each parameter

@@ -153,8 +147,8 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

153 for {b=()} args $ \arg =>

147 for {b=()} args $ \arg =>

154 case arg of

148 case arg of

155 CtorParameter _ => return ()

149 CtorParameter _ => return ()

156− CtorField arg => do claim (argName arg) (argTy arg)

150+ CtorField arg => do claim (name arg) (type arg)

157− unfocus (argName arg)

151+ unfocus (name arg)

158

152

159 -- Establish a hole for the scrutinee (infer type)

153 -- Establish a hole for the scrutinee (infer type)

160 scrutinee <- newHole "scrutinee" resTy

154 scrutinee <- newHole "scrutinee" resTy

@@ -167,9 +161,9 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

167 -- We leave the RHS with a function type: motive -> method* -> res

161 -- We leave the RHS with a function type: motive -> method* -> res

168 -- to make it easier to map methods to constructors

162 -- to make it easier to map methods to constructors

169 holes <- apply paramApp (replicate (length (getIndices info))

163 holes <- apply paramApp (replicate (length (getIndices info))

170− (True, 0) ++

164+ True ++

171− [(False, 1)])

165+ [False])

172− scr <- snd <$> last holes

166+ scr <- last holes

173 focus scr; fill (Var scrutinee); solve

167 focus scr; fill (Var scrutinee); solve

174 solve

168 solve

175

169

@@ -177,8 +171,8 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

177 focus scrutinee

171 focus scrutinee

178 apply (mkApp (Var cn) $

172 apply (mkApp (Var cn) $

179 map (\x => case x of

173 map (\x => case x of

180− CtorParameter param => Var (argName param)

174+ CtorParameter param => Var (name param)

181− CtorField arg => Var (argName arg))

175+ CtorField arg => Var (name arg))

182 args)

176 args)

183 []

177 []

184 solve)

178 solve)

@@ -195,21 +189,21 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

195 case x of

189 case x of

196 CtorParameter _ => return List.Nil

190 CtorParameter _ => return List.Nil

197 CtorField arg =>

191 CtorField arg =>

198− do let n = argName arg

192+ do let n = name arg

199− let t = argTy arg

193+ let t = type arg

200− (argArgs, argRes) <- stealBindings t (const Nothing)

194+ (argArgs, argRes) <- stealBindings t noRenames

201 if headsMatch argRes (result info) --recursive

195 if headsMatch argRes (result info) --recursive

202 then return [ NormalArgument n

196 then return [ NormalArgument n

203 , IHArgument n

197 , IHArgument n

204 ]

198 ]

205 else return [NormalArgument n])

199 else return [NormalArgument n])

206

200

207− argHs <- apply (Var methN) (replicate (List.length argSpec) (True, 0))

201+ argHs <- apply (Var methN) (replicate (List.length argSpec) True)

208 solve

202 solve

209

203

210 -- Now build the recursive calls for the induction hypotheses

204 -- Now build the recursive calls for the induction hypotheses

211 for_ {a=(ElimArg, TTName)} {b=()}

205 for_ {a=(ElimArg, TTName)} {b=()}

212− !(zipH argSpec (map snd argHs))

206+ !(zipH argSpec argHs)

213 (\(spec, nh) =>

207 (\(spec, nh) =>

214 case spec of

208 case spec of

215 NormalArgument n => do focus nh

209 NormalArgument n => do focus nh

@@ -220,12 +214,12 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

220 attack

214 attack

221 local <- intros

215 local <- intros

222 ihHs <- apply (Var elimn) $

216 ihHs <- apply (Var elimn) $

223− replicate (length (TyConInfo.args info)) (True, 0) ++

217+ replicate (length (TyConInfo.args info)) True ++

224− [(False, 1)] ++

218+ [False] ++

225− replicate (S methCount) (True, 0)

219+ replicate (S methCount) True

226 solve -- application

220 solve -- application

227

221

228− let (arg::motive::methods) = map snd $ drop (length (TyConInfo.args info)) ihHs

222+ let (arg::motive::methods) = drop (length (TyConInfo.args info)) ihHs

229 focus arg

223 focus arg

230

224

231 apply (mkApp (Var n) (map Var local)) []; solve

225 apply (mkApp (Var n) (map Var local)) []; solve

@@ -248,15 +242,12 @@ getElimClause info elimn methCount (cn, args, resTy) whichCon =

248 bindLam ((n, b)::rest) x = RBind n (Lam (getBinderTy b)) $ bindLam rest x

242 bindLam ((n, b)::rest) x = RBind n (Lam (getBinderTy b)) $ bindLam rest x

249

243

250getElimClauses : TyConInfo -> (elimn : TTName) ->

244getElimClauses : TyConInfo -> (elimn : TTName) ->

251− List (TTName, List CtorArg, Raw) -> Elab (List FunClause)

245+ List (TTName, List CtorArg, Raw) -> Elab (List (FunClause Raw))

252getElimClauses info elimn ctors =

246getElimClauses info elimn ctors =

253 let methodCount = length ctors

247 let methodCount = length ctors

254 in traverse (\(i, con) => getElimClause info elimn methodCount con i)

248 in traverse (\(i, con) => getElimClause info elimn methodCount con i)

255 (enumerate ctors)

249 (enumerate ctors)

256

250

257−instance Show FunClause where

258− show (MkFunClause x y) = "(MkFunClause " ++ show x ++ " " ++ show y ++ ")"

259−

260abstract

251abstract

261deriveElim : (tyn, elimn : TTName) -> Elab ()

252deriveElim : (tyn, elimn : TTName) -> Elab ()

262deriveElim tyn elimn =

253deriveElim tyn elimn =

libs/pruviloj/Pruviloj/Disjoint.idrnew file+85

@@ -0,0 +1,85 @@

1+||| Provides a tactic for solving constructor disjointness goals.

2+module Pruviloj.Disjoint

3+

4+import Language.Reflection.Utils

5+

6+import Pruviloj.Core

7+import Pruviloj.Internals

8+import Pruviloj.Renamers

9+

10+%default total

11+%access private

12+

13+-------------------

14+-- PRIVATE GUTS --

15+-------------------

16+

17+||| Compute the name to use for a disjointness lemma.

18+disjointName : TTName -> TTName -> TTName

19+disjointName l r = NS (SN (MetaN (UN "disjoint") (SN (MetaN l r))))

20+ ["Disjoint", "Pruviloj"]

21+

22+||| Return the name of the disjointness lemma for two constructors,

23+||| defining it if necessary.

24+|||

25+||| @ l one of the constructor names

26+||| @ r the other constructor name

27+covering

28+getDisjointness : (l, r : TTName) -> Elab TTName

29+getDisjointness l r = exists <|> declare

30+

31+ where exists : Elab TTName

32+ exists = do (yep, _, _) <- lookupTyExact (disjointName l r)

33+ return yep

34+

35+ notConstructor : TTName -> Elab a

36+ notConstructor c = fail [NamePart c, TextPart "is not a constructor"]

37+

38+ covering

39+ declare : Elab TTName

40+ declare = do (l', DCon _ _, lty) <- lookupTyExact l

41+ | _ => notConstructor l

42+ (r', DCon _ _, rty) <- lookupTyExact r

43+ | _ => notConstructor r

44+ let fn = disjointName l' r'

45+ when (l' == r') $

46+ fail [ NamePart l', TextPart "and"

47+ , NamePart r', TextPart "are clearly not disjoint!"

48+ ]

49+ (argsl, resl) <- stealBindings !(forget lty) noRenames

50+ (argsr, resr) <- stealBindings !(forget rty) noRenames

51+ let args = map {b=FunArg}

52+ (\(n, b) => MkFunArg n (binderTy b) Implicit NotErased)

53+ (argsl ++ argsr)

54+ let eq : Raw = `((=) {A=~resl}

55+ {B=~resr}

56+ ~(mkApp (Var l') (map (Var . fst) argsl))

57+ ~(mkApp (Var r') (map (Var . fst) argsr)))

58+ h <- gensym "h"

59+ declareType $ Declare fn (args ++ [MkFunArg h eq Explicit NotErased]) `(Void)

60+ defineFunction $ DefineFun fn []

61+ return fn

62+

63+----------------------

64+-- PUBLIC INTERFACE --

65+----------------------

66+

67+

68+||| Solve a goal of the form `(C1 x1 x2 ... xn = C2 x1 x2 ... xn) ->

69+||| Void` for disjoint constructors `C1` and `C2`.

70+public covering

71+disjoint : Elab ()

72+disjoint =

73+ do compute

74+ g <- snd <$> getGoal

75+ case g of

76+ `(((=) {A=~A} {B=~B} ~a ~b) -> Void) =>

77+ do Just lHead <- headName <$> forget a

78+ | Nothing => fail [TermPart a, TextPart "doesn't have a name at the head"]

79+ Just rHead <- headName <$> forget b

80+ | Nothing => fail [TermPart b, TextPart "doesn't have a name at the head"]

81+ [] <- refine (Var !(getDisjointness lHead rHead))

82+ | _ => fail [TextPart "Didn't solve argument to disjointness lemma"]

83+ skip

84+ ty =>

85+ fail [NamePart `{disjoint}, TextPart "is not applicable to goal", TermPart ty]

libs/pruviloj/Pruviloj/Induction.idr+8−13

@@ -36,7 +36,6 @@ mutual

36 alphaEqual subst f g && alphaEqual subst x y

37 alphaEqual subst RType RType = True

38 alphaEqual subst (RUType u) (RUType u') = u == u'

39− alphaEqual subst (RForce tm) (RForce tm') = alphaEqual subst tm tm'

40 alphaEqual subst (RConstant c) (RConstant c') = c == c'

39 alphaEqual subst (RConstant c) (RConstant c') = c == c'

41 alphaEqual subst _ _ = False

40 alphaEqual subst _ _ = False

42

41

@@ -49,9 +48,6 @@ mutual

49 alphaEqualBinders subst (Let tm1 tm2) (Let tm1' tm2') =

48 alphaEqualBinders subst (Let tm1 tm2) (Let tm1' tm2') =

50 alphaEqual subst tm1 tm1' &&

49 alphaEqual subst tm1 tm1' &&

51 alphaEqual subst tm2 tm2'

50 alphaEqual subst tm2 tm2'

52− alphaEqualBinders subst (NLet tm1 tm2) (NLet tm1' tm2') =

53− alphaEqual subst tm1 tm1' &&

54− alphaEqual subst tm2 tm2'

55 alphaEqualBinders subst (Hole tm) (Hole tm') =

51 alphaEqualBinders subst (Hole tm) (Hole tm') =

56 alphaEqual subst tm tm'

52 alphaEqual subst tm tm'

57 alphaEqualBinders subst (GHole tm) (GHole tm') =

53 alphaEqualBinders subst (GHole tm) (GHole tm') =

@@ -79,7 +75,6 @@ generalize hint ctxt subj = do n <- gensym hint

79 genB n (Lam ty) inner = [| Lam (gen' n ty inner) |]

75 genB n (Lam ty) inner = [| Lam (gen' n ty inner) |]

80 genB n (Pi ty ty') inner = [| Pi (gen' n ty inner) (gen' n ty' inner) |]

76 genB n (Pi ty ty') inner = [| Pi (gen' n ty inner) (gen' n ty' inner) |]

81 genB n (Let ty val) inner = [| Let (gen' n ty inner) (gen' n val inner) |]

77 genB n (Let ty val) inner = [| Let (gen' n ty inner) (gen' n val inner) |]

82− genB n (NLet ty val) inner = [| NLet (gen' n ty inner) (gen' n val inner) |]

83 genB n (Hole ty) inner = [| Hole (gen' n ty inner) |]

78 genB n (Hole ty) inner = [| Hole (gen' n ty inner) |]

84 genB n (GHole ty) inner = [| GHole (gen' n ty inner) |]

79 genB n (GHole ty) inner = [| GHole (gen' n ty inner) |]

85 genB n (Guess ty val) inner = [| Guess (gen' n ty inner) (gen' n val inner) |]

80 genB n (Guess ty val) inner = [| Guess (gen' n ty inner) (gen' n val inner) |]

@@ -134,8 +129,8 @@ public

134induction : Raw -> Elab (List TTName)

129induction : Raw -> Elab (List TTName)

135induction subj =

130induction subj =

136 do g <- goalType

131 do g <- goalType

137− (_, ty) <- check subj

132+ (_, ty) <- check !getEnv subj

138− ty' <- forgetTypes ty

133+ ty' <- forget ty

139 case headName ty' of

134 case headName ty' of

140 Nothing => fail [TermPart ty, TextPart "is not an inductive family"]

135 Nothing => fail [TermPart ty, TextPart "is not an inductive family"]

141 Just fam =>

136 Just fam =>

@@ -145,18 +140,18 @@ induction subj =

145 tydef <- lookupDatatypeExact fam

140 tydef <- lookupDatatypeExact fam

146 info <- getTyConInfo (tyConArgs tydef) (tyConRes tydef)

141 info <- getTyConInfo (tyConArgs tydef) (tyConRes tydef)

147 argHoles <- apply (Var elim)

142 argHoles <- apply (Var elim)

148− (replicate (length (args info)) (True, 0) ++

143+ (replicate (length (args info)) True ++

149− [(False, 0), (False, 0)] ++ -- scrutinee, motive

144+ [False, False] ++ -- scrutinee, motive

150− replicate (length (constructors tydef)) (False, 1))

145+ replicate (length (constructors tydef)) False)

151 solve

146 solve

152

147

153 -- Apply the eliminator to our scrutinee

148 -- Apply the eliminator to our scrutinee

154− scrutH <- snd <$> unsafeNth (length (args info)) argHoles

149+ scrutH <- unsafeNth (length (args info)) argHoles

155 focus scrutH

150 focus scrutH

156 apply subj []

151 apply subj []

157 solve

152 solve

158

153

159− motiveH <- snd <$> unsafeNth (length (args info) + 1) argHoles

154+ motiveH <- unsafeNth (length (args info) + 1) argHoles

160 focus motiveH; makeMotive info subj ty' g

155 focus motiveH; makeMotive info subj ty' g

161

156

162− return (map snd (drop (2 + length (tyConArgs tydef)) argHoles))

157+ return (drop (2 + length (tyConArgs tydef)) argHoles)

libs/pruviloj/Pruviloj/Injective.idrnew file+122

@@ -0,0 +1,122 @@

1+module Pruviloj.Injective

2+

3+import Language.Reflection.Utils

4+

5+import Pruviloj.Core

6+import Pruviloj.Internals

7+import Pruviloj.Renamers

8+

9+%default total

10+%access private

11+

12+-------------------

13+-- PRIVATE GUTS --

14+-------------------

15+

16+||| Compute the name for a constructor's injectivity lemma

17+injName : TTName -> TTName

18+injName cn = NS (SN (MetaN `{{injectivity}} cn)) ["Injective", "Pruviloj"]

19+

20+||| Provide an error message for when non-constructor names are passed

21+notConstructor : TTName -> Elab a

22+notConstructor c = fail [NamePart c, TextPart "is not a constructor"]

23+

24+covering

25+getInjectivity : (cn : TTName) -> Elab TTName

26+getInjectivity cn = exists <|> declare

27+ where exists : Elab TTName

28+ exists = do (fn, Ref, _) <- lookupTyExact (injName cn)

29+ | (fn, _, _) => fail [TextPart "Bad earlier declaration of", NamePart fn]

30+ return fn

31+

32+ covering

33+ declare : Elab TTName

34+ declare = do (cn', DCon _ _, cty) <- lookupTyExact cn

35+ | _ => notConstructor cn

36+ let fn = injName cn'

37+ (args1, res1) <- stealBindings !(forget cty) noRenames

38+ (args2, res2) <- stealBindings !(forget cty) noRenames

39+ let impls1 = map (\(n, b) => MkFunArg n (binderTy b) Implicit NotErased)

40+ args1

41+ let impls2 = map (\(n, b) => MkFunArg n (binderTy b) Implicit NotErased)

42+ args2

43+ let res = foldr (\t1, t2 => RApp (RApp (Var `{Pair}) t1) t2)

44+ `(() : Type)

45+ (map (\(a1, a2) =>

46+ `((=) {A=~(type a1)}

47+ {B=~(type a2)}

48+ ~(Var (name a1))

49+ ~(Var (name a2))))

50+ (zip impls1 impls2))

51+

52+ declareType $ Declare fn (impls1 ++ impls2 ++

53+ [ MkFunArg !(gensym "arg")

54+ `((=) {A=~res1}

55+ {B=~res2}

56+ ~(mkApp (Var cn)

57+ (map (Var . fst) args1))

58+ ~(mkApp (Var cn)

59+ (map (Var . fst) args2)))

60+ Explicit

61+ NotErased])

62+

63+ res

64+ clause <- elabPatternClause

65+ (do (h::_) <- reverse <$>

66+ apply (Var fn)

67+ (replicate (2 * length args1)

68+ True ++

69+ [False])

70+ | _ => fail [TextPart "Missing hole"]

71+ solve

72+ focus h; search)

73+ search -- rhs is conjunction of Refls

74+ defineFunction $

75+ DefineFun fn [clause]

76+ return fn

77+

78+countBinders : TT -> Nat

79+countBinders (Bind _ _ body) = S (countBinders body)

80+countBinders _ = Z

81+

82+

83+----------------------

84+-- PUBLIC INTERFACE --

85+----------------------

86+

87+

88+||| Given an equality of the form `(C x1 ... xn = C y1 ... yn)`,

89+||| generate an product of the equalities `(x1 = y1)` ... `(xn = yn)`.

90+|||

91+||| The equalities are let-bound to the provided name.

92+|||

93+||| @ tm the equality to exploit injectivity on

94+||| @ n the name at which to bind the result

95+covering public

96+injective : (tm : Raw) -> (n : TTName) -> Elab ()

97+injective tm n =

98+ do (_, ty) <- check !getEnv tm

99+ case !(forget ty) of

100+ `((=) {A=~A} {B=~B} ~x ~y) =>

101+ case (headName x, headName y) of

102+ (Just xHd, Just yHd) =>

103+ if xHd /= yHd

104+ then fail [ TextPart "Mismatch between", NamePart xHd

105+ , TextPart "and", NamePart yHd

106+ ]

107+ else do fn <- getInjectivity xHd

108+ tyH <- newHole "ty" `(Type)

109+ tmH <- newHole "tm" (Var tyH)

110+

111+ letbind n (Var tyH) (Var tmH)

112+ focus tmH

113+ (_, _, fnTy) <- lookupTyExact fn

114+

115+ (arg :: _) <- reverse <$> apply (Var fn) (replicate (pred (countBinders fnTy)) True ++ [False])

116+ | _ => fail [TextPart "No hole for argument"]

117+ solve

118+

119+ focus arg; apply tm []; solve

120+ _ => fail [TextPart "oops"]

121+

122+ _ => fail [TextPart "can't use injectivity on non-equality"]

libs/pruviloj/Pruviloj/Internals.idr+15−19

@@ -9,20 +9,20 @@ import Data.Vect

9

10||| Get the name of a reflected type constructor argument.

11tyConArgName : TyConArg -> TTName

12−tyConArgName (TyConParameter a) = argName a

12+tyConArgName (TyConParameter a) = name a

13−tyConArgName (TyConIndex a) = argName a

13+tyConArgName (TyConIndex a) = name a

14

15||| Modify the name of a reflected type constructor argument.

16setTyConArgName : TyConArg -> TTName -> TyConArg

17−setTyConArgName (TyConParameter a) n = TyConParameter (record {argName = n} a)

17+setTyConArgName (TyConParameter a) n = TyConParameter (record {name = n} a)

18−setTyConArgName (TyConIndex a) n = TyConIndex (record {argName = n} a)

18+setTyConArgName (TyConIndex a) n = TyConIndex (record {name = n} a)

19

20||| Modify the type of a reflected type constructor argument using some function.

21updateTyConArgTy : (Raw -> Raw) -> TyConArg -> TyConArg

22updateTyConArgTy f (TyConParameter a) =

23− TyConParameter (record {argTy = f (argTy a) } a)

23+ TyConParameter (record {type = f (type a) } a)

24updateTyConArgTy f (TyConIndex a) =

25− TyConIndex (record {argTy = f (argTy a) } a)

25+ TyConIndex (record {type = f (type a) } a)

26

27unApply : Raw -> (Raw, List Raw)

28unApply tm = unApply' tm []

@@ -63,7 +63,6 @@ getBinderTy : Binder t -> t

63getBinderTy (Lam t) = t

64getBinderTy (Pi t _) = t

65getBinderTy (Let t _) = t

66−getBinderTy (NLet t _) = t

67getBinderTy (Hole t) = t

66getBinderTy (Hole t) = t

68getBinderTy (GHole t) = t

67getBinderTy (GHole t) = t

69getBinderTy (Guess t _) = t

68getBinderTy (Guess t _) = t

@@ -77,10 +76,6 @@ enumerate xs = enumerate' xs 0

77 enumerate' [] _ = []

76 enumerate' [] _ = []

78 enumerate' (x::xs) n = (n, x) :: enumerate' xs (S n)

77 enumerate' (x::xs) n = (n, x) :: enumerate' xs (S n)

79

78

80−getSigmaArgs : Raw -> Elab (Raw, Raw)

81−getSigmaArgs `(MkSigma {a=~_} {P=~_} ~rhsTy ~lhs) = return (rhsTy, lhs)

82−getSigmaArgs arg = fail [TextPart "Not a sigma constructor"]

83−

84bindPats : List (TTName, Binder Raw) -> Raw -> Raw

79bindPats : List (TTName, Binder Raw) -> Raw -> Raw

85bindPats [] res = res

80bindPats [] res = res

86bindPats ((n, b)::bs) res = RBind n (PVar (getBinderTy b)) $ bindPats bs res

81bindPats ((n, b)::bs) res = RBind n (PVar (getBinderTy b)) $ bindPats bs res

@@ -106,25 +101,26 @@ bindPatTys ((n, b)::bs) res = RBind n (PVTy (getBinderTy b)) $ bindPatTys bs res

106||| It will be run in a context where the pattern variables are

101||| It will be run in a context where the pattern variables are

107||| already bound, and should leave behind no holes.

102||| already bound, and should leave behind no holes.

108partial

103partial

109−elabPatternClause : (lhs, rhs : Elab ()) -> Elab FunClause

104+elabPatternClause : (lhs, rhs : Elab ()) -> Elab (FunClause Raw)

110elabPatternClause lhs rhs =

105elabPatternClause lhs rhs =

111 do -- Elaborate the LHS in a context where its type will be solved via unification

106 do -- Elaborate the LHS in a context where its type will be solved via unification

112− (pat, _) <- runElab `(Sigma Type id) $

107+ (pat, _) <- runElab `(Infer) $

113 do th <- newHole "finalTy" `(Type)

108 do th <- newHole "finalTy" `(Type)

114 patH <- newHole "pattern" (Var th)

109 patH <- newHole "pattern" (Var th)

115− fill `(MkSigma ~(Var th) ~(Var patH) : Sigma Type id)

110+ fill `(MkInfer ~(Var th) ~(Var patH))

116 solve

111 solve

117 focus patH

112 focus patH

118 lhs

113 lhs

119 -- Convert all remaining holes to pattern variables

114 -- Convert all remaining holes to pattern variables

115+ for_ {b=()} !getHoles $ \h =>

120− traverse_ {b=()} (\h => focus h *> patvar h) !getHoles

116+ do focus h; patvar h

121− let (pvars, sigma) = extractBinders !(forgetTypes pat)

117+ (pvars, `(MkInfer ~rhsTy ~lhsTm)) <- extractBinders <$> forget pat

122− (rhsTy, lhsTm) <- getSigmaArgs sigma

118+ | fail [TextPart "Couldn't infer type of left-hand pattern"]

123 rhsTm <- runElab (bindPatTys pvars rhsTy) $

119 rhsTm <- runElab (bindPatTys pvars rhsTy) $

124− do -- Introduce all the pattern variables from the LHS

120+ do -- Introduce all the pattern variables from the LHS

125 repeatUntilFail bindPat <|> return ()

121 repeatUntilFail bindPat <|> return ()

126 rhs

122 rhs

127− realRhs <- forgetTypes (fst rhsTm)

123+ realRhs <- forget (fst rhsTm)

128 return $ MkFunClause (bindPats pvars lhsTm) realRhs

124 return $ MkFunClause (bindPats pvars lhsTm) realRhs

129

125

130||| Introduce a unique binder name, returning it

126||| Introduce a unique binder name, returning it

libs/pruviloj/Pruviloj/Internals/TyConInfo.idr+11−11

@@ -23,13 +23,13 @@ record TyConInfo where

23getParams : TyConInfo -> List (TTName, Raw)

24getParams info = mapMaybe param (args info)

25 where param : TyConArg -> Maybe (TTName, Raw)

26− param (TyConParameter a) = Just (argName a, argTy a)

26+ param (TyConParameter a) = Just (name a, type a)

27 param _ = Nothing

28

29getIndices : TyConInfo -> List (TTName, Raw)

30getIndices info = mapMaybe index (args info)

31 where index : TyConArg -> Maybe (TTName, Raw)

32− index (TyConIndex a) = Just (argName a, argTy a)

32+ index (TyConIndex a) = Just (name a, type a)

33 index _ = Nothing

34

35||| Rename a bound variable across a telescope

@@ -75,7 +75,7 @@ processCtorArgs info (cn, cargs, resTy) =

75 findParam : TTName -> List Raw -> List TyConArg -> Elab TTName

76 findParam paramN (Var n :: args) (TyConParameter a :: tcArgs) =

77 if n == paramN

78− then return (argName a)

78+ then return (name a)

79 else findParam paramN args tcArgs

80 findParam paramN (_ :: args) (_ :: tcArgs) =

81 findParam paramN args tcArgs

@@ -89,20 +89,20 @@ processCtorArgs info (cn, cargs, resTy) =

89 TyConInfo -> Elab (List CtorArg, Raw)

90 convert' subst [] ty info = return ([], alphaRaw subst ty)

91 convert' subst (CtorField a :: args) ty info =

92− do n' <- nameFrom (argName a)

92+ do n' <- nameFrom (name a)

93 let a' = record {

94− argName = n'

94+ name = n'

95− , argTy = alphaRaw subst (argTy a)

95+ , type = alphaRaw subst (type a)

96 } a

97− let subst' = extend subst (argName a) n'

97+ let subst' = extend subst (name a) n'

98 (args', ty') <- convert' subst' args ty info

99 return (CtorField a' :: args', ty')

100 convert' subst (CtorParameter a :: ctorArgs) ty info =

101− do n' <- findParam (argName a) (snd (unApply ty)) (args info)

101+ do n' <- findParam (name a) (snd (unApply ty)) (args info)

102 let a' = record {

103− argName = n'

103+ name = n'

104− , argTy = alphaRaw subst (argTy a)

104+ , type = alphaRaw subst (type a)

105 } a

106− let subst' = extend subst (argName a) n'

106+ let subst' = extend subst (name a) n'

107 (args', ty') <- convert' subst' ctorArgs ty info

108 return (CtorParameter a' :: args', ty')

libs/pruviloj/Pruviloj/Renamers.idr+5−2

@@ -6,6 +6,10 @@ import Language.Reflection.Utils

6Renamer : Type

7Renamer = TTName -> Maybe TTName

8

9+||| A renamer that renames nothing

10+noRenames : Renamer

11+noRenames = const Nothing

12+

9||| Cause a renamer to forget a renaming

13||| Cause a renamer to forget a renaming

10restrict : Renamer -> TTName -> Renamer

14restrict : Renamer -> TTName -> Renamer

11restrict f n n' = if n == n' then Nothing else f n'

15restrict f n n' = if n == n' then Nothing else f n'

@@ -19,7 +23,7 @@ extend f n n' n'' = if n'' == n then Just n' else f n''

19||| @ from the old name

23||| @ from the old name

20||| @ to the new name

24||| @ to the new name

21rename : (from, to : TTName) -> Renamer

25rename : (from, to : TTName) -> Renamer

22−rename from to = extend (const Nothing) from to

26+rename from to = extend noRenames from to

23

27

24||| Alpha-convert `Raw` terms

28||| Alpha-convert `Raw` terms

25||| @ subst a renamer

29||| @ subst a renamer

@@ -35,5 +39,4 @@ alphaRaw subst (RBind n b tm) =

35alphaRaw subst (RApp tm tm') = RApp (alphaRaw subst tm) (alphaRaw subst tm')

39alphaRaw subst (RApp tm tm') = RApp (alphaRaw subst tm) (alphaRaw subst tm')

36alphaRaw subst RType = RType

40alphaRaw subst RType = RType

37alphaRaw subst (RUType x) = RUType x

41alphaRaw subst (RUType x) = RUType x

38−alphaRaw subst (RForce tm) = RForce (alphaRaw subst tm)

39alphaRaw subst (RConstant c) = RConstant c

42alphaRaw subst (RConstant c) = RConstant c

libs/pruviloj/pruviloj.ipkg+3

@@ -3,8 +3,11 @@ package pruviloj

3opts = "--nobasepkgs -i ../prelude -i ../base"

4modules = Pruviloj

5 , Pruviloj.Core

6+ , Pruviloj.Derive.DecEq

6 , Pruviloj.Derive.Eliminators

7 , Pruviloj.Derive.Eliminators

8+ , Pruviloj.Disjoint

7 , Pruviloj.Induction

9 , Pruviloj.Induction

10+ , Pruviloj.Injective

8 , Pruviloj.Internals

11 , Pruviloj.Internals

9 , Pruviloj.Internals.TyConInfo

12 , Pruviloj.Internals.TyConInfo

10 , Pruviloj.Renamers

13 , Pruviloj.Renamers

main/Main.hs+6

@@ -45,6 +45,7 @@ main = do opts <- runArgParser

45runIdris :: [Opt] -> Idris ()

46runIdris opts = do

47 runIO setupBundledCC

48+ when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats

48 when (ShowIncs `elem` opts) $ runIO showIncs

49 when (ShowIncs `elem` opts) $ runIO showIncs

49 when (ShowLibs `elem` opts) $ runIO showLibs

50 when (ShowLibs `elem` opts) $ runIO showLibs

50 when (ShowLibdir `elem` opts) $ runIO showLibdir

51 when (ShowLibdir `elem` opts) $ runIO showLibdir

@@ -101,3 +102,8 @@ showIncs = do incFlags <- getIncFlags

101showPkgs :: IO b

102showPkgs :: IO b

102showPkgs = do mapM putStrLn =<< installedPackages

103showPkgs = do mapM putStrLn =<< installedPackages

103 exitWith ExitSuccess

104 exitWith ExitSuccess

105+

106+showLoggingCats :: IO b

107+showLoggingCats = do

108+ putStrLn loggingCatsStr

109+ exitWith ExitSuccess

rts/Makefile+4−3

@@ -1,7 +1,8 @@

1include ../config.mk

2

3OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \

4− idris_opts.o idris_stats.o idris_utf8.o mini-gmp.o getline.o

4+ idris_opts.o idris_stats.o idris_utf8.o idris_stdfgn.o mini-gmp.o \

5+ getline.o

5HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \

6HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \

6 idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h \

7 idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h \

7 idris_utf8.h getline.h

8 idris_utf8.h getline.h

@@ -19,10 +20,10 @@ endif

19endif

20endif

20

21

21ifeq ($(OS), windows)

22ifeq ($(OS), windows)

22− OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o

23+ OBJS += windows/idris_net.o windows/win_utils.o

23else

24else

24 CFLAGS += -fPIC

25 CFLAGS += -fPIC

25− OBJS += idris_stdfgn.o idris_net.o

26+ OBJS += idris_net.o

26endif

27endif

27

28

28LIBTARGET = libidris_rts.a

29LIBTARGET = libidris_rts.a

rts/idris_gmp.c+106

@@ -196,6 +196,88 @@ VAL bigMod(VM* vm, VAL x, VAL y) {

196 return cl;

197}

198

199+VAL bigAnd(VM* vm, VAL x, VAL y) {

200+ idris_requireAlloc(IDRIS_MAXGMP);

201+

202+ mpz_t* bigint;

203+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

204+ idris_doneAlloc();

205+ bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

206+ mpz_and(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

207+ SETTY(cl, BIGINT);

208+ cl -> info.ptr = (void*)bigint;

209+ return cl;

210+}

211+

212+VAL bigOr(VM* vm, VAL x, VAL y) {

213+ idris_requireAlloc(IDRIS_MAXGMP);

214+

215+ mpz_t* bigint;

216+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

217+ idris_doneAlloc();

218+ bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

219+ mpz_ior(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

220+ SETTY(cl, BIGINT);

221+ cl -> info.ptr = (void*)bigint;

222+ return cl;

223+}

224+

225+VAL bigShiftLeft(VM* vm, VAL x, VAL y) {

226+ idris_requireAlloc(IDRIS_MAXGMP);

227+

228+ mpz_t* bigint;

229+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

230+ idris_doneAlloc();

231+ bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

232+ mpz_mul_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

233+ SETTY(cl, BIGINT);

234+ cl -> info.ptr = (void*)bigint;

235+ return cl;

236+}

237+

238+

239+VAL bigLShiftRight(VM* vm, VAL x, VAL y) {

240+ idris_requireAlloc(IDRIS_MAXGMP);

241+

242+ mpz_t* bigint;

243+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

244+ idris_doneAlloc();

245+ bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

246+ mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

247+ SETTY(cl, BIGINT);

248+ cl -> info.ptr = (void*)bigint;

249+ return cl;

250+}

251+

252+VAL bigAShiftRight(VM* vm, VAL x, VAL y) {

253+ idris_requireAlloc(IDRIS_MAXGMP);

254+

255+ mpz_t* bigint;

256+ VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

257+ idris_doneAlloc();

258+ bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

259+ mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

260+ SETTY(cl, BIGINT);

261+ cl -> info.ptr = (void*)bigint;

262+ return cl;

263+}

264+

265+VAL idris_bigAnd(VM* vm, VAL x, VAL y) {

266+ if (ISINT(x) && ISINT(y)) {

267+ return INTOP(&, x, y);

268+ } else {

269+ return bigAnd(vm, GETBIG(vm, x), GETBIG(vm, y));

270+ }

271+}

272+

273+VAL idris_bigOr(VM* vm, VAL x, VAL y) {

274+ if (ISINT(x) && ISINT(y)) {

275+ return INTOP(|, x, y);

276+ } else {

277+ return bigOr(vm, GETBIG(vm, x), GETBIG(vm, y));

278+ }

279+}

280+

199VAL idris_bigPlus(VM* vm, VAL x, VAL y) {

281VAL idris_bigPlus(VM* vm, VAL x, VAL y) {

200 if (ISINT(x) && ISINT(y)) {

282 if (ISINT(x) && ISINT(y)) {

201 i_int vx = GETINT(x);

283 i_int vx = GETINT(x);

@@ -253,6 +335,30 @@ VAL idris_bigTimes(VM* vm, VAL x, VAL y) {

253 }

335 }

254}

336}

255

337

338+VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y) {

339+ if (ISINT(x) && ISINT(y)) {

340+ return INTOP(<<, x, y);

341+ } else {

342+ return bigShiftLeft(vm, GETBIG(vm, x), GETBIG(vm, y));

343+ }

344+}

345+

346+VAL idris_bigAShiftRight(VM* vm, VAL x, VAL y) {

347+ if (ISINT(x) && ISINT(y)) {

348+ return INTOP(>>, x, y);

349+ } else {

350+ return bigAShiftRight(vm, GETBIG(vm, x), GETBIG(vm, y));

351+ }

352+}

353+

354+VAL idris_bigLShiftRight(VM* vm, VAL x, VAL y) {

355+ if (ISINT(x) && ISINT(y)) {

356+ return INTOP(>>, x, y);

357+ } else {

358+ return bigLShiftRight(vm, GETBIG(vm, x), GETBIG(vm, y));

359+ }

360+}

361+

256VAL idris_bigDivide(VM* vm, VAL x, VAL y) {

362VAL idris_bigDivide(VM* vm, VAL x, VAL y) {

257 if (ISINT(x) && ISINT(y)) {

363 if (ISINT(x) && ISINT(y)) {

258 return INTOP(/, x, y);

364 return INTOP(/, x, y);

rts/idris_gmp.h+5

@@ -38,6 +38,11 @@ VAL idris_castBigFloat(VM* vm, VAL i);

38VAL idris_castStrBig(VM* vm, VAL i);

39VAL idris_castBigStr(VM* vm, VAL i);

40

41+VAL idris_bigAnd(VM* vm, VAL x, VAL y);

42+VAL idris_bigOr(VM* vm, VAL x, VAL y);

43+VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y);

44+VAL idris_bigShiftRight(VM* vm, VAL x, VAL y);

45+

41#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))

46#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))

42

47

43#endif

48#endif

rts/idris_heap.c+12−12

@@ -7,11 +7,11 @@

7

8

9/* Used for initializing the heap. */

10−void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

10+void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

11{

12− char * mem = malloc(heap_size);

12+ char * mem = malloc(heap_size);

13 if (mem == NULL) {

14− fprintf(stderr,

14+ fprintf(stderr,

15 "RTS ERROR: Unable to allocate heap. Requested %zd bytes.\n",

16 heap_size);

17 exit(EXIT_FAILURE);

@@ -37,8 +37,8 @@ void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

37void free_heap(Heap * h) {

38 free(h->heap);

39

40− if (h->old != NULL) {

40+ if (h->old != NULL) {

41− free(h->old);

41+ free(h->old);

42 }

43}

44

@@ -47,7 +47,7 @@ void free_heap(Heap * h) {

47/******************** Heap testing ********************************************/

48void heap_check_underflow(Heap * heap) {

49 if (!(heap->heap <= heap->next)) {

50− fprintf(stderr, "RTS ERROR: HEAP UNDERFLOW <bot %p> <cur %p>\n",

50+ fprintf(stderr, "RTS ERROR: HEAP UNDERFLOW <bot %p> <cur %p>\n",

51 heap->heap, heap->next);

52 exit(EXIT_FAILURE);

53 }

@@ -55,7 +55,7 @@ void heap_check_underflow(Heap * heap) {

55

56void heap_check_overflow(Heap * heap) {

57 if (!(heap->next <= heap->end)) {

58− fprintf(stderr, "RTS ERROR: HEAP OVERFLOW <cur %p> <end %p>\n",

58+ fprintf(stderr, "RTS ERROR: HEAP OVERFLOW <cur %p> <end %p>\n",

59 heap->next, heap->end);

60 exit(EXIT_FAILURE);

61 }

@@ -65,13 +65,13 @@ int is_valid_ref(VAL v) {

65 return (v != NULL) && !(ISINT(v));

66}

67

68−int ref_in_heap(Heap * heap, VAL v) {

68+int ref_in_heap(Heap * heap, VAL v) {

69 return ((VAL)heap->heap <= v) && (v < (VAL)heap->next);

70}

71

72// Checks three important properties:

73// 1. Closure.

74−// Check if all pointers in the _heap_ points only to heap.

74+// Check if all pointers in the _heap_ points only to heap.

75// 2. Unidirectionality. (if compact gc)

76// All references in the heap should be are unidirectional. In other words,

77// more recently allocated closure can point only to earlier allocated one.

@@ -79,7 +79,7 @@ int ref_in_heap(Heap * heap, VAL v) {

79//

80void heap_check_pointers(Heap * heap) {

81 char* scan = NULL;

82−

82+

83 size_t item_size = 0;

84 for(scan = heap->heap; scan < heap->next; scan += item_size) {

85 item_size = *((size_t*)scan);

@@ -96,7 +96,7 @@ void heap_check_pointers(Heap * heap) {

96 if (is_valid_ref(ptr)) {

97 // Check for closure.

98 if (!ref_in_heap(heap, ptr)) {

99− fprintf(stderr,

99+ fprintf(stderr,

100 "RTS ERROR: heap closure broken. "\

101 "<HEAP %p %p %p> <REF %p>\n",

102 heap->heap, heap->next, heap->end, ptr);

@@ -105,7 +105,7 @@ void heap_check_pointers(Heap * heap) {

105#if 0 // TODO macro

106 // Check for unidirectionality.

107 if (!(ptr < heap_item)) {

108− fprintf(stderr,

108+ fprintf(stderr,

109 "RTS ERROR: heap unidirectionality broken:" \

110 "<CON %p> <FIELD %p>\n",

111 heap_item, ptr);

rts/idris_heap.h+2−2

@@ -8,7 +8,7 @@ typedef struct {

8 char* heap; // Point to bottom of heap

9 char* end; // Point to top of heap

10 size_t size; // Size of _next_ heap. Size of current heap is /end - heap/.

11− size_t growth; // Quantity of heap growth in bytes.

11+ size_t growth; // Quantity of heap growth in bytes.

12

13 char* old;

14} Heap;

@@ -23,7 +23,7 @@ void heap_check_all(Heap * heap);

23// Should be used _between_ gc's.

24#define HEAP_CHECK(vm) heap_check_all(&(vm->heap));

25#else

26−#define HEAP_CHECK(vm)

26+#define HEAP_CHECK(vm)

27#endif // IDRIS_DEBUG

28

29#endif // _IDRIS_HEAP_H

rts/idris_main.c+1

@@ -21,6 +21,7 @@ int main(int argc, char* argv[]) {

21 init_gmpalloc();

22

23 init_nullaries();

24+ init_signals();

24

25

25 _idris__123_runMain0_125_(vm, NULL);

26 _idris__123_runMain0_125_(vm, NULL);

26

27

rts/idris_net.c+21−24

@@ -38,15 +38,15 @@ void idrnet_free(void* ptr) {

38}

39

40// We call this from quite a few functions. Given a textual host and an int port,

41−// populates a struct addrinfo.

41+// populates a struct addrinfo.

42−int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, int port,

42+int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, int port,

43 int family, int socket_type) {

44

45 struct addrinfo hints;

46 // Convert port into string

47 char str_port[8];

48 sprintf(str_port, "%d", port);

49−

49+

50 // Set up hints structure

51 memset(&hints, 0, sizeof(hints)); // zero out hints

52 hints.ai_family = family;

@@ -57,7 +57,7 @@ int idrnet_getaddrinfo(struct addrinfo** address_res, char* host, int port,

57 if (strlen(host) == 0) {

58 hints.ai_flags = AI_PASSIVE; // fill in IP automatically

59 return getaddrinfo(NULL, str_port, &hints, address_res);

60− }

60+ }

61 return getaddrinfo(host, str_port, &hints, address_res);

62

63}

@@ -75,7 +75,7 @@ int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {

75 //freeaddrinfo(address_res);

76 //printf("Lib err: bind\n");

77 return -1;

78− }

78+ }

79 return 0;

80}

81

@@ -111,7 +111,7 @@ char* idrnet_sockaddr_ipv4(void* sockaddr) {

111

112int idrnet_sockaddr_ipv4_port(void* sockaddr) {

113 struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;

114− return ((int) ntohs(addr->sin_port));

114+ return ((int) ntohs(addr->sin_port));

115}

116

117void* idrnet_create_sockaddr() {

@@ -141,13 +141,13 @@ int idrnet_send_buf(int sockfd, void* data, int len) {

141}

142

143void* idrnet_recv(int sockfd, int len) {

144− idrnet_recv_result* res_struct =

144+ idrnet_recv_result* res_struct =

145 (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));

146 char* buf = malloc(len + 1);

147 memset(buf, 0, len + 1);

148 int recv_res = recv(sockfd, buf, len, 0);

149 res_struct->result = recv_res;

150−

150+

151 if (recv_res > 0) { // Data was received

152 buf[recv_res + 1] = 0x00; // Null-term, so Idris can interpret it

153 }

@@ -172,7 +172,7 @@ char* idrnet_get_recv_payload(void* res_struct) {

172}

173

174void idrnet_free_recv_struct(void* res_struct) {

175− idrnet_recv_result* i_res_struct =

175+ idrnet_recv_result* i_res_struct =

176 (idrnet_recv_result*) res_struct;

177 if (i_res_struct->payload != NULL) {

178 free(i_res_struct->payload);

@@ -191,9 +191,9 @@ int idrnet_sendto(int sockfd, char* data, char* host, int port, int family) {

191 int addr_res = idrnet_getaddrinfo(&remote_host, host, port, family, SOCK_DGRAM);

192 if (addr_res == -1) {

193 return -1;

194− }

194+ }

195

196− int send_res = sendto(sockfd, data, strlen(data), 0,

196+ int send_res = sendto(sockfd, data, strlen(data), 0,

197 remote_host->ai_addr, remote_host->ai_addrlen);

198 freeaddrinfo(remote_host);

199 return send_res;

@@ -206,11 +206,11 @@ int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port,

206 if (addr_res == -1) {

207 //printf("lib err: sendto getaddrinfo \n");

208 return -1;

209− }

209+ }

210

211 buf_htonl(buf, buf_len);

212

213− int send_res = sendto(sockfd, buf, buf_len, 0,

213+ int send_res = sendto(sockfd, buf, buf_len, 0,

214 remote_host->ai_addr, remote_host->ai_addrlen);

215 if (send_res == -1) {

216 perror("lib err: sendto \n");

@@ -224,13 +224,13 @@ int idrnet_sendto_buf(int sockfd, void* buf, int buf_len, char* host, int port,

224void* idrnet_recvfrom(int sockfd, int len) {

225/*

226 * int recvfrom(int sockfd, void *buf, int len, unsigned int flags,

227− struct sockaddr *from, int *fromlen);

227+ struct sockaddr *from, int *fromlen);

228*/

229 // Allocate the required structures, and nuke them

230− struct sockaddr_storage* remote_addr =

230+ struct sockaddr_storage* remote_addr =

231 (struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));

232 char* buf = (char*) malloc(len + 1);

233− idrnet_recvfrom_result* ret =

233+ idrnet_recvfrom_result* ret =

234 (idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));

235 memset(remote_addr, 0, sizeof(struct sockaddr_storage));

236 memset(buf, 0, len + 1);

@@ -240,7 +240,7 @@ void* idrnet_recvfrom(int sockfd, int len) {

240 int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);

241 ret->result = recv_res;

242 // Check for failure...

243− if (recv_res == -1) {

243+ if (recv_res == -1) {

244 free(buf);

245 free(remote_addr);

246 } else {

@@ -255,12 +255,11 @@ void* idrnet_recvfrom(int sockfd, int len) {

255 return ret;

256}

257

258−

259void* idrnet_recvfrom_buf(int sockfd, void* buf, int len) {

258void* idrnet_recvfrom_buf(int sockfd, void* buf, int len) {

260 // Allocate the required structures, and nuke them

259 // Allocate the required structures, and nuke them

261− struct sockaddr_storage* remote_addr =

260+ struct sockaddr_storage* remote_addr =

262 (struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));

261 (struct sockaddr_storage*) malloc(sizeof(struct sockaddr_storage));

263− idrnet_recvfrom_result* ret =

262+ idrnet_recvfrom_result* ret =

264 (idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));

263 (idrnet_recvfrom_result*) malloc(sizeof(idrnet_recvfrom_result));

265 memset(remote_addr, 0, sizeof(struct sockaddr_storage));

264 memset(remote_addr, 0, sizeof(struct sockaddr_storage));

266 memset(ret, 0, sizeof(idrnet_recvfrom_result));

265 memset(ret, 0, sizeof(idrnet_recvfrom_result));

@@ -269,7 +268,7 @@ void* idrnet_recvfrom_buf(int sockfd, void* buf, int len) {

269 int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);

268 int recv_res = recvfrom(sockfd, buf, len, 0, (struct sockaddr*) remote_addr, &fromlen);

270 // Check for failure... But don't free the buffer! Not our job.

269 // Check for failure... But don't free the buffer! Not our job.

271 ret->result = recv_res;

270 ret->result = recv_res;

272− if (recv_res == -1) {

271+ if (recv_res == -1) {

273 free(remote_addr);

272 free(remote_addr);

274 }

273 }

275 // Payload will be NULL -- since it's been put into the user-specified buffer. We

274 // Payload will be NULL -- since it's been put into the user-specified buffer. We

@@ -298,7 +297,7 @@ void* idrnet_get_recvfrom_sockaddr(void* res_struct) {

298int idrnet_get_recvfrom_port(void* res_struct) {

297int idrnet_get_recvfrom_port(void* res_struct) {

299 idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;

298 idrnet_recvfrom_result* recv_struct = (idrnet_recvfrom_result*) res_struct;

300 if (recv_struct->remote_addr != NULL) {

299 if (recv_struct->remote_addr != NULL) {

301− struct sockaddr_in* remote_addr_in =

300+ struct sockaddr_in* remote_addr_in =

302 (struct sockaddr_in*) recv_struct->remote_addr;

301 (struct sockaddr_in*) recv_struct->remote_addr;

303 return ((int) ntohs(remote_addr_in->sin_port));

302 return ((int) ntohs(remote_addr_in->sin_port));

304 }

303 }

@@ -316,5 +315,3 @@ void idrnet_free_recvfrom_struct(void* res_struct) {

316 }

315 }

317 }

316 }

318}

317}

319−

320−

rts/idris_rts.c+16

@@ -1,4 +1,5 @@

1#include <assert.h>

2+#include <errno.h>

2

3

3#include "idris_rts.h"

4#include "idris_rts.h"

4#include "idris_gc.h"

5#include "idris_gc.h"

@@ -72,6 +73,7 @@ VM* idris_vm() {

72 init_threaddata(vm);

73 init_threaddata(vm);

73 init_gmpalloc();

74 init_gmpalloc();

74 init_nullaries();

75 init_nullaries();

76+ init_signals();

75

77

76 return vm;

78 return vm;

77}

79}

@@ -92,6 +94,12 @@ void init_threaddata(VM *vm) {

92#endif

94#endif

93}

95}

94

96

97+void init_signals() {

98+#if (__linux__ || __APPLE__ || __FreeBSD__)

99+ signal(SIGPIPE, SIG_IGN);

100+#endif

101+}

102+

95Stats terminate(VM* vm) {

103Stats terminate(VM* vm) {

96 Stats stats = vm->stats;

104 Stats stats = vm->stats;

97 STATS_ENTER_EXIT(stats)

105 STATS_ENTER_EXIT(stats)

@@ -927,6 +935,14 @@ void idris_freeMsg(Msg* msg) {

927 free(msg);

935 free(msg);

928}

936}

929

937

938+int idris_errno() {

939+ return errno;

940+}

941+

942+char* idris_showerror(int err) {

943+ return strerror(err);

944+}

945+

930VAL* nullary_cons;

946VAL* nullary_cons;

931

947

932void init_nullaries() {

948void init_nullaries() {

rts/idris_rts.h+8

@@ -9,6 +9,9 @@

9#include <pthread.h>

10#endif

11#include <stdint.h>

12+#if (__linux__ || __APPLE__ || __FreeBSD__)

13+#include <signal.h>

14+#endif

12

15

13#include "idris_heap.h"

16#include "idris_heap.h"

14#include "idris_stats.h"

17#include "idris_stats.h"

@@ -252,10 +255,15 @@ void idris_free(void* ptr, size_t size);

252

255

253#define NULL_CON(x) nullary_cons[x]

256#define NULL_CON(x) nullary_cons[x]

254

257

258+int idris_errno();

259+char* idris_showerror(int err);

260+

255extern VAL* nullary_cons;

261extern VAL* nullary_cons;

256void init_nullaries();

262void init_nullaries();

257void free_nullaries();

263void free_nullaries();

258

264

265+void init_signals();

266+

259void* vmThread(VM* callvm, func f, VAL arg);

267void* vmThread(VM* callvm, func f, VAL arg);

260

268

261// Copy a structure to another vm's heap

269// Copy a structure to another vm's heap

rts/idris_stdfgn.c+36−6

@@ -2,11 +2,18 @@

2#include "idris_rts.h"

3#include "idris_gmp.h"

4#include "idris_gc.h"

5−#include <sys/select.h>

5+

6#include <fcntl.h>

7+#include <errno.h>

7#include <stdio.h>

8#include <stdio.h>

8#include <time.h>

9#include <time.h>

9

10

11+#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)

12+int win_fpoll(void* h);

13+#else

14+#include <sys/select.h>

15+#endif

16+

10extern char** environ;

17extern char** environ;

11

18

12void putStr(char* str) {

19void putStr(char* str) {

@@ -24,13 +31,13 @@ void fileClose(void* h) {

24}

31}

25

32

26int fileEOF(void* h) {

33int fileEOF(void* h) {

27− FILE* f = (FILE*)h;

34+ FILE* f = (FILE*)h;

28− return feof(f);

35+ return feof(f);

29}

36}

30

37

31int fileError(void* h) {

38int fileError(void* h) {

32− FILE* f = (FILE*)h;

39+ FILE* f = (FILE*)h;

33− return ferror(f);

40+ return ferror(f);

34}

41}

35

42

36int idris_writeStr(void* h, char* str) {

43int idris_writeStr(void* h, char* str) {

@@ -44,6 +51,9 @@ int idris_writeStr(void* h, char* str) {

44

51

45int fpoll(void* h)

52int fpoll(void* h)

46{

53{

54+#if defined(WIN32) || defined(__WIN32) || defined(__WIN32__)

55+ return win_fpoll(h);

56+#else

47 FILE* f = (FILE*)h;

57 FILE* f = (FILE*)h;

48 fd_set x;

58 fd_set x;

49 struct timeval timeout;

59 struct timeval timeout;

@@ -56,6 +66,7 @@ int fpoll(void* h)

56

66

57 int r = select(fd+1, &x, 0, 0, &timeout);

67 int r = select(fd+1, &x, 0, 0, &timeout);

58 return r;

68 return r;

69+#endif

59}

70}

60

71

61void* do_popen(const char* cmd, const char* mode) {

72void* do_popen(const char* cmd, const char* mode) {

@@ -86,6 +97,25 @@ VAL idris_time() {

86 return MKBIGI(t);

97 return MKBIGI(t);

87}

98}

88

99

100+VAL idris_mkFileError(VM* vm) {

101+ VAL result;

102+ switch(errno) {

103+ // Make sure this corresponds to the FileError structure in

104+ // Prelude.File

105+ case ENOENT:

106+ idris_constructor(result, vm, 2, 0, 0);

107+ break;

108+ case EACCES:

109+ idris_constructor(result, vm, 3, 0, 0);

110+ break;

111+ default:

112+ idris_constructor(result, vm, 4, 1, 0);

113+ idris_setConArg(result, 0, MKINT((intptr_t)errno));

114+ break;

115+ }

116+ return result;

117+}

118+

89void idris_forceGC(void* vm) {

119void idris_forceGC(void* vm) {

90− idris_gc((VM*)vm);

120+ idris_gc((VM*)vm);

91}

121}

rts/idris_stdfgn.h+2

@@ -14,6 +14,8 @@ int fileEOF(void* h);

14int fileError(void* h);

15// return 0 on success

16int idris_writeStr(void*h, char* str);

17+// construct a file error structure (see Prelude.File) from errno

18+VAL idris_mkFileError(VM* vm);

17

19

18void* do_popen(const char* cmd, const char* mode);

20void* do_popen(const char* cmd, const char* mode);

19int fpoll(void* h);

21int fpoll(void* h);

rts/windows/idris_net.c+6−7

@@ -12,7 +12,7 @@

12#include <Ws2tcpip.h>

13

14

15−// inet_ntop isn't defined in the old mingw delivered with GHC,

15+// inet_ntop isn't defined in the old mingw delivered with GHC,

16// so put the prototype here, cribbed from a newer version of it

17WINSOCK_API_LINKAGE LPCSTR WSAAPI InetNtopA(INT Family, PVOID pAddr,

18 LPSTR pStringBuf, size_t StringBufSize);

@@ -50,7 +50,7 @@ int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {

50 // Convert port into string

51 char str_port[8];

52 sprintf(str_port, "%d", port);

53−

53+

54 if (!check_init()) {

55 return -1;

56 }

@@ -73,7 +73,7 @@ int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port) {

73 int bind_res = bind(sockfd, address_res->ai_addr, address_res->ai_addrlen);

74 if (bind_res == -1) {

75 return -1;

76− }

76+ }

77

78 return 0;

79}

@@ -152,13 +152,13 @@ void* idrnet_recv(int sockfd, int len) {

152 if (!check_init()) {

153 return NULL;

154 }

155− idrnet_recv_result* res_struct =

155+ idrnet_recv_result* res_struct =

156 (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));

157

158 char* buf = malloc(len + 1);

159 int recv_res = recv(sockfd, buf, len, 0);

160 res_struct->result = recv_res;

161−

161+

162 if (recv_res > 0) { // Data was received

163 buf[recv_res + 1] = 0x00; // Null-term, so Idris can interpret it

164 }

@@ -182,7 +182,7 @@ char* idrnet_get_recv_payload(void* res_struct) {

182}

183

184void idrnet_free_recv_struct(void* res_struct) {

185− idrnet_recv_result* i_res_struct =

185+ idrnet_recv_result* i_res_struct =

186 (idrnet_recv_result*) res_struct;

187 if (i_res_struct->payload != NULL) {

188 free(i_res_struct->payload);

@@ -193,4 +193,3 @@ void idrnet_free_recv_struct(void* res_struct) {

193int idrnet_errno() {

194 return errno;

195}

196−

rts/windows/idris_stdfgn.cdeleted−82

@@ -1,82 +0,0 @@

1−#include "../idris_stdfgn.h"

2−#include "../idris_rts.h"

3−#include "../idris_gc.h"

4−

5−#include <fcntl.h>

6−#include <stdio.h>

7−#include <time.h>

8−#include <io.h>

9−

10−extern char** environ;

11−

12−int win_fpoll(void* h);

13−

14−void putStr(char* str) {

15− printf("%s", str);

16−}

17−

18−void* fileOpen(char* name, char* mode) {

19− FILE* f = fopen(name, mode);

20− return (void*)f;

21−}

22−

23−void fileClose(void* h) {

24− FILE* f = (FILE*)h;

25− fclose(f);

26−}

27−

28−int fileEOF(void* h) {

29− FILE* f = (FILE*)h;

30− return feof(f);

31−}

32−

33−int fileError(void* h) {

34− FILE* f = (FILE*)h;

35− return ferror(f);

36−}

37−

38−int idris_writeStr(void* h, char* str) {

39− FILE* f = (FILE*)h;

40− if (fputs(str, f)) {

41− return 0;

42− } else {

43− return -1;

44− }

45−}

46−

47−int fpoll(void* h)

48−{

49− return win_fpoll(h);

50−}

51−

52−void* do_popen(const char* cmd, const char* mode) {

53− FILE* f = _popen(cmd, mode);

54−// int d = fileno(f);

55−// fcntl(d, F_SETFL, O_NONBLOCK);

56− return f;

57−}

58−

59−int isNull(void* ptr) {

60− return ptr==NULL;

61−}

62−

63−int idris_eqPtr(void* x, void* y) {

64− return x==y;

65−}

66−

67−void* idris_stdin() {

68− return (void*)stdin;

69−}

70−

71−char* getEnvPair(int i) {

72− return *(environ + i);

73−}

74−

75−VAL idris_time() {

76− time_t t = time(NULL);

77− return MKBIGI(t);

78−}

79−

80−void idris_forceGC(void* vm) {

81− idris_gc((VM*)vm);

82−}

src/IRTS/CodegenC.hs+8−3

@@ -66,7 +66,7 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

66 MavenProject -> putStrLn ("FAILURE: output type not supported")

67 Raw -> writeSource out cout

68 _ -> do

69− (tmpn, tmph) <- tempfile

69+ (tmpn, tmph) <- tempfile ".c"

70 hPutStr tmph cout

71 hFlush tmph

72 hClose tmph

@@ -78,7 +78,7 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

78 gccFlags iface ++

79 -- # Any flags defined here which alter the RTS API must also be added to config.mk

80 ["-DHAS_PTHREAD", "-DIDRIS_ENABLE_STATS",

81− "-I."] ++ objs ++ ["-x", "c"] ++ envFlags ++

81+ "-I."] ++ objs ++ envFlags ++

82 (if (exec == Executable) then [] else ["-c"]) ++

83 [tmpn] ++

84 (if not iface then concatMap words libFlags else []) ++

@@ -95,7 +95,7 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

95

96headers xs =

97 concatMap

98− (\h -> "#include <" ++ h ++ ">\n")

98+ (\h -> "#include \"" ++ h ++ "\"\n")

99 (xs ++ ["idris_rts.h", "idris_bitstring.h", "idris_stdfgn.h"])

100

101debug TRACE = "#define IDRIS_TRACE\n\n"

@@ -444,6 +444,11 @@ doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ "

444doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

445doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

446doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

447+doOp v (LAnd ITBig) [l, r] = v ++ "idris_bigAnd(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

448+doOp v (LOr ITBig) [l, r] = v ++ "idris_bigOr(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

449+doOp v (LSHL ITBig) [l, r] = v ++ "idris_bigShiftLeft(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

450+doOp v (LLSHR ITBig) [l, r] = v ++ "idris_bigLShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

451+doOp v (LASHR ITBig) [l, r] = v ++ "idris_bigAShiftRight(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

447doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

452doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

448doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

453doOp v (LSLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

449doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

454doOp v (LSLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

src/IRTS/CodegenJavaScript.hs+1−2

@@ -604,7 +604,7 @@ jsBASETOP _ 0 = JSAssign jsSTACKBASE jsSTACKTOP

604jsBASETOP _ n = JSAssign jsSTACKBASE (JSBinOp "+" jsSTACKTOP (JSNum (JSInt n)))

605

606jsNULL :: CompileInfo -> Reg -> JS

607−jsNULL _ r = JSDelete (translateReg r)

607+jsNULL _ r = JSClear (translateReg r)

608

609jsERROR :: CompileInfo -> String -> JS

610jsERROR _ = JSError

@@ -1277,4 +1277,3 @@ toFType (FApp c [_,ity])

1277toFType (FApp c [_,fty])

1278 | c == sUN "JS_FnT" = toFnType fty

1279toFType t = error (show t ++ " not yet defined in toFType")

1280−

src/IRTS/Compiler.hs+20−20

@@ -54,12 +54,12 @@ compile codegen f mtm

54 Nothing -> []

55 Just t -> freeNames t

56

57− reachableNames <- performUsageAnalysis

57+ reachableNames <- performUsageAnalysis

58 (rootNames ++ getExpNames exports)

59 maindef <- case mtm of

60 Nothing -> return []

61 Just tm -> do md <- irMain tm

62− logLvl 1 $ "MAIN: " ++ show md

62+ logCodeGen 1 $ "MAIN: " ++ show md

63 return [(sMN 0 "runMain", md)]

64 objs <- getObjectFiles codegen

65 libs <- getLibs codegen

@@ -82,13 +82,13 @@ compile codegen f mtm

82 let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)

83 let ctxtIn = addAlist tagged emptyContext

84

85− logLvl 1 "Defunctionalising"

85+ logCodeGen 1 "Defunctionalising"

86 let defuns_in = defunctionalise nexttag ctxtIn

87− logLvl 5 $ show defuns_in

87+ logCodeGen 5 $ show defuns_in

88− logLvl 1 "Inlining"

88+ logCodeGen 1 "Inlining"

89 let defuns = inline defuns_in

90− logLvl 5 $ show defuns

90+ logCodeGen 5 $ show defuns

91− logLvl 1 "Resolving variables for CG"

91+ logCodeGen 1 "Resolving variables for CG"

92

93 let checked = simplifyDefs defuns (toAlist defuns)

94 outty <- outputTy

@@ -102,7 +102,7 @@ compile codegen f mtm

102 Just f -> runIO $ writeFile f (dumpDefuns defuns)

103 triple <- Idris.AbsSyntax.targetTriple

104 cpu <- Idris.AbsSyntax.targetCPU

105− logLvl 1 "Building output"

105+ logCodeGen 1 "Building output"

106 case checked of

107 OK c -> do return $ CodegenInfo f outty triple cpu

108 hdrs impdirs objs libs flags

@@ -167,7 +167,7 @@ showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)

167 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args

168 snRank (ParentN n s) = "3" ++ nameRank n ++ show s

169 snRank (MethodN n) = "4" ++ nameRank n

170− snRank (CaseN n) = "5" ++ nameRank n

170+ snRank (CaseN _ n) = "5" ++ nameRank n

171 snRank (ElimN n) = "6" ++ nameRank n

172 snRank (InstanceCtorN n) = "7" ++ nameRank n

173 snRank (WithN i n) = "8" ++ nameRank n ++ show i

@@ -184,10 +184,10 @@ build (n, d)

184 return (n, (LFun [] n (take ar args)

185 (LOp op (map (LV . Glob) (take ar args)))))

186 _ -> do def <- mkLDecl n d

187− logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

187+ logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

188 return (n, def)

189− where getPrim n i

189+ where getPrim n i

190− | Just (ar, op) <- lookup n (idris_scprims i)

190+ | Just (ar, op) <- lookup n (idris_scprims i)

191 = Just (ar, op)

192 | Just ar <- lookup n (S.toList (idris_externs i))

193 = Just (ar, LExternal n)

@@ -205,7 +205,7 @@ mkLDecl n (CaseOp ci _ _ _ pats cd)

205 (args, sc) = cases_runtime cd

206

207 -- Always attempt to inline functions arising from 'case' expressions

208− caseName (SN (CaseN _)) = True

208+ caseName (SN (CaseN _ _)) = True

209 caseName (SN (WithN _ _)) = True

210 caseName (NS n _) = caseName n

211 caseName _ = False

@@ -224,7 +224,7 @@ data VarInfo = VI

224type Vars = M.Map Name VarInfo

225

226irTerm :: Vars -> [Name] -> Term -> Idris LExp

227−irTerm vs env tm@(App _ f a) = do

227+irTerm vs env tm@(App _ f a) = do

228 ist <- getIState

229 case unApply tm of

230 (P _ (UN m) _, args)

@@ -454,19 +454,19 @@ irTerm vs env Impossible = return $ LNothing

454doForeign :: Vars -> [Name] -> [Term] -> Idris LExp

455doForeign vs env (ret : fname : world : args)

456 = do args' <- mapM splitArg args

457− let fname' = toFDesc fname

457+ let fname' = toFDesc fname

458 let ret' = toFDesc ret

459 return $ LForeign ret' fname' args'

460 where

461 splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits

462− = do let l' = toFDesc l

462+ = do let l' = toFDesc l

463 r' <- irTerm vs env r

464 return (l', r')

465 splitArg _ = ifail "Badly formed foreign function call"

466

467− toFDesc (Constant (Str str)) = FStr str

467+ toFDesc (Constant (Str str)) = FStr str

468− toFDesc tm

468+ toFDesc tm

469− | (P _ n _, []) <- unApply tm = FCon (deNS n)

469+ | (P _ n _, []) <- unApply tm = FCon (deNS n)

470 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)

471 toFDesc _ = FUnknown

472

@@ -476,7 +476,7 @@ doForeign vs env xs = ifail "Badly formed foreign function call"

476

477irTree :: [Name] -> SC -> Idris LExp

478irTree args tree = do

479− logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

479+ logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

480 LLam args <$> irSC M.empty tree

481

482irSC :: Vars -> SC -> Idris LExp

src/IRTS/Exports.hs+8−11

@@ -13,7 +13,7 @@ import Data.Maybe

13findExports :: Idris [ExportIFace]

14findExports = do exps <- getExports

15 es <- mapM toIFace exps

16− logLvl 2 $ "Exporting " ++ show es

16+ logCodeGen 2 $ "Exporting " ++ show es

17 return es

18

19getExpNames :: [ExportIFace] -> [Name]

@@ -39,7 +39,7 @@ toIFace n = do i <- getIState

39 getExpList _ = ifail "Badly formed export list"

40

41toIFaceTyVal :: Type -> Term -> Idris ExportIFace

42−toIFaceTyVal ty tm

42+toIFaceTyVal ty tm

43 | (P _ exp _, [P _ ffi _, Constant (Str hdr), _]) <- unApply ty

44 = do tm' <- toIFaceVal tm

45 return $ Export ffi hdr tm'

@@ -51,7 +51,7 @@ toIFaceVal tm

51 | (P _ fun _, [_,_,_,_,(P _ fn _),extnm,prf,rest]) <- unApply tm,

52 fun == sNS (sUN "Fun") ["FFI_Export"]

53 = do rest' <- toIFaceVal rest

54− return $

54+ return $

55 ExportFun fn (toFDesc extnm) (toFDescRet prf) (toFDescArgs prf)

56 : rest'

57 | (P _ dat _, [_,_,_,_,d,rest]) <- unApply tm,

@@ -63,7 +63,7 @@ toIFaceVal tm

63toFDesc :: Term -> FDesc

64toFDesc (Constant (Str str)) = FStr str

65toFDesc tm

66− | (P _ n _, []) <- unApply tm = FCon (deNS n)

66+ | (P _ n _, []) <- unApply tm = FCon (deNS n)

67 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)

68toFDesc _ = FUnknown

69

@@ -91,20 +91,17 @@ toFDescBase tm

91 | otherwise = error "Badly formed export type"

92

93toFDescArgs :: Term -> [FDesc]

94−toFDescArgs tm

94+toFDescArgs tm

95 | (P _ fun _, [_,_,_,_,b,t]) <- unApply tm,

96 fun == sNS (sUN "FFI_Fun") ["FFI_Export"]

97 = toFDescBase b : toFDescArgs t

98 | otherwise = []

99

100−toFDescPrim (Constant (Str str)) = FStr str

100+toFDescPrim (Constant (Str str)) = FStr str

101−toFDescPrim tm

101+toFDescPrim tm

102− | (P _ n _, []) <- unApply tm = FCon (deNS n)

102+ | (P _ n _, []) <- unApply tm = FCon (deNS n)

103 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDescPrim as)

104toFDescPrim _ = FUnknown

105

106deNS (NS n _) = n

107deNS n = n

108−

109−

110−

src/IRTS/JavaScript/AST.hs+4−1

@@ -77,6 +77,7 @@ data JS = JSRaw String

77 | JSFFI String [JS]

78 | JSAnnotation JSAnnotation JS

79 | JSDelete JS

80+ | JSClear JS

80 | JSNoop

81 | JSNoop

81 deriving Eq

82 deriving Eq

82

83

@@ -133,6 +134,9 @@ compileJS' indent (JSAnnotation annotation js) =

133compileJS' indent (JSDelete js) =

134compileJS' indent (JSDelete js) =

134 "delete " `T.append` compileJS' 0 js

135 "delete " `T.append` compileJS' 0 js

135

136

137+compileJS' indent (JSClear js) =

138+ compileJS' 0 js `T.append` " = undefined"

139+

136compileJS' indent (JSFFI raw args) =

140compileJS' indent (JSFFI raw args) =

137 ffi raw (map (T.unpack . compileJS' indent) args)

141 ffi raw (map (T.unpack . compileJS' indent) args)

138

142

@@ -398,4 +402,3 @@ jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]

398

402

399jsPackSBits32 :: JS -> JS

403jsPackSBits32 :: JS -> JS

400jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]

404jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]

401−

src/Idris/AbsSyntax.hs+85−19

@@ -346,6 +346,14 @@ getNameHints i n =

346addToCalledG :: Name -> [Name] -> Idris ()

347addToCalledG n ns = return () -- TODO

348

349+addDeprecated :: Name -> String -> Idris ()

350+addDeprecated n reason = do i <- getIState

351+ putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

352+

353+getDeprecated :: Name -> Idris (Maybe String)

354+getDeprecated n = do i <- getIState

355+ return $ lookupCtxtExact n (idris_deprecated i)

356+

349push_estack :: Name -> Bool -> Idris ()

357push_estack :: Name -> Bool -> Idris ()

350push_estack n inst

358push_estack n inst

351 = do i <- getIState

359 = do i <- getIState

@@ -691,6 +699,13 @@ setLogLevel l = do i <- getIState

691 let opt' = opts { opt_logLevel = l }

699 let opt' = opts { opt_logLevel = l }

692 putIState $ i { idris_options = opt' }

700 putIState $ i { idris_options = opt' }

693

701

702+setLogCats :: [LogCat] -> Idris ()

703+setLogCats cs = do

704+ i <- getIState

705+ let opts = idris_options i

706+ let opt' = opts { opt_logcats = cs }

707+ putIState $ i { idris_options = opt' }

708+

694setCmdLine :: [Opt] -> Idris ()

709setCmdLine :: [Opt] -> Idris ()

695setCmdLine opts = do i <- getIState

710setCmdLine opts = do i <- getIState

696 let iopts = idris_options i

711 let iopts = idris_options i

@@ -961,15 +976,55 @@ setColour ct c = do i <- getIState

961 setColour' PromptColour c t = t { promptColour = c }

976 setColour' PromptColour c t = t { promptColour = c }

962 setColour' PostulateColour c t = t { postulateColour = c }

977 setColour' PostulateColour c t = t { postulateColour = c }

963

978

979+

964logLvl :: Int -> String -> Idris ()

980logLvl :: Int -> String -> Idris ()

981+logLvl = logLvlCats []

982+

983+logCoverage :: Int -> String -> Idris ()

984+logCoverage = logLvlCats [ICoverage]

985+

986+logErasure :: Int -> String -> Idris ()

987+logErasure = logLvlCats [IErasure]

988+

989+-- | Log an action of the parser

990+logParser :: Int -> String -> Idris ()

991+logParser = logLvlCats parserCats

992+

993+-- | Log an action of the elaborator.

994+logElab :: Int -> String -> Idris ()

995+logElab = logLvlCats elabCats

996+

997+-- | Log an action of the compiler.

998+logCodeGen :: Int -> String -> Idris ()

999+logCodeGen = logLvlCats codegenCats

1000+

1001+logIBC :: Int -> String -> Idris ()

1002+logIBC = logLvlCats [IIBC]

1003+

1004+-- | Log aspect of Idris execution

1005+--

1006+-- An empty set of logging levels is used to denote all categories.

1007+--

1008+-- @TODO update IDE protocol

1009+logLvlCats :: [LogCat] -- ^ The categories that the message should appear under.

1010+ -> Int -- ^ The Logging level the message should appear.

1011+ -> String -- ^ The message to show the developer.

1012+ -> Idris ()

1013+logLvlCats cs l str = do

965−logLvl l str = do i <- getIState

1014+ i <- getIState

966− let lvl = opt_logLevel (idris_options i)

1015+ let lvl = opt_logLevel (idris_options i)

1016+ let cats = opt_logcats (idris_options i)

967− when (lvl >= l) $

1017+ when (lvl >= l) $

1018+ when (inCat cs cats || null cats) $

968− case idris_outputmode i of

1019+ case idris_outputmode i of

1020+ RawOutput h -> do

969− RawOutput h -> do runIO $ hPutStrLn h str

1021+ runIO $ hPutStrLn h str

970− IdeMode n h ->

1022+ IdeMode n h -> do

971− do let good = SexpList [IntegerAtom (toInteger l), toSExp str]

1023+ let good = SexpList [IntegerAtom (toInteger l), toSExp str]

972− runIO . hPutStrLn h $ convSExp "log" good n

1024+ runIO . hPutStrLn h $ convSExp "log" good n

1025+ where

1026+ inCat :: [LogCat] -> [LogCat] -> Bool

1027+ inCat cs cats = or $ map (\x -> elem x cats) cs

973

1028

974cmdOptType :: Opt -> Idris Bool

1029cmdOptType :: Opt -> Idris Bool

975cmdOptType x = do i <- getIState

1030cmdOptType x = do i <- getIState

@@ -1344,7 +1399,7 @@ addUsingImpls syn n fc t

1344 let badnames = filter (\n -> not (implicitable n) &&

1399 let badnames = filter (\n -> not (implicitable n) &&

1345 n `notElem` (map iname uimpls)) ns

1400 n `notElem` (map iname uimpls)) ns

1346 when (not (null badnames)) $

1401 when (not (null badnames)) $

1347− throwError (At fc (Elaborating "type of " n

1402+ throwError (At fc (Elaborating "type of " n Nothing

1348 (NoSuchVariable (head badnames))))

1403 (NoSuchVariable (head badnames))))

1349 let cs = getArgnames t -- get already bound names

1404 let cs = getArgnames t -- get already bound names

1350 let addimpls = filter (\n -> iname n `notElem` cs) uimpls

1405 let addimpls = filter (\n -> iname n `notElem` cs) uimpls

@@ -1385,7 +1440,11 @@ getUnboundImplicits i t tm = getImps t (collectImps tm)

1385 = (n, (p, t)) : collectImps sc

1440 = (n, (p, t)) : collectImps sc

1386 collectImps _ = []

1441 collectImps _ = []

1387

1442

1443+ scopedimpl (Just i) = not (toplevel_imp i)

1444+ scopedimpl _ = False

1445+

1388− getImps (Bind n (Pi (Just _) _ _) sc) imps = getImps sc imps

1446+ getImps (Bind n (Pi i _ _) sc) imps

1447+ | scopedimpl i = getImps sc imps

1389 getImps (Bind n (Pi _ t _) sc) imps

1448 getImps (Bind n (Pi _ t _) sc) imps

1390 | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps

1449 | Just (p, t') <- lookup n imps = argInfo n p t' : getImps sc imps

1391 where

1450 where

@@ -1548,9 +1607,9 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1548 pibind using [] sc = sc

1607 pibind using [] sc = sc

1549 pibind using (n:ns) sc

1608 pibind using (n:ns) sc

1550 = case lookup n using of

1609 = case lookup n using of

1551− Just ty -> PPi (Imp [] Dynamic False Nothing)

1610+ Just ty -> PPi (Imp [] Dynamic False (Just (Impl False True)))

1552 n NoFC ty (pibind using ns sc)

1611 n NoFC ty (pibind using ns sc)

1553− Nothing -> PPi (Imp [InaccessibleArg] Dynamic False Nothing)

1612+ Nothing -> PPi (Imp [InaccessibleArg] Dynamic False (Just (Impl False True)))

1554 n NoFC Placeholder (pibind using ns sc)

1613 n NoFC Placeholder (pibind using ns sc)

1555

1614

1556-- Add implicit arguments in function calls

1615-- Add implicit arguments in function calls

@@ -1616,7 +1675,7 @@ addImpl' inpat env infns imp_meths ist ptm

1616 ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)

1675 ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)

1617 | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)

1676 | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)

1618 | not (f `elem` map fst env)

1677 | not (f `elem` map fst env)

1619− = let as' = map (fmap (ai inpat qq env ds)) as

1678+ = let as' = map (fmap (ai inpat qq env ds)) as

1620 asdotted' = map (fmap (ai False qq env ds)) as in

1679 asdotted' = map (fmap (ai False qq env ds)) as in

1621 handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'

1680 handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'

1622 | Just (Just ty) <- lookup f env =

1681 | Just (Just ty) <- lookup f env =

@@ -1694,7 +1753,9 @@ aiFn :: Name -> Bool -> Bool -> Bool

1694 -> [PArg] -- ^ initial arguments (if in an expression)

1753 -> [PArg] -- ^ initial arguments (if in an expression)

1695 -> Either Err PTerm

1754 -> Either Err PTerm

1696aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1755aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1756+ | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f

1757+ | otherwise

1697− = case lookupDef f (tt_ctxt ist) of

1758+ = case lookupDef f (tt_ctxt ist) of

1698 [] -> Right $ PPatvar ffc f

1759 [] -> Right $ PPatvar ffc f

1699 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1760 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1700 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1761 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

@@ -1707,6 +1768,10 @@ aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1707 imp _ = True

1768 imp _ = True

1708-- allImp [] = False

1769-- allImp [] = False

1709 allImp xs = all imp xs

1770 allImp xs = all imp xs

1771+

1772+ unqualified (NS _ _) = False

1773+ unqualified _ = True

1774+

1710 constructor (TyDecl (DCon _ _ _) _) = True

1775 constructor (TyDecl (DCon _ _ _) _) = True

1711 constructor _ = False

1776 constructor _ = False

1712

1777

@@ -1725,7 +1790,7 @@ aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

1725 [] -> nh

1790 [] -> nh

1726 x -> x

1791 x -> x

1727 case ns' of

1792 case ns' of

1728− [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1793+ [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1729 (insertImpl ns (chooseArgs f' as asexp))

1794 (insertImpl ns (chooseArgs f' as asexp))

1730 [] -> if f `elem` (map fst (idris_metavars ist))

1795 [] -> if f `elem` (map fst (idris_metavars ist))

1731 then Right $ PApp fc (PRef ffc [ffc] f) as

1796 then Right $ PApp fc (PRef ffc [ffc] f) as

@@ -1887,9 +1952,11 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where

1887 su tm@(PRef fc hl f)

1952 su tm@(PRef fc hl f)

1888 | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)

1953 | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)

1889 = Placeholder

1954 = Placeholder

1890− | (TType _ : _) <- lookupTy f (tt_ctxt i)

1955+ | (TType _ : _) <- lookupTy f (tt_ctxt i),

1956+ not (implicitable f)

1891 = PHidden tm

1957 = PHidden tm

1892− | (UType _ : _) <- lookupTy f (tt_ctxt i)

1958+ | (UType _ : _) <- lookupTy f (tt_ctxt i),

1959+ not (implicitable f)

1893 = PHidden tm

1960 = PHidden tm

1894 su (PApp fc f@(PRef _ _ fn) args)

1961 su (PApp fc f@(PRef _ _ fn) args)

1895 -- here we use canBeDConName because the impossible pattern

1962 -- here we use canBeDConName because the impossible pattern

@@ -2153,7 +2220,7 @@ shadow n n' t = sm 0 t where

2153-- | Rename any binders which are repeated (so that we don't have to mess

2220-- | Rename any binders which are repeated (so that we don't have to mess

2154-- about with shadowing anywhere else).

2221-- about with shadowing anywhere else).

2155mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm

2222mkUniqueNames :: [Name] -> [(Name, Name)] -> PTerm -> PTerm

2156−mkUniqueNames env shadows tm

2223+mkUniqueNames env shadows tm

2157 = evalState (mkUniq 0 initMap tm) (S.fromList env) where

2224 = evalState (mkUniq 0 initMap tm) (S.fromList env) where

2158

2225

2159 initMap = M.fromList shadows

2226 initMap = M.fromList shadows

@@ -2275,4 +2342,3 @@ mkUniqueNames env shadows tm

2275 mkUniq ql nmap (PUnquote tm) = fmap PUnquote (mkUniq (ql - 1) nmap tm)

2342 mkUniq ql nmap (PUnquote tm) = fmap PUnquote (mkUniq (ql - 1) nmap tm)

2276

2343

2277 mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm

2344 mkUniq ql nmap tm = descendM (mkUniq ql nmap) tm

2278−

src/Idris/AbsSyntaxTree.hs+90−43

@@ -68,34 +68,36 @@ toplevel = EInfo [] emptyContext id Nothing Nothing (\_ _ _ -> fail "Not impleme

68eInfoNames :: ElabInfo -> [Name]

69eInfoNames info = map fst (params info) ++ M.keys (inblock info)

70

71−data IOption = IOption { opt_logLevel :: Int,

71+data IOption = IOption {

72+ opt_logLevel :: Int

73+ , opt_logcats :: [LogCat] -- ^ List of logging categories.

72− opt_typecase :: Bool,

74+ , opt_typecase :: Bool

73− opt_typeintype :: Bool,

75+ , opt_typeintype :: Bool

74− opt_coverage :: Bool,

76+ , opt_coverage :: Bool

75− opt_showimp :: Bool, -- ^^ show implicits

77+ , opt_showimp :: Bool -- ^ show implicits

76− opt_errContext :: Bool,

78+ , opt_errContext :: Bool

77− opt_repl :: Bool,

79+ , opt_repl :: Bool

78− opt_verbose :: Bool,

80+ , opt_verbose :: Bool

79− opt_nobanner :: Bool,

81+ , opt_nobanner :: Bool

80− opt_quiet :: Bool,

82+ , opt_quiet :: Bool

81− opt_codegen :: Codegen,

83+ , opt_codegen :: Codegen

82− opt_outputTy :: OutputType,

84+ , opt_outputTy :: OutputType

83− opt_ibcsubdir :: FilePath,

85+ , opt_ibcsubdir :: FilePath

84− opt_importdirs :: [FilePath],

86+ , opt_importdirs :: [FilePath]

85− opt_triple :: String,

87+ , opt_triple :: String

86− opt_cpu :: String,

88+ , opt_cpu :: String

87− opt_cmdline :: [Opt], -- remember whole command line

89+ , opt_cmdline :: [Opt] -- remember whole command line

88− opt_origerr :: Bool,

90+ , opt_origerr :: Bool

89− opt_autoSolve :: Bool, -- ^ automatically apply "solve" tactic in prover

91+ , opt_autoSolve :: Bool -- ^ automatically apply "solve" tactic in prover

90− opt_autoImport :: [FilePath], -- ^ e.g. Builtins+Prelude

92+ , opt_autoImport :: [FilePath] -- ^ e.g. Builtins+Prelude

91− opt_optimise :: [Optimisation],

93+ , opt_optimise :: [Optimisation]

92− opt_printdepth :: Maybe Int,

94+ , opt_printdepth :: Maybe Int

93− opt_evaltypes :: Bool, -- ^ normalise types in :t

95+ , opt_evaltypes :: Bool -- ^ normalise types in :t

94− opt_desugarnats :: Bool

96+ , opt_desugarnats :: Bool

95− }

96− deriving (Show, Eq)

97+ } deriving (Show, Eq)

97

98

98defaultOpts = IOption { opt_logLevel = 0

99defaultOpts = IOption { opt_logLevel = 0

100+ , opt_logcats = []

99 , opt_typecase = False

101 , opt_typecase = False

100 , opt_typeintype = False

102 , opt_typeintype = False

101 , opt_coverage = True

103 , opt_coverage = True

@@ -135,7 +137,7 @@ defaultOptimise = [PETransform]

135

137

136-- | Pretty printing options with default verbosity.

138-- | Pretty printing options with default verbosity.

137defaultPPOption :: PPOption

139defaultPPOption :: PPOption

138−defaultPPOption = PPOption { ppopt_impl = False,

140+defaultPPOption = PPOption { ppopt_impl = False,

139 ppopt_desugarnats = False,

141 ppopt_desugarnats = False,

140 ppopt_pinames = False,

142 ppopt_pinames = False,

141 ppopt_depth = Just 200 }

143 ppopt_depth = Just 200 }

@@ -188,7 +190,7 @@ data IState = IState {

188 idris_optimisation :: Ctxt OptInfo,

190 idris_optimisation :: Ctxt OptInfo,

189 idris_datatypes :: Ctxt TypeInfo,

191 idris_datatypes :: Ctxt TypeInfo,

190 idris_namehints :: Ctxt [Name],

192 idris_namehints :: Ctxt [Name],

191− idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported

193+ idris_patdefs :: Ctxt ([([(Name, Term)], Term, Term)], [PTerm]), -- not exported

192 -- ^ list of lhs/rhs, and a list of missing clauses

194 -- ^ list of lhs/rhs, and a list of missing clauses

193 idris_flags :: Ctxt [FnOpt],

195 idris_flags :: Ctxt [FnOpt],

194 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

196 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

@@ -259,7 +261,8 @@ data IState = IState {

259 idris_symbols :: M.Map Name Name, -- ^ Symbol table (preserves sharing of names)

261 idris_symbols :: M.Map Name Name, -- ^ Symbol table (preserves sharing of names)

260 idris_exports :: [Name], -- ^ Functions with ExportList

262 idris_exports :: [Name], -- ^ Functions with ExportList

261 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

263 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

262− idris_parserHighlights :: [(FC, OutputAnnotation)] -- ^ Highlighting information from the parser

264+ idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser

265+ idris_deprecated :: Ctxt String -- ^ Deprecated names and explanation

263 }

266 }

264

267

265-- Required for parsers library, and therefore trifecta

268-- Required for parsers library, and therefore trifecta

@@ -335,6 +338,7 @@ data IBCWrite = IBCFix FixDecl

335 | IBCUsage (Name, Int)

338 | IBCUsage (Name, Int)

336 | IBCExport Name

339 | IBCExport Name

337 | IBCAutoHint Name Name

340 | IBCAutoHint Name Name

341+ | IBCDeprecate Name String

338 deriving Show

342 deriving Show

339

343

340-- | The initial state for the compiler

344-- | The initial state for the compiler

@@ -349,6 +353,7 @@ idrisInit = IState initContext S.empty []

349 [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

353 [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

350 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

354 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

351 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

355 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

356+ emptyContext

352

357

353-- | The monad for the main REPL - reading and processing files and updating

358-- | The monad for the main REPL - reading and processing files and updating

354-- global state (hence the IO inner monad).

359-- global state (hence the IO inner monad).

@@ -403,6 +408,7 @@ data Command = Quit

403 | Proofs

408 | Proofs

404 | Universes

409 | Universes

405 | LogLvl Int

410 | LogLvl Int

411+ | LogCategory [LogCat]

406 | Spec PTerm

412 | Spec PTerm

407 | WHNF PTerm

413 | WHNF PTerm

408 | TestInline PTerm

414 | TestInline PTerm

@@ -448,6 +454,44 @@ data Command = Quit

448

454

449data OutputFmt = HTMLOutput | LaTeXOutput

455data OutputFmt = HTMLOutput | LaTeXOutput

450

456

457+-- | Recognised logging categories for the Idris compiler.

458+--

459+-- @TODO add in sub categories.

460+data LogCat = IParse

461+ | IElab

462+ | ICodeGen

463+ | IErasure

464+ | ICoverage

465+ | IIBC

466+ deriving (Show, Eq, Ord)

467+

468+strLogCat :: LogCat -> String

469+strLogCat IParse = "parser"

470+strLogCat IElab = "elab"

471+strLogCat ICodeGen = "codegen"

472+strLogCat IErasure = "erasure"

473+strLogCat ICoverage = "coverage"

474+strLogCat IIBC = "ibc"

475+

476+codegenCats :: [LogCat]

477+codegenCats = [ICodeGen]

478+

479+parserCats :: [LogCat]

480+parserCats = [IParse]

481+

482+elabCats :: [LogCat]

483+elabCats = [IElab]

484+

485+loggingCatsStr :: String

486+loggingCatsStr = unlines

487+ [ (strLogCat IParse)

488+ , (strLogCat IElab)

489+ , (strLogCat ICodeGen)

490+ , (strLogCat IErasure)

491+ , (strLogCat ICoverage)

492+ , (strLogCat IIBC)

493+ ]

494+

451data Opt = Filename String

495data Opt = Filename String

452 | Quiet

496 | Quiet

453 | NoBanner

497 | NoBanner

@@ -458,11 +502,13 @@ data Opt = Filename String

458 | ShowLibdir

502 | ShowLibdir

459 | ShowIncs

503 | ShowIncs

460 | ShowPkgs

504 | ShowPkgs

505+ | ShowLoggingCats

461 | NoBasePkgs

506 | NoBasePkgs

462 | NoPrelude

507 | NoPrelude

463 | NoBuiltins -- only for the really primitive stuff!

508 | NoBuiltins -- only for the really primitive stuff!

464 | NoREPL

509 | NoREPL

465 | OLogging Int

510 | OLogging Int

511+ | OLogCats [LogCat]

466 | Output String

512 | Output String

467 | Interface

513 | Interface

468 | TypeCase

514 | TypeCase

@@ -584,9 +630,9 @@ is_scoped :: Plicity -> Maybe ImplicitInfo

584is_scoped (Imp _ _ _ s) = s

630is_scoped (Imp _ _ _ s) = s

585is_scoped _ = Nothing

631is_scoped _ = Nothing

586

632

587−impl = Imp [] Dynamic False Nothing

633+impl = Imp [] Dynamic False (Just (Impl False True))

588−forall_imp = Imp [] Dynamic False (Just (Impl False))

634+forall_imp = Imp [] Dynamic False (Just (Impl False False))

589−forall_constraint = Imp [] Dynamic False (Just (Impl True))

635+forall_constraint = Imp [] Dynamic False (Just (Impl True False))

590expl = Exp [] Dynamic False

636expl = Exp [] Dynamic False

591expl_param = Exp [] Dynamic True

637expl_param = Exp [] Dynamic True

592constraint = Constraint [] Static

638constraint = Constraint [] Static

@@ -708,12 +754,13 @@ data Directive = DLib Codegen String |

708 DNameHint Name FC [(Name, FC)] |

754 DNameHint Name FC [(Name, FC)] |

709 DErrorHandlers Name FC Name FC [(Name, FC)] |

755 DErrorHandlers Name FC Name FC [(Name, FC)] |

710 DLanguage LanguageExt |

756 DLanguage LanguageExt |

757+ DDeprecate Name String |

711 DUsed FC Name Name

758 DUsed FC Name Name

712

759

713-- | A set of instructions for things that need to happen in IState

760-- | A set of instructions for things that need to happen in IState

714-- after a term elaboration when there's been reflected elaboration.

761-- after a term elaboration when there's been reflected elaboration.

715data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

762data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

716− | RClausesInstrs Name [([Name], Term, Term)]

763+ | RClausesInstrs Name [([(Name, Term)], Term, Term)]

717 | RAddInstance Name Name

764 | RAddInstance Name Name

718

765

719-- | For elaborator state

766-- | For elaborator state

@@ -763,7 +810,7 @@ data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

763 | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }

810 | PLaterdecl { d_name :: Name, d_name_fc :: FC, d_tcon :: t }

764 -- ^ "Placeholder" for data whose constructors are defined later

811 -- ^ "Placeholder" for data whose constructors are defined later

765 deriving Functor

812 deriving Functor

766−

813+

767-- | Transform the FCs in a PData and its associated terms. The first

814-- | Transform the FCs in a PData and its associated terms. The first

768-- function transforms the general-purpose FCs, and the second transforms

815-- function transforms the general-purpose FCs, and the second transforms

769-- those that are used for semantic source highlighting, so they can be

816-- those that are used for semantic source highlighting, so they can be

@@ -1084,7 +1131,7 @@ data PTactic' t = Intro [Name] | Intros | Focus Name

1084 | MatchRefine Name

1131 | MatchRefine Name

1085 | LetTac Name t | LetTacTy Name t t

1132 | LetTac Name t | LetTacTy Name t t

1086 | Exact t | Compute | Trivial | TCInstance

1133 | Exact t | Compute | Trivial | TCInstance

1087− | ProofSearch Bool Bool Int (Maybe Name)

1134+ | ProofSearch Bool Bool Int (Maybe Name)

1088 [Name] -- allowed local names

1135 [Name] -- allowed local names

1089 [Name] -- hints

1136 [Name] -- hints

1090 -- ^ the bool is whether to search recursively

1137 -- ^ the bool is whether to search recursively

@@ -1175,7 +1222,7 @@ type PDo = PDo' PTerm

1175data PArg' t = PImp { priority :: Int,

1222data PArg' t = PImp { priority :: Int,

1176 machine_inf :: Bool, -- true if the machine inferred it

1223 machine_inf :: Bool, -- true if the machine inferred it

1177 argopts :: [ArgOpt],

1224 argopts :: [ArgOpt],

1178− pname :: Name,

1225+ pname :: Name,

1179 getTm :: t }

1226 getTm :: t }

1180 | PExp { priority :: Int,

1227 | PExp { priority :: Int,

1181 argopts :: [ArgOpt],

1228 argopts :: [ArgOpt],

@@ -1901,7 +1948,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1901 bracket p funcAppPrec . group . align . hang 2 $

1948 bracket p funcAppPrec . group . align . hang 2 $

1902 text "%runElab" <$>

1949 text "%runElab" <$>

1903 prettySe (decD d) funcAppPrec bnd tm

1950 prettySe (decD d) funcAppPrec bnd tm

1904− prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1951+ prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1905

1952

1906 prettySe d p bnd _ = text "missing pretty-printer for term"

1953 prettySe d p bnd _ = text "missing pretty-printer for term"

1907

1954

@@ -2153,7 +2200,7 @@ showTm ist = displayDecorated (consoleDecorate ist) .

2153showTmImpls :: PTerm -> String

2200showTmImpls :: PTerm -> String

2154showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

2201showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

2155

2202

2156−-- | Show a term with specific options

2203+-- | Show a term with specific options

2157showTmOpts :: PPOption -> PTerm -> String

2204showTmOpts :: PPOption -> PTerm -> String

2158showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

2205showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

2159

2206

@@ -2269,7 +2316,7 @@ boundNamesIn tm = S.toList (ni 0 S.empty tm)

2269

2316

2270-- Return names which are valid implicits in the given term (type).

2317-- Return names which are valid implicits in the given term (type).

2271implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]

2318implicitNamesIn :: [Name] -> IState -> PTerm -> [Name]

2272−implicitNamesIn uvars ist tm

2319+implicitNamesIn uvars ist tm

2273 = let (imps, fns) = execState (ni 0 [] tm) ([], []) in

2320 = let (imps, fns) = execState (ni 0 [] tm) ([], []) in

2274 nub imps \\ nub fns

2321 nub imps \\ nub fns

2275 where

2322 where

@@ -2298,15 +2345,15 @@ implicitNamesIn uvars ist tm

2298 ni 0 env (PRef _ _ n)

2345 ni 0 env (PRef _ _ n)

2299 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2346 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2300 ni 0 env (PApp _ f@(PRef _ _ n) as)

2347 ni 0 env (PApp _ f@(PRef _ _ n) as)

2301− | n `elem` uvars = do ni 0 env f

2348+ | n `elem` uvars = do ni 0 env f

2302 mapM_ (ni 0 env) (map getTm as)

2349 mapM_ (ni 0 env) (map getTm as)

2303 | otherwise = do case lookupTy n (tt_ctxt ist) of

2350 | otherwise = do case lookupTy n (tt_ctxt ist) of

2304 [] -> return ()

2351 [] -> return ()

2305 _ -> addFn n

2352 _ -> addFn n

2306 mapM_ (ni 0 env) (map getTm as)

2353 mapM_ (ni 0 env) (map getTm as)

2307− ni 0 env (PApp _ f as) = do ni 0 env f

2354+ ni 0 env (PApp _ f as) = do ni 0 env f

2308 mapM_ (ni 0 env) (map getTm as)

2355 mapM_ (ni 0 env) (map getTm as)

2309− ni 0 env (PAppBind _ f as) = do ni 0 env f

2356+ ni 0 env (PAppBind _ f as) = do ni 0 env f

2310 mapM_ (ni 0 env) (map getTm as)

2357 mapM_ (ni 0 env) (map getTm as)

2311 ni 0 env (PCase _ c os) = do ni 0 env c

2358 ni 0 env (PCase _ c os) = do ni 0 env c

2312 -- names in 'os', not counting the names bound in the cases

2359 -- names in 'os', not counting the names bound in the cases

@@ -2323,7 +2370,7 @@ implicitNamesIn uvars ist tm

2323 ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r

2370 ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r

2324 ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2371 ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2325 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2372 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2326− ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2373+ ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2327 ni 0 env t

2374 ni 0 env t

2328 ni 0 env r

2375 ni 0 env r

2329 ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2376 ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

src/Idris/CaseSplit.hs+83−60

@@ -50,8 +50,11 @@ names over '_', patterns over names, etc.

50-}

51

52-- Given a variable to split, and a term application, return a list of

53−-- variable updates

53+-- variable updates, paired with a flag to say whether the given update

54+-- typechecks (False = impossible)

55+-- if the flag is 'False' the splits should be output with the 'impossible'

56+-- flag, otherwise they should be output as normal

54−split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

57+split :: Name -> PTerm -> Idris (Bool, [[(Name, PTerm)]])

55split n t'

58split n t'

56 = do ist <- getIState

59 = do ist <- getIState

57 -- Make sure all the names in the term are accessible

60 -- Make sure all the names in the term are accessible

@@ -62,30 +65,41 @@ split n t'

62 -- ASSUMPTION: tm is in normal form after elabValBind, so we don't

65 -- ASSUMPTION: tm is in normal form after elabValBind, so we don't

63 -- need to do anything special to find out what family each argument

66 -- need to do anything special to find out what family each argument

64 -- is in

67 -- is in

65− logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

68+ logElab 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

66-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

69-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

67-- iputStrLn (show pats)

70-- iputStrLn (show pats)

68− let t = mergeUserImpl (addImplPat ist t') (delab ist tm)

71+ let t = mergeUserImpl (addImplPat ist t') (delab ist tm)

69 let ctxt = tt_ctxt ist

72 let ctxt = tt_ctxt ist

70 case lookup n pats of

73 case lookup n pats of

71 Nothing -> ifail $ show n ++ " is not a pattern variable"

74 Nothing -> ifail $ show n ++ " is not a pattern variable"

72 Just ty ->

75 Just ty ->

73 do let splits = findPats ist ty

76 do let splits = findPats ist ty

74− logLvl 1 ("New patterns " ++ showSep ", "

77+ logElab 1 ("New patterns " ++ showSep ", "

75 (map showTmImpls splits))

78 (map showTmImpls splits))

76 let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)

79 let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)

77− logLvl 4 ("Working from " ++ show t)

80+ logElab 4 ("Working from " ++ show t)

78− logLvl 4 ("Trying " ++ showSep "\n"

81+ logElab 4 ("Trying " ++ showSep "\n"

79 (map (showTmImpls) newPats_in))

82 (map (showTmImpls) newPats_in))

80− newPats <- mapM elabNewPat newPats_in

83+ newPats_in <- mapM elabNewPat newPats_in

84+ case anyValid [] [] newPats_in of

85+ Left fails -> do

86+ let fails' = mergeAllPats ist n t fails

87+ return (False, (map snd fails'))

88+ Right newPats -> do

81− logLvl 3 ("Original:\n" ++ show t)

89+ logElab 3 ("Original:\n" ++ show t)

82− logLvl 3 ("Split:\n" ++

90+ logElab 3 ("Split:\n" ++

83− (showSep "\n" (map show (mapMaybe id newPats))))

91+ (showSep "\n" (map show newPats)))

84− logLvl 3 "----"

92+ logElab 3 "----"

85− let newPats' = mergeAllPats ist n t (mapMaybe id newPats)

93+ let newPats' = mergeAllPats ist n t newPats

86− logLvl 1 ("Name updates " ++ showSep "\n"

94+ logElab 1 ("Name updates " ++ showSep "\n"

87− (map (\ (p, u) -> show u ++ " " ++ show p) newPats'))

95+ (map (\ (p, u) -> show u ++ " " ++ show p) newPats'))

88− return (map snd newPats')

96+ return (True, (map snd newPats'))

97+ where

98+ anyValid ok bad [] = if null ok then Left (reverse bad)

99+ else Right (reverse ok)

100+ anyValid ok bad ((tc, p) : ps)

101+ | tc = anyValid (p : ok) bad ps

102+ | otherwise = anyValid ok (p : bad) ps

89

103

90data MergeState = MS { namemap :: [(Name, Name)],

104data MergeState = MS { namemap :: [(Name, Name)],

91 invented :: [(Name, Name)],

105 invented :: [(Name, Name)],

@@ -97,7 +111,7 @@ addUpdate n tm = do ms <- get

97 put (ms { updates = ((n, stripNS tm) : updates ms) } )

111 put (ms { updates = ((n, stripNS tm) : updates ms) } )

98

112

99inventName :: Idris.AbsSyntaxTree.IState -> Maybe Name -> Name -> State MergeState Name

113inventName :: Idris.AbsSyntaxTree.IState -> Maybe Name -> Name -> State MergeState Name

100−inventName ist ty n =

114+inventName ist ty n =

101 do ms <- get

115 do ms <- get

102 let supp = case ty of

116 let supp = case ty of

103 Nothing -> []

117 Nothing -> []

@@ -117,11 +131,11 @@ inventName ist ty n =

117 do let n' = uniqueNameFrom nsupp badnames

131 do let n' = uniqueNameFrom nsupp badnames

118 put (ms { invented = (n, n') : invented ms })

132 put (ms { invented = (n, n') : invented ms })

119 return n'

133 return n'

120−

134+

121mkSupply :: [Name] -> [Name]

135mkSupply :: [Name] -> [Name]

122mkSupply ns = mkSupply' ns (map nextName ns)

136mkSupply ns = mkSupply' ns (map nextName ns)

123 where mkSupply' xs ns' = xs ++ mkSupply ns'

137 where mkSupply' xs ns' = xs ++ mkSupply ns'

124−

138+

125varlist :: [Name]

139varlist :: [Name]

126varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

140varlist = map (sUN . (:[])) "xyzwstuv" -- EB's personal preference :)

127

141

@@ -133,7 +147,7 @@ stripNS tm = mapPT dens tm where

133mergeAllPats :: IState -> Name -> PTerm -> [PTerm] -> [(PTerm, [(Name, PTerm)])]

147mergeAllPats :: IState -> Name -> PTerm -> [PTerm] -> [(PTerm, [(Name, PTerm)])]

134mergeAllPats ist cv t [] = []

148mergeAllPats ist cv t [] = []

135mergeAllPats ist cv t (p : ps)

149mergeAllPats ist cv t (p : ps)

136− = let (p', MS _ _ _ u) = runState (mergePat ist t p Nothing)

150+ = let (p', MS _ _ _ u) = runState (mergePat ist t p Nothing)

137 (MS [] [] (filter (/=cv) (patvars t)) [])

151 (MS [] [] (filter (/=cv) (patvars t)) [])

138 ps' = mergeAllPats ist cv t ps in

152 ps' = mergeAllPats ist cv t ps in

139 ((p', u) : ps')

153 ((p', u) : ps')

@@ -178,7 +192,7 @@ mergeUserImpl :: PTerm -> PTerm -> PTerm

178mergeUserImpl x y = x

192mergeUserImpl x y = x

179

193

180argTys :: IState -> PTerm -> [Maybe Name]

194argTys :: IState -> PTerm -> [Maybe Name]

181−argTys ist (PRef fc hls n)

195+argTys ist (PRef fc hls n)

182 = case lookupTy n (tt_ctxt ist) of

196 = case lookupTy n (tt_ctxt ist) of

183 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

197 [ty] -> map (tyName . snd) (getArgTys ty) ++ repeat Nothing

184 _ -> repeat Nothing

198 _ -> repeat Nothing

@@ -208,13 +222,13 @@ tidy ist tm ty = return tm

208-- where tidyVar (PRef _ _) = Placeholder

222-- where tidyVar (PRef _ _) = Placeholder

209-- tidyVar t = t

223-- tidyVar t = t

210

224

211−elabNewPat :: PTerm -> Idris (Maybe PTerm)

225+elabNewPat :: PTerm -> Idris (Bool, PTerm)

212elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t

226elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t

213 i <- getIState

227 i <- getIState

214− return (Just (delab i tm)))

228+ return (True, delab i tm))

215 (\e -> do i <- getIState

229 (\e -> do i <- getIState

216− logLvl 5 $ "Not a valid split:\n" ++ pshow i e

230+ logElab 5 $ "Not a valid split:\n" ++ pshow i e

217− return Nothing)

231+ return (False, t))

218

232

219findPats :: IState -> Type -> [PTerm]

233findPats :: IState -> Type -> [PTerm]

220findPats ist t | (P _ n _, _) <- unApply t

234findPats ist t | (P _ n _, _) <- unApply t

@@ -236,7 +250,7 @@ replaceVar ctxt n t (PApp fc f pats) = PApp fc f (map substArg pats)

236 subst orig@(PRef _ _ v) | v == n = t

250 subst orig@(PRef _ _ v) | v == n = t

237 | isDConName v ctxt = orig

251 | isDConName v ctxt = orig

238 subst (PRef _ _ _) = Placeholder

252 subst (PRef _ _ _) = Placeholder

239− subst (PApp fc (PRef _ _ t) pats)

253+ subst (PApp fc (PRef _ _ t) pats)

240 | isTConName t ctxt = Placeholder -- infer types

254 | isTConName t ctxt = Placeholder -- infer types

241 subst (PApp fc f pats) = PApp fc f (map substArg pats)

255 subst (PApp fc f pats) = PApp fc f (map substArg pats)

242 subst x = x

256 subst x = x

@@ -248,30 +262,31 @@ replaceVar ctxt n t pat = pat

248splitOnLine :: Int -- ^ line number

262splitOnLine :: Int -- ^ line number

249 -> Name -- ^ variable

263 -> Name -- ^ variable

250 -> FilePath -- ^ name of file

264 -> FilePath -- ^ name of file

251− -> Idris [[(Name, PTerm)]]

265+ -> Idris (Bool, [[(Name, PTerm)]])

252splitOnLine l n fn = do

266splitOnLine l n fn = do

253−-- let (before, later) = splitAt (l-1) (lines inp)

254−-- i <- getIState

255 cl <- getInternalApp fn l

267 cl <- getInternalApp fn l

256− logLvl 3 ("Working with " ++ showTmImpls cl)

268+ logElab 3 ("Working with " ++ showTmImpls cl)

257 tms <- split n cl

269 tms <- split n cl

258−-- iputStrLn (showSep "\n" (map show tms))

259− return tms -- "" -- not yet done...

270+ return tms

260

271

261−replaceSplits :: String -> [[(Name, PTerm)]] -> Idris [String]

272+replaceSplits :: String -> [[(Name, PTerm)]] -> Bool -> Idris [String]

273+replaceSplits l ups impossible

262−replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

274+ = updateRHSs 1 (map (rep (expandBraces l)) ups)

263 where

275 where

264 rep str [] = str ++ "\n"

276 rep str [] = str ++ "\n"

265 rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow tm) str) ups

277 rep str ((n, tm) : ups) = rep (updatePat False (show n) (nshow tm) str) ups

266

278

267 updateRHSs i [] = return []

279 updateRHSs i [] = return []

280+ updateRHSs i (x : xs)

281+ | impossible = do xs' <- updateRHSs i xs

282+ return (setImpossible False x : xs')

268− updateRHSs i (x : xs) = do (x', i') <- updateRHS (null xs) i x

283+ | otherwise = do (x', i') <- updateRHS (null xs) i x

269− xs' <- updateRHSs i' xs

284+ xs' <- updateRHSs i' xs

270− return (x' : xs')

285+ return (x' : xs')

271

286

272 updateRHS last i ('?':'=':xs) = do (xs', i') <- updateRHS last i xs

287 updateRHS last i ('?':'=':xs) = do (xs', i') <- updateRHS last i xs

273 return ("?=" ++ xs', i')

288 return ("?=" ++ xs', i')

274− updateRHS last i ('?':xs)

289+ updateRHS last i ('?':xs)

275 = do let (nm, rest_in) = span (not . (\x -> isSpace x || x == ')'

290 = do let (nm, rest_in) = span (not . (\x -> isSpace x || x == ')'

276 || x == '(')) xs

291 || x == '(')) xs

277 let rest = if last then rest_in else

292 let rest = if last then rest_in else

@@ -283,6 +298,11 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

283 return (x : xs', i')

298 return (x : xs', i')

284 updateRHS last i [] = return ("", i)

299 updateRHS last i [] = return ("", i)

285

300

301+ setImpossible brace ('}':xs) = '}' : setImpossible False xs

302+ setImpossible brace ('{':xs) = '{' : setImpossible True xs

303+ setImpossible False ('=':xs) = "impossible\n"

304+ setImpossible brace (x : xs) = x : setImpossible brace xs

305+ setImpossible brace [] = ""

286

306

287 -- TMP HACK: If there are Nats, we don't want to show as numerals since

307 -- TMP HACK: If there are Nats, we don't want to show as numerals since

288 -- this isn't supported in a pattern, so special case here

308 -- this isn't supported in a pattern, so special case here

@@ -321,7 +341,7 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

321 | otherwise = tm

341 | otherwise = tm

322

342

323

343

324−getUniq :: (Show t, Num t) => [Char] -> t -> Idris ([Char], t)

344+getUniq :: (Show t, Num t) => [Char] -> t -> Idris ([Char], t)

325getUniq nm i

345getUniq nm i

326 = do ist <- getIState

346 = do ist <- getIState

327 let n = nameRoot [] nm ++ "_" ++ show i

347 let n = nameRoot [] nm ++ "_" ++ show i

@@ -337,27 +357,31 @@ nameRoot acc nm =

337

357

338getClause :: Int -- ^ line number that the type is declared on

358getClause :: Int -- ^ line number that the type is declared on

339 -> Name -- ^ Function name

359 -> Name -- ^ Function name

360+ -> Name -- ^ User given name

340 -> FilePath -- ^ Source file name

361 -> FilePath -- ^ Source file name

341 -> Idris String

362 -> Idris String

342−getClause l fn fp

363+getClause l fn un fp

343 = do i <- getIState

364 = do i <- getIState

344− case lookupCtxt fn (idris_classes i) of

365+ case lookupCtxt un (idris_classes i) of

345 [c] -> return (mkClassBodies i (class_methods c))

366 [c] -> return (mkClassBodies i (class_methods c))

346− _ -> do ty <- getInternalApp fp l

367+ _ -> do ty_in <- getInternalApp fp l

368+ let ty = case ty_in of

369+ PTyped n t -> t

370+ x -> x

347 ist <- get

371 ist <- get

348 let ap = mkApp ist ty []

372 let ap = mkApp ist ty []

349− return (show fn ++ " " ++ ap ++ "= ?"

373+ return (show un ++ " " ++ ap ++ "= ?"

350− ++ show fn ++ "_rhs")

374+ ++ show un ++ "_rhs")

351 where mkApp :: IState -> PTerm -> [Name] -> String

375 where mkApp :: IState -> PTerm -> [Name] -> String

352 mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used

376 mkApp i (PPi (Exp _ _ False) (MN _ _) _ ty sc) used

353 = let n = getNameFrom i used ty in

377 = let n = getNameFrom i used ty in

354− show n ++ " " ++ mkApp i sc (n : used)

378+ show n ++ " " ++ mkApp i sc (n : used)

355 mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used

379 mkApp i (PPi (Exp _ _ False) (UN n) _ ty sc) used

356 | thead n == '_'

380 | thead n == '_'

357 = let n = getNameFrom i used ty in

381 = let n = getNameFrom i used ty in

358− show n ++ " " ++ mkApp i sc (n : used)

382+ show n ++ " " ++ mkApp i sc (n : used)

359− mkApp i (PPi (Exp _ _ False) n _ _ sc) used

383+ mkApp i (PPi (Exp _ _ False) n _ _ sc) used

360− = show n ++ " " ++ mkApp i sc (n : used)

384+ = show n ++ " " ++ mkApp i sc (n : used)

361 mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used

385 mkApp i (PPi _ _ _ _ sc) used = mkApp i sc used

362 mkApp i _ _ = ""

386 mkApp i _ _ = ""

363

387

@@ -370,17 +394,17 @@ getClause l fn fp

370 sUN "z"]) used

394 sUN "z"]) used

371 ns -> uniqueNameFrom (mkSupply ns) used

395 ns -> uniqueNameFrom (mkSupply ns) used

372 getNameFrom i used _ = uniqueNameFrom (mkSupply [sUN "x", sUN "y",

396 getNameFrom i used _ = uniqueNameFrom (mkSupply [sUN "x", sUN "y",

373− sUN "z"]) used

397+ sUN "z"]) used

374

398

375 -- write method declarations, indent with 4 spaces

399 -- write method declarations, indent with 4 spaces

376 mkClassBodies :: IState -> [(Name, (FnOpts, PTerm))] -> String

400 mkClassBodies :: IState -> [(Name, (FnOpts, PTerm))] -> String

377− mkClassBodies i ns

401+ mkClassBodies i ns

378 = showSep "\n"

402 = showSep "\n"

379− (zipWith (\(n, (_, ty)) m -> " " ++

403+ (zipWith (\(n, (_, ty)) m -> " " ++

380 def (show (nsroot n)) ++ " "

404 def (show (nsroot n)) ++ " "

381 ++ mkApp i ty []

405 ++ mkApp i ty []

382− ++ "= ?"

406+ ++ "= ?"

383− ++ show fn ++ "_rhs_" ++ show m) ns [1..])

407+ ++ show un ++ "_rhs_" ++ show m) ns [1..])

384

408

385 def n@(x:xs) | not (isAlphaNum x) = "(" ++ n ++ ")"

409 def n@(x:xs) | not (isAlphaNum x) = "(" ++ n ++ ")"

386 def n = n

410 def n = n

@@ -390,7 +414,10 @@ getProofClause :: Int -- ^ line number that the type is declared

390 -> FilePath -- ^ Source file name

414 -> FilePath -- ^ Source file name

391 -> Idris String

415 -> Idris String

392getProofClause l fn fp

416getProofClause l fn fp

393− = do ty <- getInternalApp fp l

417+ = do ty_in <- getInternalApp fp l

418+ let ty = case ty_in of

419+ PTyped n t -> t

420+ x -> x

394 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

421 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

395 where mkApp (PPi _ _ _ _ sc) = mkApp sc

422 where mkApp (PPi _ _ _ _ sc) = mkApp sc

396 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

423 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

@@ -427,9 +454,5 @@ nameMissing ps = do ist <- get

427

454

428 nm ptm = do mptm <- elabNewPat ptm

455 nm ptm = do mptm <- elabNewPat ptm

429 case mptm of

456 case mptm of

430− Nothing -> return ptm

457+ (False, _) -> return ptm

431− Just ptm' -> return ptm'

458+ (True, ptm') -> return ptm'

432−

433−

434−

435−

src/Idris/Chaser.hs+81−38

@@ -1,5 +1,6 @@

1−module Idris.Chaser(buildTree, getModuleFiles, ModuleTree(..)) where

1+module Idris.Chaser(buildTree, getImports, getModuleFiles, ModuleTree(..)) where

2

3+import Idris.Core.TT

3import Idris.Parser

4import Idris.Parser

4import Idris.AbsSyntax

5import Idris.AbsSyntax

5import Idris.Imports

6import Idris.Imports

@@ -79,42 +80,86 @@ getIModTime (IBC i _) = getModificationTime i

79getIModTime (IDR i) = getModificationTime i

80getIModTime (IDR i) = getModificationTime i

80getIModTime (LIDR i) = getModificationTime i

81getIModTime (LIDR i) = getModificationTime i

81

82

83+getImports :: [(FilePath, [ImportInfo])] -> [FilePath] ->

84+ Idris [(FilePath, [ImportInfo])]

85+getImports acc [] = return acc

86+getImports acc (f : fs) = do

87+ i <- getIState

88+ let file = extractFileName f

89+ ibcsd <- valIBCSubDir i

90+ ids <- allImportDirs

91+ idrisCatch (do

92+ fp <- findImport ["."] ibcsd file

93+ let parsef = fname fp

94+ case lookup parsef acc of

95+ Just _ -> getImports acc fs

96+ _ -> do

97+ exist <- runIO $ doesFileExist parsef

98+ if exist then do

99+ src_in <- runIO $ readSource parsef

100+ src <- if lit fp then tclift $ unlit parsef src_in

101+ else return src_in

102+ (_, _, modules, _) <- parseImports parsef src

103+ clearParserWarnings

104+ getImports ((parsef, modules) : acc)

105+ (fs ++ map import_path modules)

106+ else getImports ((parsef, []) : acc) fs)

107+ (\_ -> getImports acc fs) -- not in current soure tree, ignore

108+ where

109+ lit (LIDR _) = True

110+ lit _ = False

111+

112+ fname (IDR fn) = fn

113+ fname (LIDR fn) = fn

114+ fname (IBC _ src) = fname src

115+

82buildTree :: [FilePath] -> -- already guaranteed built

116buildTree :: [FilePath] -> -- already guaranteed built

117+ [(FilePath, [ImportInfo])] -> -- import lists (don't reparse)

83 FilePath -> Idris [ModuleTree]

118 FilePath -> Idris [ModuleTree]

84−buildTree built fp = btree [] fp

119+buildTree built importlists fp = evalStateT (btree [] fp) []

85−-- = idrisCatch (btree [] fp)

86−-- (\e -> do now <- runIO $ getCurrentTime

87−-- iputStrLn (show e)

88−-- return [MTree (IDR fp) True now []])

89 where

120 where

121+ addFile :: FilePath -> [ModuleTree] ->

122+ StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]

123+ addFile f m = do fs <- get

124+ put ((f, m) : fs)

125+ return m

126+

127+ btree :: [FilePath] -> FilePath ->

128+ StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]

90− btree done f =

129+ btree stk f =

91− do i <- getIState

130+ do i <- lift getIState

92 let file = extractFileName f

131 let file = extractFileName f

93− logLvl 1 $ "CHASING " ++ show file

132+ lift $ logLvl 1 $ "CHASING " ++ show file ++ " (" ++ show fp ++ ")"

94− ibcsd <- valIBCSubDir i

133+ ibcsd <- lift $ valIBCSubDir i

95− ids <- allImportDirs

134+ ids <- lift $ allImportDirs

96− fp <- findImport ids ibcsd file

135+ fp <- lift $ findImport ids ibcsd file

97− logLvl 1 $ "Found " ++ show fp

136+ lift $ logLvl 1 $ "Found " ++ show fp

98− mt <- runIO $ getIModTime fp

137+ mt <- lift $ runIO $ getIModTime fp

99 if (file `elem` built)

138 if (file `elem` built)

100 then return [MTree fp False mt []]

139 then return [MTree fp False mt []]

101− else if file `elem` done

140+ else if file `elem` stk then

141+ do lift $ tclift $ tfail

142+ (Msg $ "Cycle detected in imports: "

143+ ++ showSep " -> " (reverse (file : stk)))

144+ else do donetree <- get

145+ case lookup file donetree of

102− then return []

146+ Just t -> return t

103− else mkChildren fp

147+ _ -> do ms <- mkChildren file fp

104−

148+ addFile file ms

149+

105− where mkChildren (LIDR fn) = do ms <- children True fn (f:done)

150+ where mkChildren file (LIDR fn) = do ms <- children True fn (file : stk)

106− mt <- runIO $ getModificationTime fn

151+ mt <- lift $ runIO $ getModificationTime fn

107− return [MTree (LIDR fn) True mt ms]

152+ return [MTree (LIDR fn) True mt ms]

108− mkChildren (IDR fn) = do ms <- children False fn (f:done)

153+ mkChildren file (IDR fn) = do ms <- children False fn (file : stk)

109− mt <- runIO $ getModificationTime fn

154+ mt <- lift $ runIO $ getModificationTime fn

110− return [MTree (IDR fn) True mt ms]

155+ return [MTree (IDR fn) True mt ms]

111− mkChildren (IBC fn src)

156+ mkChildren file (IBC fn src)

112− = do srcexist <- runIO $ doesFileExist (getSrcFile src)

157+ = do srcexist <- lift $ runIO $ doesFileExist (getSrcFile src)

113 ms <- if srcexist then

158 ms <- if srcexist then

114− do [MTree _ _ _ ms'] <- mkChildren src

159+ do [MTree _ _ _ ms'] <- mkChildren file src

115 return ms'

160 return ms'

116 else return []

161 else return []

117− mt <- idrisCatch (runIO $ getModificationTime fn)

162+ mt <- lift $ idrisCatch (runIO $ getModificationTime fn)

118 (\c -> runIO $ getIModTime src)

163 (\c -> runIO $ getIModTime src)

119 -- FIXME: It's also not up to date if anything it imports has

164 -- FIXME: It's also not up to date if anything it imports has

120 -- been modified since its own ibc has.

165 -- been modified since its own ibc has.

@@ -122,7 +167,7 @@ buildTree built fp = btree [] fp

122 -- Issue #1592 on the issue tracker.

167 -- Issue #1592 on the issue tracker.

123 --

168 --

124 -- https://github.com/idris-lang/Idris-dev/issues/1592

169 -- https://github.com/idris-lang/Idris-dev/issues/1592

125− ibcOutdated <- fn `younger` (getSrcFile src)

170+ ibcOutdated <- lift $ fn `younger` (getSrcFile src)

126 -- FIXME (EB): The below 'hasValidIBCVersion' that's

171 -- FIXME (EB): The below 'hasValidIBCVersion' that's

127 -- commented out appears to be breaking reloading in vim

172 -- commented out appears to be breaking reloading in vim

128 -- mode. Until we know why, I've commented it out.

173 -- mode. Until we know why, I've commented it out.

@@ -140,16 +185,14 @@ buildTree built fp = btree [] fp

140 return (srct > ibct)

185 return (srct > ibct)

141 else return False

186 else return False

142

187

143− children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree]

188+ children :: Bool -> FilePath -> [FilePath] ->

189+ StateT [(FilePath, [ModuleTree])] Idris [ModuleTree]

144− children lit f done = -- idrisCatch

190+ children lit f stk = -- idrisCatch

145− do exist <- runIO $ doesFileExist f

191+ do exist <- lift $ runIO $ doesFileExist f

146 if exist then do

192 if exist then do

147− file_in <- runIO $ readSource f

193+ lift $ logLvl 1 $ "Reading source " ++ show f

148− file <- if lit then tclift $ unlit f file_in else return file_in

194+ let modules = maybe [] id (lookup f importlists)

149− (_, _, modules, _) <- parseImports f file

150− -- The chaser should never report warnings from sub-modules

151− clearParserWarnings

152− ms <- mapM (btree done . import_path) modules

195+ ms <- mapM (btree stk . import_path) modules

153 return (concat ms)

196 return (concat ms)

154 else return [] -- IBC with no source available

197 else return [] -- IBC with no source available

155-- (\c -> return []) -- error, can't chase modules here

198-- (\c -> return []) -- error, can't chase modules here

src/Idris/CmdOptions.hs+43−13

@@ -86,6 +86,11 @@ parseFlags = many $

86 <|> (Client <$> strOption (long "client"))

87 -- Logging Flags

88 <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))

89+ <|> (OLogCats <$> option (str >>= parseLogCats)

90+ (long "logging-categories"

91+ <> metavar "CATS"

92+ <> help "Colon separated logging categories. Use --listlogcats to see list."))

93+

89 -- Turn off Certain libraries.

94 -- Turn off Certain libraries.

90 <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")

95 <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")

91 <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude")

96 <|> flag' NoPrelude (long "noprelude" <> help "Do not use the given prelude")

@@ -101,11 +106,13 @@ parseFlags = many $

101 <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")

106 <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")

102 <|> flag' NoCoverage (long "nocoverage")

107 <|> flag' NoCoverage (long "nocoverage")

103 <|> flag' ErrContext (long "errorcontext")

108 <|> flag' ErrContext (long "errorcontext")

109+ -- Show things

110+ <|> flag' ShowLoggingCats (long "listlogcats" <> help "Display logging categories")

104− <|> flag' ShowLibs (long "link" <> help "Display link flags")

111+ <|> flag' ShowLibs (long "link" <> help "Display link flags")

105− <|> flag' ShowPkgs (long "listlibs" <> help "Display installed libraries")

112+ <|> flag' ShowPkgs (long "listlibs" <> help "Display installed libraries")

106− <|> flag' ShowLibdir (long "libdir" <> help "Display library directory")

113+ <|> flag' ShowLibdir (long "libdir" <> help "Display library directory")

107− <|> flag' ShowIncs (long "include" <> help "Display the includes flags")

114+ <|> flag' ShowIncs (long "include" <> help "Display the includes flags")

108− <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")

115+ <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")

109 <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))

116 <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))

110 <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))

117 <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))

111 <|> flag' WarnOnly (long "warn")

118 <|> flag' WarnOnly (long "warn")

@@ -161,21 +168,44 @@ parseVersion :: Parser (a -> a)

161parseVersion = infoOption ver (short 'v' <> long "version" <> help "Print version information")

168parseVersion = infoOption ver (short 'v' <> long "version" <> help "Print version information")

162

169

163preProcOpts :: [Opt] -> [Opt] -> [Opt]

170preProcOpts :: [Opt] -> [Opt] -> [Opt]

164−preProcOpts [] ys = ys

171+preProcOpts [] ys = ys

165preProcOpts (NoBuiltins:xs) ys = NoBuiltins : NoPrelude : preProcOpts xs ys

172preProcOpts (NoBuiltins:xs) ys = NoBuiltins : NoPrelude : preProcOpts xs ys

166−preProcOpts (Output s:xs) ys = Output s : NoREPL : preProcOpts xs ys

173+preProcOpts (Output s:xs) ys = Output s : NoREPL : preProcOpts xs ys

167−preProcOpts (BCAsm s:xs) ys = BCAsm s : NoREPL : preProcOpts xs ys

174+preProcOpts (BCAsm s:xs) ys = BCAsm s : NoREPL : preProcOpts xs ys

168−preProcOpts (x:xs) ys = preProcOpts xs (x:ys)

175+preProcOpts (x:xs) ys = preProcOpts xs (x:ys)

169

176

170parseCodegen :: String -> Codegen

177parseCodegen :: String -> Codegen

171parseCodegen "bytecode" = Bytecode

178parseCodegen "bytecode" = Bytecode

172−parseCodegen cg = Via (map toLower cg)

179+parseCodegen cg = Via (map toLower cg)

173−

174−

175

180

181+parseLogCats :: Monad m => String -> m [LogCat]

182+parseLogCats s =

183+ case lastMay (readP_to_S (doParse) s) of

184+ Just (xs, _) -> return xs

185+ _ -> fail $ "Incorrect categories specified"

186+ where

187+ doParse :: ReadP [LogCat]

188+ doParse = do

189+ cs <- sepBy1 parseLogCat (char ':')

190+ eof

191+ return (concat cs)

192+

193+ parseLogCat :: ReadP [LogCat]

194+ parseLogCat = (string (strLogCat IParse) *> return parserCats)

195+ <|> (string (strLogCat IElab) *> return elabCats)

196+ <|> (string (strLogCat ICodeGen) *> return codegenCats)

197+ <|> (string (strLogCat ICoverage) *> return [ICoverage])

198+ <|> (string (strLogCat IIBC) *> return [IIBC])

199+ <|> (string (strLogCat IErasure) *> return [IErasure])

200+ <|> parseLogCatBad

201+

202+ parseLogCatBad :: ReadP [LogCat]

203+ parseLogCatBad = do

204+ s <- look

205+ fail $ "Category: " ++ s ++ " is not recognised."

176

206

177parseConsoleWidth :: Monad m => String -> m ConsoleWidth

207parseConsoleWidth :: Monad m => String -> m ConsoleWidth

178−parseConsoleWidth "auto" = return AutomaticWidth

208+parseConsoleWidth "auto" = return AutomaticWidth

179parseConsoleWidth "infinite" = return InfinitelyWide

209parseConsoleWidth "infinite" = return InfinitelyWide

180parseConsoleWidth s =

210parseConsoleWidth s =

181 case lastMay (readP_to_S (integerReader) s) of

211 case lastMay (readP_to_S (integerReader) s) of

src/Idris/Completion.hs+2−8

@@ -12,7 +12,7 @@ import Idris.Colours

12import Idris.ParseHelpers(opChars)

13import qualified Idris.ParseExpr (constants, tactics)

14import Idris.ParseExpr (TacticArg (..))

15−import Idris.REPLParser (allHelp)

15+import Idris.REPLParser (allHelp, setOptions)

16import Control.Monad.State.Strict

17

18import Data.List

@@ -82,13 +82,7 @@ completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM

82

83completeOption :: CompletionFunc Idris

84completeOption = completeWord Nothing " \t" completeOpt

85− where completeOpt = return . completeWith [ "errorcontext"

85+ where completeOpt = return . completeWith (map fst setOptions)

86− , "showimplicits"

87− , "originalerrors"

88− , "autosolve"

89− , "nobanner"

90− , "desugarnats"

91− ]

92

86

93completeConsoleWidth :: CompletionFunc Idris

87completeConsoleWidth :: CompletionFunc Idris

94completeConsoleWidth = completeWord Nothing " \t" completeW

88completeConsoleWidth = completeWord Nothing " \t" completeW

src/Idris/Core/Binary.hs+27−22

@@ -145,10 +145,11 @@ instance Binary a => Binary (Err' a) where

145 put (At fc e) = do putWord8 27

146 put fc

147 put e

148− put (Elaborating str n e) = do putWord8 28

148+ put (Elaborating str n ty e) = do putWord8 28

149− put str

149+ put str

150− put n

150+ put n

151+ put ty

151− put e

152+ put e

152 put (ElaboratingArg n1 n2 ns e) = do putWord8 29

153 put (ElaboratingArg n1 n2 ns e) = do putWord8 29

153 put n1

154 put n1

154 put n2

155 put n2

@@ -188,7 +189,10 @@ instance Binary a => Binary (Err' a) where

188 put ns

189 put ns

189 put (RunningElabScript e) = do putWord8 42

190 put (RunningElabScript e) = do putWord8 42

190 put e

191 put e

191−

192+ put (ElabScriptStaging n) = do putWord8 43

193+ put n

194+ put (FancyMsg xs) = do putWord8 44

195+ put xs

192 get = do i <- getWord8

196 get = do i <- getWord8

193 case i of

197 case i of

194 0 -> fmap Msg get

198 0 -> fmap Msg get

@@ -230,8 +234,8 @@ instance Binary a => Binary (Err' a) where

230 26 -> fmap NoRewriting get

234 26 -> fmap NoRewriting get

231 27 -> do x <- get ; y <- get

235 27 -> do x <- get ; y <- get

232 return $ At x y

236 return $ At x y

233− 28 -> do x <- get ; y <- get ; z <- get

237+ 28 -> do w <- get; x <- get ; y <- get ; z <- get

234− return $ Elaborating x y z

238+ return $ Elaborating w x y z

235 29 -> do w <- get ; x <- get ; y <- get ; z <- get

239 29 -> do w <- get ; x <- get ; y <- get ; z <- get

236 return $ ElaboratingArg w x y z

240 return $ ElaboratingArg w x y z

237 30 -> fmap ProviderError get

241 30 -> fmap ProviderError get

@@ -259,6 +263,8 @@ instance Binary a => Binary (Err' a) where

259 return $ UnknownImplicit x y

263 return $ UnknownImplicit x y

260 41 -> fmap NoValidAlts get

264 41 -> fmap NoValidAlts get

261 42 -> fmap RunningElabScript get

265 42 -> fmap RunningElabScript get

266+ 43 -> fmap ElabScriptStaging get

267+ 44 -> fmap FancyMsg get

262 _ -> error "Corrupted binary data for Err'"

268 _ -> error "Corrupted binary data for Err'"

263----- Generated by 'derive'

269----- Generated by 'derive'

264

270

@@ -284,6 +290,9 @@ instance Binary FC where

284 return (FileFC x1)

290 return (FileFC x1)

285 _ -> error "Corrupted binary data for FC"

291 _ -> error "Corrupted binary data for FC"

286

292

293+instance Binary FC' where

294+ put (FC' fc) = put fc

295+ get = fmap FC' get

287

296

288instance Binary Name where

297instance Binary Name where

289 put x

298 put x

@@ -296,10 +305,9 @@ instance Binary Name where

296 MN x1 x2 -> do putWord8 2

305 MN x1 x2 -> do putWord8 2

297 put x1

306 put x1

298 put x2

307 put x2

299− NErased -> putWord8 3

300− SN x1 -> do putWord8 4

308+ SN x1 -> do putWord8 3

301 put x1

309 put x1

302− SymRef x1 -> do putWord8 5

310+ SymRef x1 -> do putWord8 4

303 put x1

311 put x1

304 get

312 get

305 = do i <- getWord8

313 = do i <- getWord8

@@ -312,10 +320,9 @@ instance Binary Name where

312 2 -> do x1 <- get

320 2 -> do x1 <- get

313 x2 <- get

321 x2 <- get

314 return (MN x1 x2)

322 return (MN x1 x2)

315− 3 -> return NErased

316− 4 -> do x1 <- get

323+ 3 -> do x1 <- get

317 return (SN x1)

324 return (SN x1)

318− 5 -> do x1 <- get

325+ 4 -> do x1 <- get

319 return (SymRef x1)

326 return (SymRef x1)

320 _ -> error "Corrupted binary data for Name"

327 _ -> error "Corrupted binary data for Name"

321

328

@@ -334,7 +341,7 @@ instance Binary SpecialName where

334 put x2

341 put x2

335 MethodN x1 -> do putWord8 3

342 MethodN x1 -> do putWord8 3

336 put x1

343 put x1

337− CaseN x1 -> do putWord8 4; put x1

344+ CaseN x1 x2 -> do putWord8 4; put x1; put x2

338 ElimN x1 -> do putWord8 5; put x1

345 ElimN x1 -> do putWord8 5; put x1

339 InstanceCtorN x1 -> do putWord8 6; put x1

346 InstanceCtorN x1 -> do putWord8 6; put x1

340 WithN x1 x2 -> do putWord8 7

347 WithN x1 x2 -> do putWord8 7

@@ -359,7 +366,8 @@ instance Binary SpecialName where

359 3 -> do x1 <- get

366 3 -> do x1 <- get

360 return (MethodN x1)

367 return (MethodN x1)

361 4 -> do x1 <- get

368 4 -> do x1 <- get

369+ x2 <- get

362− return (CaseN x1)

370+ return (CaseN x1 x2)

363 5 -> do x1 <- get

371 5 -> do x1 <- get

364 return (ElimN x1)

372 return (ElimN x1)

365 6 -> do x1 <- get

373 6 -> do x1 <- get

@@ -452,9 +460,7 @@ instance Binary Raw where

452 RType -> putWord8 3

460 RType -> putWord8 3

453 RConstant x1 -> do putWord8 4

461 RConstant x1 -> do putWord8 4

454 put x1

462 put x1

455− RForce x1 -> do putWord8 5

456− put x1

457− RUType x1 -> do putWord8 6

463+ RUType x1 -> do putWord8 5

458 put x1

464 put x1

459 get

465 get

460 = do i <- getWord8

466 = do i <- getWord8

@@ -472,18 +478,17 @@ instance Binary Raw where

472 4 -> do x1 <- get

478 4 -> do x1 <- get

473 return (RConstant x1)

479 return (RConstant x1)

474 5 -> do x1 <- get

480 5 -> do x1 <- get

475− return (RForce x1)

476− 6 -> do x1 <- get

477 return (RUType x1)

481 return (RUType x1)

478 _ -> error "Corrupted binary data for Raw"

482 _ -> error "Corrupted binary data for Raw"

479

483

480instance Binary ImplicitInfo where

484instance Binary ImplicitInfo where

481 put x

485 put x

482 = case x of

486 = case x of

483− Impl x1 -> put x1

487+ Impl x1 x2 -> do put x1; put x2

484 get

488 get

485 = do x1 <- get

489 = do x1 <- get

490+ x2 <- get

486− return (Impl x1)

491+ return (Impl x1 x2)

487

492

488instance (Binary b) => Binary (Binder b) where

493instance (Binary b) => Binary (Binder b) where

489 put x

494 put x

src/Idris/Core/Constraints.hs+5−7

@@ -167,13 +167,11 @@ solve maxUniverseLevel ucs =

167 doms <- gets domainStore

168 let (oldDom@(Domain _ upper), suspects) = doms M.! Var var

169 let newDom = Domain lower upper

170− when (wipeOut newDom) $ lift $ Error $ At (ufc suspect) $ Msg $ unlines

170+ when (wipeOut newDom) $

171− $ "Universe inconsistency."

171+ lift $ Error $

172− : ("Working on: " ++ show (UVar var))

172+ UniverseError (ufc suspect) (UVar var)

173− : ("Old domain: " ++ show oldDom)

173+ (asPair oldDom) (asPair newDom)

174− : ("New domain: " ++ show newDom)

175− : "Involved constraints: "

176− : map (("\t"++) . show) (suspect : S.toList suspects)

174+ (suspect : S.toList suspects)

177 modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }

175 modify $ \ st -> st { domainStore = M.insert (Var var) (newDom, S.insert suspect suspects) doms }

178 addToQueueLHS (uconstraint suspect) (Var var)

176 addToQueueLHS (uconstraint suspect) (Var var)

179 updateLowerBoundOf _ UVal{} _ = return ()

177 updateLowerBoundOf _ UVal{} _ = return ()

src/Idris/Core/DeepSeq.hs+9−6

@@ -13,7 +13,6 @@ instance NFData Name where

13 rnf (UN x1) = rnf x1 `seq` ()

14 rnf (NS x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

15 rnf (MN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

16− rnf NErased = ()

17 rnf (SN x1) = rnf x1 `seq` ()

16 rnf (SN x1) = rnf x1 `seq` ()

18 rnf (SymRef x1) = rnf x1 `seq` ()

17 rnf (SymRef x1) = rnf x1 `seq` ()

19

18

@@ -65,7 +64,7 @@ instance NFData SpecialName where

65 rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

64 rnf (InstanceN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

66 rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

65 rnf (ParentN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

67 rnf (MethodN x1) = rnf x1 `seq` ()

66 rnf (MethodN x1) = rnf x1 `seq` ()

68− rnf (CaseN x1) = rnf x1 `seq` ()

67+ rnf (CaseN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

69 rnf (ElimN x1) = rnf x1 `seq` ()

68 rnf (ElimN x1) = rnf x1 `seq` ()

70 rnf (InstanceCtorN x1) = rnf x1 `seq` ()

69 rnf (InstanceCtorN x1) = rnf x1 `seq` ()

71 rnf (MetaN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

70 rnf (MetaN x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -81,7 +80,6 @@ instance NFData Raw where

81 rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

80 rnf (RApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

82 rnf RType = ()

81 rnf RType = ()

83 rnf (RUType x1) = rnf x1 `seq` ()

82 rnf (RUType x1) = rnf x1 `seq` ()

84− rnf (RForce x1) = rnf x1 `seq` ()

85 rnf (RConstant x1) = x1 `seq` ()

83 rnf (RConstant x1) = x1 `seq` ()

86

84

87instance NFData FC where

85instance NFData FC where

@@ -89,6 +87,9 @@ instance NFData FC where

89 rnf NoFC = ()

87 rnf NoFC = ()

90 rnf (FileFC f) = rnf f `seq` ()

88 rnf (FileFC f) = rnf f `seq` ()

91

89

90+instance NFData FC' where

91+ rnf (FC' fc) = rnf fc `seq` ()

92+

92instance NFData Provenance where

93instance NFData Provenance where

93 rnf ExpectedType = ()

94 rnf ExpectedType = ()

94 rnf InferredVal = ()

95 rnf InferredVal = ()

@@ -148,13 +149,15 @@ instance NFData Err where

148 rnf (ProofSearchFail x1) = rnf x1 `seq` ()

149 rnf (ProofSearchFail x1) = rnf x1 `seq` ()

149 rnf (NoRewriting x1) = rnf x1 `seq` ()

150 rnf (NoRewriting x1) = rnf x1 `seq` ()

150 rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

151 rnf (At x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

151− rnf (Elaborating x1 x2 x3)

152+ rnf (Elaborating x1 x2 x3 x4)

152− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

153+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

153 rnf (ProviderError x1) = rnf x1 `seq` ()

154 rnf (ProviderError x1) = rnf x1 `seq` ()

154 rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

155 rnf (LoadingFailed x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

155 rnf (ElabScriptDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

156 rnf (ElabScriptDebug x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

156 rnf (ElabScriptStuck x1) = rnf x1 `seq` ()

157 rnf (ElabScriptStuck x1) = rnf x1 `seq` ()

157 rnf (RunningElabScript x1) = rnf x1 `seq` ()

158 rnf (RunningElabScript x1) = rnf x1 `seq` ()

159+ rnf (ElabScriptStaging x1) = rnf x1 `seq` ()

160+ rnf (FancyMsg x1) = rnf x1 `seq` ()

158

161

159instance NFData ErrorReportPart where

162instance NFData ErrorReportPart where

160 rnf (TextPart x1) = rnf x1 `seq` ()

163 rnf (TextPart x1) = rnf x1 `seq` ()

@@ -164,7 +167,7 @@ instance NFData ErrorReportPart where

164 rnf (SubReport x1) = rnf x1 `seq` ()

167 rnf (SubReport x1) = rnf x1 `seq` ()

165

168

166instance NFData ImplicitInfo where

169instance NFData ImplicitInfo where

167− rnf (Impl x1) = rnf x1 `seq` ()

170+ rnf (Impl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

168

171

169instance (NFData b) => NFData (Binder b) where

172instance (NFData b) => NFData (Binder b) where

170 rnf (Lam x1) = rnf x1 `seq` ()

173 rnf (Lam x1) = rnf x1 `seq` ()

src/Idris/Core/Elaborate.hs+58−9

@@ -119,8 +119,8 @@ transformErr f elab = do s <- get

119 rewriteErr (ProofSearchFail e) = ProofSearchFail (rewriteErr e)

120 rewriteErr e = f e

121

122−errAt :: String -> Name -> Elab' aux a -> Elab' aux a

122+errAt :: String -> Name -> Maybe Type -> Elab' aux a -> Elab' aux a

123−errAt thing n = transformErr (Elaborating thing n)

123+errAt thing n ty = transformErr (Elaborating thing n ty)

124

125

126erun :: FC -> Elab' aux a -> Elab' aux a

@@ -353,6 +353,9 @@ claimFn n bn t = processTactic' (ClaimFn n bn t)

353unifyGoal :: Raw -> Elab' aux ()

354unifyGoal t = processTactic' (UnifyGoal t)

355

356+unifyTerms :: Raw -> Raw -> Elab' aux ()

357+unifyTerms t1 t2 = processTactic' (UnifyTerms t1 t2)

358+

356exact :: Raw -> Elab' aux ()

359exact :: Raw -> Elab' aux ()

357exact t = processTactic' (Exact t)

360exact t = processTactic' (Exact t)

358

361

@@ -711,8 +714,8 @@ checkPiGoal n

711 = do g <- goal

714 = do g <- goal

712 case g of

715 case g of

713 Bind _ (Pi _ _ _) _ -> return ()

716 Bind _ (Pi _ _ _) _ -> return ()

714− _ -> do a <- getNameFrom (sMN 0 "pargTy")

717+ _ -> do a <- getNameFrom (sMN 0 "__pargTy")

715− b <- getNameFrom (sMN 0 "pretTy")

718+ b <- getNameFrom (sMN 0 "__pretTy")

716 f <- getNameFrom (sMN 0 "pf")

719 f <- getNameFrom (sMN 0 "pf")

717 claim a RType

720 claim a RType

718 claim b RType

721 claim b RType

@@ -724,9 +727,14 @@ checkPiGoal n

724 focus f

727 focus f

725

728

726simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

729simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

727−simple_app infer fun arg str =

730+simple_app infer fun arg str =

731+ try (dep_app fun arg str)

732+ (infer_app infer fun arg str)

733+

734+infer_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

735+infer_app infer fun arg str =

728− do a <- getNameFrom (sMN 0 "argTy")

736+ do a <- getNameFrom (sMN 0 "__argTy")

729− b <- getNameFrom (sMN 0 "retTy")

737+ b <- getNameFrom (sMN 0 "__retTy")

730 f <- getNameFrom (sMN 0 "f")

738 f <- getNameFrom (sMN 0 "f")

731 s <- getNameFrom (sMN 0 "s")

739 s <- getNameFrom (sMN 0 "s")

732 claim a RType

740 claim a RType

@@ -755,8 +763,49 @@ simple_app infer fun arg str =

755 when (a `elem` hs) $ do movelast a

763 when (a `elem` hs) $ do movelast a

756 when (b `elem` hs) $ do movelast b

764 when (b `elem` hs) $ do movelast b

757 end_unify

765 end_unify

758− where

766+

759− regretWith err = try regret (lift $ tfail err)

767+dep_app :: Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

768+dep_app fun arg str =

769+ do a <- getNameFrom (sMN 0 "__argTy")

770+ b <- getNameFrom (sMN 0 "__retTy")

771+ fty <- getNameFrom (sMN 0 "__fnTy")

772+ f <- getNameFrom (sMN 0 "f")

773+ s <- getNameFrom (sMN 0 "s")

774+ claim a RType

775+ claim fty RType

776+ claim f (Var fty)

777+ tm <- get_term

778+ g <- goal

779+ start_unify s

780+ claim s (Var a)

781+

782+ prep_fill f [s]

783+ focus f; attack; fun

784+ end_unify

785+ fty <- goal

786+ solve

787+ focus s; attack;

788+ ctxt <- get_context

789+ env <- get_env

790+ case normalise ctxt env fty of

791+ -- if f gives a function type, unify our argument type with

792+ -- f's expected argument type

793+ Bind _ (Pi _ argty _) _ -> unifyGoal (forget argty)

794+ -- Can't infer a type for 'f', so fail here (and drop back to

795+ -- simply typed application where we infer the type for f)

796+ _ -> fail "Can't make type"

797+ end_unify

798+ arg

799+ solve

800+ complete_fill

801+

802+ -- We don't need a and b in the hole queue any more since they were

803+ -- just for checking f, so move them to the end. If they never end up

804+ -- getting solved, we'll get an 'Incomplete term' error.

805+ hs <- get_holes

806+ when (a `elem` hs) $ do movelast a

807+ when (b `elem` hs) $ do movelast b

808+ end_unify

760

809

761-- Abstract over an argument of unknown type, giving a name for the hole

810-- Abstract over an argument of unknown type, giving a name for the hole

762-- which we'll fill with the argument type too.

811-- which we'll fill with the argument type too.

src/Idris/Core/Evaluate.hs+10−1

@@ -2,7 +2,8 @@

2 PatternGuards #-}

3{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

4

5−module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll, toValue, quoteTerm,

5+module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,

6+ normaliseAll, normaliseBlocking, toValue, quoteTerm,

6 rt_simplify, simplify, specialise, hnf, convEq, convEq',

7 rt_simplify, simplify, specialise, hnf, convEq, convEq',

7 Def(..), CaseInfo(..), CaseDefs(..),

8 Def(..), CaseInfo(..), CaseDefs(..),

8 Accessibility(..), Totality(..), PReason(..), MetaInformation(..),

9 Accessibility(..), Totality(..), PReason(..), MetaInformation(..),

@@ -79,11 +80,19 @@ normaliseC ctxt env t

79 = evalState (do val <- eval False ctxt [] (map finalEntry env) t []

80 = evalState (do val <- eval False ctxt [] (map finalEntry env) t []

80 quote 0 val) initEval

81 quote 0 val) initEval

81

82

83+-- | Normalise everything, whether abstract, private or public

82normaliseAll :: Context -> Env -> TT Name -> TT Name

84normaliseAll :: Context -> Env -> TT Name -> TT Name

83normaliseAll ctxt env t

85normaliseAll ctxt env t

84 = evalState (do val <- eval False ctxt [] (map finalEntry env) t [AtREPL]

86 = evalState (do val <- eval False ctxt [] (map finalEntry env) t [AtREPL]

85 quote 0 val) initEval

87 quote 0 val) initEval

86

88

89+-- | As normaliseAll, but with an explicit list of names *not* to reduce

90+normaliseBlocking :: Context -> Env -> [Name] -> TT Name -> TT Name

91+normaliseBlocking ctxt env blocked t

92+ = evalState (do val <- eval False ctxt (map (\n -> (n, 0)) blocked)

93+ (map finalEntry env) t [AtREPL]

94+ quote 0 val) initEval

95+

87normalise :: Context -> Env -> TT Name -> TT Name

96normalise :: Context -> Env -> TT Name -> TT Name

88normalise = normaliseTrace False

97normalise = normaliseTrace False

89

98

src/Idris/Core/Execute.hs+11

@@ -349,6 +349,17 @@ execForeign env ctxt arity ty fn xs onfail

349 "The argument to fileEOF should be a file handle, but it was " ++

350 show handle ++

351 ". Are all cases covered?"

352+ | Just (FFun "fileError" [(_,handle)] _) <- foreignFromTT arity ty fn xs

353+ = case handle of

354+ -- errors handled differently in Haskell than in C, so if

355+ -- there's been an error we'll have had an exception already.

356+ -- Therefore, assume we're okay.

357+ EHandle h -> do let res = ioWrap (EConstant (I 0))

358+ execApp env ctxt res (drop arity xs)

359+ _ -> execFail . Msg $

360+ "The argument to fileError should be a file handle, but it was " ++

361+ show handle ++

362+ ". Are all cases covered?"

352 | Just (FFun "fileClose" [(_,handle)] _) <- foreignFromTT arity ty fn xs

363 | Just (FFun "fileClose" [(_,handle)] _) <- foreignFromTT arity ty fn xs

353 = case handle of

364 = case handle of

354 EHandle h -> do execIO $ hClose h

365 EHandle h -> do execIO $ hClose h

src/Idris/Core/ProofState.hs+20−2

@@ -91,6 +91,7 @@ data Tactic = Attack

91 | MatchProblems Bool

92 | UnifyProblems

93 | UnifyGoal Raw

94+ | UnifyTerms Raw Raw

94 | ProofState

95 | ProofState

95 | Undo

96 | Undo

96 | QED

97 | QED

@@ -408,6 +409,8 @@ instanceArg n ctxt env (Bind x (Hole t) sc)

408 ps { holes = (hs \\ [x]) ++ [x],

409 ps { holes = (hs \\ [x]) ++ [x],

409 instances = x:is })

410 instances = x:is })

410 return (Bind x (Hole t) sc)

411 return (Bind x (Hole t) sc)

412+instanceArg n ctxt env _

413+ = fail "The current focus is not a hole."

411

414

412autoArg :: Name -> RunTactic

415autoArg :: Name -> RunTactic

413autoArg n ctxt env (Bind x (Hole t) sc)

416autoArg n ctxt env (Bind x (Hole t) sc)

@@ -418,6 +421,8 @@ autoArg n ctxt env (Bind x (Hole t) sc)

418 autos = (x, (while_elaborating ps, refsIn t)) : autos ps }

421 autos = (x, (while_elaborating ps, refsIn t)) : autos ps }

419 Just _ -> ps)

422 Just _ -> ps)

420 return (Bind x (Hole t) sc)

423 return (Bind x (Hole t) sc)

424+autoArg n ctxt env _

425+ = fail "The current focus not a hole."

421

426

422setinj :: Name -> RunTactic

427setinj :: Name -> RunTactic

423setinj n ctxt env (Bind x b sc)

428setinj n ctxt env (Bind x b sc)

@@ -439,6 +444,7 @@ defer dropped n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

439 mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar 0))) (mkTy bs t)

444 mkTy ((n,b) : bs) t = Bind n (Pi Nothing (binderTy b) (TType (UVar 0))) (mkTy bs t)

440

445

441 getP (n, b) = P Bound n (binderTy b)

446 getP (n, b) = P Bound n (binderTy b)

447+defer dropped n ctxt env _ = fail "Can't defer a non-hole focus."

442

448

443-- as defer, but build the type and application explicitly

449-- as defer, but build the type and application explicitly

444deferType :: Name -> Raw -> [Name] -> RunTactic

450deferType :: Name -> Raw -> [Name] -> RunTactic

@@ -454,6 +460,7 @@ deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

454 getP n = case lookup n env of

460 getP n = case lookup n env of

455 Just b -> P Bound n (binderTy b)

461 Just b -> P Bound n (binderTy b)

456 Nothing -> error ("deferType can't find " ++ show n)

462 Nothing -> error ("deferType can't find " ++ show n)

463+deferType _ _ _ _ _ _ = fail "Can't defer a non-hole focus."

457

464

458regret :: RunTactic

465regret :: RunTactic

459regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =

466regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =

@@ -462,12 +469,21 @@ regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =

462 return sc

469 return sc

463regret ctxt env (Bind x (Hole t) _)

470regret ctxt env (Bind x (Hole t) _)

464 = fail $ show x ++ " : " ++ show t ++ " is not solved..."

471 = fail $ show x ++ " : " ++ show t ++ " is not solved..."

472+regret _ _ _ = fail "The current focus is not a hole."

465

473

466unifyGoal :: Raw -> RunTactic

474unifyGoal :: Raw -> RunTactic

467unifyGoal tm ctxt env h@(Bind x b sc) =

475unifyGoal tm ctxt env h@(Bind x b sc) =

468 do (tmv, _) <- lift $ check ctxt env tm

476 do (tmv, _) <- lift $ check ctxt env tm

469 ns' <- unify' ctxt env (binderTy b, Nothing) (tmv, Nothing)

477 ns' <- unify' ctxt env (binderTy b, Nothing) (tmv, Nothing)

470 return h

478 return h

479+unifyGoal _ _ _ _ = fail "The focus is not a binder."

480+

481+unifyTerms :: Raw -> Raw -> RunTactic

482+unifyTerms tm1 tm2 ctxt env h =

483+ do (tm1v, _) <- lift $ check ctxt env tm1

484+ (tm2v, _) <- lift $ check ctxt env tm2

485+ ns' <- unify' ctxt env (tm1v, Nothing) (tm2v, Nothing)

486+ return h

471

487

472exact :: Raw -> RunTactic

488exact :: Raw -> RunTactic

473exact guess ctxt env (Bind x (Hole ty) sc) =

489exact guess ctxt env (Bind x (Hole ty) sc) =

@@ -714,7 +730,7 @@ casetac tm induction ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

714 let tmt' = normalise ctxt env tmt

730 let tmt' = normalise ctxt env tmt

715 let (tacn, tacstr, tactt) = if induction

731 let (tacn, tacstr, tactt) = if induction

716 then (ElimN, "eliminator", "Induction")

732 then (ElimN, "eliminator", "Induction")

717− else (CaseN, "case analysis", "Case analysis")

733+ else (CaseN (FC' emptyFC), "case analysis", "Case analysis")

718 case unApply tmt' of

734 case unApply tmt' of

719 (P _ tnm _, tyargs) -> do

735 (P _ tnm _, tyargs) -> do

720 case lookupTy (SN (tacn tnm)) ctxt of

736 case lookupTy (SN (tacn tnm)) ctxt of

@@ -870,7 +886,7 @@ updateProv ns p = p

870

886

871updateError [] err = err

887updateError [] err = err

872updateError ns (At f e) = At f (updateError ns e)

888updateError ns (At f e) = At f (updateError ns e)

873−updateError ns (Elaborating s n e) = Elaborating s n (updateError ns e)

889+updateError ns (Elaborating s n ty e) = Elaborating s n ty (updateError ns e)

874updateError ns (ElaboratingArg f a env e)

890updateError ns (ElaboratingArg f a env e)

875 = ElaboratingArg f a env (updateError ns e)

891 = ElaboratingArg f a env (updateError ns e)

876updateError ns (CantUnify b (l,lp) (r,rp) e xs sc)

892updateError ns (CantUnify b (l,lp) (r,rp) e xs sc)

@@ -1105,3 +1121,5 @@ process t h = tactic (Just h) (mktac t)

1105 mktac (SetInjective n) = setinj n

1121 mktac (SetInjective n) = setinj n

1106 mktac (MoveLast n) = movelast n

1122 mktac (MoveLast n) = movelast n

1107 mktac (UnifyGoal r) = unifyGoal r

1123 mktac (UnifyGoal r) = unifyGoal r

1124+ mktac (UnifyTerms x y) = unifyTerms x y

1125+

src/Idris/Core/TT.hs+52−25

@@ -58,6 +58,7 @@ import Debug.Trace

58import qualified Data.Map.Strict as Map

59import Data.Char

60import Data.Data (Data)

61+import Data.Monoid (mconcat)

61import Numeric (showIntAtBase)

62import Numeric (showIntAtBase)

62import qualified Data.Text as T

63import qualified Data.Text as T

63import Data.List hiding (group, insert)

64import Data.List hiding (group, insert)

@@ -148,7 +149,7 @@ instance Eq FC where

148 _ == _ = True

149 _ == _ = True

149

150

150-- | FC with equality

151-- | FC with equality

151−newtype FC' = FC' { unwrapFC :: FC }

152+newtype FC' = FC' { unwrapFC :: FC } deriving (Data, Typeable, Ord)

152

153

153instance Eq FC' where

154instance Eq FC' where

154 FC' fc == FC' fc' = fcEq fc fc'

155 FC' fc == FC' fc' = fcEq fc fc'

@@ -157,6 +158,9 @@ instance Eq FC' where

157 fcEq (FileFC f) (FileFC f') = f == f'

158 fcEq (FileFC f) (FileFC f') = f == f'

158 fcEq _ _ = False

159 fcEq _ _ = False

159

160

161+instance Show FC' where

162+ showsPrec d (FC' fc) = showsPrec d fc

163+

160-- | Empty source location

164-- | Empty source location

161emptyFC :: FC

165emptyFC :: FC

162emptyFC = NoFC

166emptyFC = NoFC

@@ -283,7 +287,7 @@ data Err' t

283 | ProofSearchFail (Err' t)

287 | ProofSearchFail (Err' t)

284 | NoRewriting t

288 | NoRewriting t

285 | At FC (Err' t)

289 | At FC (Err' t)

286− | Elaborating String Name (Err' t)

290+ | Elaborating String Name (Maybe t) (Err' t)

287 | ElaboratingArg Name Name [(Name, Name)] (Err' t)

291 | ElaboratingArg Name Name [(Name, Name)] (Err' t)

288 | ProviderError String

292 | ProviderError String

289 | LoadingFailed String (Err' t)

293 | LoadingFailed String (Err' t)

@@ -293,6 +297,8 @@ data Err' t

293 -- ^ User-specified message, proof term, goals with context (first goal is focused)

297 -- ^ User-specified message, proof term, goals with context (first goal is focused)

294 | ElabScriptStuck t

298 | ElabScriptStuck t

295 | RunningElabScript (Err' t) -- ^ The error occurred during a top-level elaboration script

299 | RunningElabScript (Err' t) -- ^ The error occurred during a top-level elaboration script

300+ | ElabScriptStaging Name

301+ | FancyMsg [ErrorReportPart]

296 deriving (Eq, Functor, Data, Typeable)

302 deriving (Eq, Functor, Data, Typeable)

297

303

298type Err = Err' Term

304type Err = Err' Term

@@ -354,7 +360,7 @@ instance Sized Err where

354 size (IncompleteTerm trm) = size trm

360 size (IncompleteTerm trm) = size trm

355 size ProgramLineComment = 1

361 size ProgramLineComment = 1

356 size (At fc err) = size fc + size err

362 size (At fc err) = size fc + size err

357− size (Elaborating _ n err) = size err

363+ size (Elaborating _ _ _ err) = size err

358 size (ElaboratingArg _ _ _ err) = size err

364 size (ElaboratingArg _ _ _ err) = size err

359 size (ProviderError msg) = length msg

365 size (ProviderError msg) = length msg

360 size (LoadingFailed fn e) = 1 + length fn + size e

366 size (LoadingFailed fn e) = 1 + length fn + size e

@@ -375,7 +381,11 @@ instance Show Err where

375 show (At f e) = show f ++ ":" ++ show e

381 show (At f e) = show f ++ ":" ++ show e

376 show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++

382 show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++

377 show x ++ ": " ++ show e

383 show x ++ ": " ++ show e

378− show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e

384+ show (Elaborating what n ty e) = "Elaborating " ++ what ++ show n ++

385+ showType ty ++ ":" ++ show e

386+ where

387+ showType Nothing = ""

388+ showType (Just ty) = " with expected type " ++ show ty

379 show (ProofSearchFail e) = "Proof search fail: " ++ show e

389 show (ProofSearchFail e) = "Proof search fail: " ++ show e

380 show (InfiniteUnify _ _ _) = "InfiniteUnify"

390 show (InfiniteUnify _ _ _) = "InfiniteUnify"

381 show (UnifyScope _ _ _ _) = "UnifyScope"

391 show (UnifyScope _ _ _ _) = "UnifyScope"

@@ -442,7 +452,6 @@ traceWhen False _ a = a

442data Name = UN !T.Text -- ^ User-provided name

452data Name = UN !T.Text -- ^ User-provided name

443 | NS !Name [T.Text] -- ^ Root, namespaces

453 | NS !Name [T.Text] -- ^ Root, namespaces

444 | MN !Int !T.Text -- ^ Machine chosen names

454 | MN !Int !T.Text -- ^ Machine chosen names

445− | NErased -- ^ Name of something which is never used in scope

446 | SN !SpecialName -- ^ Decorated function names

455 | SN !SpecialName -- ^ Decorated function names

447 | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

456 | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

448 deriving (Eq, Ord, Data, Typeable)

457 deriving (Eq, Ord, Data, Typeable)

@@ -479,7 +488,7 @@ data SpecialName = WhereN !Int !Name !Name

479 | InstanceN !Name [T.Text]

488 | InstanceN !Name [T.Text]

480 | ParentN !Name !T.Text

489 | ParentN !Name !T.Text

481 | MethodN !Name

490 | MethodN !Name

482− | CaseN !Name

491+ | CaseN !FC' !Name

483 | ElimN !Name

492 | ElimN !Name

484 | InstanceCtorN !Name

493 | InstanceCtorN !Name

485 | MetaN !Name !Name

494 | MetaN !Name !Name

@@ -509,7 +518,6 @@ instance Pretty Name OutputAnnotation where

509 pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

518 pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

510 pretty n@(SymRef i) = annotate (AnnName n Nothing Nothing Nothing) $

519 pretty n@(SymRef i) = annotate (AnnName n Nothing Nothing Nothing) $

511 text $ "##symbol" ++ show i ++ "##"

520 text $ "##symbol" ++ show i ++ "##"

512− pretty NErased = annotate (AnnName NErased Nothing Nothing Nothing) $ text "_"

513

521

514instance Pretty [Name] OutputAnnotation where

522instance Pretty [Name] OutputAnnotation where

515 pretty = encloseSep empty empty comma . map pretty

523 pretty = encloseSep empty empty comma . map pretty

@@ -521,7 +529,6 @@ instance Show Name where

521 show (MN i s) = "{" ++ str s ++ show i ++ "}"

529 show (MN i s) = "{" ++ str s ++ show i ++ "}"

522 show (SN s) = show s

530 show (SN s) = show s

523 show (SymRef i) = "##symbol" ++ show i ++ "##"

531 show (SymRef i) = "##symbol" ++ show i ++ "##"

524− show NErased = "_"

525

532

526instance Show SpecialName where

533instance Show SpecialName where

527 show (WhereN i p c) = show p ++ ", " ++ show c

534 show (WhereN i p c) = show p ++ ", " ++ show c

@@ -529,7 +536,8 @@ instance Show SpecialName where

529 show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl

536 show (InstanceN cl inst) = showSep ", " (map T.unpack inst) ++ " instance of " ++ show cl

530 show (MethodN m) = "method " ++ show m

537 show (MethodN m) = "method " ++ show m

531 show (ParentN p c) = show p ++ "#" ++ T.unpack c

538 show (ParentN p c) = show p ++ "#" ++ T.unpack c

532− show (CaseN n) = "case block in " ++ show n

539+ show (CaseN fc n) = "case block in " ++ show n ++

540+ if fc == FC' emptyFC then "" else " at " ++ show fc

533 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

541 show (ElimN n) = "<<" ++ show n ++ " eliminator>>"

534 show (InstanceCtorN n) = "constructor of " ++ show n

542 show (InstanceCtorN n) = "constructor of " ++ show n

535 show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>"

543 show (MetaN parent meta) = "<<" ++ show parent ++ " " ++ show meta ++ ">>"

@@ -546,12 +554,20 @@ showCG (SN s) = showCG' s

546 showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst)

554 showCG' (InstanceN cl inst) = '@':showCG cl ++ '$':showSep ":" (map T.unpack inst)

547 showCG' (MethodN m) = '!':showCG m

555 showCG' (MethodN m) = '!':showCG m

548 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

556 showCG' (ParentN p c) = showCG p ++ "#" ++ show c

549− showCG' (CaseN c) = showCG c ++ "_case"

557+ showCG' (CaseN fc c) = showCG c ++ showFC' fc ++ "_case"

550 showCG' (ElimN sn) = showCG sn ++ "_elim"

558 showCG' (ElimN sn) = showCG sn ++ "_elim"

551 showCG' (InstanceCtorN n) = showCG n ++ "_ictor"

559 showCG' (InstanceCtorN n) = showCG n ++ "_ictor"

552 showCG' (MetaN parent meta) = showCG parent ++ "_meta_" ++ showCG meta

560 showCG' (MetaN parent meta) = showCG parent ++ "_meta_" ++ showCG meta

561+ showFC' (FC' NoFC) = ""

562+ showFC' (FC' (FileFC f)) = "_" ++ cgFN f

563+ showFC' (FC' (FC f s e))

564+ | s == e = "_" ++ cgFN f ++

565+ "_" ++ show (fst s) ++ "_" ++ show (snd s)

566+ | otherwise = "_" ++ cgFN f ++

567+ "_" ++ show (fst s) ++ "_" ++ show (snd s) ++

568+ "_" ++ show (fst e) ++ "_" ++ show (snd e)

569+ cgFN = concatMap (\c -> if not (isDigit c || isLetter c) then "__" else [c])

553showCG (SymRef i) = error "can't do codegen for a symbol reference"

570showCG (SymRef i) = error "can't do codegen for a symbol reference"

554−showCG NErased = "_"

555

571

556

572

557-- |Contexts allow us to map names to things. A root name maps to a collection

573-- |Contexts allow us to map names to things. A root name maps to a collection

@@ -776,7 +792,6 @@ data Raw = Var Name

776 | RApp Raw Raw

792 | RApp Raw Raw

777 | RType

793 | RType

778 | RUType Universe

794 | RUType Universe

779− | RForce Raw

780 | RConstant Const

795 | RConstant Const

781 deriving (Show, Eq, Data, Typeable)

796 deriving (Show, Eq, Data, Typeable)

782

797

@@ -786,7 +801,6 @@ instance Sized Raw where

786 size (RApp left right) = 1 + size left + size right

801 size (RApp left right) = 1 + size left + size right

787 size RType = 1

802 size RType = 1

788 size (RUType _) = 1

803 size (RUType _) = 1

789− size (RForce raw) = 1 + size raw

790 size (RConstant const) = size const

804 size (RConstant const) = size const

791

805

792instance Pretty Raw OutputAnnotation where

806instance Pretty Raw OutputAnnotation where

@@ -797,7 +811,7 @@ deriving instance Binary Raw

797deriving instance NFData Raw

811deriving instance NFData Raw

798!-}

812!-}

799

813

800−data ImplicitInfo = Impl { tcinstance :: Bool }

814+data ImplicitInfo = Impl { tcinstance :: Bool, toplevel_imp :: Bool }

801 deriving (Show, Eq, Ord, Data, Typeable)

815 deriving (Show, Eq, Ord, Data, Typeable)

802

816

803{-!

817{-!

@@ -812,27 +826,44 @@ deriving instance NFData ImplicitInfo

812-- the types of bindings (and their values, if any); the attached identifiers are part

826-- the types of bindings (and their values, if any); the attached identifiers are part

813-- of the 'Bind' constructor for the 'TT' type.

827-- of the 'Bind' constructor for the 'TT' type.

814data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

828data Binder b = Lam { binderTy :: !b {-^ type annotation for bound variable-}}

829+ -- ^ A function binding

815 | Pi { binderImpl :: Maybe ImplicitInfo,

830 | Pi { binderImpl :: Maybe ImplicitInfo,

816 binderTy :: !b,

831 binderTy :: !b,

817 binderKind :: !b }

832 binderKind :: !b }

818− {-^ A binding that occurs in a function type expression, e.g. @(x:Int) -> ...@

833+ -- ^ A binding that occurs in a function type

834+ -- expression, e.g. @(x:Int) -> ...@ The 'binderImpl'

819− The 'binderImpl' flag says whether it was a scoped implicit

835+ -- flag says whether it was a scoped implicit

820− (i.e. forall bound) in the high level Idris, but otherwise

836+ -- (i.e. forall bound) in the high level Idris, but

821− has no relevance in TT. -}

837+ -- otherwise has no relevance in TT.

822 | Let { binderTy :: !b,

838 | Let { binderTy :: !b,

823 binderVal :: b {-^ value for bound variable-}}

839 binderVal :: b {-^ value for bound variable-}}

824 -- ^ A binding that occurs in a @let@ expression

840 -- ^ A binding that occurs in a @let@ expression

825 | NLet { binderTy :: !b,

841 | NLet { binderTy :: !b,

826 binderVal :: b }

842 binderVal :: b }

843+ -- ^ NLet is an intermediate product in the evaluator

844+ -- that's used for temporarily naming locals during

845+ -- reduction. It won't occur outside the evaluator.

827 | Hole { binderTy :: !b}

846 | Hole { binderTy :: !b}

847+ -- ^ A hole in a term under construction in the

848+ -- elaborator. If this is not filled during

849+ -- elaboration, it is an error.

828 | GHole { envlen :: Int,

850 | GHole { envlen :: Int,

829 localnames :: [Name],

851 localnames :: [Name],

830 binderTy :: !b}

852 binderTy :: !b}

853+ -- ^ A saved TT hole that will later be converted to a

854+ -- top-level Idris metavariable applied to all

855+ -- elements of its local environment.

831 | Guess { binderTy :: !b,

856 | Guess { binderTy :: !b,

832 binderVal :: b }

857 binderVal :: b }

858+ -- ^ A provided value for a hole. It will later be

859+ -- substituted - the guess is to keep it

860+ -- computationally inert while working on other things

861+ -- if necessary.

833 | PVar { binderTy :: !b }

862 | PVar { binderTy :: !b }

834− -- ^ A pattern variable

863+ -- ^ A pattern variable (these are bound around terms

864+ -- that make up pattern-match clauses)

835 | PVTy { binderTy :: !b }

865 | PVTy { binderTy :: !b }

866+ -- ^ The type of a pattern binding

836 deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable)

867 deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable)

837{-!

868{-!

838deriving instance Binary Binder

869deriving instance Binary Binder

@@ -1420,12 +1451,11 @@ nextName (SN x) = SN (nextName' x)

1420 nextName' (WithN i n) = WithN i (nextName n)

1451 nextName' (WithN i n) = WithN i (nextName n)

1421 nextName' (InstanceN n ns) = InstanceN (nextName n) ns

1452 nextName' (InstanceN n ns) = InstanceN (nextName n) ns

1422 nextName' (ParentN n ns) = ParentN (nextName n) ns

1453 nextName' (ParentN n ns) = ParentN (nextName n) ns

1423− nextName' (CaseN n) = CaseN (nextName n)

1454+ nextName' (CaseN fc n) = CaseN fc (nextName n)

1424 nextName' (ElimN n) = ElimN (nextName n)

1455 nextName' (ElimN n) = ElimN (nextName n)

1425 nextName' (MethodN n) = MethodN (nextName n)

1456 nextName' (MethodN n) = MethodN (nextName n)

1426 nextName' (InstanceCtorN n) = InstanceCtorN (nextName n)

1457 nextName' (InstanceCtorN n) = InstanceCtorN (nextName n)

1427 nextName' (MetaN parent meta) = MetaN parent (nextName meta)

1458 nextName' (MetaN parent meta) = MetaN parent (nextName meta)

1428−nextName NErased = NErased

1429nextName (SymRef i) = error "Can't generate a name from a symbol reference"

1459nextName (SymRef i) = error "Can't generate a name from a symbol reference"

1430

1460

1431type Term = TT Name

1461type Term = TT Name

@@ -1582,7 +1612,7 @@ pureTerm (Bind n b sc) = notClassName n && pureBinder b && pureTerm sc where

1582 pureBinder (Let t v) = pureTerm t && pureTerm v

1612 pureBinder (Let t v) = pureTerm t && pureTerm v

1583 pureBinder t = pureTerm (binderTy t)

1613 pureBinder t = pureTerm (binderTy t)

1584

1614

1585− notClassName (MN _ c) | c == txt "class" = False

1615+ notClassName (MN _ c) | c == txt "__class" = False

1586 notClassName _ = True

1616 notClassName _ = True

1587

1617

1588pureTerm _ = True

1618pureTerm _ = True

@@ -1823,9 +1853,6 @@ pprintRaw bound (RApp f x) =

1823pprintRaw bound RType = text "RType"

1853pprintRaw bound RType = text "RType"

1824pprintRaw bound (RUType u) = enclose lparen rparen . group . align . hang 2 $

1854pprintRaw bound (RUType u) = enclose lparen rparen . group . align . hang 2 $

1825 text "RUType" <$> text (show u)

1855 text "RUType" <$> text (show u)

1826−pprintRaw bound (RForce r) =

1827− enclose lparen rparen . group . align . hang 2 $

1828− vsep [text "RForce", pprintRaw bound r]

1829pprintRaw bound (RConstant c) =

1856pprintRaw bound (RConstant c) =

1830 enclose lparen rparen . group . align . hang 2 $

1857 enclose lparen rparen . group . align . hang 2 $

1831 vsep [text "RConstant", annotate (AnnConst c) (text (show c))]

1858 vsep [text "RConstant", annotate (AnnConst c) (text (show c))]

src/Idris/Core/Typecheck.hs−3

@@ -160,9 +160,6 @@ check' holes ctxt env top = chk (TType (UVar (-5))) env top where

160 constType TheWorld = Constant WorldType

161 constType Forgot = Erased

162 constType _ = TType (UVal 0)

163− chk u env (RForce t)

164− = do (_, ty) <- chk u env t

165− return (Erased, ty)

166 chk u env (RBind n (Pi i s k) t)

163 chk u env (RBind n (Pi i s k) t)

167 = do (sv, st) <- chk u env s

164 = do (sv, st) <- chk u env s

168 (v, cs) <- get

165 (v, cs) <- get

src/Idris/Core/Unify.hs+1−1

@@ -40,7 +40,7 @@ unrecoverable = any bad

40

41 unrec (CantUnify r _ _ _ _ _) = not r

42 unrec (At _ e) = unrec e

43− unrec (Elaborating _ _ e) = unrec e

43+ unrec (Elaborating _ _ _ e) = unrec e

44 unrec (ElaboratingArg _ _ _ e) = unrec e

45 unrec _ = False

46

src/Idris/Core/WHNF.hs+8−8

@@ -1,7 +1,7 @@

1{-# LANGUAGE PatternGuards #-}

2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3

4−-- Reduction to Weak Head Normal Form

4+-- | Reduction to Weak Head Normal Form

5module Idris.Core.WHNF(whnf, WEnv) where

6

7import Idris.Core.TT

@@ -11,7 +11,7 @@ import qualified Idris.Core.Evaluate as Evaluate

11

12import Debug.Trace

13

14−-- A stack entry consists of a term and the environment it is to be

14+-- | A stack entry consists of a term and the environment it is to be

15-- evaluated in (i.e. it's a thunk)

16type StackEntry = (Term, WEnv)

17data WEnv = WEnv Int -- number of free variables

@@ -20,17 +20,17 @@ data WEnv = WEnv Int -- number of free variables

20

21type Stack = [StackEntry]

22

23−-- A WHNF is a top level term evaluated in the empty environment. It is

23+-- | A WHNF is a top level term evaluated in the empty environment. It is

24-- always headed by either an irreducible expression, i.e. a constructor,

25-- a lambda, a constant, or a postulate

26−

26+--

27-- Every 'Term' or 'Type' in this structure is associated with the

28-- environment it was encountered in, so that when we quote back to a term

29-- we get the substitutions right.

30

31−data WHNF = WDCon Int Int Bool Name (Type, WEnv) -- data constructor

31+data WHNF = WDCon Int Int Bool Name (Type, WEnv) -- ^ data constructor

32− | WTCon Int Int Name (Type, WEnv) -- type constructor

32+ | WTCon Int Int Name (Type, WEnv) -- ^ type constructor

33− | WPRef Name (Type, WEnv) -- irreducible global (e.g. a postulate)

33+ | WPRef Name (Type, WEnv) -- ^irreducible global (e.g. a postulate)

34 | WBind Name (Binder Term) (Term, WEnv)

35 | WApp WHNF (Term, WEnv)

36 | WConstant Const

@@ -40,7 +40,7 @@ data WHNF = WDCon Int Int Bool Name (Type, WEnv) -- data constructor

40 | WErased

41 | WImpossible

42

43−-- Reduce a *closed* term to weak head normal form.

43+-- | Reduce a *closed* term to weak head normal form.

44whnf :: Context -> Term -> Term

45whnf ctxt tm = quote (do_whnf ctxt (WEnv 0 []) tm)

46

src/Idris/Coverage.hs+26−76

@@ -56,17 +56,17 @@ genClauses fc n xs given

56 = do i <- getIState

57 let lhs_tms = map (\x -> flattenArgs $ delab' i x True True) xs

58 -- if a placeholder was given, don't bother generating cases for it

59− let lhs_tms' = zipWith mergePlaceholders lhs_tms

59+ let lhs_tms' = zipWith mergePlaceholders lhs_tms

60 (map (stripUnmatchable i) (map flattenArgs given))

61 let lhss = map pUnApply lhs_tms'

62

63 let argss = transpose lhss

64 let all_args = map (genAll i) argss

65− logLvl 5 $ "COVERAGE of " ++ show n

65+ logCoverage 5 $ "COVERAGE of " ++ show n

66− logLvl 5 $ show (lhs_tms, lhss)

66+ logCoverage 5 $ show (lhs_tms, lhss)

67− logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

67+ logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

68− logLvl 10 $ show argss ++ "\n" ++ show all_args

68+ logCoverage 10 $ show argss ++ "\n" ++ show all_args

69− logLvl 3 $ "Original: \n" ++

69+ logCoverage 3 $ "Original: \n" ++

70 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

71 -- add an infinite supply of explicit arguments to update the possible

72 -- cases for (the return type may be variadic, or function type, so

@@ -77,11 +77,11 @@ genClauses fc n xs given

77 p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)

78 _ -> repeat (pexp Placeholder)

79 let tryclauses = mkClauses parg all_args

80− logLvl 3 $ show (length tryclauses) ++ " initially to check"

80+ logCoverage 3 $ show (length tryclauses) ++ " initially to check"

81− logLvl 2 $ showSep "\n" (map (showTm i) tryclauses)

81+ logCoverage 2 $ showSep "\n" (map (showTm i) tryclauses)

82 let new = filter (noMatch i) (nub tryclauses)

83− logLvl 2 $ show (length new) ++ " clauses to check for impossibility"

83+ logCoverage 2 $ show (length new) ++ " clauses to check for impossibility"

84− logLvl 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

84+ logCoverage 4 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

85-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

86 return new

87-- return (map (\t -> PClause n t [] PImpossible []) new)

@@ -92,7 +92,7 @@ genClauses fc n xs given

92 pUnApply (PApp _ f args) = map getTm args

93 pUnApply _ = []

94

95− flattenArgs (PApp fc (PApp _ f as) as')

95+ flattenArgs (PApp fc (PApp _ f as) as')

96 = flattenArgs (PApp fc f (as ++ as'))

97 flattenArgs t = t

98

@@ -137,7 +137,7 @@ validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

137 _ -> False

138validCoverageCase ctxt (CantConvert _ _ _) = False

139validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140−validCoverageCase ctxt (Elaborating _ _ e) = validCoverageCase ctxt e

140+validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

141validCoverageCase ctxt (ElaboratingArg _ _ _ e) = validCoverageCase ctxt e

142validCoverageCase ctxt _ = True

143

@@ -167,7 +167,7 @@ recoverableCoverage ctxt (CantUnify r (topx, _) (topy, _) e _ _)

167 | (Bound, Bound) <- (x, y) = True

168 | otherwise = False -- name is different, unrecoverable

169recoverableCoverage ctxt (At _ e) = recoverableCoverage ctxt e

170−recoverableCoverage ctxt (Elaborating _ _ e) = recoverableCoverage ctxt e

170+recoverableCoverage ctxt (Elaborating _ _ _ e) = recoverableCoverage ctxt e

171recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e

172recoverableCoverage _ _ = False

173

@@ -248,7 +248,7 @@ genAll i args

248

249 -- put it back to its original form

250 resugar (PApp _ (PRef fc hl n) [_,_,t,v])

251− | n == sigmaCon

251+ | n == sigmaCon

252 = PDPair fc [] TypeOrTerm (getTm t) Placeholder (getTm v)

253 resugar (PApp _ (PRef fc hl n) [_,_,l,r])

254 | n == pairCon

@@ -330,7 +330,7 @@ checkPositive mut_ns (cn, ty')

330 let tot = if p then Total (args ty) else Partial NotPositive

331 let ctxt' = setTotal cn tot (tt_ctxt i)

332 putIState (i { tt_ctxt = ctxt' })

333− logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns

333+ logCoverage 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns

334 addIBC (IBCTotal cn tot)

335 return tot

336 where

@@ -351,56 +351,6 @@ checkPositive mut_ns (cn, ty')

351 noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg)

352

353

354−calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

355−calcProd i fc topn pats

356− = cp topn pats []

357− where

358− -- every application of n must be in an argument of a coinductive

359− -- constructor, in every function reachable from here in the

360− -- call graph.

361− cp n pats done = do patsprod <- mapM (prodRec n done) pats

362− if (and patsprod)

363− then return Productive

364− else return (Partial NotProductive)

365−

366− prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

367− prodRec n done _ | n `elem` done = return True

368− prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

369−

370− prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

371− prod n done ok ap@(App _ _ _)

372− | (P nt f _, args) <- unApply ap

373− = do recOK <- checkProdRec (n:done) f

374− let ctxt = tt_ctxt i

375− let [ty] = lookupTy f ctxt -- must exist!

376− let co = cotype nt f ty in

377− if (not recOK) then return False else

378− if f == topn

379− then do argsprod <- mapM (prod n done co) args

380− return (and (ok : argsprod) )

381− else do argsprod <- mapM (prod n done co) args

382− return (and argsprod)

383− prod n done ok (App _ f a) = liftM2 (&&) (prod n done False f)

384− (prod n done False a)

385− prod n done ok (Bind _ (Let t v) sc)

386− = liftM2 (&&) (prod n done False v) (prod n done False v)

387− prod n done ok (Bind _ b sc) = prod n done ok sc

388− prod n done ok t = return True

389−

390− checkProdRec :: [Name] -> Name -> Idris Bool

391− checkProdRec done f

392− = case lookupCtxt f (idris_patdefs i) of

393− [(def, _)] -> do ok <- mapM (prodRec f done) def

394− return (and ok)

395− _ -> return True -- defined elsewhere, can't call topn

396−

397− cotype (DCon _ _ _) n ty

398− | (P _ t _, _) <- unApply (getRetTy ty)

399− = case lookupCtxt t (idris_datatypes i) of

400− [TI _ True _ _ _] -> True

401− _ -> False

402− cotype nt n ty = False

403−

404-- | Calculate the totality of a function from its patterns.

354-- | Calculate the totality of a function from its patterns.

405-- Either follow the size change graph (if inductive) or check for

355-- Either follow the size change graph (if inductive) or check for

406-- productivity (if coinductive)

356-- productivity (if coinductive)

@@ -482,9 +432,9 @@ checkTotality path fc n

482

432

483checkDeclTotality :: (FC, Name) -> Idris Totality

433checkDeclTotality :: (FC, Name) -> Idris Totality

484checkDeclTotality (fc, n)

434checkDeclTotality (fc, n)

485− = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

435+ = do logCoverage 2 $ "Checking " ++ show n ++ " for totality"

486-- buildSCG (fc, n)

436-- buildSCG (fc, n)

487−-- logLvl 2 $ "Built SCG"

437+-- logCoverage 2 $ "Built SCG"

488 i <- getIState

438 i <- getIState

489 let opts = case lookupCtxt n (idris_flags i) of

439 let opts = case lookupCtxt n (idris_flags i) of

490 [fs] -> fs

440 [fs] -> fs

@@ -496,7 +446,7 @@ checkDeclTotality (fc, n)

496 -- typechecking decidable

446 -- typechecking decidable

497 p@(Partial _) -> do setAccessibility n Frozen

447 p@(Partial _) -> do setAccessibility n Frozen

498 addIBC (IBCAccess n Frozen)

448 addIBC (IBCAccess n Frozen)

499− logLvl 5 $ "HIDDEN: "

449+ logCoverage 5 $ "HIDDEN: "

500 ++ show n ++ show p

450 ++ show n ++ show p

501 _ -> return ()

451 _ -> return ()

502 return t

452 return t

@@ -519,12 +469,12 @@ buildSCG (_, n) = do

519 [cg] -> case lookupDefExact n (tt_ctxt ist) of

469 [cg] -> case lookupDefExact n (tt_ctxt ist) of

520 Just (CaseOp _ _ _ pats _ cd) ->

470 Just (CaseOp _ _ _ pats _ cd) ->

521 let (args, sc) = cases_totcheck cd in

471 let (args, sc) = cases_totcheck cd in

522− do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"

472+ do logCoverage 2 $ "Building SCG for " ++ show n ++ " from\n"

523 ++ show pats ++ "\n" ++ show sc

473 ++ show pats ++ "\n" ++ show sc

524 let newscg = buildSCG' ist (rights pats) args

474 let newscg = buildSCG' ist (rights pats) args

525− logLvl 5 $ "SCG is: " ++ show newscg

475+ logCoverage 5 $ "SCG is: " ++ show newscg

526 addToCG n ( cg { scg = newscg } )

476 addToCG n ( cg { scg = newscg } )

527− [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

477+ [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

528 x -> error $ "buildSCG: " ++ show (n, x)

478 x -> error $ "buildSCG: " ++ show (n, x)

529

479

530delazy = delazy' False -- not lazy codata

480delazy = delazy' False -- not lazy codata

@@ -644,20 +594,20 @@ checkSizeChange n = do

644 ist <- getIState

594 ist <- getIState

645 case lookupCtxt n (idris_callgraph ist) of

595 case lookupCtxt n (idris_callgraph ist) of

646 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

596 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

647− logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

597+ logCoverage 5 ("Multipath for " ++ show n ++ ":\n" ++

648 "from " ++ show (scg cg) ++ "\n" ++

598 "from " ++ show (scg cg) ++ "\n" ++

649 show (length ms) ++ "\n" ++

599 show (length ms) ++ "\n" ++

650 showSep "\n" (map show ms))

600 showSep "\n" (map show ms))

651− logLvl 6 (show cg)

601+ logCoverage 6 (show cg)

652 -- every multipath must have an infinitely descending

602 -- every multipath must have an infinitely descending

653 -- thread, then the function terminates

603 -- thread, then the function terminates

654 -- also need to checks functions called are all total

604 -- also need to checks functions called are all total

655 -- (Unchecked is okay as we'll spot problems here)

605 -- (Unchecked is okay as we'll spot problems here)

656 let tot = map (checkMP ist (getArity ist n)) ms

606 let tot = map (checkMP ist (getArity ist n)) ms

657− logLvl 4 $ "Generated " ++ show (length tot) ++ " paths"

607+ logCoverage 4 $ "Generated " ++ show (length tot) ++ " paths"

658− logLvl 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot)

608+ logCoverage 6 $ "Paths for " ++ show n ++ " yield " ++ (show tot)

659 return (noPartial tot)

609 return (noPartial tot)

660− [] -> do logLvl 5 $ "No paths for " ++ show n

610+ [] -> do logCoverage 5 $ "No paths for " ++ show n

661 return Unchecked

611 return Unchecked

662 where getArity ist n

612 where getArity ist n

663 = case lookupTy n (tt_ctxt ist) of

613 = case lookupTy n (tt_ctxt ist) of

src/Idris/DSL.hs+7−4

@@ -42,7 +42,7 @@ mkTTName fc n =

42 , pexp (mkList fc ns)]

43 MN i nm -> PApp fc (PRef fc [] (reflm "MN")) [ pexp (intC i)

44 , pexp (stringC nm)]

45− otherwise -> PRef fc [] $ reflm "NErased"

45+ _ -> error "Invalid name from user syntax for DSL name"

46

47expandSugar :: DSL -> PTerm -> PTerm

48expandSugar dsl (PLam fc n nfc ty tm)

@@ -98,8 +98,8 @@ expandSugar dsl (PDoBlock ds)

98 block b (DoBind fc n nfc tm : rest)

99 = PApp fc b [pexp tm, pexp (PLam fc n nfc Placeholder (block b rest))]

100 block b (DoBindP fc p tm alts : rest)

101− = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "bpat") NoFC Placeholder

101+ = PApp fc b [pexp tm, pexp (PLam fc (sMN 0 "__bpat") NoFC Placeholder

102− (PCase fc (PRef fc [] (sMN 0 "bpat"))

102+ (PCase fc (PRef fc [] (sMN 0 "__bpat"))

103 ((p, block b rest) : alts)))]

104 block b (DoLet fc n nfc ty tm : rest)

105 = PLet fc n nfc ty tm (block b rest)

@@ -108,7 +108,10 @@ expandSugar dsl (PDoBlock ds)

108 block b (DoExp fc tm : rest)

109 = PApp fc b

110 [pexp tm,

111− pexp (PLam fc (sMN 0 "bindx") NoFC Placeholder (block b rest))]

111+ pexp (PLam fc (sMN 0 "__bindx") NoFC (mkTy tm) (block b rest))]

112+ where mkTy (PCase _ _ _) = PRef fc [] unitTy

113+ mkTy (PMetavar _ _) = PRef fc [] unitTy

114+ mkTy _ = Placeholder

112 block b _ = PElabError (Msg "Invalid statement in do block")

115 block b _ = PElabError (Msg "Invalid statement in do block")

113

116

114expandSugar dsl (PIdiom fc e) = expandSugar dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

117expandSugar dsl (PIdiom fc e) = expandSugar dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

src/Idris/DataOpts.hs−1

@@ -40,7 +40,6 @@ instance Optimisable Raw where

40 | otherwise = RApp <$> applyOpts f <*> applyOpts a

41

42 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

43− applyOpts (RForce t) = applyOpts t

44 applyOpts t = return t

43 applyOpts t = return t

45

44

46-- Erase types (makes ibc smaller, and we don't need them)

45-- Erase types (makes ibc smaller, and we don't need them)

src/Idris/DeepSeq.hs+12−5

@@ -107,6 +107,7 @@ instance NFData Opt where

107 rnf (ColourREPL bool) = rnf bool `seq` ()

108 rnf (Idemode) = ()

109 rnf (IdemodeSocket) = ()

110+ rnf (ShowLoggingCats) = ()

110 rnf (ShowLibs) = ()

111 rnf (ShowLibs) = ()

111 rnf (ShowLibdir) = ()

112 rnf (ShowLibdir) = ()

112 rnf (ShowIncs) = ()

113 rnf (ShowIncs) = ()

@@ -116,6 +117,7 @@ instance NFData Opt where

116 rnf (NoBuiltins) = ()

117 rnf (NoBuiltins) = ()

117 rnf (NoREPL) = ()

118 rnf (NoREPL) = ()

118 rnf (OLogging i) = rnf i `seq` ()

119 rnf (OLogging i) = rnf i `seq` ()

120+ rnf (OLogCats cs) = rnf cs `seq` ()

119 rnf (Output str) = rnf str `seq` ()

121 rnf (Output str) = rnf str `seq` ()

120 rnf (Interface) = ()

122 rnf (Interface) = ()

121 rnf (TypeCase) = ()

123 rnf (TypeCase) = ()

@@ -174,6 +176,7 @@ instance NFData TIData where

174instance NFData IOption where

176instance NFData IOption where

175 rnf (IOption

177 rnf (IOption

176 opt_logLevel

178 opt_logLevel

179+ opt_logcats

177 opt_typecase

180 opt_typecase

178 opt_typeintype

181 opt_typeintype

179 opt_coverage

182 opt_coverage

@@ -226,7 +229,7 @@ instance NFData IOption where

226instance NFData LanguageExt where

229instance NFData LanguageExt where

227 rnf TypeProviders = ()

230 rnf TypeProviders = ()

228 rnf ErrorReflection = ()

231 rnf ErrorReflection = ()

229−

232+

230instance NFData Optimisation where

233instance NFData Optimisation where

231 rnf PETransform = ()

234 rnf PETransform = ()

232

235

@@ -300,6 +303,7 @@ instance NFData IBCWrite where

300 rnf (IBCUsage usage) = rnf usage `seq` ()

303 rnf (IBCUsage usage) = rnf usage `seq` ()

301 rnf (IBCExport name) = rnf name `seq` ()

304 rnf (IBCExport name) = rnf name `seq` ()

302 rnf (IBCAutoHint n1 n2) = rnf n1 `seq` rnf n2 `seq` ()

305 rnf (IBCAutoHint n1 n2) = rnf n1 `seq` rnf n2 `seq` ()

306+ rnf (IBCDeprecate n1 n2) = rnf n1 `seq` rnf n2 `seq` ()

303 rnf (IBCRecord x) = rnf x `seq` ()

307 rnf (IBCRecord x) = rnf x `seq` ()

304

308

305

309

@@ -357,6 +361,9 @@ instance NFData Codegen where

357 rnf (Via x1) = rnf x1 `seq` ()

361 rnf (Via x1) = rnf x1 `seq` ()

358 rnf Bytecode = ()

362 rnf Bytecode = ()

359

363

364+instance NFData LogCat where

365+ rnf _ = ()

366+

360instance NFData CGInfo where

367instance NFData CGInfo where

361 rnf (CGInfo x1 x2 x3 x4 x5)

368 rnf (CGInfo x1 x2 x3 x4 x5)

362 = rnf x1 `seq`

369 = rnf x1 `seq`

@@ -562,7 +569,7 @@ instance NFData PTerm where

562instance NFData PAltType where

569instance NFData PAltType where

563 rnf (ExactlyOne x1) = rnf x1 `seq` ()

570 rnf (ExactlyOne x1) = rnf x1 `seq` ()

564 rnf FirstSuccess = ()

571 rnf FirstSuccess = ()

565− rnf TryImplicit = ()

572+ rnf TryImplicit = ()

566

573

567instance (NFData t) => NFData (PTactic' t) where

574instance (NFData t) => NFData (PTactic' t) where

568 rnf (Intro x1) = rnf x1 `seq` ()

575 rnf (Intro x1) = rnf x1 `seq` ()

@@ -686,11 +693,11 @@ instance NFData OutputMode where

686

693

687

694

688instance NFData IState where

695instance NFData IState where

689− rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

696+ rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

690 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

697 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

691 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

698 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

692− x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73)

699+ x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74)

693 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`

700 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`

694 rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`

701 rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`

695 rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`

702 rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`

696− rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` ()

703+ rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` rnf x74 `seq` ()

src/Idris/Delaborate.hs+20−6

@@ -110,6 +110,9 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

110 _ -> PRef un [] n

111 de env _ (Bind n (Lam ty) sc)

112 = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)

113+ de env (_ : is) (Bind n (Pi (Just impl) ty _) sc)

114+ | toplevel_imp impl -- information in 'imps' repeated

115+ = PPi (Imp [] Dynamic False (Just impl)) n NoFC (de env [] ty) (de ((n,n):env) is sc)

113 de env is (Bind n (Pi (Just impl) ty _) sc)

116 de env is (Bind n (Pi (Just impl) ty _) sc)

114 | tcinstance impl

117 | tcinstance impl

115 = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)

118 = PPi constraint n NoFC (de env [] ty) (de ((n,n):env) is sc)

@@ -192,7 +195,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

192 isCaseApp tm | P _ n _ <- fst (unApply tm) = isCN n

195 isCaseApp tm | P _ n _ <- fst (unApply tm) = isCN n

193 | otherwise = False

196 | otherwise = False

194 where isCN (NS n _) = isCN n

197 where isCN (NS n _) = isCN n

195− isCN (SN (CaseN _)) = True

198+ isCN (SN (CaseN _ _)) = True

196 isCN _ = False

199 isCN _ = False

197

200

198 delabCase :: [(Name, Name)] -> [PArg] -> Name -> Term -> Name -> [Term] -> Maybe PTerm

201 delabCase :: [(Name, Name)] -> [PArg] -> Name -> Term -> Name -> [Term] -> Maybe PTerm

@@ -201,8 +204,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

201 [(cases, _)] -> return cases

204 [(cases, _)] -> return cases

202 _ -> Nothing

205 _ -> Nothing

203 return $ PCase un (de env imps scrutinee)

206 return $ PCase un (de env imps scrutinee)

204− [ (de (env ++ map (\n -> (n, n)) vars) imps (splitArg lhs),

207+ [ (de (env ++ map (\(n, _) -> (n, n)) vars) imps (splitArg lhs),

205− de (env ++ map (\n -> (n, n)) vars) imps rhs)

208+ de (env ++ map (\(n, _) -> (n, n)) vars) imps rhs)

206 | (vars, lhs, rhs) <- cases

209 | (vars, lhs, rhs) <- cases

207 ]

210 ]

208 where splitArg tm | (_, args) <- unApply tm = nonVar (reverse args)

211 where splitArg tm | (_, args) <- unApply tm = nonVar (reverse args)

@@ -437,9 +440,14 @@ pprintErr' i (AlreadyDefined n) = annName n<+>

437pprintErr' i (ProofSearchFail e) = pprintErr' i e

440pprintErr' i (ProofSearchFail e) = pprintErr' i e

438pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> annTm tm (pprintTerm i (delabSugared i tm))

441pprintErr' i (NoRewriting tm) = text "rewrite did not change type" <+> annTm tm (pprintTerm i (delabSugared i tm))

439pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr' i e

442pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr' i e

440−pprintErr' i (Elaborating s n e) = text "When checking" <+> text s <>

443+pprintErr' i (Elaborating s n ty e) = text "When checking" <+> text s <>

441− annName' n (showqual i n) <> colon <$>

444+ annName' n (showqual i n) <>

445+ pprintTy ty <$>

442− pprintErr' i e

446+ pprintErr' i e

447+ where pprintTy Nothing = colon

448+ pprintTy (Just ty) = text " with expected type" <>

449+ indented (annTm ty (pprintTerm i (delabSugared i ty)))

450+ <> line

443pprintErr' i (ElaboratingArg f x _ e)

451pprintErr' i (ElaboratingArg f x _ e)

444 | isInternal f = pprintErr' i e

452 | isInternal f = pprintErr' i e

445 | isUN x =

453 | isUN x =

@@ -503,6 +511,12 @@ pprintErr' i (ElabScriptStuck tm) =

503 text "Is it a stuck term?"

511 text "Is it a stuck term?"

504pprintErr' i (RunningElabScript e) =

512pprintErr' i (RunningElabScript e) =

505 text "While running an elaboration script, the following error occurred" <> colon <$> pprintErr' i e

513 text "While running an elaboration script, the following error occurred" <> colon <$> pprintErr' i e

514+pprintErr' i (ElabScriptStaging n) =

515+ text "Can't run elaboration script because it contains pattern matching that has not yet been elaborated." <$>

516+ text "Try lifting the script to a top-level definition." <$>

517+ text "In particular, the problem is caused by:" <+> annName n

518+pprintErr' i (FancyMsg parts) =

519+ fillSep (map (showPart i) parts)

506

520

507showPart :: IState -> ErrorReportPart -> Doc OutputAnnotation

521showPart :: IState -> ErrorReportPart -> Doc OutputAnnotation

508showPart ist (TextPart str) = fillSep . map text . words $ str

522showPart ist (TextPart str) = fillSep . map text . words $ str

src/Idris/Directives.hs+4−1

@@ -64,7 +64,10 @@ directiveAction (DErrorHandlers fn nfc arg afc ns) =

64 map (\(n, fc) -> (fc, AnnName n Nothing Nothing Nothing)) ns'

65

66directiveAction (DLanguage ext) = addLangExt ext

67−

67+directiveAction (DDeprecate n reason)

68+ = do n' <- disambiguate n

69+ addDeprecated n' reason

70+ addIBC (IBCDeprecate n' reason)

68directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

71directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

69

72

70disambiguate :: Name -> Idris Name

73disambiguate :: Name -> Idris Name

src/Idris/Elab/Class.hs+11−13

@@ -78,7 +78,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

78 let idecls = filter instdecl ds -- default superclass instance declarations

79 mapM_ checkDefaultSuperclassInstance idecls

80 let mnames = map getMName mdecls

81− logLvl 1 $ "Building methods " ++ show mnames

81+ logElab 1 $ "Building methods " ++ show mnames

82 ims <- mapM (tdecl mnames) mdecls

83 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

84 (filter clause ds)

@@ -94,7 +94,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

94 let cons = [(cd, pDocs ++ mapMaybe memberDocs ds, cn, NoFC, cty, fc, [])]

95 let ddecl = PDatadecl tn NoFC tty cons

96

97− logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

97+ logElab 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

98

99 -- Elaborate the data declaration

100 elabData info (syn { no_imp = no_imp syn ++ mnames,

@@ -109,7 +109,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

109 -- for each method, build a top level function

110 fns <- mapM (tfun cn constraint (syn { imp_methods = mnames })

111 (map fst imethods)) imethods

112− logLvl 5 $ "Functions " ++ show fns

112+ logElab 5 $ "Functions " ++ show fns

113 -- Elaborate the the top level methods

114 mapM_ (rec_elabDecl info EAll info) (concat fns)

115

@@ -159,7 +159,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

159 getMName (PTy _ _ _ _ _ n nfc _) = nsroot n

160 tdecl allmeths (PTy doc _ syn _ o n nfc t)

161 = do t' <- implicit' info syn (map (\(n, _, _) -> n) ps ++ allmeths) n t

162− logLvl 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

162+ logElab 2 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

163 return ( (n, (toExp (map (\(pn, _, _) -> pn) ps) Exp t')),

164 (n, (nfc, doc, o, (toExp (map (\(pn, _, _) -> pn) ps)

165 (\ l s p -> Imp l s p Nothing) t'))),

@@ -174,7 +174,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

174 let ds = map (decorateid defaultdec)

175 [PTy emptyDocstring [] syn fc [] n nfc ty',

176 PClauses fc (o ++ opts) n cs]

177− logLvl 1 (show ds)

177+ logElab 1 (show ds)

178 return (n, ((defaultdec n, ds!!1), ds))

179 _ -> ifail $ show n ++ " is not a method"

180 defdecl _ _ _ = ifail "Can't happen (defdecl)"

@@ -199,8 +199,8 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

199 let lhs = PApp fc (PRef fc [] cfn) [pconst capp]

200 let rhs = PResolveTC (fileFC "HACK")

201 let ty = PPi constraint cnm NoFC c con

202− logLvl 2 ("Dictionary constraint: " ++ showTmImpls ty)

202+ logElab 2 ("Dictionary constraint: " ++ showTmImpls ty)

203− logLvl 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

203+ logElab 2 (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

204 i <- getIState

205 let conn = case con of

206 PRef _ _ n -> n

@@ -230,9 +230,9 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

230 let anames = map (\x -> sMN x "arg") [0..]

231 let lhs = PApp fc (PRef fc [] m) (pconst capp : lhsArgs margs anames)

232 let rhs = PApp fc (getMeth mnames all m) (rhsArgs margs anames)

233− logLvl 2 ("Top level type: " ++ showTmImpls ty')

233+ logElab 2 ("Top level type: " ++ showTmImpls ty')

234− logLvl 1 (show (m, ty', capp, margs))

234+ logElab 1 (show (m, ty', capp, margs))

235− logLvl 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

235+ logElab 2 ("Definition: " ++ showTmImpls lhs ++ " = " ++ showTmImpls rhs)

236 return [PTy doc [] syn fc o m mfc ty',

237 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

238

@@ -258,7 +258,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

258 insertConstraint :: PTerm -> [Name] -> PTerm -> PTerm

259 insertConstraint c all (PPi p@(Imp _ _ _ _) n fc ty sc)

260 = PPi p n fc ty (insertConstraint c all sc)

261− insertConstraint c all sc = let dictN = sMN 0 "class"

261+ insertConstraint c all sc = let dictN = sMN 0 "__class"

262 in PPi (constraint { pstatic = Static })

263 dictN NoFC c

264 (constrainMeths (map basename all)

@@ -318,5 +318,3 @@ findDets n ns =

318 | n `elem` ns = i : getDetPos (i + 1) ns sc

319 | otherwise = getDetPos (i + 1) ns sc

320 getDetPos _ _ _ = []

321−

322−

src/Idris/Elab/Clause.hs+153−156

@@ -84,7 +84,7 @@ elabClauses info' fc opts n_in cs =

84 -- no simplification or PE

85 let (pats_in, cs_full) = unzip cs_elab

86 let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in

87− logLvl 3 $ "Elaborated patterns:\n" ++ show pats_raw

87+ logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

88

89 solveDeferred n

90

@@ -102,7 +102,7 @@ elabClauses info' fc opts n_in cs =

102 -- If the definition is specialisable, this reduces the

103 -- RHS

104 pe_tm <- doPartialEval ist tpats

105− let pats_pe = if petrans

105+ let pats_pe = if petrans

106 then map (simple_lhs (tt_ctxt ist)) pe_tm

107 else pats_raw

108

@@ -111,7 +111,7 @@ elabClauses info' fc opts n_in cs =

111 -- Look for 'static' names and generate new specialised

112 -- definitions for them, as well as generating rewrite rules

113 -- for partially evaluated definitions

114− newrules <- if petrans

114+ newrules <- if petrans

115 then mapM (\ e -> case e of

116 Left _ -> return []

117 Right (l, r) -> elabPE info fc n r) pats_pe

@@ -133,13 +133,13 @@ elabClauses info' fc opts n_in cs =

133

134 -- pdef is the compile-time pattern definition.

135 -- This will get further inlined to help with totality checking.

136− let pdef = map debind pats_raw

136+ let pdef = map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) $ map debind pats_raw

137− -- pdef_pe is the one which will get further optimised

137+ -- pdef_pe is the one which will get further optimised

138 -- for run-time, and, partially evaluated

139 let pdef_pe = map debind pats_transformed

140

141− logLvl 5 $ "Initial typechecked patterns:\n" ++ show pats_raw

141+ logElab 5 $ "Initial typechecked patterns:\n" ++ show pats_raw

142− logLvl 5 $ "Initial typechecked pattern def:\n" ++ show pdef

142+ logElab 5 $ "Initial typechecked pattern def:\n" ++ show pdef

143

144 -- NOTE: Need to store original definition so that proofs which

145 -- rely on its structure aren't affected by any changes to the

@@ -152,10 +152,10 @@ elabClauses info' fc opts n_in cs =

152 numArgs <- tclift $ sameLength pdef

153

154 case specNames opts of

155− Just _ ->

155+ Just _ ->

156− do logLvl 3 $ "Partially evaluated:\n" ++ show pats_pe

156+ do logElab 3 $ "Partially evaluated:\n" ++ show pats_pe

157 _ -> return ()

158− logLvl 3 $ "Transformed:\n" ++ show pats_transformed

158+ logElab 3 $ "Transformed:\n" ++ show pats_transformed

159

160 erInfo <- getErasureInfo <$> getIState

161 tree@(CaseDef scargs sc _) <- tclift $

@@ -167,7 +167,7 @@ elabClauses info' fc opts n_in cs =

167 -- missing <- genMissing n scargs sc

168 missing' <- filterM (checkPossible info fc True n) missing

169 let clhs = map getLHS pdef

170− logLvl 2 $ "Must be unreachable:\n" ++

170+ logElab 2 $ "Must be unreachable:\n" ++

171 showSep "\n" (map showTmImpls missing') ++

172 "\nAgainst: " ++

173 showSep "\n" (map (\t -> showTmImpls (delab ist t)) (map getLHS pdef))

@@ -182,15 +182,15 @@ elabClauses info' fc opts n_in cs =

182

183 -- pdef' is the version that gets compiled for run-time,

184 -- so we start from the partially evaluated version

185− pdef_in' <- applyOpts pdef_pe

185+ pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe

186 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

187

188− logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

188+ logElab 5 $ "After data structure transformations:\n" ++ show pdef'

189

190 ist <- getIState

191 -- let wf = wellFounded ist n sc

192 let tot | pcover || AssertTotal `elem` opts = Unchecked -- finish later

193− | PEGenerated `elem` opts = Generated

193+ | PEGenerated `elem` opts = Generated

194 | otherwise = Partial NotCovering -- already know it's not total

195

196 -- case lookupCtxt (namespace info) n (idris_flags ist) of

@@ -206,63 +206,64 @@ elabClauses info' fc opts n_in cs =

206 ":warning - Unreachable case: " ++

207 show (delab ist x)) xs

208 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

209− let defaultcase = if knowncovering

209+ let defaultcase = if knowncovering

210 then STerm Erased

211− else UnmatchedCase $ "*** " ++

211+ else UnmatchedCase $ "*** " ++

212− show fc ++

212+ show fc ++

213− ":unmatched case in " ++ show n ++

213+ ":unmatched case in " ++ show n ++

214 " ***"

215

216 tree' <- tclift $ simpleCase tcase defaultcase reflect

217 RunTime fc inacc atys pdef' erInfo

218− logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

218+ logElab 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

219− logLvl 3 $ "Optimised: " ++ show tree'

219+ logElab 3 $ "Optimised: " ++ show tree'

220 ctxt <- getContext

221 ist <- getIState

222 let opt = idris_optimisation ist

223 putIState (ist { idris_patdefs = addDef n (force pdef_pe, force pmissing)

224 (idris_patdefs ist) })

225 let caseInfo = CaseInfo (inlinable opts) (inlinable opts) (dictionary opts)

226− case lookupTy n ctxt of

226+ case lookupTyExact n ctxt of

227+ Just ty ->

227− [ty] -> do ctxt' <- do ctxt <- getContext

228+ do ctxt' <- do ctxt <- getContext

228− tclift $

229+ tclift $

229− addCasedef n erInfo caseInfo

230+ addCasedef n erInfo caseInfo

230− tcase defaultcase

231+ tcase defaultcase

231− reflect

232+ reflect

232− (AssertTotal `elem` opts)

233+ (AssertTotal `elem` opts)

233− atys

234+ atys

234− inacc

235+ inacc

235− pats_pe

236+ pats_pe

236− pdef

237+ pdef

237− pdef -- compile time

238+ pdef -- compile time

238− pdef_inl -- inlined

239+ pdef_inl -- inlined

239− pdef' ty

240+ pdef' ty

240− ctxt

241+ ctxt

241− setContext ctxt'

242+ setContext ctxt'

242− addIBC (IBCDef n)

243+ addIBC (IBCDef n)

243− setTotality n tot

244+ setTotality n tot

244− when (not reflect && PEGenerated `notElem` opts) $

245+ when (not reflect && PEGenerated `notElem` opts) $

245− do totcheck (fc, n)

246+ do totcheck (fc, n)

246− defer_totcheck (fc, n)

247+ defer_totcheck (fc, n)

247− when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

248+ when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

248− i <- getIState

249+ i <- getIState

249− case lookupDef n (tt_ctxt i) of

250+ case lookupDef n (tt_ctxt i) of

250− (CaseOp _ _ _ _ _ cd : _) ->

251+ (CaseOp _ _ _ _ _ cd : _) ->

251− let (scargs, sc) = cases_compiletime cd

252+ let (scargs, sc) = cases_compiletime cd

252− (scargs', sc') = cases_runtime cd in

253+ (scargs', sc') = cases_runtime cd in

253− do let calls = findCalls sc' scargs'

254+ do let calls = findCalls sc' scargs'

254− let used = findUsedArgs sc' scargs'

255+ let used = findUsedArgs sc' scargs'

255− -- let scg = buildSCG i sc scargs

256+ -- let scg = buildSCG i sc scargs

256− -- add SCG later, when checking totality

257+ -- add SCG later, when checking totality

257− let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

258+ let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

258− logLvl 2 $ "Called names: " ++ show cg

259+ logElab 2 $ "Called names: " ++ show cg

259− addToCG n cg

260+ addToCG n cg

260− addToCalledG n (nub (map fst calls)) -- plus names in type!

261+ addToCalledG n (nub (map fst calls)) -- plus names in type!

261− addIBC (IBCCG n)

262+ addIBC (IBCCG n)

262− _ -> return ()

263+ _ -> return ()

263− return ()

264+ return ()

264 -- addIBC (IBCTotal n tot)

265 -- addIBC (IBCTotal n tot)

265− [] -> return ()

266+ _ -> return ()

266 -- Check it's covering, if 'covering' option is used. Chase

267 -- Check it's covering, if 'covering' option is used. Chase

267 -- all called functions, and fail if any of them are also

268 -- all called functions, and fail if any of them are also

268 -- 'Partial NotCovering'

269 -- 'Partial NotCovering'

@@ -288,7 +289,7 @@ elabClauses info' fc opts n_in cs =

288 debind (Left x) = let (vs, x') = depat [] x in

289 debind (Left x) = let (vs, x') = depat [] x in

289 (vs, x', Impossible)

290 (vs, x', Impossible)

290

291

291− depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

292+ depat acc (Bind n (PVar t) sc) = depat ((n, t) : acc) (instantiate (P Bound n t) sc)

292 depat acc x = (acc, x)

293 depat acc x = (acc, x)

293

294

295

@@ -359,7 +360,7 @@ elabPE info fc caller r =

359 let undef = case lookupDefExact newnm (tt_ctxt ist) of

360 let undef = case lookupDefExact newnm (tt_ctxt ist) of

360 Nothing -> True

361 Nothing -> True

361 _ -> False

362 _ -> False

362− logLvl 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

363+ logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

363 idrisCatch

364 idrisCatch

364 (if (undef && all (concreteArg ist) (snd specapp)) then do

365 (if (undef && all (concreteArg ist) (snd specapp)) then do

365 cgns <- getAllNames n

366 cgns <- getAllNames n

@@ -373,32 +374,32 @@ elabPE info fc caller r =

373 [Total _] -> 65536

374 [Total _] -> 65536

374 [Productive] -> 16

375 [Productive] -> 16

375 _ -> 1

376 _ -> 1

376− let opts = [Specialise ((if pe_simple specdecl

377+ let opts = [Specialise ((if pe_simple specdecl

377− then map (\x -> (x, Nothing)) cgns'

378+ then map (\x -> (x, Nothing)) cgns'

378 else []) ++

379 else []) ++

379− (n, Just maxred) :

380+ (n, Just maxred) :

380 mapMaybe (specName (pe_simple specdecl))

381 mapMaybe (specName (pe_simple specdecl))

381 (snd specapp))]

382 (snd specapp))]

382− logLvl 3 $ "Specialising application: " ++ show specapp

383+ logElab 3 $ "Specialising application: " ++ show specapp

383 ++ " in " ++ show caller ++

384 ++ " in " ++ show caller ++

384 " with " ++ show opts

385 " with " ++ show opts

385− logLvl 3 $ "New name: " ++ show newnm

386+ logElab 3 $ "New name: " ++ show newnm

386− logLvl 3 $ "PE definition type : " ++ (show specTy)

387+ logElab 3 $ "PE definition type : " ++ (show specTy)

387 ++ "\n" ++ show opts

388 ++ "\n" ++ show opts

388− logLvl 3 $ "PE definition " ++ show newnm ++ ":\n" ++

389+ logElab 3 $ "PE definition " ++ show newnm ++ ":\n" ++

389 showSep "\n"

390 showSep "\n"

390 (map (\ (lhs, rhs) ->

391 (map (\ (lhs, rhs) ->

391 (showTmImpls lhs ++ " = " ++

392 (showTmImpls lhs ++ " = " ++

392 showTmImpls rhs)) (pe_clauses specdecl))

393 showTmImpls rhs)) (pe_clauses specdecl))

393

394

394− logLvl 2 $ show n ++ " transformation rule: " ++

395+ logElab 2 $ show n ++ " transformation rule: " ++

395 showTmImpls rhs ++ " ==> " ++ showTmImpls lhs

396 showTmImpls rhs ++ " ==> " ++ showTmImpls lhs

396

397

397 elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy

398 elabType info defaultSyntax emptyDocstring [] fc opts newnm NoFC specTy

398 let def = map (\(lhs, rhs) ->

399 let def = map (\(lhs, rhs) ->

399 let lhs' = mapPT hiddenToPH $ stripUnmatchable ist lhs in

400 let lhs' = mapPT hiddenToPH $ stripUnmatchable ist lhs in

400− PClause fc newnm lhs' [] rhs [])

401+ PClause fc newnm lhs' [] rhs [])

401− (pe_clauses specdecl)

402+ (pe_clauses specdecl)

402 trans <- elabTransform info fc False rhs lhs

403 trans <- elabTransform info fc False rhs lhs

403 elabClauses info fc (PEGenerated:opts) newnm def

404 elabClauses info fc (PEGenerated:opts) newnm def

404 return [trans]

405 return [trans]

@@ -406,7 +407,7 @@ elabPE info fc caller r =

406 -- if it doesn't work, just don't specialise. Could happen for lots

407 -- if it doesn't work, just don't specialise. Could happen for lots

407 -- of valid reasons (e.g. local variables in scope which can't be

408 -- of valid reasons (e.g. local variables in scope which can't be

408 -- lifted out).

409 -- lifted out).

409− (\e -> do logLvl 3 $ "Couldn't specialise: " ++ (pshow ist e)

410+ (\e -> do logElab 3 $ "Couldn't specialise: " ++ (pshow ist e)

410 return [])

411 return [])

411

412

412 hiddenToPH (PHidden _) = Placeholder

413 hiddenToPH (PHidden _) = Placeholder

@@ -449,7 +450,7 @@ elabPE info fc caller r =

449 -- get the clause of a specialised application

450 -- get the clause of a specialised application

450 getSpecClause ist (n, args)

451 getSpecClause ist (n, args)

451 = let newnm = sUN ("PE_" ++ show (nsroot n) ++ "_" ++

452 = let newnm = sUN ("PE_" ++ show (nsroot n) ++ "_" ++

452− qhash 5381 (showSep "_" (map showArg args))) in

453+ qhash 5381 (showSep "_" (map showArg args))) in

453 -- UN (show n ++ show (map snd args)) in

454 -- UN (show n ++ show (map snd args)) in

454 (n, newnm, mkPE_TermDecl ist newnm n args)

455 (n, newnm, mkPE_TermDecl ist newnm n args)

455 where showArg (ExplicitS, n) = qshow n

456 where showArg (ExplicitS, n) = qshow n

@@ -476,7 +477,9 @@ checkPossible info fc tcgen fname lhs_in

476 let lhs = addImplPat i lhs_in

477 let lhs = addImplPat i lhs_in

477 -- if the LHS type checks, it is possible

478 -- if the LHS type checks, it is possible

478 case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

479 case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

479− (erun fc (buildTC i info ELHS [] fname (infTerm lhs))) of

480+ (erun fc (buildTC i info ELHS [] fname

481+ (allNamesIn lhs_in)

482+ (infTerm lhs))) of

480 OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

483 OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

481 do setContext ctxt'

484 do setContext ctxt'

482 processTacticDecls info newDecls

485 processTacticDecls info newDecls

@@ -491,19 +494,19 @@ checkPossible info fc tcgen fname lhs_in

491 recoverableCoverage ctxt err)

494 recoverableCoverage ctxt err)

492

495

493

496

494−propagateParams :: IState -> [Name] -> Type -> PTerm -> PTerm

497+propagateParams :: IState -> [Name] -> Type -> [Name] -> PTerm -> PTerm

495−propagateParams i ps t tm@(PApp _ (PRef fc hls n) args)

498+propagateParams i ps t bound tm@(PApp _ (PRef fc hls n) args)

496 = PApp fc (PRef fc hls n) (addP t args)

499 = PApp fc (PRef fc hls n) (addP t args)

497 where addP (Bind n _ sc) (t : ts)

500 where addP (Bind n _ sc) (t : ts)

498 | Placeholder <- getTm t,

501 | Placeholder <- getTm t,

499 n `elem` ps,

502 n `elem` ps,

500− not (n `elem` allNamesIn tm)

503+ not (n `elem` bound)

501− = t { getTm = PRef NoFC [] n } : addP sc ts

504+ = t { getTm = PPatvar NoFC n } : addP sc ts

502 addP (Bind n _ sc) (t : ts) = t : addP sc ts

505 addP (Bind n _ sc) (t : ts) = t : addP sc ts

503 addP _ ts = ts

506 addP _ ts = ts

504−propagateParams i ps t tm@(PApp fc ap args)

507+propagateParams i ps t bound (PApp fc ap args)

505− = PApp fc (propagateParams i ps t ap) args

508+ = PApp fc (propagateParams i ps t bound ap) args

506−propagateParams i ps t (PRef fc hls n)

509+propagateParams i ps t bound (PRef fc hls n)

507 = case lookupCtxt n (idris_implicits i) of

510 = case lookupCtxt n (idris_implicits i) of

508 [is] -> let ps' = filter (isImplicit is) ps in

511 [is] -> let ps' = filter (isImplicit is) ps in

509 PApp fc (PRef fc hls n) (map (\x -> pimp x (PRef fc [] x) True) ps')

512 PApp fc (PRef fc hls n) (map (\x -> pimp x (PRef fc [] x) True) ps')

@@ -511,7 +514,7 @@ propagateParams i ps t (PRef fc hls n)

511 where isImplicit [] n = False

514 where isImplicit [] n = False

512 isImplicit (PImp _ _ _ x _ : is) n | x == n = True

515 isImplicit (PImp _ _ _ x _ : is) n | x == n = True

513 isImplicit (_ : is) n = isImplicit is n

516 isImplicit (_ : is) n = isImplicit is n

514−propagateParams i ps t x = x

517+propagateParams i ps t bound x = x

515

518

516findUnique :: Context -> Env -> Term -> [Name]

519findUnique :: Context -> Env -> Term -> [Name]

517findUnique ctxt env (Bind n b sc)

520findUnique ctxt env (Bind n b sc)

@@ -548,6 +551,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

548 -- pattern bindings

551 -- pattern bindings

549 i <- getIState

552 i <- getIState

550 inf <- isTyInferred fname

553 inf <- isTyInferred fname

554+

555+ -- Check if we have "with" patterns outside of "with" block

556+ when (isOutsideWith lhs_in && (not $ null withs)) $

557+ ierror $ (At fc (Elaborating "left hand side of " fname Nothing

558+ (Msg "unexpected patterns outside of \"with\" block")))

559+

551 -- get the parameters first, to pass through to any where block

560 -- get the parameters first, to pass through to any where block

552 let fn_ty = case lookupTy fname (tt_ctxt i) of

561 let fn_ty = case lookupTy fname (tt_ctxt i) of

553 [t] -> t

562 [t] -> t

@@ -560,34 +569,36 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

560 let tcparams = getTCParamsInType i [] fn_is norm_ty

569 let tcparams = getTCParamsInType i [] fn_is norm_ty

561

570

562 let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $

571 let lhs = mkLHSapp $ stripLinear i $ stripUnmatchable i $

563− propagateParams i params norm_ty (addImplPat i lhs_in)

572+ propagateParams i params norm_ty (allNamesIn lhs_in) (addImplPat i lhs_in)

564−-- let lhs = mkLHSapp $

573+-- let lhs = mkLHSapp $

565-- propagateParams i params fn_ty (addImplPat i lhs_in)

574-- propagateParams i params fn_ty (addImplPat i lhs_in)

566− logLvl 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))

575+ logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))

567− logLvl 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)

576+ logElab 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)

568− logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

577+ logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

569 "\n" ++ show (fn_ty, fn_is))

578 "\n" ++ show (fn_ty, fn_is))

570

579

571 ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

580 ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

572 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

581 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

573− (do res <- errAt "left hand side of " fname

582+ (do res <- errAt "left hand side of " fname Nothing

574− (erun fc (buildTC i info ELHS opts fname (infTerm lhs)))

583+ (erun fc (buildTC i info ELHS opts fname

584+ (allNamesIn lhs_in)

585+ (infTerm lhs)))

575 probs <- get_probs

586 probs <- get_probs

576 inj <- get_inj

587 inj <- get_inj

577 return (res, probs, inj))

588 return (res, probs, inj))

578 setContext ctxt'

589 setContext ctxt'

579 processTacticDecls info newDecls

590 processTacticDecls info newDecls

580 sendHighlighting highlights

591 sendHighlighting highlights

581−

592+

582 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

593 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

583

594

584 let lhs_tm = orderPats (getInferTerm lhs')

595 let lhs_tm = orderPats (getInferTerm lhs')

585 let lhs_ty = getInferType lhs'

596 let lhs_ty = getInferType lhs'

586 let static_names = getStaticNames i lhs_tm

597 let static_names = getStaticNames i lhs_tm

587

598

588− logLvl 3 ("Elaborated: " ++ show lhs_tm)

599+ logElab 3 ("Elaborated: " ++ show lhs_tm)

589− logLvl 3 ("Elaborated type: " ++ show lhs_ty)

600+ logElab 3 ("Elaborated type: " ++ show lhs_ty)

590− logLvl 5 ("Injective: " ++ show fname ++ " " ++ show inj)

601+ logElab 5 ("Injective: " ++ show fname ++ " " ++ show inj)

591

602

592 -- If we're inferring metavariables in the type, don't recheck,

603 -- If we're inferring metavariables in the type, don't recheck,

593 -- because we're only doing this to try to work out those metavariables

604 -- because we're only doing this to try to work out those metavariables

@@ -604,16 +615,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

604 -- Issue #1615 on the Issue Tracker.

615 -- Issue #1615 on the Issue Tracker.

605 -- https://github.com/idris-lang/Idris-dev/issues/1615

616 -- https://github.com/idris-lang/Idris-dev/issues/1615

606 when (not (null borrowed)) $

617 when (not (null borrowed)) $

607− logLvl 5 ("Borrowed names on LHS: " ++ show borrowed)

618+ logElab 5 ("Borrowed names on LHS: " ++ show borrowed)

608

619

609− logLvl 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs))

620+ logElab 3 ("Normalised LHS: " ++ showTmImpls (delabMV i clhs))

610

621

611 rep <- useREPL

622 rep <- useREPL

612 when rep $ do

623 when rep $ do

613 addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?

624 addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?

614 addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

625 addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

615

626

616− logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

627+ logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

617 -- Elaborate where block

628 -- Elaborate where block

618 ist <- getIState

629 ist <- getIState

619 windex <- getName

630 windex <- getName

@@ -636,16 +647,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

636 -- Elaborate those with a type *before* RHS, those without *after*

647 -- Elaborate those with a type *before* RHS, those without *after*

637 let (wbefore, wafter) = sepBlocks wb

648 let (wbefore, wafter) = sepBlocks wb

638

649

639− logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

650+ logElab 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

640 mapM_ (rec_elabDecl info EAll winfo) wbefore

651 mapM_ (rec_elabDecl info EAll winfo) wbefore

641 -- Now build the RHS, using the type of the LHS as the goal.

652 -- Now build the RHS, using the type of the LHS as the goal.

642 i <- getIState -- new implicits from where block

653 i <- getIState -- new implicits from where block

643− logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

654+ logElab 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

644 let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls)

655 let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls)

645 (expandParams decorate newargs defs (defs \\ decls) rhs_in)

656 (expandParams decorate newargs defs (defs \\ decls) rhs_in)

646− logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

657+ logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

647 ctxt <- getContext -- new context with where block added

658 ctxt <- getContext -- new context with where block added

648− logLvl 5 "STARTING CHECK"

659+ logElab 5 "STARTING CHECK"

649 ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

660 ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

650 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

661 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

651 (do pbinds ist lhs_tm

662 (do pbinds ist lhs_tm

@@ -654,15 +665,13 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

654 mapM_ setinj (nub (tcparams ++ inj))

665 mapM_ setinj (nub (tcparams ++ inj))

655 setNextName

666 setNextName

656 (ElabResult _ _ is ctxt' newDecls highlights) <-

667 (ElabResult _ _ is ctxt' newDecls highlights) <-

657− errAt "right hand side of " fname

668+ errAt "right hand side of " fname (Just clhsty)

658 (erun fc (build i winfo ERHS opts fname rhs))

669 (erun fc (build i winfo ERHS opts fname rhs))

659− errAt "right hand side of " fname

670+ errAt "right hand side of " fname (Just clhsty)

660 (erun fc $ psolve lhs_tm)

671 (erun fc $ psolve lhs_tm)

661− hs <- get_holes

662− mapM_ (elabCaseHole is) hs

663 tt <- get_term

672 tt <- get_term

664 aux <- getAux

673 aux <- getAux

665− let (tm, ds) = runState (collectDeferred (Just fname)

674+ let (tm, ds) = runState (collectDeferred (Just fname)

666 (map fst $ case_decls aux) ctxt tt) []

675 (map fst $ case_decls aux) ctxt tt) []

667 probs <- get_probs

676 probs <- get_probs

668 return (tm, ds, is, probs, ctxt', newDecls, highlights))

677 return (tm, ds, is, probs, ctxt', newDecls, highlights))

@@ -672,11 +681,11 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

672

681

673 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

682 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

674

683

675− logLvl 5 "DONE CHECK"

684+ logElab 5 "DONE CHECK"

676− logLvl 4 $ "---> " ++ show rhs'

685+ logElab 4 $ "---> " ++ show rhs'

677− when (not (null defer)) $ logLvl 1 $ "DEFERRED " ++

686+ when (not (null defer)) $ logElab 1 $ "DEFERRED " ++

678 show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)

687 show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)

679− def' <- checkDef fc (Elaborating "deferred type of ") defer

688+ def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) defer

680 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

689 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

681 addDeferred def''

690 addDeferred def''

682 mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

691 mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

@@ -691,20 +700,20 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

691 mapM_ (elabCaseBlock winfo opts) is

700 mapM_ (elabCaseBlock winfo opts) is

692

701

693 ctxt <- getContext

702 ctxt <- getContext

694− logLvl 5 $ "Rechecking"

703+ logElab 5 $ "Rechecking"

695− logLvl 6 $ " ==> " ++ show (forget rhs')

704+ logElab 6 $ " ==> " ++ show (forget rhs')

696

705

697 (crhs, crhsty) <- if not inf

706 (crhs, crhsty) <- if not inf

698 then recheckC_borrowing True (PEGenerated `notElem` opts)

707 then recheckC_borrowing True (PEGenerated `notElem` opts)

699 borrowed fc id [] rhs'

708 borrowed fc id [] rhs'

700 else return (rhs', clhsty)

709 else return (rhs', clhsty)

701− logLvl 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty

710+ logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty

702 ctxt <- getContext

711 ctxt <- getContext

703 let constv = next_tvar ctxt

712 let constv = next_tvar ctxt

704 case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of

713 case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of

705 OK (_, cs) -> when (PEGenerated `notElem` opts) $ do

714 OK (_, cs) -> when (PEGenerated `notElem` opts) $ do

706− addConstraints fc cs

715+ addConstraints fc cs

707− logLvl 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty)

716+ logElab 6 $ "CONSTRAINTS ADDED: " ++ show cs ++ "\n" ++ show (clhsty, crhsty)

708 return ()

717 return ()

709 Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0))

718 Error e -> ierror (At fc (CantUnify False (clhsty, Nothing) (crhsty, Nothing) e [] 0))

710 i <- getIState

719 i <- getIState

@@ -777,26 +786,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

777 (b : bf, af)

786 (b : bf, af)

778 sepBlocks' ns [] = ([], [])

787 sepBlocks' ns [] = ([], [])

779

788

780−

789+ -- term is not within "with" block

781− -- if a hole is just an argument/result of a case block, treat it as

790+ isOutsideWith :: PTerm -> Bool

782− -- the unit type. Hack to help elaborate case in do blocks.

791+ isOutsideWith (PApp _ (PRef _ _ (SN (WithN _ _))) _) = False

783− elabCaseHole aux h = do

792+ isOutsideWith _ = True

784− focus h

785− g <- goal

786− case g of

787− TType _ -> when (any (isArg h) aux) $ do apply (Var unitTy) []; solve

788− _ -> return ()

789−

790− -- Is the name a pattern argument in the declaration

791− isArg :: Name -> PDecl -> Bool

792− isArg n (PClauses _ _ _ cs) = any isArg' cs

793− where

794− isArg' (PClause _ _ (PApp _ _ args) _ _ _)

795− = any (\x -> case x of

796− PRef _ _ n' -> n == n'

797− _ -> False) (map getTm args)

798− isArg' _ = False

799− isArg _ _ = False

800

793

801elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

794elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

802 = do let tcgen = Dictionary `elem` opts

795 = do let tcgen = Dictionary `elem` opts

@@ -812,12 +805,16 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

812 [t] -> t

805 [t] -> t

813 _ -> []

806 _ -> []

814 let params = getParamsInType i [] fn_is (normalise ctxt [] fn_ty)

807 let params = getParamsInType i [] fn_is (normalise ctxt [] fn_ty)

815− let lhs = stripLinear i $ stripUnmatchable i $ propagateParams i params fn_ty (addImplPat i lhs_in)

808+ let lhs = stripLinear i $ stripUnmatchable i $

809+ propagateParams i params fn_ty (allNamesIn lhs_in)

810+ (addImplPat i lhs_in)

816− logLvl 2 ("LHS: " ++ show lhs)

811+ logElab 2 ("LHS: " ++ show lhs)

817 (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

812 (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

818 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

813 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

819− (errAt "left hand side of with in " fname

814+ (errAt "left hand side of with in " fname Nothing

820− (erun fc (buildTC i info ELHS opts fname (infTerm lhs))) )

815+ (erun fc (buildTC i info ELHS opts fname

816+ (allNamesIn lhs_in)

817+ (infTerm lhs))) )

821 setContext ctxt'

818 setContext ctxt'

822 processTacticDecls info newDecls

819 processTacticDecls info newDecls

823 sendHighlighting highlights

820 sendHighlighting highlights

@@ -826,12 +823,12 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

826 let lhs_ty = getInferType lhs'

823 let lhs_ty = getInferType lhs'

827 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

824 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

828 let static_names = getStaticNames i lhs_tm

825 let static_names = getStaticNames i lhs_tm

829− logLvl 5 (show lhs_tm ++ "\n" ++ show static_names)

826+ logElab 5 (show lhs_tm ++ "\n" ++ show static_names)

830 (clhs, clhsty) <- recheckC fc id [] lhs_tm

827 (clhs, clhsty) <- recheckC fc id [] lhs_tm

831− logLvl 5 ("Checked " ++ show clhs)

828+ logElab 5 ("Checked " ++ show clhs)

832 let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))

829 let bargs = getPBtys (explicitNames (normalise ctxt [] lhs_tm))

833 let wval = addImplBound i (map fst bargs) wval_in

830 let wval = addImplBound i (map fst bargs) wval_in

834− logLvl 5 ("Checking " ++ showTmImpls wval)

831+ logElab 5 ("Checking " ++ showTmImpls wval)

835 -- Elaborate wval in this context

832 -- Elaborate wval in this context

836 ((wval', defer, is, ctxt', newDecls, highlights), _) <-

833 ((wval', defer, is, ctxt', newDecls, highlights), _) <-

837 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

834 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

@@ -841,7 +838,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

841 mapM_ addPSname (allNamesIn lhs_in)

838 mapM_ addPSname (allNamesIn lhs_in)

842 setNextName

839 setNextName

843 -- TODO: may want where here - see winfo abpve

840 -- TODO: may want where here - see winfo abpve

844− (ElabResult _ d is ctxt' newDecls highlights) <- errAt "with value in " fname

841+ (ElabResult _ d is ctxt' newDecls highlights) <- errAt "with value in " fname Nothing

845 (erun fc (build i info ERHS opts fname (infTerm wval)))

842 (erun fc (build i info ERHS opts fname (infTerm wval)))

846 erun fc $ psolve lhs_tm

843 erun fc $ psolve lhs_tm

847 tt <- get_term

844 tt <- get_term

@@ -854,11 +851,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

854 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

851 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

855 addDeferred def''

852 addDeferred def''

856 mapM_ (elabCaseBlock info opts) is

853 mapM_ (elabCaseBlock info opts) is

857− logLvl 5 ("Checked wval " ++ show wval')

854+ logElab 5 ("Checked wval " ++ show wval')

858 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

855 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

859 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

856 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

860 let cwvalN = explicitNames (normalise ctxt [] cwval)

857 let cwvalN = explicitNames (normalise ctxt [] cwval)

861− logLvl 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)

858+ logElab 3 ("With type " ++ show cwvalty ++ "\nRet type " ++ show ret_ty)

862 -- We're going to assume the with type is not a function shortly,

859 -- We're going to assume the with type is not a function shortly,

863 -- so report an error if it is (you can't match on a function anyway

860 -- so report an error if it is (you can't match on a function anyway

864 -- so this doesn't lose anything)

861 -- so this doesn't lose anything)

@@ -879,9 +876,9 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

879 -- Highlight explicit proofs

876 -- Highlight explicit proofs

880 sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in]

877 sendHighlighting $ [(fc, AnnBoundName n False) | (n, fc) <- maybeToList pn_in]

881

878

882− logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

879+ logElab 10 ("With type " ++ show (getRetTy cwvaltyN) ++

883 " depends on " ++ show pdeps ++ " from " ++ show pvars)

880 " depends on " ++ show pdeps ++ " from " ++ show pvars)

884− logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

881+ logElab 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

885 windex <- getName

882 windex <- getName

886 -- build a type declaration for the new function:

883 -- build a type declaration for the new function:

887 -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

884 -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

@@ -889,7 +886,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

889 let wargtype = getRetTy cwvaltyN

886 let wargtype = getRetTy cwvaltyN

890 let wargname = sMN windex "warg"

887 let wargname = sMN windex "warg"

891

888

892− logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)

889+ logElab 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)

893 let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++

890 let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++

894 (wargname, wargtype) :

891 (wargname, wargtype) :

895 map (abstract wargname wargval wargtype) bargs_post ++

892 map (abstract wargname wargval wargtype) bargs_post ++

@@ -899,13 +896,13 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

899 P Bound wargname Erased, wargval])]

896 P Bound wargname Erased, wargval])]

900 Nothing -> [])

897 Nothing -> [])

901 (substTerm wargval (P Bound wargname wargtype) ret_ty)

898 (substTerm wargval (P Bound wargname wargtype) ret_ty)

902− logLvl 3 ("New function type " ++ show wtype)

899+ logElab 3 ("New function type " ++ show wtype)

903 let wname = SN (WithN windex fname)

900 let wname = SN (WithN windex fname)

904

901

905 let imps = getImps wtype -- add to implicits context

902 let imps = getImps wtype -- add to implicits context

906 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

903 putIState (i { idris_implicits = addDef wname imps (idris_implicits i) })

907 let statics = getStatics static_names wtype

904 let statics = getStatics static_names wtype

908− logLvl 5 ("Static positions " ++ show statics)

905+ logElab 5 ("Static positions " ++ show statics)

909 i <- getIState

906 i <- getIState

910 putIState (i { idris_statics = addDef wname statics (idris_statics i) })

907 putIState (i { idris_statics = addDef wname statics (idris_statics i) })

911

908

@@ -922,7 +919,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

922 -- ==> fname' ps wpat [rest], match pats against toplevel for ps

919 -- ==> fname' ps wpat [rest], match pats against toplevel for ps

923 wb <- mapM (mkAuxC mpn wname lhs (map fst bargs_pre) (map fst bargs_post))

920 wb <- mapM (mkAuxC mpn wname lhs (map fst bargs_pre) (map fst bargs_post))

924 withblock

921 withblock

925− logLvl 3 ("with block " ++ show wb)

922+ logElab 3 ("with block " ++ show wb)

926 -- propagate totality assertion to the new definitions

923 -- propagate totality assertion to the new definitions

927 when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]

924 when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]

928 mapM_ (rec_elabDecl info EAll info) wb

925 mapM_ (rec_elabDecl info EAll info) wb

@@ -938,7 +935,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

938 [ pimp (sUN "A") Placeholder False

935 [ pimp (sUN "A") Placeholder False

939 , pimp (sUN "x") Placeholder False

936 , pimp (sUN "x") Placeholder False

940 ])])

937 ])])

941− logLvl 5 ("New RHS " ++ showTmImpls rhs)

938+ logElab 5 ("New RHS " ++ showTmImpls rhs)

942 ctxt <- getContext -- New context with block added

939 ctxt <- getContext -- New context with block added

943 i <- getIState

940 i <- getIState

944 ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

941 ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

@@ -958,7 +955,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

958 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

955 let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

959 addDeferred def''

956 addDeferred def''

960 mapM_ (elabCaseBlock info opts) is

957 mapM_ (elabCaseBlock info opts) is

961− logLvl 5 ("Checked RHS " ++ show rhs')

958+ logElab 5 ("Checked RHS " ++ show rhs')

962 (crhs, crhsty) <- recheckC fc id [] rhs'

959 (crhs, crhsty) <- recheckC fc id [] rhs'

963 return $ (Right (clhs, crhs), lhs)

960 return $ (Right (clhs, crhs), lhs)

964 where

961 where

@@ -974,18 +971,18 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

974 mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

971 mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

975 = do i <- getIState

972 = do i <- getIState

976 let tm = addImplPat i tm_in

973 let tm = addImplPat i tm_in

977− logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

974+ logElab 2 ("Matching " ++ showTmImpls tm ++ " against " ++

978 showTmImpls toplhs)

975 showTmImpls toplhs)

979 case matchClause i toplhs tm of

976 case matchClause i toplhs tm of

980 Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"

977 Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"

981 Right mvars ->

978 Right mvars ->

982− do logLvl 3 ("Match vars : " ++ show mvars)

979+ do logElab 3 ("Match vars : " ++ show mvars)

983 lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w

980 lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w

984 return $ PClause fc wname lhs ws rhs wheres

981 return $ PClause fc wname lhs ws rhs wheres

985 mkAux pn wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval pn' withs)

982 mkAux pn wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval pn' withs)

986 = do i <- getIState

983 = do i <- getIState

987 let tm = addImplPat i tm_in

984 let tm = addImplPat i tm_in

988− logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

985+ logElab 2 ("Matching " ++ showTmImpls tm ++ " against " ++

989 showTmImpls toplhs)

986 showTmImpls toplhs)

990 withs' <- mapM (mkAuxC pn wname toplhs ns ns') withs

987 withs' <- mapM (mkAuxC pn wname toplhs ns ns') withs

991 case matchClause i toplhs tm of

988 case matchClause i toplhs tm of

@@ -1004,7 +1001,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

1004 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

1001 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

1005 return $ substMatches mvars $

1002 return $ substMatches mvars $

1006 PApp fc (PRef fc' [] wname)

1003 PApp fc (PRef fc' [] wname)

1007− (map pexp ns ++ pexp w : (map pexp ns') ++

1004+ (map pexp ns ++ pexp w : (map pexp ns') ++

1008 case pn of

1005 case pn of

1009 Nothing -> []

1006 Nothing -> []

1010 Just pnm -> [pexp (PRef fc [] pnm)])

1007 Just pnm -> [pexp (PRef fc [] pnm)])

src/Idris/Elab/Data.hs+30−20

@@ -48,13 +48,19 @@ import qualified Data.Text as T

48import Data.Char(isLetter, toLower)

49import Data.List.Split (splitOn)

50

51−import Util.Pretty(pretty, text)

51+import Util.Pretty

52+

53+warnLC :: FC -> Name -> Idris ()

54+warnLC fc n

55+ = iWarn fc $ annName n <+> text "has a name which may be implicitly bound."

56+ <> line <> text "This is likely to lead to problems!"

52

57

53elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris ()

58elabData :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm)-> [(Name, Docstring (Either Err PTerm))] -> FC -> DataOpts -> PData -> Idris ()

54elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)

59elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)

55 = do let codata = Codata `elem` opts

60 = do let codata = Codata `elem` opts

56− logLvl 1 (show (fc, doc))

61+ logElab 1 (show (fc, doc))

57 checkUndefined fc n

62 checkUndefined fc n

63+ when (implicitable n) $ warnLC fc n

58 (cty, _, t, inacc) <- buildType info syn fc [] n t_in

64 (cty, _, t, inacc) <- buildType info syn fc [] n t_in

59

65

60 addIBC (IBCDef n)

66 addIBC (IBCDef n)

@@ -63,8 +69,9 @@ elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)

63

69

64elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

70elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

65 = do let codata = Codata `elem` opts

71 = do let codata = Codata `elem` opts

66− logLvl 1 (show fc)

72+ logElab 1 (show fc)

67 undef <- isUndefined fc n

73 undef <- isUndefined fc n

74+ when (implicitable n) $ warnLC fc n

68 (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in

75 (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in

69 -- if n is defined already, make sure it is just a type declaration

76 -- if n is defined already, make sure it is just a type declaration

70 -- with the same type we've just elaborated, and no constructors

77 -- with the same type we've just elaborated, and no constructors

@@ -74,15 +81,17 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

74 -- temporary, to check cons

81 -- temporary, to check cons

75 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

82 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

76 let cnameinfo = cinfo info (map cname dcons)

83 let cnameinfo = cinfo info (map cname dcons)

77− let unique = case getRetTy cty of

84+ unique <- case getRetTy (normalise (tt_ctxt i) [] cty) of

78− UType UniqueType -> True

85+ UType UniqueType -> return True

86+ UType _ -> return False

79− _ -> False

87+ TType _ -> return False

88+ rt -> tclift $ tfail (At fc (Elaborating "type constructor " n Nothing (Msg "Not a valid type constructor")))

80 cons <- mapM (elabCon cnameinfo syn n codata (getRetTy cty) ckind) dcons

89 cons <- mapM (elabCon cnameinfo syn n codata (getRetTy cty) ckind) dcons

81 ttag <- getName

90 ttag <- getName

82 i <- getIState

91 i <- getIState

83 let as = map (const (Left (Msg ""))) (getArgTys cty)

92 let as = map (const (Left (Msg ""))) (getArgTys cty)

84 let params = findParams (map snd cons)

93 let params = findParams (map snd cons)

85− logLvl 2 $ "Parameters : " ++ show params

94+ logElab 2 $ "Parameters : " ++ show params

86 -- TI contains information about mutually declared types - this will

95 -- TI contains information about mutually declared types - this will

87 -- be updated when the mutual block is complete

96 -- be updated when the mutual block is complete

88 putIState (i { idris_datatypes =

97 putIState (i { idris_datatypes =

@@ -222,7 +231,8 @@ elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

222 Idris (Name, Type)

231 Idris (Name, Type)

223elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

232elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

224 = do checkUndefined fc n

233 = do checkUndefined fc n

234+ when (implicitable n) $ warnLC fc n

225− logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

235+ logElab 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

226 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

236 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

227 ctxt <- getContext

237 ctxt <- getContext

228 let cty' = normalise ctxt [] cty

238 let cty' = normalise ctxt [] cty

@@ -232,13 +242,13 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

232 -- Check that the constructor type is, in fact, a part of the family being defined

242 -- Check that the constructor type is, in fact, a part of the family being defined

233 tyIs n cty'

243 tyIs n cty'

234

244

235− logLvl 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t

245+ logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t

236− logLvl 5 $ "Inaccessible args: " ++ show inacc

246+ logElab 5 $ "Inaccessible args: " ++ show inacc

237− logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'

247+ logElab 2 $ "---> " ++ show n ++ " : " ++ show cty'

238

248

239 -- Add to the context (this is temporary, so that later constructors

249 -- Add to the context (this is temporary, so that later constructors

240 -- can be indexed by it)

250 -- can be indexed by it)

241− updateContext (addTyDecl n (DCon 0 0 False) cty)

251+ updateContext (addTyDecl n (DCon 0 0 False) cty)

242

252

243 addIBC (IBCDef n)

253 addIBC (IBCDef n)

244 checkDocs fc argDocs t

254 checkDocs fc argDocs t

@@ -253,9 +263,9 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

253 where

263 where

254 tyIs con (Bind n b sc) = tyIs con sc

264 tyIs con (Bind n b sc) = tyIs con sc

255 tyIs con t | (P _ n' _, _) <- unApply t

265 tyIs con t | (P _ n' _, _) <- unApply t

256− = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show n' ++ " is not " ++ show tn))))

266+ = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show n' ++ " is not " ++ show tn))))

257 else return ()

267 else return ()

258− tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con (Msg (show t ++ " is not " ++ show tn))))

268+ tyIs con t = tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show t ++ " is not " ++ show tn))))

259

269

260 mkLazy (PPi pl n nfc ty sc)

270 mkLazy (PPi pl n nfc ty sc)

261 = let ty' = if getTyName ty

271 = let ty' = if getTyName ty

@@ -288,12 +298,12 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

288 = tclift $ tfail (At fc (UniqueKindError UniqueType n))

298 = tclift $ tfail (At fc (UniqueKindError UniqueType n))

289 checkUniqueKind (UType AllTypes) (UType AllTypes) = return ()

299 checkUniqueKind (UType AllTypes) (UType AllTypes) = return ()

290 checkUniqueKind (UType AllTypes) (UType UniqueType) = return ()

300 checkUniqueKind (UType AllTypes) (UType UniqueType) = return ()

291− checkUniqueKind (UType AllTypes) _

301+ checkUniqueKind (UType AllTypes) _

292 = tclift $ tfail (At fc (UniqueKindError AllTypes n))

302 = tclift $ tfail (At fc (UniqueKindError AllTypes n))

293 checkUniqueKind _ _ = return ()

303 checkUniqueKind _ _ = return ()

294

304

295 -- Constructor's kind must be <= expected kind

305 -- Constructor's kind must be <= expected kind

296− addDataConstraint (TType con) (TType exp)

306+ addDataConstraint (TType con) (TType exp)

297 = do ctxt <- getContext

307 = do ctxt <- getContext

298 let v = next_tvar ctxt

308 let v = next_tvar ctxt

299 addConstraints fc (v, [ULT con exp])

309 addConstraints fc (v, [ULT con exp])

@@ -337,20 +347,20 @@ elabCaseFun ind paramPos n ty cons info = do

337 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

347 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

338 elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef

348 elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef

339 State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl)

349 State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl)

340− (ierror . Elaborating "type declaration of " elimDeclName)

350+ (ierror . Elaborating "type declaration of " elimDeclName Nothing)

341 -- Do not elaborate clauses if there aren't any

351 -- Do not elaborate clauses if there aren't any

342 case eliminatorClauses of

352 case eliminatorClauses of

343 [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

353 [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

344 _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

354 _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

345− (ierror . Elaborating "clauses of " elimDeclName)

355+ (ierror . Elaborating "clauses of " elimDeclName Nothing)

346 where elimLog :: String -> EliminatorState ()

356 where elimLog :: String -> EliminatorState ()

347− elimLog s = State.lift (logLvl 2 s)

357+ elimLog s = State.lift (logElab 2 s)

348

358

349 elimFC :: FC

359 elimFC :: FC

350 elimFC = fileFC "(casefun)"

360 elimFC = fileFC "(casefun)"

351

361

352 elimDeclName :: Name

362 elimDeclName :: Name

353− elimDeclName = if ind then SN . ElimN $ n else SN . CaseN $ n

363+ elimDeclName = if ind then SN . ElimN $ n else SN . CaseN (FC' emptyFC) $ n

354

364

355 applyNS :: Name -> [String] -> Name

365 applyNS :: Name -> [String] -> Name

356 applyNS n [] = n

366 applyNS n [] = n

src/Idris/Elab/Instance.hs+15−16

@@ -71,7 +71,7 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

71 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

72 let iname = mkiname n (namespace info) ps expn

73 let emptyclass = null (class_methods ci)

74− when (what /= EDefns) $ do

74+ when (what /= EDefns) $ do

75 nty <- elabType' True info syn doc argDocs fc [] iname NoFC t

76 -- if the instance type matches any of the instances we have already,

77 -- and it's not a named instance, then it's overlapping, so report an error

@@ -106,19 +106,19 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

106 (decorate ns iname n,

107 op, coninsert cs t', t'))

108 (class_methods ci)

109− logLvl 3 (show (mtys, ips))

109+ logElab 3 (show (mtys, ips))

110− logLvl 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))

110+ logElab 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))

111 let ds_defs = insertDefaults i iname (class_defaults ci) ns ds

112− logLvl 3 ("After defaults: " ++ show ds_defs ++ "\n")

112+ logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")

113 let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs

114− logLvl 1 ("Reordered: " ++ show ds' ++ "\n")

114+ logElab 1 ("Reordered: " ++ show ds' ++ "\n")

115 mapM_ (warnMissing ds' ns iname) (map fst (class_methods ci))

116 mapM_ (checkInClass (map fst (class_methods ci))) (concatMap defined ds')

117 let wbTys = map mkTyDecl mtys

118 let wbVals = map (decorateid (decorate ns iname)) ds'

119 let wb = wbTys ++ wbVals

120− logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)

120+ logElab 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)

121− logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

121+ logElab 3 $ "Instance is " ++ show ps ++ " implicits " ++

122 show (concat (nub wparams))

123

124 -- Bring variables in instance head into scope

@@ -134,12 +134,12 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

134 let rhs = PApp fc (PRef fc [] (instanceCtorName ci))

135 (map (pexp . mkMethApp) mtys)

136

137− logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

137+ logElab 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

138− logLvl 5 $ "Instance RHS " ++ show rhs

138+ logElab 5 $ "Instance RHS " ++ show rhs

139

140 let idecls = [PClauses fc [Dictionary] iname

141 [PClause fc iname lhs [] rhs wb]]

142− logLvl 1 (show idecls)

142+ logElab 1 (show idecls)

143 push_estack iname True

144 mapM_ (rec_elabDecl info EAll info) idecls

145 pop_estack

@@ -181,7 +181,7 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

181 ctxt <- getContext

182 (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-

183 tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

184− (errAt "type of " iname (erun fc (build i info ERHS [] iname ty)))

184+ (errAt "type of " iname Nothing (erun fc (build i info ERHS [] iname ty)))

185 setContext ctxt'

186 processTacticDecls info newDecls

187 sendHighlighting highlights

@@ -267,11 +267,11 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

267 reorderDefs :: [Name] -> [PDecl] -> [PDecl]

268 reorderDefs ns [] = []

269 reorderDefs [] ds = ds

270− reorderDefs (n : ns) ds = case pick n [] ds of

270+ reorderDefs (n : ns) ds = case pick n [] ds of

271 Just (def, ds') -> def : reorderDefs ns ds'

272 Nothing -> reorderDefs ns ds

273

274− pick n acc [] = Nothing

274+ pick n acc [] = Nothing

275 pick n acc (def@(PClauses _ _ cn cs) : ds)

276 | nsroot n == nsroot cn = Just (def, acc ++ ds)

277 pick n acc (d : ds) = pick n (acc ++ [d]) ds

@@ -313,13 +313,13 @@ checkInjectiveArgs fc n ds (Just ty)

313 let (_, args) = unApply (instantiateRetTy ty)

314 ci 0 ist args

315 where

316− ci i ist (a : as) | i `elem` ds

316+ ci i ist (a : as) | i `elem` ds

317 = if isInj ist a then ci (i + 1) ist as

318 else tclift $ tfail (At fc (InvalidTCArg n a))

319 ci i ist (a : as) = ci (i + 1) ist as

320 ci i ist [] = return ()

321

322− isInj i (P Bound n _) = True

322+ isInj i (P Bound n _) = True

323 isInj i (P _ n _) = isConName n (tt_ctxt i)

324 isInj i (App _ f a) = isInj i f && isInj i a

325 isInj i (V _) = True

@@ -329,4 +329,3 @@ checkInjectiveArgs fc n ds (Just ty)

329 instantiateRetTy (Bind n (Pi _ _ _) sc)

330 = substV (P Bound n Erased) (instantiateRetTy sc)

331 instantiateRetTy t = t

332−

src/Idris/Elab/Provider.hs+3−3

@@ -84,7 +84,7 @@ elabProvider doc info syn fc nfc what n

84 rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

85 [Erased, e])

86 let rhs' = normalise ctxt [] rhs

87− logLvl 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

87+ logElab 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

88

89 -- Extract the provided term or postulate from the type provider

90 provided <- getProvided fc rhs'

@@ -95,11 +95,11 @@ elabProvider doc info syn fc nfc what n

95 do -- Finally add a top-level definition of the provided term

96 elabType info syn doc [] fc [] n NoFC ty

97 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc [] n) []) [] (delab i tm) []]

98− logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

98+ logElab 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

99 | ProvPostulate _ <- what ->

100 do -- Add the postulate

101 elabPostulate info syn doc fc nfc [] n (delab i tm)

102− logLvl 3 $ "Elaborated provided postulate " ++ show n

102+ logElab 3 $ "Elaborated provided postulate " ++ show n

103 | otherwise ->

104 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

105

src/Idris/Elab/Record.hs+36−37

@@ -47,18 +47,18 @@ elabRecord :: ElabInfo

47 -> SyntaxInfo -- ^ Constructor SyntaxInfo

48 -> Idris ()

49elabRecord info what doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc csyn

50− = do logLvl 1 $ "Building data declaration for " ++ show tyn

50+ = do logElab 1 $ "Building data declaration for " ++ show tyn

51 -- Type constructor

52 let tycon = generateTyConType params

53− logLvl 1 $ "Type constructor " ++ showTmImpls tycon

53+ logElab 1 $ "Type constructor " ++ showTmImpls tycon

54−

54+

55 -- Data constructor

56 dconName <- generateDConName (fmap fst cname)

57 let dconTy = generateDConType params fieldsWithNameAndDoc

58− logLvl 1 $ "Data constructor: " ++ showTmImpls dconTy

58+ logElab 1 $ "Data constructor: " ++ showTmImpls dconTy

59

60 -- Build data declaration for elaboration

61− logLvl 1 $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)

61+ logElab 1 $ foldr (++) "" $ intersperse "\n" (map show dconsArgDocs)

62 let datadecl = case what of

63 ETypes -> PLaterdecl tyn NoFC tycon

64 _ -> PDatadecl tyn NoFC tycon [(cdoc, dconsArgDocs, dconName, NoFC, dconTy, fc, [])]

@@ -71,8 +71,8 @@ elabRecord info what doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc

71 addIBC (IBCRecord tyn)

72

73 when (what /= ETypes) $ do

74− logLvl 1 $ "fieldsWithName " ++ show fieldsWithName

74+ logElab 1 $ "fieldsWithName " ++ show fieldsWithName

75− logLvl 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc

75+ logElab 1 $ "fieldsWIthNameAndDoc " ++ show fieldsWithNameAndDoc

76 elabRecordFunctions info rsyn fc tyn paramsAndDoc fieldsWithNameAndDoc dconName target

77

78 sendHighlighting $

@@ -162,24 +162,24 @@ elabRecordFunctions :: ElabInfo -> SyntaxInfo -> FC

162 -> PTerm -- ^ Target type

163 -> Idris ()

164elabRecordFunctions info rsyn fc tyn params fields dconName target

165− = do logLvl 1 $ "Elaborating helper functions for record " ++ show tyn

165+ = do logElab 1 $ "Elaborating helper functions for record " ++ show tyn

166

167− logLvl 1 $ "Fields: " ++ show fieldNames

167+ logElab 1 $ "Fields: " ++ show fieldNames

168− logLvl 1 $ "Params: " ++ show paramNames

168+ logElab 1 $ "Params: " ++ show paramNames

169 -- The elaborated constructor type for the data declaration

170 i <- getIState

171 ttConsTy <-

172 case lookupTyExact dconName (tt_ctxt i) of

173 Just as -> return as

174− Nothing -> tclift $ tfail $ At fc (Elaborating "record " tyn (InternalMsg "It seems like the constructor for this record has disappeared. :( \n This is a bug. Please report."))

174+ Nothing -> tclift $ tfail $ At fc (Elaborating "record " tyn Nothing (InternalMsg "It seems like the constructor for this record has disappeared. :( \n This is a bug. Please report."))

175

176 -- The arguments to the constructor

177 let constructorArgs = getArgTys ttConsTy

178− logLvl 1 $ "Cons args: " ++ show constructorArgs

178+ logElab 1 $ "Cons args: " ++ show constructorArgs

179− logLvl 1 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)

179+ logElab 1 $ "Free fields: " ++ show (filter (not . isFieldOrParam') constructorArgs)

180 -- If elaborating the constructor has resulted in some new implicit fields we make projection functions for them.

181 let freeFieldsForElab = map (freeField i) (filter (not . isFieldOrParam') constructorArgs)

182−

182+

183 -- The parameters for elaboration with their documentation

184 -- Parameter functions are all prefixed with "param_".

185 let paramsForElab = [((nsroot n), (paramName n), impl, t, d) | (n, _, _, t, d) <- params] -- zipParams i params paramDocs]

@@ -187,14 +187,14 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

187 -- The fields (written by the user) with their documentation.

188 let userFieldsForElab = [((nsroot n), n, p, t, d) | (n, nfc, p, t, d) <- fields]

189

190− -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.

190+ -- All things we need to elaborate projection functions for, together with a number denoting their position in the constructor.

191− let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]

191+ let projectors = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (freeFieldsForElab ++ paramsForElab ++ userFieldsForElab) [0..]]

192 -- Build and elaborate projection functions

193 elabProj dconName projectors

194

195− logLvl 1 $ "Dependencies: " ++ show fieldDependencies

195+ logElab 1 $ "Dependencies: " ++ show fieldDependencies

196

197− logLvl 1 $ "Depended on: " ++ show dependedOn

197+ logElab 1 $ "Depended on: " ++ show dependedOn

198

199 -- All things we need to elaborate update functions for, together with a number denoting their position in the constructor.

200 let updaters = [(n, n', p, t, d, i) | ((n, n', p, t, d), i) <- zip (paramsForElab ++ userFieldsForElab) [0..]]

@@ -237,7 +237,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

237 plicity = impl -- All free fields are implicit as they are machine generated

238 fieldType = delab i (snd arg) -- The type of the field

239 doc = emptyDocstring -- No docmentation for machine generated fields

240− in (nameInCons, nameFree, plicity, fieldType, doc)

240+ in (nameInCons, nameFree, plicity, fieldType, doc)

241

242 freeName :: Name -> Name

243 freeName (UN n) = sUN ("free_" ++ str n)

@@ -278,7 +278,7 @@ elabRecordFunctions info rsyn fc tyn params fields dconName target

278 -- | Decides whether a setter should be generated for a field or not.

279 optionalSetter :: Name -> Bool

280 optionalSetter n = n `elem` dependedOn

281−

281+

282 -- | A map from a field name to the other fields it depends on.

283 fieldDependencies :: [(Name, [Name])]

284 fieldDependencies = map (uncurry fieldDep) [(n, t) | (n, _, _, t, _) <- fields ++ params]

@@ -314,15 +314,15 @@ elabProjection :: ElabInfo

314 -> Int -- ^ Argument Index

315 -> Idris ()

316elabProjection info cname pname plicity projTy pdoc psyn fc targetTy cn phArgs fnames index

317− = do logLvl 1 $ "Generating Projection for " ++ show pname

317+ = do logElab 1 $ "Generating Projection for " ++ show pname

318−

318+

319 let ty = generateTy

320− logLvl 1 $ "Type of " ++ show pname ++ ": " ++ show ty

320+ logElab 1 $ "Type of " ++ show pname ++ ": " ++ show ty

321−

321+

322 let lhs = generateLhs

323− logLvl 1 $ "LHS of " ++ show pname ++ ": " ++ showTmImpls lhs

323+ logElab 1 $ "LHS of " ++ show pname ++ ": " ++ showTmImpls lhs

324 let rhs = generateRhs

325− logLvl 1 $ "RHS of " ++ show pname ++ ": " ++ showTmImpls rhs

325+ logElab 1 $ "RHS of " ++ show pname ++ ": " ++ showTmImpls rhs

326

327 rec_elabDecl info EAll info ty

328

@@ -372,24 +372,24 @@ elabUpdate :: ElabInfo

372 -> Bool -- ^ Optional

373 -> Idris ()

374elabUpdate info cname pname plicity pty pdoc psyn fc sty cn args fnames i optional

375− = do logLvl 1 $ "Generating Update for " ++ show pname

375+ = do logElab 1 $ "Generating Update for " ++ show pname

376−

376+

377 let ty = generateTy

378− logLvl 1 $ "Type of " ++ show set_pname ++ ": " ++ show ty

378+ logElab 1 $ "Type of " ++ show set_pname ++ ": " ++ show ty

379−

379+

380 let lhs = generateLhs

381− logLvl 1 $ "LHS of " ++ show set_pname ++ ": " ++ showTmImpls lhs

381+ logElab 1 $ "LHS of " ++ show set_pname ++ ": " ++ showTmImpls lhs

382−

382+

383 let rhs = generateRhs

384− logLvl 1 $ "RHS of " ++ show set_pname ++ ": " ++ showTmImpls rhs

384+ logElab 1 $ "RHS of " ++ show set_pname ++ ": " ++ showTmImpls rhs

385

386− let clause = PClause fc set_pname lhs [] rhs []

386+ let clause = PClause fc set_pname lhs [] rhs []

387

388 idrisCatch (do rec_elabDecl info EAll info ty

389 rec_elabDecl info EAll info $ PClauses fc [] set_pname [clause])

390− (\err -> logLvl 1 $ "Could not generate update function for " ++ show pname)

390+ (\err -> logElab 1 $ "Could not generate update function for " ++ show pname)

391 {-if optional

392− then logLvl 1 $ "Could not generate update function for " ++ show pname

392+ then logElab 1 $ "Could not generate update function for " ++ show pname

393 else tclift $ tfail $ At fc (Elaborating "record update function " pname err)) -}

394 where

395 -- | The type of the update function.

@@ -463,4 +463,3 @@ projectInType xs = mapPT st

463-- | Creates an PArg from a plicity and a name where the term is a PRef.

464asPRefArg :: Plicity -> Name -> PArg

465asPRefArg p n = asArg p (nsroot n) $ PRef emptyFC [] (nsroot n)

466−

src/Idris/Elab/Term.hs+293−203

@@ -28,9 +28,10 @@ import qualified Util.Pretty as U

28import Control.Applicative ((<$>))

29import Control.Monad

30import Control.Monad.State.Strict

31+import Data.Foldable (for_)

31import Data.List

32import Data.List

32import qualified Data.Map as M

33import qualified Data.Map as M

33−import Data.Maybe (mapMaybe, fromMaybe, catMaybes)

34+import Data.Maybe (mapMaybe, fromMaybe, catMaybes, maybeToList)

34import qualified Data.Set as S

35import qualified Data.Set as S

35import qualified Data.Text as T

36import qualified Data.Text as T

36

37

@@ -90,7 +91,7 @@ build ist info emode opts fn tm

90 g <- goal

91 g <- goal

91 ptm <- get_term

92 ptm <- get_term

92 resolveTC' True True 10 g fn ist) ivs

93 resolveTC' True True 10 g fn ist) ivs

93−

94+

94 when (not pattern) $ solveAutos ist fn False

95 when (not pattern) $ solveAutos ist fn False

95

96

96 tm <- get_term

97 tm <- get_term

@@ -137,15 +138,16 @@ build ist info emode opts fn tm

137-- (Separate, so we don't go overboard resolving things that we don't

138-- (Separate, so we don't go overboard resolving things that we don't

138-- know about yet on the LHS of a pattern def)

139-- know about yet on the LHS of a pattern def)

139

140

140−buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm ->

141+buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name ->

142+ [Name] -> -- Cached names in the PTerm, before adding PAlternatives

143+ PTerm ->

141 ElabD ElabResult

144 ElabD ElabResult

142−buildTC ist info emode opts fn tm

145+buildTC ist info emode opts fn ns tm

143− = do -- set name supply to begin after highest index in tm

144− let ns = allNamesIn tm

145− let tmIn = tm

146+ = do let tmIn = tm

146 let inf = case lookupCtxt fn (idris_tyinfodata ist) of

147 let inf = case lookupCtxt fn (idris_tyinfodata ist) of

147 [TIPartial] -> True

148 [TIPartial] -> True

148 _ -> False

149 _ -> False

150+ -- set name supply to begin after highest index in tm

149 initNextNameFrom ns

151 initNextNameFrom ns

150 elab ist info emode opts fn tm

152 elab ist info emode opts fn tm

151 probs <- get_probs

153 probs <- get_probs

@@ -169,7 +171,7 @@ buildTC ist info emode opts fn tm

169 else return (ElabResult tm ds (map snd is) ctxt impls highlights)

171 else return (ElabResult tm ds (map snd is) ctxt impls highlights)

170 where pattern = emode == ELHS

172 where pattern = emode == ELHS

171

173

172−-- return whether arguments of the given constructor name can be

174+-- return whether arguments of the given constructor name can be

173-- matched on. If they're polymorphic, no, unless the type has beed made

175-- matched on. If they're polymorphic, no, unless the type has beed made

174-- concrete by the time we get around to elaborating the argument.

176-- concrete by the time we get around to elaborating the argument.

175getUnmatchable :: Context -> Name -> [Bool]

177getUnmatchable :: Context -> Name -> [Bool]

@@ -178,11 +180,11 @@ getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon

178 Nothing -> []

180 Nothing -> []

179 Just ty -> checkArgs [] [] ty

181 Just ty -> checkArgs [] [] ty

180 where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]

182 where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]

181− checkArgs env ns (Bind n (Pi _ t _) sc)

183+ checkArgs env ns (Bind n (Pi _ t _) sc)

182 = let env' = case t of

184 = let env' = case t of

183 TType _ -> n : env

185 TType _ -> n : env

184 _ -> env in

186 _ -> env in

185− checkArgs env' (intersect env (refsIn t) : ns)

187+ checkArgs env' (intersect env (refsIn t) : ns)

186 (instantiate (P Bound n t) sc)

188 (instantiate (P Bound n t) sc)

187 checkArgs env ns t

189 checkArgs env ns t

188 = map (not . null) (reverse ns)

190 = map (not . null) (reverse ns)

@@ -191,7 +193,7 @@ getUnmatchable ctxt n = []

191

193

192data ElabCtxt = ElabCtxt { e_inarg :: Bool,

194data ElabCtxt = ElabCtxt { e_inarg :: Bool,

193 e_isfn :: Bool, -- ^ Function part of application

195 e_isfn :: Bool, -- ^ Function part of application

194− e_guarded :: Bool,

196+ e_guarded :: Bool,

195 e_intype :: Bool,

197 e_intype :: Bool,

196 e_qq :: Bool,

198 e_qq :: Bool,

197 e_nomatching :: Bool -- ^ can't pattern match

199 e_nomatching :: Bool -- ^ can't pattern match

@@ -265,17 +267,17 @@ elab ist info emode opts fn tm

265 -- normally correct to call elabE - the ones that don't are desugarings

267 -- normally correct to call elabE - the ones that don't are desugarings

266 -- typically

268 -- typically

267 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()

269 elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()

268− elabE ina fc' t =

270+ elabE ina fc' t =

269 do solved <- get_recents

271 do solved <- get_recents

270 as <- get_autos

272 as <- get_autos

271 hs <- get_holes

273 hs <- get_holes

272 -- If any of the autos use variables which have recently been solved,

274 -- If any of the autos use variables which have recently been solved,

273 -- have another go at solving them now.

275 -- have another go at solving them now.

274− mapM_ (\(a, (failc, ns)) ->

276+ mapM_ (\(a, (failc, ns)) ->

275 if any (\n -> n `elem` solved) ns && head hs /= a

277 if any (\n -> n `elem` solved) ns && head hs /= a

276 then solveAuto ist fn False (a, failc)

278 then solveAuto ist fn False (a, failc)

277 else return ()) as

279 else return ()) as

278−

280+

279 itm <- if not pattern then insertImpLam ina t else return t

281 itm <- if not pattern then insertImpLam ina t else return t

280 ct <- insertCoerce ina itm

282 ct <- insertCoerce ina itm

281 t' <- insertLazy ct

283 t' <- insertLazy ct

@@ -308,7 +310,7 @@ elab ist info emode opts fn tm

308 forceErr orig env (InfiniteUnify _ t _)

310 forceErr orig env (InfiniteUnify _ t _)

309 | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

311 | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

310 ht == txt "Lazy'" = notDelay orig

312 ht == txt "Lazy'" = notDelay orig

311− forceErr orig env (Elaborating _ _ t) = forceErr orig env t

313+ forceErr orig env (Elaborating _ _ _ t) = forceErr orig env t

312 forceErr orig env (ElaboratingArg _ _ _ t) = forceErr orig env t

314 forceErr orig env (ElaboratingArg _ _ _ t) = forceErr orig env t

313 forceErr orig env (At _ t) = forceErr orig env t

315 forceErr orig env (At _ t) = forceErr orig env t

314 forceErr orig env t = False

316 forceErr orig env t = False

@@ -341,7 +343,7 @@ elab ist info emode opts fn tm

341-- elab' (_,_,inty) (PConstant c)

343-- elab' (_,_,inty) (PConstant c)

342-- | constType c && pattern && not reflection && not inty

344-- | constType c && pattern && not reflection && not inty

343-- = lift $ tfail (Msg "Typecase is not allowed")

345-- = lift $ tfail (Msg "Typecase is not allowed")

344− elab' ina fc tm@(PConstant fc' c)

346+ elab' ina fc tm@(PConstant fc' c)

345 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

347 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

346 && isTypeConst c

348 && isTypeConst c

347 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

349 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

@@ -361,7 +363,7 @@ elab ist info emode opts fn tm

361 elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

363 elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

362 = do g <- goal; resolveTC' False False 5 g fn ist

364 = do g <- goal; resolveTC' False False 5 g fn ist

363 elab' ina fc (PResolveTC fc')

365 elab' ina fc (PResolveTC fc')

364− = do c <- getNameFrom (sMN 0 "class")

366+ = do c <- getNameFrom (sMN 0 "__class")

365 instanceArg c

367 instanceArg c

366 -- Elaborate the equality type first homogeneously, then

368 -- Elaborate the equality type first homogeneously, then

367 -- heterogeneously as a fallback

369 -- heterogeneously as a fallback

@@ -395,7 +397,7 @@ elab ist info emode opts fn tm

395 UType _ -> elab' ina (Just fc) (PApp fc (PRef fc hls upairTy)

397 UType _ -> elab' ina (Just fc) (PApp fc (PRef fc hls upairTy)

396 [pexp l,pexp r])

398 [pexp l,pexp r])

397 _ -> case tc of

399 _ -> case tc of

398− P _ n _ | n == upairTy

400+ P _ n _ | n == upairTy

399 -> elab' ina (Just fc) (PApp fc (PRef fc hls upairCon)

401 -> elab' ina (Just fc) (PApp fc (PRef fc hls upairCon)

400 [pimp (sUN "A") Placeholder False,

402 [pimp (sUN "A") Placeholder False,

401 pimp (sUN "B") Placeholder False,

403 pimp (sUN "B") Placeholder False,

@@ -442,16 +444,17 @@ elab ist info emode opts fn tm

442 uns <- get_usedns

444 uns <- get_usedns

443 let as' = map (mkUniqueNames (uns ++ map snd ms) ms) as_pruned

445 let as' = map (mkUniqueNames (uns ++ map snd ms) ms) as_pruned

444 (h : hs) <- get_holes

446 (h : hs) <- get_holes

445−-- trace (show (map showHd as')) $

446 ty <- goal

447 ty <- goal

447 case as' of

448 case as' of

449+ [] -> do hds <- mapM showHd as

448− [] -> lift $ tfail $ NoValidAlts (map showHd as)

450+ lift $ tfail $ NoValidAlts hds

449 [x] -> elab' ina fc x

451 [x] -> elab' ina fc x

450 -- If there's options, try now, and if that fails, postpone

452 -- If there's options, try now, and if that fails, postpone

451 -- to later.

453 -- to later.

452 _ -> handleError isAmbiguous

454 _ -> handleError isAmbiguous

455+ (do hds <- mapM showHd as'

453− (tryAll (zip (map (elab' ina fc) as')

456+ tryAll (zip (map (elab' ina fc) as')

454− (map showHd as')))

457+ hds))

455 (do movelast h

458 (do movelast h

456 delayElab 5 $ do

459 delayElab 5 $ do

457 hs <- get_holes

460 hs <- get_holes

@@ -460,16 +463,17 @@ elab ist info emode opts fn tm

460 as'' <- doPrune as'

463 as'' <- doPrune as'

461 case as'' of

464 case as'' of

462 [x] -> elab' ina fc x

465 [x] -> elab' ina fc x

466+ _ -> do hds <- mapM showHd as''

463− _ -> tryAll (zip (map (elab' ina fc) as'')

467+ tryAll (zip (map (elab' ina fc) as'')

464− (map showHd as'')))

468+ hds))

465 where showHd (PApp _ (PRef _ _ (UN l)) [_, _, arg])

469 where showHd (PApp _ (PRef _ _ (UN l)) [_, _, arg])

466 | l == txt "Delay" = showHd (getTm arg)

470 | l == txt "Delay" = showHd (getTm arg)

467− showHd (PApp _ (PRef _ _ n) _) = n

471+ showHd (PApp _ (PRef _ _ n) _) = return n

468− showHd (PRef _ _ n) = n

472+ showHd (PRef _ _ n) = return n

469 showHd (PApp _ h _) = showHd h

473 showHd (PApp _ h _) = showHd h

470− showHd x = NErased -- We probably should do something better than this here

474+ showHd x = getNameFrom (sMN 0 "_") -- We probably should do something better than this here

471

475

472− doPrune as =

476+ doPrune as =

473 do compute

477 do compute

474 ty <- goal

478 ty <- goal

475 let (tc, _) = unApply (unDelay ty)

479 let (tc, _) = unApply (unDelay ty)

@@ -479,10 +483,9 @@ elab ist info emode opts fn tm

479 unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,

483 unDelay t | (P _ (UN l) _, [_, arg]) <- unApply t,

480 l == txt "Lazy'" = unDelay arg

484 l == txt "Lazy'" = unDelay arg

481 | otherwise = t

485 | otherwise = t

482−

483

486

484 isAmbiguous (CantResolveAlts _) = delayok

487 isAmbiguous (CantResolveAlts _) = delayok

485− isAmbiguous (Elaborating _ _ e) = isAmbiguous e

488+ isAmbiguous (Elaborating _ _ _ e) = isAmbiguous e

486 isAmbiguous (ElaboratingArg _ _ _ e) = isAmbiguous e

489 isAmbiguous (ElaboratingArg _ _ _ e) = isAmbiguous e

487 isAmbiguous (At _ e) = isAmbiguous e

490 isAmbiguous (At _ e) = isAmbiguous e

488 isAmbiguous _ = False

491 isAmbiguous _ = False

@@ -506,7 +509,7 @@ elab ist info emode opts fn tm

506 ty <- goal

509 ty <- goal

507 let doelab = elab' ina fc orig

510 let doelab = elab' ina fc orig

508 tryCatch doelab

511 tryCatch doelab

509− (\err ->

512+ (\err ->

510 if recoverableErr err

513 if recoverableErr err

511 then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++

514 then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++

512 -- show alts ++ "\n" ++

515 -- show alts ++ "\n" ++

@@ -544,7 +547,7 @@ elab ist info emode opts fn tm

544 pruneAlts err alts _ = filter isLend alts

547 pruneAlts err alts _ = filter isLend alts

545

548

546 hasArg n env ap | isLend ap = True -- special case hack for 'Borrowed'

549 hasArg n env ap | isLend ap = True -- special case hack for 'Borrowed'

547− hasArg n env (PApp _ (PRef _ _ a) _)

550+ hasArg n env (PApp _ (PRef _ _ a) _)

548 = case lookupTyExact a (tt_ctxt ist) of

551 = case lookupTyExact a (tt_ctxt ist) of

549 Just ty -> let args = map snd (getArgTys (normalise (tt_ctxt ist) env ty)) in

552 Just ty -> let args = map snd (getArgTys (normalise (tt_ctxt ist) env ty)) in

550 any (fnIs n) args

553 any (fnIs n) args

@@ -659,7 +662,7 @@ elab ist info emode opts fn tm

659 introTy (Var tyn) (Just n)

662 introTy (Var tyn) (Just n)

660 addPSname n -- okay for proof search

663 addPSname n -- okay for proof search

661 focus tyn

664 focus tyn

662−

665+

663 elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty

666 elabE (ec { e_inarg = True, e_intype = True }) (Just fc) ty

664 elabE (ec { e_inarg = True }) (Just fc) sc

667 elabE (ec { e_inarg = True }) (Just fc) sc

665 solve

668 solve

@@ -698,10 +701,10 @@ elab ist info emode opts fn tm

698 Placeholder -> return ()

701 Placeholder -> return ()

699 _ -> do focus tyn

702 _ -> do focus tyn

700 explicit tyn

703 explicit tyn

701− elabE (ina { e_inarg = True, e_intype = True })

704+ elabE (ina { e_inarg = True, e_intype = True })

702 (Just fc) ty

705 (Just fc) ty

703 focus valn

706 focus valn

704− elabE (ina { e_inarg = True, e_intype = True })

707+ elabE (ina { e_inarg = True, e_intype = True })

705 (Just fc) val

708 (Just fc) val

706 ivs' <- get_instances

709 ivs' <- get_instances

707 env <- get_env

710 env <- get_env

@@ -711,8 +714,9 @@ elab ist info emode opts fn tm

711 g <- goal

714 g <- goal

712 hs <- get_holes

715 hs <- get_holes

713 if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)

716 if all (\n -> n == tyn || not (n `elem` hs)) (freeNames g)

717+ then handleError (tcRecoverable emode)

714− then try (resolveTC' True False 10 g fn ist)

718+ (resolveTC' True False 10 g fn ist)

715− (movelast n)

719+ (movelast n)

716 else movelast n)

720 else movelast n)

717 (ivs' \\ ivs)

721 (ivs' \\ ivs)

718 -- HACK: If the name leaks into its type, it may leak out of

722 -- HACK: If the name leaks into its type, it may leak out of

@@ -804,14 +808,14 @@ elab ist info emode opts fn tm

804 annot <- findHighlight f

808 annot <- findHighlight f

805 mapM_ checkKnownImplicit args_in

809 mapM_ checkKnownImplicit args_in

806 let args = insertScopedImps fc (normalise ctxt env fty) args_in

810 let args = insertScopedImps fc (normalise ctxt env fty) args_in

807− let unmatchableArgs = if pattern

811+ let unmatchableArgs = if pattern

808 then getUnmatchable (tt_ctxt ist) f

812 then getUnmatchable (tt_ctxt ist) f

809 else []

813 else []

810−-- trace ("BEFORE " ++ show f ++ ": " ++ show ty) $

814+-- trace ("BEFORE " ++ show f ++ ": " ++ show ty) $

811 when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)

815 when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)

812 && isTConName f (tt_ctxt ist)) $

816 && isTConName f (tt_ctxt ist)) $

813 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

817 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

814−-- trace (show (f, args_in, args)) $

818+-- trace (show (f, args_in, args)) $

815 if (f `elem` map fst env && length args == 1 && length args_in == 1)

819 if (f `elem` map fst env && length args == 1 && length args_in == 1)

816 then -- simple app, as below

820 then -- simple app, as below

817 do simple_app False

821 do simple_app False

@@ -849,7 +853,7 @@ elab ist info emode opts fn tm

849 mapM (uncurry highlightSource) $

853 mapM (uncurry highlightSource) $

850 (ffc, annot) : map (\f -> (f, annot)) hls

854 (ffc, annot) : map (\f -> (f, annot)) hls

851

855

852− elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })

856+ elabArgs ist (ina { e_inarg = e_inarg ina || not isinf })

853 [] fc False f

857 [] fc False f

854 (zip ns (unmatchableArgs ++ repeat False))

858 (zip ns (unmatchableArgs ++ repeat False))

855 (f == sUN "Force")

859 (f == sUN "Force")

@@ -876,26 +880,27 @@ elab ist info emode opts fn tm

876 ivs' <- get_instances

880 ivs' <- get_instances

877 -- Attempt to resolve any type classes which have 'complete' types,

881 -- Attempt to resolve any type classes which have 'complete' types,

878 -- i.e. no holes in them

882 -- i.e. no holes in them

879− when (not pattern || (e_inarg ina && not tcgen &&

883+ when (not pattern || (e_inarg ina && not tcgen &&

880 not (e_guarded ina))) $

884 not (e_guarded ina))) $

881 mapM_ (\n -> do focus n

885 mapM_ (\n -> do focus n

882 g <- goal

886 g <- goal

883 env <- get_env

887 env <- get_env

884 hs <- get_holes

888 hs <- get_holes

885 if all (\n -> not (n `elem` hs)) (freeNames g)

889 if all (\n -> not (n `elem` hs)) (freeNames g)

890+ then handleError (tcRecoverable emode)

886− then try (resolveTC' False False 10 g fn ist)

891+ (resolveTC' False False 10 g fn ist)

887 (movelast n)

892 (movelast n)

888 else movelast n)

893 else movelast n)

889 (ivs' \\ ivs)

894 (ivs' \\ ivs)

890 return []

895 return []

891− where

896+ where

892 -- Run the elaborator, which returns how many implicit

897 -- Run the elaborator, which returns how many implicit

893 -- args were needed, then run it again with those args. We need

898 -- args were needed, then run it again with those args. We need

894 -- this because we have to elaborate the whole application to

899 -- this because we have to elaborate the whole application to

895 -- find out whether any computations have caused more implicits

900 -- find out whether any computations have caused more implicits

896 -- to be needed.

901 -- to be needed.

897 implicitApp :: ElabD [ImplicitInfo] -> ElabD ()

902 implicitApp :: ElabD [ImplicitInfo] -> ElabD ()

898− implicitApp elab

903+ implicitApp elab

899 | pattern || intransform = do elab; return ()

904 | pattern || intransform = do elab; return ()

900 | otherwise

905 | otherwise

901 = do s <- get

906 = do s <- get

@@ -904,7 +909,7 @@ elab ist info emode opts fn tm

904 [] -> return ()

909 [] -> return ()

905 es -> do put s

910 es -> do put s

906 elab' ina topfc (PAppImpl tm es)

911 elab' ina topfc (PAppImpl tm es)

907−

912+

908 checkKnownImplicit imp

913 checkKnownImplicit imp

909 | UnknownImp `elem` argopts imp

914 | UnknownImp `elem` argopts imp

910 = lift $ tfail $ UnknownImplicit (pname imp) f

915 = lift $ tfail $ UnknownImplicit (pname imp) f

@@ -961,7 +966,7 @@ elab ist info emode opts fn tm

961 headRef (PAlternative _ _ as) = all headRef as

966 headRef (PAlternative _ _ as) = all headRef as

962 headRef _ = False

967 headRef _ = False

963

968

964− elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look...

969+ elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look...

965 solve

970 solve

966 where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits

971 where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits

967 appImpl (e : es) = simple_app False

972 appImpl (e : es) = simple_app False

@@ -1023,12 +1028,22 @@ elab ist info emode opts fn tm

1023 solve

1028 solve

1024 elab' ina _ c@(PCase fc scr opts)

1029 elab' ina _ c@(PCase fc scr opts)

1025 = do attack

1030 = do attack

1031+

1026 tyn <- getNameFrom (sMN 0 "scty")

1032 tyn <- getNameFrom (sMN 0 "scty")

1027 claim tyn RType

1033 claim tyn RType

1028 valn <- getNameFrom (sMN 0 "scval")

1034 valn <- getNameFrom (sMN 0 "scval")

1029 scvn <- getNameFrom (sMN 0 "scvar")

1035 scvn <- getNameFrom (sMN 0 "scvar")

1030 claim valn (Var tyn)

1036 claim valn (Var tyn)

1031 letbind scvn (Var tyn) (Var valn)

1037 letbind scvn (Var tyn) (Var valn)

1038+

1039+ -- Start filling in the scrutinee type, if we can work one

1040+ -- out from the case options

1041+ let scrTy = getScrType (map fst opts)

1042+ case scrTy of

1043+ Nothing -> return ()

1044+ Just ty -> do focus tyn

1045+ elabE ina (Just fc) ty

1046+

1032 focus valn

1047 focus valn

1033 elabE (ina { e_inarg = True }) (Just fc) scr

1048 elabE (ina { e_inarg = True }) (Just fc) scr

1034 -- Solve any remaining implicits - we need to solve as many

1049 -- Solve any remaining implicits - we need to solve as many

@@ -1041,7 +1056,7 @@ elab ist info emode opts fn tm

1041

1056

1042 -- Drop the unique arguments used in the term already

1057 -- Drop the unique arguments used in the term already

1043 -- and in the scrutinee (since it's

1058 -- and in the scrutinee (since it's

1044− -- not valid to use them again anyway)

1059+ -- not valid to use them again anyway)

1045 --

1060 --

1046 -- Also drop unique arguments which don't appear explicitly

1061 -- Also drop unique arguments which don't appear explicitly

1047 -- in either case branch so they don't count as used

1062 -- in either case branch so they don't count as used

@@ -1050,14 +1065,14 @@ elab ist info emode opts fn tm

1050 ptm <- get_term

1065 ptm <- get_term

1051 let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)

1066 let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)

1052

1067

1053− let argsDropped = filter (isUnique envU)

1068+ let argsDropped = filter (isUnique envU)

1054 (nub $ allNamesIn scr ++ inApp ptm ++

1069 (nub $ allNamesIn scr ++ inApp ptm ++

1055 inOpts)

1070 inOpts)

1056

1071

1057 let args' = filter (\(n, _) -> n `notElem` argsDropped) args

1072 let args' = filter (\(n, _) -> n `notElem` argsDropped) args

1058

1073

1059 attack

1074 attack

1060− cname' <- defer argsDropped (mkN (mkCaseName fn))

1075+ cname' <- defer argsDropped (mkN (mkCaseName fc fn))

1061 solve

1076 solve

1062

1077

1063 -- if the scrutinee is one of the 'args' in env, we should

1078 -- if the scrutinee is one of the 'args' in env, we should

@@ -1070,8 +1085,8 @@ elab ist info emode opts fn tm

1070 -- if we haven't got the type yet, hopefully we'll get it later!

1085 -- if we haven't got the type yet, hopefully we'll get it later!

1071 movelast tyn

1086 movelast tyn

1072 solve

1087 solve

1073− where mkCaseName (NS n ns) = NS (mkCaseName n) ns

1088+ where mkCaseName fc (NS n ns) = NS (mkCaseName fc n) ns

1074− mkCaseName n = SN (CaseN n)

1089+ mkCaseName fc n = SN (CaseN (FC' fc) n)

1075-- mkCaseName (UN x) = UN (x ++ "_case")

1090-- mkCaseName (UN x) = UN (x ++ "_case")

1076-- mkCaseName (MN i x) = MN i (x ++ "_case")

1091-- mkCaseName (MN i x) = MN i (x ++ "_case")

1077 mkN n@(NS _ _) = n

1092 mkN n@(NS _ _) = n

@@ -1079,6 +1094,21 @@ elab ist info emode opts fn tm

1079 Just xs@(_:_) -> sNS n xs

1094 Just xs@(_:_) -> sNS n xs

1080 _ -> n

1095 _ -> n

1081

1096

1097+ getScrType [] = Nothing

1098+ getScrType (f : os) = maybe (getScrType os) Just (getAppType f)

1099+

1100+ getAppType (PRef _ _ n) =

1101+ case lookupTyName n (tt_ctxt ist) of

1102+ [(n', ty)] | isDConName n' (tt_ctxt ist) ->

1103+ case unApply (getRetTy ty) of

1104+ (P _ tyn _, args) ->

1105+ Just (PApp fc (PRef fc [] tyn)

1106+ (map pexp (map (const Placeholder) args)))

1107+ _ -> Nothing

1108+ _ -> Nothing -- ambiguity is no help to us!

1109+ getAppType (PApp _ t as) = getAppType t

1110+ getAppType _ = Nothing

1111+

1082 inApp (P _ n _) = [n]

1112 inApp (P _ n _) = [n]

1083 inApp (App _ f a) = inApp f ++ inApp a

1113 inApp (App _ f a) = inApp f ++ inApp a

1084 inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

1114 inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

@@ -1220,12 +1250,12 @@ elab ist info emode opts fn tm

1220 [] -> lift . tfail . NoSuchVariable $ n

1250 [] -> lift . tfail . NoSuchVariable $ n

1221 more -> lift . tfail . CantResolveAlts $ map fst more

1251 more -> lift . tfail . CantResolveAlts $ map fst more

1222 elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"

1252 elab' ina fc (PAs _ n t) = lift . tfail . Msg $ "@-pattern not allowed here"

1223− elab' ina fc (PHidden t)

1253+ elab' ina fc (PHidden t)

1224 | reflection = elab' ina fc t

1254 | reflection = elab' ina fc t

1225 | otherwise

1255 | otherwise

1226 = do (h : hs) <- get_holes

1256 = do (h : hs) <- get_holes

1227 -- Dotting a hole means that either the hole or any outer

1257 -- Dotting a hole means that either the hole or any outer

1228− -- hole (a hole outside any occurrence of it)

1258+ -- hole (a hole outside any occurrence of it)

1229 -- must be solvable by unification as well as being filled

1259 -- must be solvable by unification as well as being filled

1230 -- in directly.

1260 -- in directly.

1231 -- Delay dotted things to the end, then when we elaborate them

1261 -- Delay dotted things to the end, then when we elaborate them

@@ -1237,17 +1267,18 @@ elab ist info emode opts fn tm

1237 elab' ina fc (PRunElab fc' tm ns) =

1267 elab' ina fc (PRunElab fc' tm ns) =

1238 do attack

1268 do attack

1239 n <- getNameFrom (sMN 0 "tacticScript")

1269 n <- getNameFrom (sMN 0 "tacticScript")

1240− n' <- getNameFrom (sMN 0 "tacticExpr")

1241 let scriptTy = RApp (Var (sNS (sUN "Elab")

1270 let scriptTy = RApp (Var (sNS (sUN "Elab")

1242 ["Elab", "Reflection", "Language"]))

1271 ["Elab", "Reflection", "Language"]))

1243 (Var unitTy)

1272 (Var unitTy)

1244 claim n scriptTy

1273 claim n scriptTy

1245− movelast n

1246− letbind n' scriptTy (Var n)

1247 focus n

1274 focus n

1275+ attack -- to get an extra hole

1248 elab' ina (Just fc') tm

1276 elab' ina (Just fc') tm

1277+ script <- get_guess

1278+ fullyElaborated script

1279+ solve -- eliminate the hole. Becuase there are no references, the script is only in the binding

1249 env <- get_env

1280 env <- get_env

1250− runElabAction ist (maybe fc' id fc) env (P Bound n' Erased) ns

1281+ runElabAction ist (maybe fc' id fc) env script ns

1251 solve

1282 solve

1252 elab' ina fc (PConstSugar constFC tm) =

1283 elab' ina fc (PConstSugar constFC tm) =

1253 -- Here we elaborate the contained term, then calculate

1284 -- Here we elaborate the contained term, then calculate

@@ -1292,7 +1323,7 @@ elab ist info emode opts fn tm

1292 -- The delayed things with lower numbered priority will be elaborated

1323 -- The delayed things with lower numbered priority will be elaborated

1293 -- first. (In practice, this means delayed alternatives, then PHidden

1324 -- first. (In practice, this means delayed alternatives, then PHidden

1294 -- things.)

1325 -- things.)

1295− delayElab pri t

1326+ delayElab pri t

1296 = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })

1327 = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [(pri, t)] })

1297

1328

1298 isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))

1329 isScr :: PTerm -> (Name, Binder Term) -> (Name, (Bool, Binder Term))

@@ -1360,6 +1391,19 @@ elab ist info emode opts fn tm

1360 getFC d (PAlternative _ _ (x:_)) = getFC d x

1391 getFC d (PAlternative _ _ (x:_)) = getFC d x

1361 getFC d x = d

1392 getFC d x = d

1362

1393

1394+ -- Fail if a term is not yet fully elaborated (e.g. if it contains

1395+ -- case block functions that don't yet exist)

1396+ fullyElaborated :: Term -> ElabD ()

1397+ fullyElaborated (P _ n _) =

1398+ do EState cases _ _ _ <- getAux

1399+ case lookup n cases of

1400+ Nothing -> return ()

1401+ Just _ -> lift . tfail $ ElabScriptStaging n

1402+ fullyElaborated (Bind n b body) = fullyElaborated body >> for_ b fullyElaborated

1403+ fullyElaborated (App _ l r) = fullyElaborated l >> fullyElaborated r

1404+ fullyElaborated (Proj t _) = fullyElaborated t

1405+ fullyElaborated _ = return ()

1406+

1363 insertLazy :: PTerm -> ElabD PTerm

1407 insertLazy :: PTerm -> ElabD PTerm

1364 insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Delay" = return t

1408 insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Delay" = return t

1365 insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Force" = return t

1409 insertLazy t@(PApp _ (PRef _ _ (UN l)) _) | l == txt "Force" = return t

@@ -1396,9 +1440,9 @@ elab ist info emode opts fn tm

1396 notImplicitable _ = False

1440 notImplicitable _ = False

1397

1441

1398 insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs

1442 insertScopedImps fc (Bind n (Pi im@(Just i) _ _) sc) xs

1399− | tcinstance i

1443+ | tcinstance i && not (toplevel_imp i)

1400 = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs

1444 = pimp n (PResolveTC fc) True : insertScopedImps fc sc xs

1401− | otherwise

1445+ | not (toplevel_imp i)

1402 = pimp n Placeholder True : insertScopedImps fc sc xs

1446 = pimp n Placeholder True : insertScopedImps fc sc xs

1403 insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)

1447 insertScopedImps fc (Bind n (Pi _ _ _) sc) (x : xs)

1404 = x : insertScopedImps fc sc xs

1448 = x : insertScopedImps fc sc xs

@@ -1432,7 +1476,7 @@ elab ist info emode opts fn tm

1432 let t' = case (t, cs) of

1476 let t' = case (t, cs) of

1433 (PCoerced tm, _) -> tm

1477 (PCoerced tm, _) -> tm

1434 (_, []) -> t

1478 (_, []) -> t

1435− (_, cs) -> PAlternative [] TryImplicit

1479+ (_, cs) -> PAlternative [] TryImplicit

1436 (t : map (mkCoerce env t) cs)

1480 (t : map (mkCoerce env t) cs)

1437 return t'

1481 return t'

1438 where

1482 where

@@ -1554,7 +1598,7 @@ pruneByType env (P _ n _) ist as

1554 [] -> asV

1598 [] -> asV

1555 _ -> as'

1599 _ -> as'

1556 where

1600 where

1557− ctxt = tt_ctxt ist

1601+ ctxt = tt_ctxt ist

1558

1602

1559 headIs var f (PRef _ _ f') = typeHead var f f'

1603 headIs var f (PRef _ _ f') = typeHead var f f'

1560 headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg])

1604 headIs var f (PApp _ (PRef _ _ (UN l)) [_, _, arg])

@@ -1573,7 +1617,7 @@ pruneByType env (P _ n _) ist as

1573 _ -> let ty' = normalise ctxt [] ty in

1617 _ -> let ty' = normalise ctxt [] ty in

1574 case unApply (getRetTy ty') of

1618 case unApply (getRetTy ty') of

1575 (P _ ftyn _, _) -> ftyn == f

1619 (P _ ftyn _, _) -> ftyn == f

1576− (V _, _) ->

1620+ (V _, _) ->

1577 -- keep, variable

1621 -- keep, variable

1578-- trace ("Keeping " ++ show (f', ty')

1622-- trace ("Keeping " ++ show (f', ty')

1579-- ++ " for " ++ show n) $

1623-- ++ " for " ++ show n) $

@@ -1590,22 +1634,22 @@ pruneByType _ t _ as = as

1590-- (FIXME: This isn't complete, but I'm leaving it here and coming back

1634-- (FIXME: This isn't complete, but I'm leaving it here and coming back

1591-- to it later - just returns 'var' for now. EB)

1635-- to it later - just returns 'var' for now. EB)

1592isPlausible :: IState -> Bool -> Env -> Name -> Type -> Bool

1636isPlausible :: IState -> Bool -> Env -> Name -> Type -> Bool

1593−isPlausible ist var env n ty

1637+isPlausible ist var env n ty

1594 = let (hvar, classes) = collectConstraints [] [] ty in

1638 = let (hvar, classes) = collectConstraints [] [] ty in

1595 case hvar of

1639 case hvar of

1596 Nothing -> True

1640 Nothing -> True

1597 Just rth -> var -- trace (show (rth, classes)) var

1641 Just rth -> var -- trace (show (rth, classes)) var

1598 where

1642 where

1599− collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->

1643+ collectConstraints :: [Name] -> [(Term, [Name])] -> Type ->

1600 (Maybe Name, [(Term, [Name])])

1644 (Maybe Name, [(Term, [Name])])

1601 collectConstraints env tcs (Bind n (Pi _ ty _) sc)

1645 collectConstraints env tcs (Bind n (Pi _ ty _) sc)

1602 = let tcs' = case unApply ty of

1646 = let tcs' = case unApply ty of

1603− (P _ c _, _) ->

1647+ (P _ c _, _) ->

1604 case lookupCtxtExact c (idris_classes ist) of

1648 case lookupCtxtExact c (idris_classes ist) of

1605− Just tc -> ((ty, map fst (class_instances tc))

1649+ Just tc -> ((ty, map fst (class_instances tc))

1606− : tcs)

1650+ : tcs)

1607 Nothing -> tcs

1651 Nothing -> tcs

1608− _ -> tcs

1652+ _ -> tcs

1609 in

1653 in

1610 collectConstraints (n : env) tcs' sc

1654 collectConstraints (n : env) tcs' sc

1611 collectConstraints env tcs t

1655 collectConstraints env tcs t

@@ -1625,7 +1669,7 @@ findHighlight n = do ctxt <- get_context

1625

1669

1626-- Try again to solve auto implicits

1670-- Try again to solve auto implicits

1627solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()

1671solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()

1628−solveAuto ist fn ambigok (n, failc)

1672+solveAuto ist fn ambigok (n, failc)

1629 = do hs <- get_holes

1673 = do hs <- get_holes

1630 when (not (null hs)) $ do

1674 when (not (null hs)) $ do

1631 env <- get_env

1675 env <- get_env

@@ -1638,15 +1682,15 @@ solveAuto ist fn ambigok (n, failc)

1638 (lift $ Error (addLoc failc

1682 (lift $ Error (addLoc failc

1639 (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))))

1683 (CantSolveGoal g (map (\(n, b) -> (n, binderTy b)) env))))

1640 return ()

1684 return ()

1641− where addLoc (FailContext fc f x : prev) err

1685+ where addLoc (FailContext fc f x : prev) err

1642− = At fc (ElaboratingArg f x

1686+ = At fc (ElaboratingArg f x

1643 (map (\(FailContext _ f' x') -> (f', x')) prev) err)

1687 (map (\(FailContext _ f' x') -> (f', x')) prev) err)

1644 addLoc _ err = err

1688 addLoc _ err = err

1645

1689

1646 cantsolve (CantSolveGoal _ _) = True

1690 cantsolve (CantSolveGoal _ _) = True

1647 cantsolve (InternalMsg _) = True

1691 cantsolve (InternalMsg _) = True

1648 cantsolve (At _ e) = cantsolve e

1692 cantsolve (At _ e) = cantsolve e

1649− cantsolve (Elaborating _ _ e) = cantsolve e

1693+ cantsolve (Elaborating _ _ _ e) = cantsolve e

1650 cantsolve (ElaboratingArg _ _ _ e) = cantsolve e

1694 cantsolve (ElaboratingArg _ _ _ e) = cantsolve e

1651 cantsolve _ = False

1695 cantsolve _ = False

1652

1696

@@ -1655,6 +1699,15 @@ solveAutos ist fn ambigok

1655 = do autos <- get_autos

1699 = do autos <- get_autos

1656 mapM_ (solveAuto ist fn ambigok) (map (\(n, (fc, _)) -> (n, fc)) autos)

1700 mapM_ (solveAuto ist fn ambigok) (map (\(n, (fc, _)) -> (n, fc)) autos)

1657

1701

1702+-- Return true if the given error suggests a type class failure is

1703+-- recoverable

1704+tcRecoverable :: ElabMode -> Err -> Bool

1705+tcRecoverable ERHS (CantResolve f g) = f

1706+tcRecoverable ETyDecl (CantResolve f g) = f

1707+tcRecoverable e (ElaboratingArg _ _ _ err) = tcRecoverable e err

1708+tcRecoverable e (At _ err) = tcRecoverable e err

1709+tcRecoverable _ _ = True

1710+

1658trivial' ist

1711trivial' ist

1659 = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist

1712 = trivial (elab ist toplevel ERHS [] (sMN 0 "tac")) ist

1660trivialHoles' psn h ist

1713trivialHoles' psn h ist

@@ -1668,38 +1721,25 @@ resolveTC' di mv depth tm n ist

1668

1721

1669collectDeferred :: Maybe Name -> [Name] -> Context ->

1722collectDeferred :: Maybe Name -> [Name] -> Context ->

1670 Term -> State [(Name, (Int, Maybe Name, Type, [Name]))] Term

1723 Term -> State [(Name, (Int, Maybe Name, Type, [Name]))] Term

1671−collectDeferred top casenames ctxt (Bind n (GHole i psns t) app) =

1724+collectDeferred top casenames ctxt tm = cd [] tm

1672− do ds <- get

1673− t' <- collectDeferred top casenames ctxt t

1674− when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, tidyArg [] t', psns))])

1675− collectDeferred top casenames ctxt app

1676 where

1725 where

1677− -- Evaluate the top level functions in arguments, if possible, and if it's

1726+ cd env (Bind n (GHole i psns t) app) =

1678− -- not a name we're immediately going to define in a case block, so that

1727+ do ds <- get

1679− -- any immediate specialisation of the function applied to constructors

1728+ t' <- collectDeferred top casenames ctxt t

1680− -- can be done

1729+ when (not (n `elem` map fst ds)) $ put (ds ++ [(n, (i, top, t', psns))])

1730+ cd env app

1681− tidyArg env (Bind n b@(Pi im t k) sc)

1731+ cd env (Bind n b t)

1682− = Bind n (Pi im (tidy ctxt env t) k)

1732+ = do b' <- cdb b

1683− (tidyArg ((n, b) : env) sc)

1733+ t' <- cd ((n, b) : env) t

1684− tidyArg env t = tidy ctxt env t

1685−

1686− tidy ctxt env t = normalise ctxt env t

1687−

1688− getFn (Bind n (Lam _) t) = getFn t

1689− getFn t | (f, a) <- unApply t = f

1690−

1691−collectDeferred top ns ctxt (Bind n b t)

1692− = do b' <- cdb b

1693− t' <- collectDeferred top ns ctxt t

1694− return (Bind n b' t')

1734+ return (Bind n b' t')

1695− where

1735+ where

1696− cdb (Let t v) = liftM2 Let (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1736+ cdb (Let t v) = liftM2 Let (cd env t) (cd env v)

1697− cdb (Guess t v) = liftM2 Guess (collectDeferred top ns ctxt t) (collectDeferred top ns ctxt v)

1737+ cdb (Guess t v) = liftM2 Guess (cd env t) (cd env v)

1698− cdb b = do ty' <- collectDeferred top ns ctxt (binderTy b)

1738+ cdb b = do ty' <- cd env (binderTy b)

1699− return (b { binderTy = ty' })

1739+ return (b { binderTy = ty' })

1700−collectDeferred top ns ctxt (App s f a) = liftM2 (App s) (collectDeferred top ns ctxt f)

1740+ cd env (App s f a) = liftM2 (App s) (cd env f)

1701− (collectDeferred top ns ctxt a)

1741+ (cd env a)

1702−collectDeferred top ns ctxt t = return t

1742+ cd env t = return t

1703

1743

1704case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()

1744case_ :: Bool -> Bool -> IState -> Name -> PTerm -> ElabD ()

1705case_ ind autoSolve ist fn tm = do

1745case_ ind autoSolve ist fn tm = do

@@ -1735,14 +1775,33 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1735

1775

1736 returnUnit = return $ P (DCon 0 0 False) unitCon (P (TCon 0 0) unitTy Erased)

1776 returnUnit = return $ P (DCon 0 0 False) unitCon (P (TCon 0 0) unitTy Erased)

1737

1777

1738− patvars :: [Name] -> Term -> ([Name], Term)

1778+ patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)

1739− patvars ns (Bind n (PVar t) sc) = patvars (n : ns) (instantiate (P Bound n t) sc)

1779+ patvars ns (Bind n (PVar t) sc) = patvars ((n, t) : ns) (instantiate (P Bound n t) sc)

1740 patvars ns tm = (ns, tm)

1780 patvars ns tm = (ns, tm)

1741

1781

1742− pullVars :: (Term, Term) -> ([Name], Term, Term)

1782+ pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)

1743 pullVars (lhs, rhs) = (fst (patvars [] lhs), snd (patvars [] lhs), snd (patvars [] rhs)) -- TODO alpha-convert rhs

1783 pullVars (lhs, rhs) = (fst (patvars [] lhs), snd (patvars [] lhs), snd (patvars [] rhs)) -- TODO alpha-convert rhs

1744

1784

1785+ requireError :: Err -> ElabD a -> ElabD ()

1786+ requireError orErr elab =

1787+ do state <- get

1788+ case runStateT elab state of

1789+ OK (_, state') -> lift (tfail orErr)

1790+ Error e -> return ()

1791+

1792+ -- create a fake TT term for the LHS of an impossible case

1793+ fakeTT :: Raw -> Term

1794+ fakeTT (Var n) =

1795+ case lookupNameDef n (tt_ctxt ist) of

1796+ [(n', TyDecl nt _)] -> P nt n' Erased

1797+ _ -> P Ref n Erased

1798+ fakeTT (RBind n b body) = Bind n (fmap fakeTT b) (fakeTT body)

1799+ fakeTT (RApp f a) = App Complete (fakeTT f) (fakeTT a)

1800+ fakeTT RType = TType (UVar (-1))

1801+ fakeTT (RUType u) = UType u

1802+ fakeTT (RConstant c) = Constant c

1803+

1745− defineFunction :: RFunDefn -> ElabD ()

1804+ defineFunction :: RFunDefn Raw -> ElabD ()

1746 defineFunction (RDefineFun n clauses) =

1805 defineFunction (RDefineFun n clauses) =

1747 do ctxt <- get_context

1806 do ctxt <- get_context

1748 ty <- maybe (fail "no type decl") return $ lookupTyExact n ctxt

1807 ty <- maybe (fail "no type decl") return $ lookupTyExact n ctxt

@@ -1754,22 +1813,24 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1754 lift $ converts ctxt [] lty rty

1813 lift $ converts ctxt [] lty rty

1755 return $ Right (lhs', rhs')

1814 return $ Right (lhs', rhs')

1756 RMkImpossibleClause lhs ->

1815 RMkImpossibleClause lhs ->

1816+ do requireError (Msg "Not an impossible case") . lift $

1757− do lhs' <- fmap fst . lift $ check ctxt [] lhs

1817+ check ctxt [] lhs

1758− return $ Left lhs')

1818+ return $ Left (fakeTT lhs))

1759 let clauses'' = map (\case Right c -> pullVars c

1819 let clauses'' = map (\case Right c -> pullVars c

1760− Left lhs -> let (ns, lhs') = patvars [] lhs'

1820+ Left lhs -> let (ns, lhs') = patvars [] lhs

1761 in (ns, lhs', Impossible))

1821 in (ns, lhs', Impossible))

1762 clauses'

1822 clauses'

1823+ let clauses''' = map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) clauses''

1763 ctxt'<- lift $

1824 ctxt'<- lift $

1764 addCasedef n (const [])

1825 addCasedef n (const [])

1765 info False (STerm Erased)

1826 info False (STerm Erased)

1766 True False -- TODO what are these?

1827 True False -- TODO what are these?

1767 (map snd $ getArgTys ty) [] -- TODO inaccessible types

1828 (map snd $ getArgTys ty) [] -- TODO inaccessible types

1768 clauses'

1829 clauses'

1769− clauses''

1830+ clauses'''

1770− clauses''

1831+ clauses'''

1771− clauses''

1832+ clauses'''

1772− clauses''

1833+ clauses'''

1773 ty

1834 ty

1774 ctxt

1835 ctxt

1775 set_context ctxt'

1836 set_context ctxt'

@@ -1785,10 +1846,10 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1785 -- step, the output is the (reflected) term returned.

1846 -- step, the output is the (reflected) term returned.

1786 runTacTm :: Term -> ElabD Term

1847 runTacTm :: Term -> ElabD Term

1787 runTacTm (unApply -> tac@(P _ n _, args))

1848 runTacTm (unApply -> tac@(P _ n _, args))

1788− | n == tacN "prim__Solve", [] <- args

1849+ | n == tacN "Prim__Solve", [] <- args

1789 = do solve

1850 = do solve

1790 returnUnit

1851 returnUnit

1791− | n == tacN "prim__Goal", [] <- args

1852+ | n == tacN "Prim__Goal", [] <- args

1792 = do hs <- get_holes

1853 = do hs <- get_holes

1793 case hs of

1854 case hs of

1794 (h : _) -> do t <- goal

1855 (h : _) -> do t <- goal

@@ -1798,27 +1859,19 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1798 [] -> lift . tfail . Msg $

1859 [] -> lift . tfail . Msg $

1799 "Elaboration is complete. There are no goals."

1860 "Elaboration is complete. There are no goals."

1800

1861

1801− | n == tacN "prim__Holes", [] <- args

1862+ | n == tacN "Prim__Holes", [] <- args

1802 = do hs <- get_holes

1863 = do hs <- get_holes

1803 fmap fst . checkClosed $

1864 fmap fst . checkClosed $

1804 mkList (Var $ reflm "TTName") (map reflectName hs)

1865 mkList (Var $ reflm "TTName") (map reflectName hs)

1805− | n == tacN "prim__Guess", [] <- args

1866+ | n == tacN "Prim__Guess", [] <- args

1806− = do ok <- is_guess

1807− if ok

1808− then do guess <- fmap forget get_guess

1867+ = do g <- get_guess

1809− fmap fst . get_type_val $

1810− RApp (RApp (Var (sNS (sUN "Just") ["Maybe", "Prelude"]))

1811− (Var (reflm "TT")))

1812− guess

1813− else fmap fst . checkClosed $

1868+ fmap fst . checkClosed $ reflect g

1814− RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))

1815− (Var (reflm "TT"))

1816− | n == tacN "prim__LookupTy", [n] <- args

1869+ | n == tacN "Prim__LookupTy", [n] <- args

1817 = do n' <- reifyTTName n

1870 = do n' <- reifyTTName n

1818 ctxt <- get_context

1871 ctxt <- get_context

1819− let getNameTypeAndType = \case Function ty _ -> (Ref, ty)

1872+ let getNameTypeAndType = \case Function ty _ -> (Ref, ty)

1820− TyDecl nt ty -> (nt, ty)

1873+ TyDecl nt ty -> (nt, ty)

1821− Operator ty _ _ -> (Ref, ty)

1874+ Operator ty _ _ -> (Ref, ty)

1822 CaseOp _ ty _ _ _ _ -> (Ref, ty)

1875 CaseOp _ ty _ _ _ _ -> (Ref, ty)

1823 -- Idris tuples nest to the right

1876 -- Idris tuples nest to the right

1824 reflectTriple (x, y, z) =

1877 reflectTriple (x, y, z) =

@@ -1835,46 +1888,75 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1835 , raw_apply (Var pairTy) [ Var (reflm "NameType")

1888 , raw_apply (Var pairTy) [ Var (reflm "NameType")

1836 , Var (reflm "TT")]])

1889 , Var (reflm "TT")]])

1837 defs

1890 defs

1838− | n == tacN "prim__LookupDatatype", [name] <- args

1891+ | n == tacN "Prim__LookupDatatype", [name] <- args

1839 = do n' <- reifyTTName name

1892 = do n' <- reifyTTName name

1840 datatypes <- get_datatypes

1893 datatypes <- get_datatypes

1841 ctxt <- get_context

1894 ctxt <- get_context

1842 fmap fst . checkClosed $

1895 fmap fst . checkClosed $

1843 rawList (Var (tacN "Datatype"))

1896 rawList (Var (tacN "Datatype"))

1844 (map reflectDatatype (buildDatatypes ist n'))

1897 (map reflectDatatype (buildDatatypes ist n'))

1845− | n == tacN "prim__SourceLocation", [] <- args

1898+ | n == tacN "Prim__LookupFunDefn", [name] <- args

1899+ = do n' <- reifyTTName name

1900+ fmap fst . checkClosed $

1901+ rawList (RApp (Var $ tacN "FunDefn") (Var $ reflm "TT"))

1902+ (map reflectFunDefn (buildFunDefns ist n'))

1903+ | n == tacN "Prim__LookupArgs", [name] <- args

1904+ = do n' <- reifyTTName name

1905+ let listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1906+ listFunArg = RApp listTy (Var (tacN "FunArg"))

1907+ -- Idris tuples nest to the right

1908+ let reflectTriple (x, y, z) =

1909+ raw_apply (Var pairCon) [ Var (reflm "TTName")

1910+ , raw_apply (Var pairTy) [listFunArg, Var (reflm "Raw")]

1911+ , x

1912+ , raw_apply (Var pairCon) [listFunArg, Var (reflm "Raw")

1913+ , y, z]]

1914+ let out =

1915+ [ reflectTriple (reflectName fn, reflectList (Var (tacN "FunArg")) (map reflectArg args), reflectRaw res)

1916+ | (fn, pargs) <- lookupCtxtName n' (idris_implicits ist)

1917+ , (args, res) <- getArgs pargs . forget <$>

1918+ maybeToList (lookupTyExact fn (tt_ctxt ist))

1919+ ]

1920+

1921+ fmap fst . checkClosed $

1922+ rawList (raw_apply (Var pairTy) [Var (reflm "TTName")

1923+ , raw_apply (Var pairTy) [ RApp listTy

1924+ (Var (tacN "FunArg"))

1925+ , Var (reflm "Raw")]])

1926+ out

1927+ | n == tacN "Prim__SourceLocation", [] <- args

1846 = fmap fst . checkClosed $

1928 = fmap fst . checkClosed $

1847 reflectFC fc

1929 reflectFC fc

1848− | n == tacN "prim__Namespace", [] <- args

1930+ | n == tacN "Prim__Namespace", [] <- args

1849 = fmap fst . checkClosed $

1931 = fmap fst . checkClosed $

1850 rawList (RConstant StrType) (map (RConstant . Str) ns)

1932 rawList (RConstant StrType) (map (RConstant . Str) ns)

1851− | n == tacN "prim__Env", [] <- args

1933+ | n == tacN "Prim__Env", [] <- args

1852 = do env <- get_env

1934 = do env <- get_env

1853 fmap fst . checkClosed $ reflectEnv env

1935 fmap fst . checkClosed $ reflectEnv env

1854− | n == tacN "prim__Fail", [_a, errs] <- args

1936+ | n == tacN "Prim__Fail", [_a, errs] <- args

1855 = do errs' <- eval errs

1937 = do errs' <- eval errs

1856 parts <- reifyReportParts errs'

1938 parts <- reifyReportParts errs'

1857 lift . tfail $ ReflectionError [parts] (Msg "")

1939 lift . tfail $ ReflectionError [parts] (Msg "")

1858− | n == tacN "prim__PureElab", [_a, tm] <- args

1940+ | n == tacN "Prim__PureElab", [_a, tm] <- args

1859 = return tm

1941 = return tm

1860− | n == tacN "prim__BindElab", [_a, _b, first, andThen] <- args

1942+ | n == tacN "Prim__BindElab", [_a, _b, first, andThen] <- args

1861 = do first' <- eval first

1943 = do first' <- eval first

1862 res <- eval =<< runTacTm first'

1944 res <- eval =<< runTacTm first'

1863 next <- eval (App Complete andThen res)

1945 next <- eval (App Complete andThen res)

1864 runTacTm next

1946 runTacTm next

1865− | n == tacN "prim__Try", [_a, first, alt] <- args

1947+ | n == tacN "Prim__Try", [_a, first, alt] <- args

1866 = do first' <- eval first

1948 = do first' <- eval first

1867 alt' <- eval alt

1949 alt' <- eval alt

1868 try' (runTacTm first') (runTacTm alt') True

1950 try' (runTacTm first') (runTacTm alt') True

1869− | n == tacN "prim__Fill", [raw] <- args

1951+ | n == tacN "Prim__Fill", [raw] <- args

1870 = do raw' <- reifyRaw =<< eval raw

1952 = do raw' <- reifyRaw =<< eval raw

1871− fill raw'

1953+ apply raw' []

1872 returnUnit

1954 returnUnit

1873− | n == tacN "prim__Apply" || n == tacN "prim__MatchApply"

1955+ | n == tacN "Prim__Apply" || n == tacN "Prim__MatchApply"

1874 , [raw, argSpec] <- args

1956 , [raw, argSpec] <- args

1875 = do raw' <- reifyRaw =<< eval raw

1957 = do raw' <- reifyRaw =<< eval raw

1876− argSpec' <- reifyList (reifyPair reifyBool reifyInt) argSpec

1958+ argSpec' <- map (\b -> (b, 0)) <$> reifyList reifyBool argSpec

1877− let op = if n == tacN "prim__Apply"

1959+ let op = if n == tacN "Prim__Apply"

1878 then apply

1960 then apply

1879 else match_apply

1961 else match_apply

1880 ns <- op raw' argSpec'

1962 ns <- op raw' argSpec'

@@ -1884,91 +1966,88 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1884 (reflectName n1, reflectName n2)

1966 (reflectName n1, reflectName n2)

1885 | (n1, n2) <- ns

1967 | (n1, n2) <- ns

1886 ]

1968 ]

1887− | n == tacN "prim__Gensym", [hint] <- args

1969+ | n == tacN "Prim__Gensym", [hint] <- args

1888 = do hintStr <- eval hint

1970 = do hintStr <- eval hint

1889 case hintStr of

1971 case hintStr of

1890 Constant (Str h) -> do

1972 Constant (Str h) -> do

1891 n <- getNameFrom (sMN 0 h)

1973 n <- getNameFrom (sMN 0 h)

1892 fmap fst $ get_type_val (reflectName n)

1974 fmap fst $ get_type_val (reflectName n)

1893 _ -> fail "no hint"

1975 _ -> fail "no hint"

1894− | n == tacN "prim__Claim", [n, ty] <- args

1976+ | n == tacN "Prim__Claim", [n, ty] <- args

1895 = do n' <- reifyTTName n

1977 = do n' <- reifyTTName n

1896 ty' <- reifyRaw ty

1978 ty' <- reifyRaw ty

1897 claim n' ty'

1979 claim n' ty'

1898 returnUnit

1980 returnUnit

1899− | n == tacN "prim__Check", [raw] <- args

1981+ | n == tacN "Prim__Check", [env', raw] <- args

1982+ = do env <- reifyEnv env'

1900− = do raw' <- reifyRaw =<< eval raw

1983+ raw' <- reifyRaw =<< eval raw

1901 ctxt <- get_context

1984 ctxt <- get_context

1902− env <- get_env

1903 (tm, ty) <- lift $ check ctxt env raw'

1985 (tm, ty) <- lift $ check ctxt env raw'

1904 fmap fst . checkClosed $

1986 fmap fst . checkClosed $

1905 rawPair (Var (reflm "TT"), Var (reflm "TT"))

1987 rawPair (Var (reflm "TT"), Var (reflm "TT"))

1906 (reflect tm, reflect ty)

1988 (reflect tm, reflect ty)

1907− | n == tacN "prim__Forget", [tt] <- args

1989+ | n == tacN "Prim__Attack", [] <- args

1908− = do tt' <- reifyTT tt

1909− fmap fst . checkClosed . reflectRaw $ forget tt'

1910− | n == tacN "prim__Attack", [] <- args

1911 = do attack

1990 = do attack

1912 returnUnit

1991 returnUnit

1913− | n == tacN "prim__Rewrite", [rule] <- args

1992+ | n == tacN "Prim__Rewrite", [rule] <- args

1914 = do r <- reifyRaw rule

1993 = do r <- reifyRaw rule

1915 rewrite r

1994 rewrite r

1916 returnUnit

1995 returnUnit

1917− | n == tacN "prim__Focus", [what] <- args

1996+ | n == tacN "Prim__Focus", [what] <- args

1918 = do n' <- reifyTTName what

1997 = do n' <- reifyTTName what

1919 hs <- get_holes

1998 hs <- get_holes

1920 if elem n' hs

1999 if elem n' hs

1921 then focus n' >> returnUnit

2000 then focus n' >> returnUnit

1922 else lift . tfail . Msg $ "The name " ++ show n' ++ " does not denote a hole"

2001 else lift . tfail . Msg $ "The name " ++ show n' ++ " does not denote a hole"

1923− | n == tacN "prim__Unfocus", [what] <- args

2002+ | n == tacN "Prim__Unfocus", [what] <- args

1924 = do n' <- reifyTTName what

2003 = do n' <- reifyTTName what

1925 movelast n'

2004 movelast n'

1926 returnUnit

2005 returnUnit

1927− | n == tacN "prim__Intro", [mn] <- args

2006+ | n == tacN "Prim__Intro", [mn] <- args

1928 = do n <- case fromTTMaybe mn of

2007 = do n <- case fromTTMaybe mn of

1929 Nothing -> return Nothing

2008 Nothing -> return Nothing

1930 Just name -> fmap Just $ reifyTTName name

2009 Just name -> fmap Just $ reifyTTName name

1931 intro n

2010 intro n

1932 returnUnit

2011 returnUnit

1933− | n == tacN "prim__Forall", [n, ty] <- args

2012+ | n == tacN "Prim__Forall", [n, ty] <- args

1934 = do n' <- reifyTTName n

2013 = do n' <- reifyTTName n

1935 ty' <- reifyRaw ty

2014 ty' <- reifyRaw ty

1936 forall n' Nothing ty'

2015 forall n' Nothing ty'

1937 returnUnit

2016 returnUnit

1938− | n == tacN "prim__PatVar", [n] <- args

2017+ | n == tacN "Prim__PatVar", [n] <- args

1939 = do n' <- reifyTTName n

2018 = do n' <- reifyTTName n

1940 patvar' n'

2019 patvar' n'

1941 returnUnit

2020 returnUnit

1942− | n == tacN "prim__PatBind", [n] <- args

2021+ | n == tacN "Prim__PatBind", [n] <- args

1943 = do n' <- reifyTTName n

2022 = do n' <- reifyTTName n

1944 patbind n'

2023 patbind n'

1945 returnUnit

2024 returnUnit

1946− | n == tacN "prim__LetBind", [n, ty, tm] <- args

2025+ | n == tacN "Prim__LetBind", [n, ty, tm] <- args

1947 = do n' <- reifyTTName n

2026 = do n' <- reifyTTName n

1948 ty' <- reifyRaw ty

2027 ty' <- reifyRaw ty

1949 tm' <- reifyRaw tm

2028 tm' <- reifyRaw tm

1950 letbind n' ty' tm'

2029 letbind n' ty' tm'

1951 returnUnit

2030 returnUnit

1952− | n == tacN "prim__Compute", [] <- args

2031+ | n == tacN "Prim__Compute", [] <- args

1953 = do compute ; returnUnit

2032 = do compute ; returnUnit

1954− | n == tacN "prim__Normalise", [env, tm] <- args

2033+ | n == tacN "Prim__Normalise", [env, tm] <- args

1955 = do env' <- reifyEnv env

2034 = do env' <- reifyEnv env

1956 tm' <- reifyTT tm

2035 tm' <- reifyTT tm

1957 ctxt <- get_context

2036 ctxt <- get_context

1958 let out = normaliseAll ctxt env' (finalise tm')

2037 let out = normaliseAll ctxt env' (finalise tm')

1959 fmap fst . checkClosed $ reflect out

2038 fmap fst . checkClosed $ reflect out

1960− | n == tacN "prim__Whnf", [tm] <- args

2039+ | n == tacN "Prim__Whnf", [tm] <- args

1961 = do tm' <- reifyTT tm

2040 = do tm' <- reifyTT tm

1962 ctxt <- get_context

2041 ctxt <- get_context

1963 fmap fst . checkClosed . reflect $ whnf ctxt tm'

2042 fmap fst . checkClosed . reflect $ whnf ctxt tm'

1964− | n == tacN "prim__Converts", [env, tm1, tm2] <- args

2043+ | n == tacN "Prim__Converts", [env, tm1, tm2] <- args

1965 = do env' <- reifyEnv env

2044 = do env' <- reifyEnv env

1966 tm1' <- reifyTT tm1

2045 tm1' <- reifyTT tm1

1967 tm2' <- reifyTT tm2

2046 tm2' <- reifyTT tm2

1968 ctxt <- get_context

2047 ctxt <- get_context

1969 lift $ converts ctxt env' tm1' tm2'

2048 lift $ converts ctxt env' tm1' tm2'

1970 returnUnit

2049 returnUnit

1971− | n == tacN "prim__DeclareType", [decl] <- args

2050+ | n == tacN "Prim__DeclareType", [decl] <- args

1972 = do (RDeclare n args res) <- reifyTyDecl decl

2051 = do (RDeclare n args res) <- reifyTyDecl decl

1973 ctxt <- get_context

2052 ctxt <- get_context

1974 let mkPi arg res = RBind (argName arg)

2053 let mkPi arg res = RBind (argName arg)

@@ -1990,24 +2069,28 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1990 set_context ctxt'

2069 set_context ctxt'

1991 updateAux $ \e -> e { new_tyDecls = (RTyDeclInstrs n fc (map rFunArgToPArg args) checked) :

2070 updateAux $ \e -> e { new_tyDecls = (RTyDeclInstrs n fc (map rFunArgToPArg args) checked) :

1992 new_tyDecls e }

2071 new_tyDecls e }

1993− aux <- getAux

1994 returnUnit

2072 returnUnit

1995− | n == tacN "prim__DefineFunction", [decl] <- args

2073+ | n == tacN "Prim__DefineFunction", [decl] <- args

1996 = do defn <- reifyFunDefn decl

2074 = do defn <- reifyFunDefn decl

1997 defineFunction defn

2075 defineFunction defn

1998 returnUnit

2076 returnUnit

1999− | n == tacN "prim__AddInstance", [cls, inst] <- args

2077+ | n == tacN "Prim__AddInstance", [cls, inst] <- args

2000 = do className <- reifyTTName cls

2078 = do className <- reifyTTName cls

2001 instName <- reifyTTName inst

2079 instName <- reifyTTName inst

2002 updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :

2080 updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :

2003 new_tyDecls e}

2081 new_tyDecls e}

2004 returnUnit

2082 returnUnit

2005− | n == tacN "prim__ResolveTC", [fn] <- args

2083+ | n == tacN "Prim__IsTCName", [n] <- args

2084+ = do n' <- reifyTTName n

2085+ case lookupCtxtExact n' (idris_classes ist) of

2086+ Just _ -> fmap fst . checkClosed $ Var (sNS (sUN "True") ["Bool", "Prelude"])

2087+ Nothing -> fmap fst . checkClosed $ Var (sNS (sUN "False") ["Bool", "Prelude"])

2088+ | n == tacN "Prim__ResolveTC", [fn] <- args

2006 = do g <- goal

2089 = do g <- goal

2007 fn <- reifyTTName fn

2090 fn <- reifyTTName fn

2008 resolveTC' False True 100 g fn ist

2091 resolveTC' False True 100 g fn ist

2009 returnUnit

2092 returnUnit

2010− | n == tacN "prim__Search", [depth, hints] <- args

2093+ | n == tacN "Prim__Search", [depth, hints] <- args

2011 = do d <- eval depth

2094 = do d <- eval depth

2012 hints' <- eval hints

2095 hints' <- eval hints

2013 case (d, unList hints') of

2096 case (d, unList hints') of

@@ -2020,7 +2103,7 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2020 (Constant (I _), Nothing ) ->

2103 (Constant (I _), Nothing ) ->

2021 lift . tfail . InternalMsg $ "Not a list: " ++ show hints'

2104 lift . tfail . InternalMsg $ "Not a list: " ++ show hints'

2022 (_, _) -> lift . tfail . InternalMsg $ "Can't reify int " ++ show d

2105 (_, _) -> lift . tfail . InternalMsg $ "Can't reify int " ++ show d

2023− | n == tacN "prim__RecursiveElab", [goal, script] <- args

2106+ | n == tacN "Prim__RecursiveElab", [goal, script] <- args

2024 = do goal' <- reifyRaw goal

2107 = do goal' <- reifyRaw goal

2025 ctxt <- get_context

2108 ctxt <- get_context

2026 script <- eval script

2109 script <- eval script

@@ -2030,22 +2113,28 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2030 aux <- getAux

2113 aux <- getAux

2031 datatypes <- get_datatypes

2114 datatypes <- get_datatypes

2032 env <- get_env

2115 env <- get_env

2116+

2033− (_, ES (p, aux') _ _) <-

2117+ (ctxt', ES (p, aux') _ _) <-

2034 do (ES (current_p, _) _ _) <- get

2118 do (ES (current_p, _) _ _) <- get

2119+ lift $ runElab aux

2035− lift $ runElab aux (runElabAction ist fc [] script ns)

2120+ (do runElabAction ist fc [] script ns

2121+ ctxt' <- get_context

2122+ return ctxt')

2036− ((newProof recH ctxt datatypes goalTT)

2123+ ((newProof recH ctxt datatypes goalTT)

2037− { nextname = nextname current_p})

2124+ { nextname = nextname current_p })

2125+ set_context ctxt'

2126+

2038 let tm_out = getProofTerm (pterm p)

2127 let tm_out = getProofTerm (pterm p)

2039 do (ES (prf, _) s e) <- get

2128 do (ES (prf, _) s e) <- get

2040 let p' = prf { nextname = nextname p }

2129 let p' = prf { nextname = nextname p }

2041 put (ES (p', aux') s e)

2130 put (ES (p', aux') s e)

2042 env' <- get_env

2131 env' <- get_env

2043− (tm, ty, _) <- lift $ recheck ctxt env (forget tm_out) tm_out

2132+ (tm, ty, _) <- lift $ recheck ctxt' env (forget tm_out) tm_out

2044 let (tm', ty') = (reflect tm, reflect ty)

2133 let (tm', ty') = (reflect tm, reflect ty)

2045 fmap fst . checkClosed $

2134 fmap fst . checkClosed $

2046 rawPair (Var $ reflm "TT", Var $ reflm "TT")

2135 rawPair (Var $ reflm "TT", Var $ reflm "TT")

2047 (tm', ty')

2136 (tm', ty')

2048− | n == tacN "prim__Metavar", [n] <- args

2137+ | n == tacN "Prim__Metavar", [n] <- args

2049 = do n' <- reifyTTName n

2138 = do n' <- reifyTTName n

2050 ctxt <- get_context

2139 ctxt <- get_context

2051 ptm <- get_term

2140 ptm <- get_term

@@ -2056,10 +2145,10 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2056 defer unique_used mvn

2145 defer unique_used mvn

2057 solve

2146 solve

2058 returnUnit

2147 returnUnit

2059− | n == tacN "prim__Fixity", [op'] <- args

2148+ | n == tacN "Prim__Fixity", [op'] <- args

2060 = do opTm <- eval op'

2149 = do opTm <- eval op'

2061 case opTm of

2150 case opTm of

2062− Constant (Str op) ->

2151+ Constant (Str op) ->

2063 let opChars = ":!#$%&*+./<=>?@\\^|-~"

2152 let opChars = ":!#$%&*+./<=>?@\\^|-~"

2064 invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]

2153 invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]

2065 fixities = idris_infixes ist

2154 fixities = idris_infixes ist

@@ -2070,7 +2159,7 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2070 [f] -> fmap fst . checkClosed $ reflectFixity f

2159 [f] -> fmap fst . checkClosed $ reflectFixity f

2071 many -> lift . tfail . InternalMsg $ "Ambiguous fixity for '" ++ op ++ "'! Found " ++ show many

2160 many -> lift . tfail . InternalMsg $ "Ambiguous fixity for '" ++ op ++ "'! Found " ++ show many

2072 _ -> lift . tfail . Msg $ "Not a constant string for an operator name: " ++ show opTm

2161 _ -> lift . tfail . Msg $ "Not a constant string for an operator name: " ++ show opTm

2073− | n == tacN "prim__Debug", [ty, msg] <- args

2162+ | n == tacN "Prim__Debug", [ty, msg] <- args

2074 = do msg' <- eval msg

2163 = do msg' <- eval msg

2075 parts <- reifyReportParts msg

2164 parts <- reifyReportParts msg

2076 debugElaborator parts

2165 debugElaborator parts

@@ -2096,7 +2185,7 @@ runTac autoSolve ist perhapsFC fn tac

2096 bname _ = Nothing

2185 bname _ = Nothing

2097 runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs

2186 runT (Intro xs) = mapM_ (\x -> do attack; intro (Just x)) xs

2098 runT Intros = do g <- goal

2187 runT Intros = do g <- goal

2099− attack;

2188+ attack;

2100 intro (bname g)

2189 intro (bname g)

2101 try' (runT Intros)

2190 try' (runT Intros)

2102 (return ()) True

2191 (return ()) True

@@ -2341,18 +2430,18 @@ elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

2341withErrorReflection :: Idris a -> Idris a

2430withErrorReflection :: Idris a -> Idris a

2342withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2431withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2343 where handle :: Err -> Idris Err

2432 where handle :: Err -> Idris Err

2344− handle e@(ReflectionError _ _) = do logLvl 3 "Skipping reflection of error reflection result"

2433+ handle e@(ReflectionError _ _) = do logElab 3 "Skipping reflection of error reflection result"

2345 return e -- Don't do meta-reflection of errors

2434 return e -- Don't do meta-reflection of errors

2346− handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

2435+ handle e@(ReflectionFailed _ _) = do logElab 3 "Skipping reflection of reflection failure"

2347 return e

2436 return e

2348 -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them

2437 -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them

2349− handle e@(At fc err) = do logLvl 3 "Reflecting body of At"

2438+ handle e@(At fc err) = do logElab 3 "Reflecting body of At"

2350 err' <- handle err

2439 err' <- handle err

2351 return (At fc err')

2440 return (At fc err')

2352− handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"

2441+ handle e@(Elaborating what n ty err) = do logElab 3 "Reflecting body of Elaborating"

2353− err' <- handle err

2442+ err' <- handle err

2354− return (Elaborating what n err')

2443+ return (Elaborating what n ty err')

2355− handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"

2444+ handle e@(ElaboratingArg f a prev err) = do logElab 3 "Reflecting body of ElaboratingArg"

2356 hs <- getFnHandlers f a

2445 hs <- getFnHandlers f a

2357 err' <- if null hs

2446 err' <- if null hs

2358 then handle err

2447 then handle err

@@ -2362,8 +2451,8 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2362 handle (ProofSearchFail e) = handle e

2451 handle (ProofSearchFail e) = handle e

2363 -- TODO: argument-specific error handlers go here for ElaboratingArg

2452 -- TODO: argument-specific error handlers go here for ElaboratingArg

2364 handle e = do ist <- getIState

2453 handle e = do ist <- getIState

2365− logLvl 2 "Starting error reflection"

2454+ logElab 2 "Starting error reflection"

2366− logLvl 5 (show e)

2455+ logElab 5 (show e)

2367 let handlers = idris_errorhandlers ist

2456 let handlers = idris_errorhandlers ist

2368 applyHandlers e handlers

2457 applyHandlers e handlers

2369 getFnHandlers :: Name -> Name -> Idris [Name]

2458 getFnHandlers :: Name -> Name -> Idris [Name]

@@ -2377,7 +2466,7 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2377 applyHandlers e handlers =

2466 applyHandlers e handlers =

2378 do ist <- getIState

2467 do ist <- getIState

2379 let err = fmap (errReverse ist) e

2468 let err = fmap (errReverse ist) e

2380− logLvl 3 $ "Using reflection handlers " ++

2469+ logElab 3 $ "Using reflection handlers " ++

2381 concat (intersperse ", " (map show handlers))

2470 concat (intersperse ", " (map show handlers))

2382 let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

2471 let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

2383

2472

@@ -2389,7 +2478,7 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2389 -- Normalize error handler terms to produce the new messages

2478 -- Normalize error handler terms to produce the new messages

2390 ctxt <- getContext

2479 ctxt <- getContext

2391 let results = map (normalise ctxt []) (map fst handlers)

2480 let results = map (normalise ctxt []) (map fst handlers)

2392− logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2481+ logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2393

2482

2394 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

2483 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

2395 let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

2484 let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

@@ -2410,8 +2499,8 @@ processTacticDecls info steps =

2410 -- establish metavars that later function bodies resolve.

2499 -- establish metavars that later function bodies resolve.

2411 forM_ (reverse steps) $ \case

2500 forM_ (reverse steps) $ \case

2412 RTyDeclInstrs n fc impls ty ->

2501 RTyDeclInstrs n fc impls ty ->

2413− do logLvl 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty

2502+ do logElab 3 $ "Declaration from tactics: " ++ show n ++ " : " ++ show ty

2414− logLvl 3 $ " It has impls " ++ show impls

2503+ logElab 3 $ " It has impls " ++ show impls

2415 updateIState $ \i -> i { idris_implicits =

2504 updateIState $ \i -> i { idris_implicits =

2416 addDef n impls (idris_implicits i) }

2505 addDef n impls (idris_implicits i) }

2417 addIBC (IBCImp n)

2506 addIBC (IBCImp n)

@@ -2428,13 +2517,13 @@ processTacticDecls info steps =

2428 in addDeferred ds'

2517 in addDeferred ds'

2429 _ -> return ()

2518 _ -> return ()

2430 RAddInstance className instName ->

2519 RAddInstance className instName ->

2431− do -- The type class resolution machinery relies on a special

2520+ do -- The type class resolution machinery relies on a special

2432− logLvl 2 $ "Adding elab script instance " ++ show instName ++

2521+ logElab 2 $ "Adding elab script instance " ++ show instName ++

2433 " for " ++ show className

2522 " for " ++ show className

2434 addInstance False True className instName

2523 addInstance False True className instName

2435 addIBC (IBCInstance False True className instName)

2524 addIBC (IBCInstance False True className instName)

2436 RClausesInstrs n cs ->

2525 RClausesInstrs n cs ->

2437− do logLvl 3 $ "Pattern-matching definition from tactics: " ++ show n

2526+ do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n

2438 solveDeferred n

2527 solveDeferred n

2439 let lhss = map (\(_, lhs, _) -> lhs) cs

2528 let lhss = map (\(_, lhs, _) -> lhs) cs

2440 let fc = fileFC "elab_reflected"

2529 let fc = fileFC "elab_reflected"

@@ -2464,7 +2553,7 @@ processTacticDecls info steps =

2464 calls = findCalls sc' scargs

2553 calls = findCalls sc' scargs

2465 used = findUsedArgs sc' scargs'

2554 used = findUsedArgs sc' scargs'

2466 cg = CGInfo scargs' calls [] used []

2555 cg = CGInfo scargs' calls [] used []

2467− in do logLvl 2 $ "Called names in reflected elab: " ++ show cg

2556+ in do logElab 2 $ "Called names in reflected elab: " ++ show cg

2468 addToCG n cg

2557 addToCG n cg

2469 addToCalledG n (nub (map fst calls))

2558 addToCalledG n (nub (map fst calls))

2470 addIBC $ IBCCG n

2559 addIBC $ IBCCG n

@@ -2493,7 +2582,8 @@ processTacticDecls info steps =

2493 let fc = fileFC "elab_reflected_totality"

2582 let fc = fileFC "elab_reflected_totality"

2494 let tcgen = False -- TODO: later we may support dictionary generation

2583 let tcgen = False -- TODO: later we may support dictionary generation

2495 case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2584 case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2496− (erun fc (buildTC ist info ELHS [] fname (infTerm lhs))) of

2585+ (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in)

2586+ (infTerm lhs))) of

2497 OK (ElabResult lhs' _ _ _ _ _, _) ->

2587 OK (ElabResult lhs' _ _ _ _ _, _) ->

2498 do -- not recursively calling here, because we don't

2588 do -- not recursively calling here, because we don't

2499 -- want to run infinitely many times

2589 -- want to run infinitely many times

src/Idris/Elab/Transform.hs+8−9

@@ -53,11 +53,11 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

53 = do ctxt <- getContext

54 i <- getIState

55 let lhs = addImplPat i lhs_in

56− logLvl 5 ("Transform LHS input: " ++ showTmImpls lhs)

56+ logElab 5 ("Transform LHS input: " ++ showTmImpls lhs)

57 (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

58 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

59 (erun fc (buildTC i info ETransLHS [] (sUN "transform")

60− (infTerm lhs)))

60+ (allNamesIn lhs_in) (infTerm lhs)))

61 setContext ctxt'

62 processTacticDecls info newDecls

63 sendHighlighting highlights

@@ -67,11 +67,11 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

67

68 (clhs_tm_in, clhs_ty) <- recheckC_borrowing False False [] fc id [] lhs_tm

69 let clhs_tm = renamepats pnames clhs_tm_in

70− logLvl 3 ("Transform LHS " ++ show clhs_tm)

70+ logElab 3 ("Transform LHS " ++ show clhs_tm)

71− logLvl 3 ("Transform type " ++ show clhs_ty)

71+ logElab 3 ("Transform type " ++ show clhs_ty)

72−

72+

73 let rhs = addImplBound i (map fst newargs) rhs_in

74− logLvl 5 ("Transform RHS input: " ++ showTmImpls rhs)

74+ logElab 5 ("Transform RHS input: " ++ showTmImpls rhs)

75

76 ((rhs', defer, ctxt', newDecls), _) <-

77 tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

@@ -88,7 +88,7 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

88

89 (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'

90 let crhs_tm = renamepats pnames crhs_tm_in

91− logLvl 3 ("Transform RHS " ++ show crhs_tm)

91+ logElab 3 ("Transform RHS " ++ show crhs_tm)

92

93 -- Types must always convert

94 case converts ctxt [] clhs_ty crhs_ty of

@@ -118,6 +118,5 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

118 -- with any other names when applying rules, so rename here.

119 pnames = map (\i -> sMN i ("tvar" ++ show i)) [0..]

120

121−elabTransform info fc safe lhs_in rhs_in

121+elabTransform info fc safe lhs_in rhs_in

122 = ierror (At fc (Msg "Invalid transformation rule (must be function application)"))

123−

src/Idris/Elab/Type.hs+23−25

@@ -1,5 +1,5 @@

1{-# LANGUAGE PatternGuards #-}

2−module Idris.Elab.Type (buildType, elabType, elabType',

2+module Idris.Elab.Type (buildType, elabType, elabType',

3 elabPostulate, elabExtern) where

4

5import Idris.AbsSyntax

@@ -52,31 +52,31 @@ import Data.List.Split (splitOn)

52

53import Util.Pretty(pretty, text)

54

55−buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm ->

55+buildType :: ElabInfo -> SyntaxInfo -> FC -> FnOpts -> Name -> PTerm ->

56 Idris (Type, Type, PTerm, [(Int, Name)])

57buildType info syn fc opts n ty' = do

58 ctxt <- getContext

59 i <- getIState

60

61− logLvl 2 $ show n ++ " pre-type " ++ showTmImpls ty' ++ show (no_imp syn)

61+ logElab 2 $ show n ++ " pre-type " ++ showTmImpls ty' ++ show (no_imp syn)

62 ty' <- addUsingConstraints syn fc ty'

63 ty' <- addUsingImpls syn n fc ty'

64 let ty = addImpl (imp_methods syn) i ty'

65

66− logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'

66+ logElab 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'

67− logLvl 5 $ show "with methods " ++ show (imp_methods syn)

67+ logElab 5 $ show "with methods " ++ show (imp_methods syn)

68− logLvl 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

68+ logElab 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

69

70 (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

71 tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

72− (errAt "type of " n (erun fc (build i info ETyDecl [] n ty)))

72+ (errAt "type of " n Nothing (erun fc (build i info ETyDecl [] n ty)))

73 setContext ctxt'

74 processTacticDecls info newDecls

75 sendHighlighting highlights

76

77 let tyT = patToImp tyT'

78

79− logLvl 3 $ show ty ++ "\nElaborated: " ++ show tyT'

79+ logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT'

80

81 ds <- checkAddDef True False fc iderr defer

82 -- if the type is not complete, note that we'll need to infer

@@ -86,20 +86,20 @@ buildType info syn fc opts n ty' = do

86

87 mapM_ (elabCaseBlock info opts) is

88 ctxt <- getContext

89− logLvl 5 $ "Rechecking"

89+ logElab 5 $ "Rechecking"

90− logLvl 6 $ show tyT

90+ logElab 6 $ show tyT

91− logLvl 10 $ "Elaborated to " ++ showEnvDbg [] tyT

91+ logElab 10 $ "Elaborated to " ++ showEnvDbg [] tyT

92 (cty, ckind) <- recheckC fc id [] tyT

93

94 -- record the implicit and inaccessible arguments

95 i <- getIState

96 let (inaccData, impls) = unzip $ getUnboundImplicits i cty ty

97 let inacc = inaccessibleImps 0 cty inaccData

98− logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc ++

98+ logElab 3 $ show n ++ ": inaccessible arguments: " ++ show inacc ++

99 " from " ++ show cty ++ "\n" ++ showTmImpls ty

100

101 putIState $ i { idris_implicits = addDef n impls (idris_implicits i) }

102− logLvl 3 ("Implicit " ++ show n ++ " " ++ show impls)

102+ logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103 addIBC (IBCImp n)

104

105 when (Constructor `notElem` opts) $ do

@@ -114,7 +114,7 @@ buildType info syn fc opts n ty' = do

114 patToImp (Bind n b sc) = Bind n b (patToImp sc)

115 patToImp t = t

116

117− param_pos i ns (Bind n (Pi _ t _) sc)

117+ param_pos i ns (Bind n (Pi _ t _) sc)

118 | n `elem` ns = i : param_pos (i + 1) ns sc

119 | otherwise = param_pos (i + 1) ns sc

120 param_pos i ns t = []

@@ -140,16 +140,17 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

140 let nty = cty -- normalise ctxt [] cty

141 -- if the return type is something coinductive, freeze the definition

142 ctxt <- getContext

143− logLvl 2 $ "Rechecked to " ++ show nty

143+ logElab 2 $ "Rechecked to " ++ show nty

144 let nty' = normalise ctxt [] nty

145− logLvl 2 $ "Rechecked to " ++ show nty'

145+ logElab 2 $ "Rechecked to " ++ show nty'

146

147− -- Add normalised type to internals

147+ -- Add function name to internals (used for making :addclause know

148+ -- the name unambiguously)

148 i <- getIState

149 i <- getIState

149 rep <- useREPL

150 rep <- useREPL

150 when rep $ do

151 when rep $ do

151− addInternalApp (fc_fname fc) (fst . fc_start $ fc) ty' -- (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?

152+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (PTyped (PRef fc [] n) ty') -- (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?

152− addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) ty') -- (mergeTy ty' (delab i nty')))

153+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (PTyped (PRef fc [] n) ty')) -- (mergeTy ty' (delab i nty')))

153

154

154 let (fam, _) = unApply (getRetTy nty')

155 let (fam, _) = unApply (getRetTy nty')

155 let corec = case fam of

156 let corec = case fam of

@@ -157,7 +158,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

157 [TI _ True _ _ _] -> True

158 [TI _ True _ _ _] -> True

158 _ -> False

159 _ -> False

160 _ -> False

160− -- Productivity checking now via checking for guarded 'Delay'

161+ -- Productivity checking now via checking for guarded 'Delay'

161 let opts' = opts -- if corec then (Coinductive : opts) else opts

162 let opts' = opts -- if corec then (Coinductive : opts) else opts

162 let usety = if norm then nty' else nty

163 let usety = if norm then nty' else nty

163 ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

164 ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

@@ -176,7 +177,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

176 addIBC (IBCOpt n)

177 addIBC (IBCOpt n)

177 when (Implicit `elem` opts') $ do addCoercion n

178 when (Implicit `elem` opts') $ do addCoercion n

178 addIBC (IBCCoercion n)

179 addIBC (IBCCoercion n)

179− when (AutoHint `elem` opts') $

180+ when (AutoHint `elem` opts') $

180 case fam of

181 case fam of

181 P _ tyn _ -> do addAutoHint tyn n

182 P _ tyn _ -> do addAutoHint tyn n

182 addIBC (IBCAutoHint tyn n)

183 addIBC (IBCAutoHint tyn n)

@@ -200,7 +201,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

200 sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]

201 sendHighlighting [(nfc, AnnName n Nothing Nothing Nothing)]

201 -- if it's an export list type, make a note of it

202 -- if it's an export list type, make a note of it

202 case (unApply usety) of

203 case (unApply usety) of

203− (P _ ut _, _)

204+ (P _ ut _, _)

204 | ut == ffiexport -> do addIBC (IBCExport n)

205 | ut == ffiexport -> do addIBC (IBCExport n)

205 addExport n

206 addExport n

206 _ -> return ()

207 _ -> return ()

@@ -255,6 +256,3 @@ elabExtern info syn doc fc nfc opts n ty = do

255

256

256 -- remove it from the deferred definitions list

257 -- remove it from the deferred definitions list

257 solveDeferred n

258 solveDeferred n

258−

259−

260−

src/Idris/Elab/Utils.hs+32−19

@@ -6,12 +6,15 @@ import Idris.Error

6import Idris.DeepSeq

7import Idris.Delaborate

8import Idris.Docstrings

9+import Idris.Output

9

10

10import Idris.Core.TT

11import Idris.Core.TT

11import Idris.Core.Elaborate hiding (Tactic(..))

12import Idris.Core.Elaborate hiding (Tactic(..))

12import Idris.Core.Evaluate

13import Idris.Core.Evaluate

13import Idris.Core.Typecheck

14import Idris.Core.Typecheck

14

15

16+import Util.Pretty

17+

15import Control.Applicative hiding (Const)

18import Control.Applicative hiding (Const)

16import Control.Monad.State

19import Control.Monad.State

17import Control.Monad

20import Control.Monad

@@ -34,10 +37,22 @@ recheckC_borrowing uniq_check addConstrs bs fc mkerr env t

34 (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of

37 (tm, ty, cs) <- tclift $ case recheck_borrowing uniq_check bs ctxt env t' t of

35 Error e -> tfail (At fc (mkerr e))

38 Error e -> tfail (At fc (mkerr e))

36 OK x -> return x

39 OK x -> return x

37− logLvl 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)

40+ logElab 6 $ "CONSTRAINTS ADDED: " ++ show (tm, ty, cs)

38 when addConstrs $ addConstraints fc cs

41 when addConstrs $ addConstraints fc cs

42+ mapM_ (checkDeprecated fc) (allTTNames tm)

43+ mapM_ (checkDeprecated fc) (allTTNames ty)

39 return (tm, ty)

44 return (tm, ty)

40

45

46+checkDeprecated :: FC -> Name -> Idris ()

47+checkDeprecated fc n

48+ = do r <- getDeprecated n

49+ case r of

50+ Nothing -> return ()

51+ Just r -> do iWarn fc $ text "Use of deprecated name " <> annName n

52+ <> case r of

53+ "" -> Util.Pretty.empty

54+ _ -> line <> text r

55+

41iderr :: Name -> Err -> Err

56iderr :: Name -> Err -> Err

42iderr _ e = e

57iderr _ e = e

43

58

@@ -49,8 +64,9 @@ checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err)

49 -> [(Name, (Int, Maybe Name, Type, [Name]))]

64 -> [(Name, (Int, Maybe Name, Type, [Name]))]

50 -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

65 -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

51checkAddDef add toplvl fc mkerr [] = return []

66checkAddDef add toplvl fc mkerr [] = return []

52−checkAddDef add toplvl fc mkerr ((n, (i, top, t, psns)) : ns)

67+checkAddDef add toplvl fc mkerr ((n, (i, top, t, psns)) : ns)

53 = do ctxt <- getContext

68 = do ctxt <- getContext

69+ logElab 5 $ "Rechecking deferred name " ++ show (n, t)

54 (t', _) <- recheckC fc (mkerr n) [] t

70 (t', _) <- recheckC fc (mkerr n) [] t

55 when add $ do addDeferred [(n, (i, top, t, psns, toplvl))]

71 when add $ do addDeferred [(n, (i, top, t, psns, toplvl))]

56 addIBC (IBCDef n)

72 addIBC (IBCDef n)

@@ -77,7 +93,7 @@ inaccessibleArgs _ _ = []

77elabCaseBlock :: ElabInfo -> FnOpts -> PDecl -> Idris ()

93elabCaseBlock :: ElabInfo -> FnOpts -> PDecl -> Idris ()

78elabCaseBlock info opts d@(PClauses f o n ps)

94elabCaseBlock info opts d@(PClauses f o n ps)

79 = do addIBC (IBCDef n)

95 = do addIBC (IBCDef n)

80− logLvl 5 $ "CASE BLOCK: " ++ show (n, d)

96+ logElab 5 $ "CASE BLOCK: " ++ show (n, d)

81 let opts' = nub (o ++ opts)

97 let opts' = nub (o ++ opts)

82 -- propagate totality assertion to the new definitions

98 -- propagate totality assertion to the new definitions

83 when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]

99 when (AssertTotal `elem` opts) $ setFlags n [AssertTotal]

@@ -88,16 +104,16 @@ elabCaseBlock info opts d@(PClauses f o n ps)

88-- they are the same!)

104-- they are the same!)

89checkInferred :: FC -> PTerm -> PTerm -> Idris ()

105checkInferred :: FC -> PTerm -> PTerm -> Idris ()

90checkInferred fc inf user =

106checkInferred fc inf user =

91− do logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" ++

107+ do logElab 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n\nFROM\n\n" ++

92 showTmImpls user

108 showTmImpls user

93− logLvl 10 $ "Checking match"

109+ logElab 10 $ "Checking match"

94 i <- getIState

110 i <- getIState

95 tclift $ case matchClause' True i user inf of

111 tclift $ case matchClause' True i user inf of

96 _ -> return ()

112 _ -> return ()

97-- Left (x, y) -> tfail $ At fc

113-- Left (x, y) -> tfail $ At fc

98-- (Msg $ "The type-checked term and given term do not match: "

114-- (Msg $ "The type-checked term and given term do not match: "

99-- ++ show x ++ " and " ++ show y)

115-- ++ show x ++ " and " ++ show y)

100− logLvl 10 $ "Checked match"

116+ logElab 10 $ "Checked match"

101-- ++ "\n" ++ showImp True inf ++ "\n" ++ showImp True user)

117-- ++ "\n" ++ showImp True inf ++ "\n" ++ showImp True user)

102

118

103-- | Return whether inferred term is different from given term

119-- | Return whether inferred term is different from given term

@@ -105,7 +121,7 @@ checkInferred fc inf user =

105inferredDiff :: FC -> PTerm -> PTerm -> Idris Bool

121inferredDiff :: FC -> PTerm -> PTerm -> Idris Bool

106inferredDiff fc inf user =

122inferredDiff fc inf user =

107 do i <- getIState

123 do i <- getIState

108− logLvl 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n" ++

124+ logElab 6 $ "Checked to\n" ++ showTmImpls inf ++ "\n" ++

109 showTmImpls user

125 showTmImpls user

110 tclift $ case matchClause' True i user inf of

126 tclift $ case matchClause' True i user inf of

111 Right vs -> return False

127 Right vs -> return False

@@ -136,7 +152,7 @@ decorateid decorate (PClauses f o n cs)

136

152

137-- if 't' is a type class application, assume its arguments are injective

153-- if 't' is a type class application, assume its arguments are injective

138pbinds :: IState -> Term -> ElabD ()

154pbinds :: IState -> Term -> ElabD ()

139−pbinds i (Bind n (PVar t) sc)

155+pbinds i (Bind n (PVar t) sc)

140 = do attack; patbind n

156 = do attack; patbind n

141 env <- get_env

157 env <- get_env

142 case unApply (normalise (tt_ctxt i) env t) of

158 case unApply (normalise (tt_ctxt i) env t) of

@@ -191,14 +207,14 @@ getFlexInType i env ps tm@(App _ f a)

191 | (P nt tn _, args) <- unApply tm, nt /= Bound

207 | (P nt tn _, args) <- unApply tm, nt /= Bound

192 = case lookupCtxtExact tn (idris_datatypes i) of

208 = case lookupCtxtExact tn (idris_datatypes i) of

193 Just t -> nub $ paramNames args env [x | x <- [0..length args],

209 Just t -> nub $ paramNames args env [x | x <- [0..length args],

194− not (x `elem` param_pos t)]

210+ not (x `elem` param_pos t)]

195 ++ getFlexInType i env ps f ++

211 ++ getFlexInType i env ps f ++

196 getFlexInType i env ps a

212 getFlexInType i env ps a

197 Nothing -> let ppos = case lookupCtxtExact tn (idris_fninfo i) of

213 Nothing -> let ppos = case lookupCtxtExact tn (idris_fninfo i) of

198 Just fi -> fn_params fi

214 Just fi -> fn_params fi

199 Nothing -> []

215 Nothing -> []

200 in nub $ paramNames args env [x | x <- [0..length args],

216 in nub $ paramNames args env [x | x <- [0..length args],

201− not (x `elem` ppos)]

217+ not (x `elem` ppos)]

202 ++ getFlexInType i env ps f ++

218 ++ getFlexInType i env ps f ++

203 getFlexInType i env ps a

219 getFlexInType i env ps a

204 | otherwise = nub $ getFlexInType i env ps f ++

220 | otherwise = nub $ getFlexInType i env ps f ++

@@ -212,7 +228,7 @@ getParamsInType i env ps t = let fix = getFixedInType i env ps t

212 flex = getFlexInType i env fix t in

228 flex = getFlexInType i env fix t in

213 [x | x <- fix, not (x `elem` flex)]

229 [x | x <- fix, not (x `elem` flex)]

214

230

215−getTCinj i (Bind n (Pi _ t _) sc)

231+getTCinj i (Bind n (Pi _ t _) sc)

216 = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc)

232 = getTCinj i t ++ getTCinj i (instantiate (P Bound n t) sc)

217getTCinj i ap@(App _ f a)

233getTCinj i ap@(App _ f a)

218 | (P _ n _, args) <- unApply ap,

234 | (P _ n _, args) <- unApply ap,

@@ -242,7 +258,7 @@ paramNames args env (p : ps)

242getUniqueUsed :: Context -> Term -> [Name]

258getUniqueUsed :: Context -> Term -> [Name]

243getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []

259getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []

244 where

260 where

245− getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] ()

261+ getUniq :: Env -> [(Name, Bool)] -> Term -> State [Name] ()

246 getUniq env us (Bind n b sc)

262 getUniq env us (Bind n b sc)

247 = let uniq = case check ctxt env (forgetEnv (map fst env) (binderTy b)) of

263 = let uniq = case check ctxt env (forgetEnv (map fst env) (binderTy b)) of

248 OK (_, UType UniqueType) -> True

264 OK (_, UType UniqueType) -> True

@@ -269,9 +285,9 @@ getUniqueUsed ctxt tm = execState (getUniq [] [] tm) []

269-- In a functional application, return the names which are used

285-- In a functional application, return the names which are used

270-- directly in a static position

286-- directly in a static position

271getStaticNames :: IState -> Term -> [Name]

287getStaticNames :: IState -> Term -> [Name]

272−getStaticNames ist (Bind n (PVar _) sc)

288+getStaticNames ist (Bind n (PVar _) sc)

273 = getStaticNames ist (instantiate (P Bound n Erased) sc)

289 = getStaticNames ist (instantiate (P Bound n Erased) sc)

274−getStaticNames ist tm

290+getStaticNames ist tm

275 | (P _ fn _, args) <- unApply tm

291 | (P _ fn _, args) <- unApply tm

276 = case lookupCtxtExact fn (idris_statics ist) of

292 = case lookupCtxtExact fn (idris_statics ist) of

277 Just stpos -> getStatics args stpos

293 Just stpos -> getStatics args stpos

@@ -289,15 +305,12 @@ getStatics ns (Bind n (Pi _ _ _) t)

289getStatics _ _ = []

305getStatics _ _ = []

290

306

291mkStatic :: [Name] -> PDecl -> PDecl

307mkStatic :: [Name] -> PDecl -> PDecl

292−mkStatic ns (PTy doc argdocs syn fc o n nfc ty)

308+mkStatic ns (PTy doc argdocs syn fc o n nfc ty)

293 = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty)

309 = PTy doc argdocs syn fc o n nfc (mkStaticTy ns ty)

294mkStatic ns t = t

310mkStatic ns t = t

295

311

296mkStaticTy :: [Name] -> PTerm -> PTerm

312mkStaticTy :: [Name] -> PTerm -> PTerm

297−mkStaticTy ns (PPi p n fc ty sc)

313+mkStaticTy ns (PPi p n fc ty sc)

298 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

314 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

299 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

315 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

300mkStaticTy ns t = t

316mkStaticTy ns t = t

301−

302−

303−

src/Idris/Elab/Value.hs+5−4

@@ -1,6 +1,6 @@

1{-# LANGUAGE PatternGuards #-}

2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3−module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms,

3+module Idris.Elab.Value(elabVal, elabValBind, elabDocTerms,

4 elabExec, elabREPL) where

5

6import Idris.AbsSyntax

@@ -58,7 +58,7 @@ elabValBind info aspat norm tm_in

58 = do ctxt <- getContext

59 i <- getIState

60 let tm = addImpl [] i tm_in

61− logLvl 10 (showTmImpls tm)

61+ logElab 10 (showTmImpls tm)

62 -- try:

63 -- * ordinary elaboration

64 -- * elaboration as a Type

@@ -80,7 +80,7 @@ elabValBind info aspat norm tm_in

80 addDeferred def''

81 mapM_ (elabCaseBlock info []) is

82

83− logLvl 3 ("Value: " ++ show vtm)

83+ logElab 3 ("Value: " ++ show vtm)

84 (vtm_in, vty) <- recheckC (fileFC "(input)") id [] vtm

85

86 let vtm = if norm then normalise (tt_ctxt i) [] vtm_in

@@ -127,7 +127,8 @@ elabExec fc tm = runtm (PAlternative [] FirstSuccess

127 printtm tm

128 ])

129 where

130− runtm t = PApp fc (PRef fc [] (sUN "run__IO")) [pexp t]

130+ runtm t = PApp fc (PRef fc [] (sUN "run__IO"))

131+ [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]

131 printtm t = PApp fc (PRef fc [] (sUN "printLn"))

132 printtm t = PApp fc (PRef fc [] (sUN "printLn"))

132 [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]

133 [pimp (sUN "ffi") (PRef fc [] (sUN "FFI_C")) False, pexp t]

133

134

src/Idris/ElabDecls.hs+14−14

@@ -159,25 +159,25 @@ elabDecl' _ info (PSyntax _ p)

159 = return () -- nothing to elaborate

160elabDecl' what info (PTy doc argdocs s f o n nfc ty)

161 | what /= EDefns

162− = do logLvl 1 $ "Elaborating type decl " ++ show n ++ show o

162+ = do logElab 1 $ "Elaborating type decl " ++ show n ++ show o

163 elabType info s doc argdocs f o n nfc ty

164 return ()

165elabDecl' what info (PPostulate b doc s f nfc o n ty)

166 | what /= EDefns

167− = do logLvl 1 $ "Elaborating postulate " ++ show n ++ show o

167+ = do logElab 1 $ "Elaborating postulate " ++ show n ++ show o

168− if b

168+ if b

169 then elabExtern info s doc f nfc o n ty

170 else elabPostulate info s doc f nfc o n ty

171elabDecl' what info (PData doc argDocs s f co d)

172 | what /= ETypes

173− = do logLvl 1 $ "Elaborating " ++ show (d_name d)

173+ = do logElab 1 $ "Elaborating " ++ show (d_name d)

174 elabData info s doc argDocs f co d

175 | otherwise

176− = do logLvl 1 $ "Elaborating [type of] " ++ show (d_name d)

176+ = do logElab 1 $ "Elaborating [type of] " ++ show (d_name d)

177 elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_name_fc d) (d_tcon d))

178elabDecl' what info d@(PClauses f o n ps)

179 | what /= ETypes

180− = do logLvl 1 $ "Elaborating clause " ++ show n

180+ = do logElab 1 $ "Elaborating clause " ++ show n

181 i <- getIState -- get the type options too

182 let o' = case lookupCtxt n (idris_flags i) of

183 [fs] -> fs

@@ -191,11 +191,11 @@ elabDecl' what info (PMutual f ps)

191 -- record mutually defined data definitions

192 let datans = concatMap declared (filter isDataDecl ps)

193 mapM_ (setMutData datans) datans

194− logLvl 1 $ "Rechecking for positivity " ++ show datans

194+ logElab 1 $ "Rechecking for positivity " ++ show datans

195 mapM_ (\x -> do setTotality x Unchecked) datans

196 -- Do totality checking after entire mutual block

197 i <- get

198− mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

198+ mapM_ (\n -> do logElab 5 $ "Simplifying " ++ show n

199 ctxt' <- do ctxt <- getContext

200 tclift $ simplifyCasedef n (getErasureInfo i) ctxt

201 setContext ctxt')

@@ -216,7 +216,7 @@ elabDecl' what info (PMutual f ps)

216

217elabDecl' what info (PParams f ns ps)

218 = do i <- getIState

219− logLvl 1 $ "Expanding params block with " ++ show ns ++ " decls " ++

219+ logElab 1 $ "Expanding params block with " ++ show ns ++ " decls " ++

220 show (concatMap tldeclared ps)

221 let nblock = pblock i

222 mapM_ (elabDecl' what info) nblock

@@ -240,17 +240,17 @@ elabDecl' what info (PNamespace n nfc ps) =

240

241elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)

242 | what /= EDefns

243− = do logLvl 1 $ "Elaborating class " ++ show n

243+ = do logElab 1 $ "Elaborating class " ++ show n

244 elabClass info (s { syn_params = [] }) doc f cs n nfc ps pdocs fds ds cn cd

245elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)

246− = do logLvl 1 $ "Elaborating instance " ++ show n

246+ = do logElab 1 $ "Elaborating instance " ++ show n

247 elabInstance info s doc argDocs what f cs n nfc ps t expn ds

248elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)

249− = do logLvl 1 $ "Elaborating record " ++ show name

249+ = do logElab 1 $ "Elaborating record " ++ show name

250 elabRecord info what doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn

251{-

252 | otherwise

253− = do logLvl 1 $ "Elaborating [type of] " ++ show tyn

253+ = do logElab 1 $ "Elaborating [type of] " ++ show tyn

254 elabData info s doc [] f [] (PLaterdecl tyn ty)

255-}

256elabDecl' _ info (PDSL n dsl)

@@ -261,7 +261,7 @@ elabDecl' what info (PDirective i)

261 | what /= EDefns = directiveAction i

262elabDecl' what info (PProvider doc syn fc nfc provWhat n)

263 | what /= EDefns

264− = do logLvl 1 $ "Elaborating type provider " ++ show n

264+ = do logElab 1 $ "Elaborating type provider " ++ show n

265 elabProvider doc info syn fc nfc provWhat n

266elabDecl' what info (PTransform fc safety old new)

267 = do elabTransform info fc safety old new

src/Idris/Erasure.hs+15−18

@@ -85,10 +85,10 @@ performUsageAnalysis startNames = do

85 usage = M.toList minUse

86

87 -- Print some debug info.

88− logLvl 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)

88+ logErasure 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)

89− logLvl 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)

89+ logErasure 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)

90− logLvl 4 $ "Minimal usage:\n" ++ fmtUseMap usage

90+ logErasure 4 $ "Minimal usage:\n" ++ fmtUseMap usage

91− logLvl 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)

91+ logErasure 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)

92

93 -- Check that everything reachable is accessible.

94 checkEnabled <- (WarnReach `elem`) . opt_cmdline . idris_options <$> getIState

@@ -135,7 +135,7 @@ performUsageAnalysis startNames = do

135 where

136 fmt n [] = show n ++ " (no more information available)"

137 fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs]

138− warn = logLvl 0

138+ warn = logErasure 0

139

140-- Find the minimal consistent usage by forward chaining.

141minimalUsage :: Deps -> (Deps, (Set Name, UseMap))

@@ -150,7 +150,7 @@ minimalUsage = second gather . forwardChain

150

151forwardChain :: Deps -> (Deps, DepSet)

152forwardChain deps

153− | Just trivials <- M.lookup S.empty deps

153+ | Just trivials <- M.lookup S.empty deps

154 = (M.unionWith S.union trivials)

155 `second` forwardChain (remove trivials . M.delete S.empty $ deps)

156 | otherwise = (deps, M.empty)

@@ -164,7 +164,7 @@ forwardChain deps

164-- starting the depth-first search from a list of Names.

165buildDepMap :: Ctxt ClassInfo -> [(Name, Int)] -> [(Name, Int)] ->

166 Context -> [Name] -> Deps

167−buildDepMap ci used externs ctx startNames

167+buildDepMap ci used externs ctx startNames

168 = addPostulates used $ dfs S.empty M.empty startNames

169 where

170 -- mark the result of Main.main as used with the empty assumption

@@ -181,7 +181,7 @@ buildDepMap ci used externs ctx startNames

181 usedNames = allNames deps S.\\ specialPrims

182 usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames]

183

184− postulates used =

184+ postulates used =

185 [ [] ==> concat

186 -- Main.main ( + export lists) and run__IO, are always evaluated

187 -- but they elude analysis since they come from the seed term.

@@ -190,7 +190,7 @@ buildDepMap ci used externs ctx startNames

190 ,[(sUN "call__IO", Result), (sUN "call__IO", Arg 2)]

191

192 -- Explicit usage declarations from a %used pragma

193− , map (\(n, i) -> (n, Arg i)) used

193+ , map (\(n, i) -> (n, Arg i)) used

194

195 -- MkIO is read by run__IO,

196 -- but this cannot be observed in the source code of programs.

@@ -200,7 +200,7 @@ buildDepMap ci used externs ctx startNames

200 -- Foreign calls are built with pairs, but mkForeign doesn't

201 -- have an implementation so analysis won't see them

202 , [(pairCon, Arg 2),

203− (pairCon, Arg 3)] -- Used in foreign calls

203+ (pairCon, Arg 3)] -- Used in foreign calls

204

205 -- these have been discovered as builtins but are not listed

206 -- among Idris.Primitives.primitives

@@ -211,7 +211,7 @@ buildDepMap ci used externs ctx startNames

211 -- believe_me is a primitive but it only uses its third argument

212 -- it is special-cased in usedNames above

213 , it "prim__believe_me" [2]

214−

214+

215 -- in general, all other primitives use all their arguments

216 , [(n, Arg i) | (n,arity) <- usedPrims, i <- [0..arity-1]]

217

@@ -324,7 +324,7 @@ buildDepMap ci used externs ctx startNames

324 , viMethod = meth j

325 })

326 | (v, j) <- zip ns [0..]]

327−

327+

328 -- this is safe because it's certainly a patvar

329 varIdx = fromJust (viFunArg var)

330

@@ -414,7 +414,7 @@ buildDepMap ci used externs ctx startNames

414 V i -> snd (bs !! i) cd `union` unconditionalDeps args

415

416 -- we interpret applied lambdas as lets in order to reuse code here

417− Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

417+ Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet app)

418

419 -- and we interpret applied lets as lambdas

420 Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App Complete (Bind n (Lam ty) t) t')

@@ -491,11 +491,8 @@ buildDepMap ci used externs ctx startNames

491

492 -- convert applications of lambdas to lets

493 -- Note that this transformation preserves de bruijn numbering

494− lamToLet :: [Term] -> Term -> Term

494+ lamToLet :: Term -> Term

495− lamToLet xs (App _ f x) = lamToLet (x:xs) f

496− lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)

495+ lamToLet (App _ (Bind n (Lam ty) tm) val) = Bind n (Let ty val) tm

497− lamToLet (x:xs) t = App Complete (lamToLet xs t) x

498− lamToLet [] t = t

499

496

500 -- split "\x_i -> T(x_i)" into [x_i] and T

497 -- split "\x_i -> T(x_i)" into [x_i] and T

501 unfoldLams :: Term -> ([Name], Term)

498 unfoldLams :: Term -> ([Name], Term)

src/Idris/IBC.hs+33−24

@@ -40,7 +40,7 @@ import System.Directory

40import Codec.Archive.Zip

41

42ibcVersion :: Word16

43−ibcVersion = 120

43+ibcVersion = 128

44

45data IBCFile = IBCFile { ver :: Word16,

46 sourcefile :: FilePath,

@@ -80,13 +80,14 @@ data IBCFile = IBCFile { ver :: Word16,

80 ibc_errorhandlers :: ![Name],

81 ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler

82 ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool))],

83− ibc_patdefs :: ![(Name, ([([Name], Term, Term)], [PTerm]))],

83+ ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],

84 ibc_postulates :: ![Name],

85 ibc_externs :: ![(Name, Int)],

86 ibc_parsedSpan :: !(Maybe FC),

87 ibc_usage :: ![(Name, Int)],

88 ibc_exports :: ![Name],

89− ibc_autohints :: ![(Name, Name)]

89+ ibc_autohints :: ![(Name, Name)],

90+ ibc_deprecated :: ![(Name, String)]

90 }

91 }

91 deriving Show

92 deriving Show

92{-!

93{-!

@@ -94,7 +95,7 @@ deriving instance Binary IBCFile

94!-}

95!-}

95

96

96initIBC :: IBCFile

97initIBC :: IBCFile

97−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] []

98+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] []

98

99

99hasValidIBCVersion :: FilePath -> Idris Bool

100hasValidIBCVersion :: FilePath -> Idris Bool

100hasValidIBCVersion fp = do

101hasValidIBCVersion fp = do

@@ -112,7 +113,7 @@ loadIBC reexport fp

112 Nothing -> True

113 Nothing -> True

113 Just p -> not p && reexport

114 Just p -> not p && reexport

114 when redo $

115 when redo $

115− do logLvl 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport

116+ do logIBC 1 $ "Loading ibc " ++ fp ++ " " ++ show reexport

116 archiveFile <- runIO $ B.readFile fp

117 archiveFile <- runIO $ B.readFile fp

117 case toArchiveOrFail archiveFile of

118 case toArchiveOrFail archiveFile of

118 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

119 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

@@ -179,7 +180,8 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

179 toEntry "ibc_parsedSpan" 0 . encode <$> ibc_parsedSpan i,

180 toEntry "ibc_parsedSpan" 0 . encode <$> ibc_parsedSpan i,

180 makeEntry "ibc_usage" (ibc_usage i),

181 makeEntry "ibc_usage" (ibc_usage i),

181 makeEntry "ibc_exports" (ibc_exports i),

182 makeEntry "ibc_exports" (ibc_exports i),

182− makeEntry "ibc_autohints" (ibc_autohints i)]

183+ makeEntry "ibc_autohints" (ibc_autohints i),

184+ makeEntry "ibc_deprecated" (ibc_deprecated i)]

183

185

184writeArchive :: FilePath -> IBCFile -> Idris ()

186writeArchive :: FilePath -> IBCFile -> Idris ()

185writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

187writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

@@ -187,7 +189,7 @@ writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArch

187

189

188writeIBC :: FilePath -> FilePath -> Idris ()

190writeIBC :: FilePath -> FilePath -> Idris ()

189writeIBC src f

191writeIBC src f

190− = do logLvl 1 $ "Writing ibc " ++ show f

192+ = do logIBC 1 $ "Writing ibc " ++ show f

191 i <- getIState

193 i <- getIState

192-- case (Data.List.map fst (idris_metavars i)) \\ primDefs of

194-- case (Data.List.map fst (idris_metavars i)) \\ primDefs of

193-- (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

195-- (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

@@ -196,8 +198,8 @@ writeIBC src f

196 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

198 ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

197 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

199 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

198 writeArchive f ibcf

200 writeArchive f ibcf

199− logLvl 1 "Written")

201+ logIBC 1 "Written")

200− (\c -> do logLvl 1 $ "Failed " ++ pshow i c)

202+ (\c -> do logIBC 1 $ "Failed " ++ pshow i c)

201 return ()

203 return ()

202

204

203-- Write a package index containing all the imports in the current IState

205-- Write a package index containing all the imports in the current IState

@@ -206,20 +208,20 @@ writePkgIndex :: FilePath -> Idris ()

206writePkgIndex f

208writePkgIndex f

207 = do i <- getIState

209 = do i <- getIState

208 let imps = map (\ (x, y) -> (True, x)) $ idris_imported i

210 let imps = map (\ (x, y) -> (True, x)) $ idris_imported i

209− logLvl 1 $ "Writing package index " ++ show f ++ " including\n" ++

211+ logIBC 1 $ "Writing package index " ++ show f ++ " including\n" ++

210 show (map snd imps)

212 show (map snd imps)

211 resetNameIdx

213 resetNameIdx

212 let ibcf = initIBC { ibc_imports = imps }

214 let ibcf = initIBC { ibc_imports = imps }

213 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

215 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

214 writeArchive f ibcf

216 writeArchive f ibcf

215− logLvl 1 "Written")

217+ logIBC 1 "Written")

216− (\c -> do logLvl 1 $ "Failed " ++ pshow i c)

218+ (\c -> do logIBC 1 $ "Failed " ++ pshow i c)

217 return ()

219 return ()

218

220

219mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

221mkIBC :: [IBCWrite] -> IBCFile -> Idris IBCFile

220mkIBC [] f = return f

222mkIBC [] f = return f

221mkIBC (i:is) f = do ist <- getIState

223mkIBC (i:is) f = do ist <- getIState

222− logLvl 5 $ show i ++ " " ++ show (L.length is)

224+ logIBC 5 $ show i ++ " " ++ show (L.length is)

223 f' <- ibc ist i f

225 f' <- ibc ist i f

224 mkIBC is f'

226 mkIBC is f'

225

227

@@ -305,6 +307,7 @@ ibc i (IBCModDocs n) f = case lookupCtxtExact n (idris_moduledocs i) of

305ibc i (IBCUsage n) f = return f { ibc_usage = n : ibc_usage f }

307ibc i (IBCUsage n) f = return f { ibc_usage = n : ibc_usage f }

306ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }

308ibc i (IBCExport n) f = return f { ibc_exports = n : ibc_exports f }

307ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f }

309ibc i (IBCAutoHint n h) f = return f { ibc_autohints = (n, h) : ibc_autohints f }

310+ibc i (IBCDeprecate n r) f = return f { ibc_deprecated = (n, r) : ibc_deprecated f }

308

311

309getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b

312getEntry :: (Binary b, NFData b) => b -> FilePath -> Archive -> Idris b

310getEntry alt f a = case findEntryByPath f a of

313getEntry alt f a = case findEntryByPath f a of

@@ -316,7 +319,7 @@ process :: Bool -- ^ Reexporting

316process reexp i fn = do

319process reexp i fn = do

317 ver <- getEntry 0 "ver" i

320 ver <- getEntry 0 "ver" i

318 when (ver /= ibcVersion) $ do

321 when (ver /= ibcVersion) $ do

319− logLvl 1 "ibc out of date"

322+ logIBC 1 "ibc out of date"

320 let e = if ver < ibcVersion

323 let e = if ver < ibcVersion

321 then " an earlier " else " a later "

324 then " an earlier " else " a later "

322 ifail $ "Incompatible ibc version.\nThis library was built with"

325 ifail $ "Incompatible ibc version.\nThis library was built with"

@@ -367,6 +370,7 @@ process reexp i fn = do

367 pUsage =<< getEntry [] "ibc_usage" i

370 pUsage =<< getEntry [] "ibc_usage" i

368 pExports =<< getEntry [] "ibc_exports" i

371 pExports =<< getEntry [] "ibc_exports" i

369 pAutoHints =<< getEntry [] "ibc_autohints" i

372 pAutoHints =<< getEntry [] "ibc_autohints" i

373+ pDeprecate =<< getEntry [] "ibc_deprecated" i

370

374

371timestampOlder :: FilePath -> FilePath -> Idris ()

375timestampOlder :: FilePath -> FilePath -> Idris ()

372timestampOlder src ibc = do srct <- runIO $ getModificationTime src

376timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -394,6 +398,9 @@ pExports ns = updateIState (\i -> i { idris_exports = ns ++ idris_exports i })

394pAutoHints :: [(Name, Name)] -> Idris ()

398pAutoHints :: [(Name, Name)] -> Idris ()

395pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns

399pAutoHints ns = mapM_ (\(n,h) -> addAutoHint n h) ns

396

400

401+pDeprecate :: [(Name, String)] -> Idris ()

402+pDeprecate ns = mapM_ (\(n,reason) -> addDeprecated n reason) ns

403+

397pImportDirs :: [FilePath] -> Idris ()

404pImportDirs :: [FilePath] -> Idris ()

398pImportDirs fs = mapM_ addImportDir fs

405pImportDirs fs = mapM_ addImportDir fs

399

406

@@ -408,10 +415,12 @@ pImports reexp fs

408-- then logLvl 1 $ "Already read " ++ f

415-- then logLvl 1 $ "Already read " ++ f

409 putIState (i { imported = f : imported i })

416 putIState (i { imported = f : imported i })

410 case fp of

417 case fp of

418+ LIDR fn -> do

411− LIDR fn -> do logLvl 1 $ "Failed at " ++ fn

419+ logIBC 1 $ "Failed at " ++ fn

412− ifail "Must be an ibc"

420+ ifail "Must be an ibc"

421+ IDR fn -> do

413− IDR fn -> do logLvl 1 $ "Failed at " ++ fn

422+ logIBC 1 $ "Failed at " ++ fn

414− ifail "Must be an ibc"

423+ ifail "Must be an ibc"

415 IBC fn src -> loadIBC (reexp && re) fn)

424 IBC fn src -> loadIBC (reexp && re) fn)

416 fs

425 fs

417

426

@@ -498,7 +507,7 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

498pHdrs :: [(Codegen, String)] -> Idris ()

507pHdrs :: [(Codegen, String)] -> Idris ()

499pHdrs hs = mapM_ (uncurry addHdr) hs

508pHdrs hs = mapM_ (uncurry addHdr) hs

500

509

501−pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()

510+pPatdefs :: [(Name, ([([(Name, Term)], Term, Term)], [PTerm]))] -> Idris ()

502pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->

511pPatdefs ds = mapM_ (\ (n, d) -> updateIState (\i ->

503 i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds

512 i { idris_patdefs = addDef n (force d) (idris_patdefs i) })) ds

504

513

@@ -508,13 +517,13 @@ pDefs reexp ds

508 do d' <- updateDef d

517 do d' <- updateDef d

509 case d' of

518 case d' of

510 TyDecl _ _ -> return ()

519 TyDecl _ _ -> return ()

511− _ -> do logLvl 1 $ "SOLVING " ++ show n

520+ _ -> do logIBC 1 $ "SOLVING " ++ show n

512 solveDeferred n

521 solveDeferred n

513 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

522 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

514-- logLvl 1 $ "Added " ++ show (n, d')

523-- logLvl 1 $ "Added " ++ show (n, d')

515− if (not reexp) then do logLvl 1 $ "Not exporting " ++ show n

524+ if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

516 setAccessibility n Hidden

525 setAccessibility n Hidden

517− else logLvl 1 $ "Exporting " ++ show n) ds

526+ else logIBC 1 $ "Exporting " ++ show n) ds

518 where

527 where

519 updateDef (CaseOp c t args o s cd)

528 updateDef (CaseOp c t args o s cd)

520 = do o' <- mapM updateOrig o

529 = do o' <- mapM updateOrig o

@@ -579,7 +588,7 @@ pAccess :: Bool -- ^ Reexporting?

579pAccess reexp ds

588pAccess reexp ds

580 = mapM_ (\ (n, a_in) ->

589 = mapM_ (\ (n, a_in) ->

581 do let a = if reexp then a_in else Hidden

590 do let a = if reexp then a_in else Hidden

582− logLvl 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

591+ logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

583 updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

592 updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

584

593

585pFlags :: [(Name, [FnOpt])] -> Idris ()

594pFlags :: [(Name, [FnOpt])] -> Idris ()

@@ -1836,7 +1845,7 @@ instance Binary PTerm where

1836 _ -> error "Corrupted binary data for PTerm"

1845 _ -> error "Corrupted binary data for PTerm"

1837

1846

1838instance Binary PAltType where

1847instance Binary PAltType where

1839− put x

1848+ put x

1840 = case x of

1849 = case x of

1841 ExactlyOne x1 -> do putWord8 0

1850 ExactlyOne x1 -> do putWord8 0

1842 put x1

1851 put x1

src/Idris/Interactive.hs+34−17

@@ -34,10 +34,10 @@ import Debug.Trace

34caseSplitAt :: FilePath -> Bool -> Int -> Name -> Idris ()

35caseSplitAt fn updatefile l n

36 = do src <- runIO $ readSource fn

37− res <- splitOnLine l n fn

37+ (ok, res) <- splitOnLine l n fn

38 logLvl 1 (showSep "\n" (map show res))

39 let (before, (ap : later)) = splitAt (l-1) (lines src)

40− res' <- replaceSplits ap res

40+ res' <- replaceSplits ap res (not ok)

41 let new = concat res'

42 if updatefile

43 then do let fb = fn ++ "~" -- make a backup!

@@ -47,11 +47,20 @@ caseSplitAt fn updatefile l n

47 iPrintResult new

48

49addClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

50−addClauseFrom fn updatefile l n

50+addClauseFrom fn updatefile l n = do

51+ -- if a definition already exists, add missing cases rather than

52+ -- adding a new definition.

53+ ist <- getIState

54+ cl <- getInternalApp fn l

55+ let fulln = getAppName cl

56+

57+ case lookup fulln (idris_metavars ist) of

58+ Nothing -> addMissing fn updatefile l n

59+ Just _ -> do

51− = do src <- runIO $ readSource fn

60+ src <- runIO $ readSource fn

52 let (before, tyline : later) = splitAt (l-1) (lines src)

61 let (before, tyline : later) = splitAt (l-1) (lines src)

53 let indent = getIndent 0 (show n) tyline

62 let indent = getIndent 0 (show n) tyline

54− cl <- getClause l n fn

63+ cl <- getClause l fulln n fn

55 -- add clause before first blank line in 'later'

64 -- add clause before first blank line in 'later'

56 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

65 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

57 if updatefile

66 if updatefile

@@ -62,11 +71,16 @@ addClauseFrom fn updatefile l n

62 unlines rest)

71 unlines rest)

63 runIO $ copyFile fb fn

72 runIO $ copyFile fb fn

64 else iPrintResult cl

73 else iPrintResult cl

65− where

74+ where

66− getIndent i n [] = 0

75+ getIndent i n [] = 0

67− getIndent i n xs | take 9 xs == "instance " = i

76+ getIndent i n xs | take 9 xs == "instance " = i

68− getIndent i n xs | take (length n) xs == n = i

77+ getIndent i n xs | take (length n) xs == n = i

69− getIndent i n (x : xs) = getIndent (i + 1) n xs

78+ getIndent i n (x : xs) = getIndent (i + 1) n xs

79+

80+ getAppName (PApp _ r _) = getAppName r

81+ getAppName (PRef _ _ r) = r

82+ getAppName (PTyped n _) = getAppName n

83+ getAppName _ = n

70

84

71addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

85addProofClauseFrom :: FilePath -> Bool -> Int -> Name -> Idris ()

72addProofClauseFrom fn updatefile l n

86addProofClauseFrom fn updatefile l n

@@ -98,16 +112,17 @@ addMissing fn updatefile l n

98 cl <- getInternalApp fn l

112 cl <- getInternalApp fn l

99 let n' = getAppName cl

113 let n' = getAppName cl

100

114

101− extras <- case lookupCtxt n' (idris_patdefs i) of

115+ extras <- case lookupCtxtExact n' (idris_patdefs i) of

102− [] -> return ""

116+ Nothing -> return ""

103− [(_, tms)] -> do tms' <- nameMissing tms

117+ Just (_, tms) -> do tms' <- nameMissing tms

104− showNew (show n ++ "_rhs") 1 indent tms'

118+ showNew (show n ++ "_rhs") 1 indent tms'

105− other -> return "" -- happens if called on a metavar, or with no clauses

106 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

119 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

107 if updatefile

120 if updatefile

108 then do let fb = fn ++ "~"

121 then do let fb = fn ++ "~"

109 runIO $ writeSource fb (unlines (before ++ nonblank)

122 runIO $ writeSource fb (unlines (before ++ nonblank)

123+ ++ extras ++

124+ (if null extras then ""

110− ++ extras ++ unlines rest)

125+ else "\n" ++ unlines rest))

111 runIO $ copyFile fb fn

126 runIO $ copyFile fb fn

112 else iPrintResult extras

127 else iPrintResult extras

113 where showPat = show . stripNS

128 where showPat = show . stripNS

@@ -121,6 +136,7 @@ addMissing fn updatefile l n

121

136

122 getAppName (PApp _ r _) = getAppName r

137 getAppName (PApp _ r _) = getAppName r

123 getAppName (PRef _ _ r) = r

138 getAppName (PRef _ _ r) = r

139+ getAppName (PTyped n _) = getAppName n

124 getAppName _ = n

140 getAppName _ = n

125

141

126 makeIndent ind | ".lidr" `isSuffixOf` fn = '>' : ' ' : replicate (ind-2) ' '

142 makeIndent ind | ".lidr" `isSuffixOf` fn = '>' : ' ' : replicate (ind-2) ' '

@@ -131,7 +147,8 @@ addMissing fn updatefile l n

131 rest <- showNew nm i' ind tms

147 rest <- showNew nm i' ind tms

132 return (makeIndent ind ++

148 return (makeIndent ind ++

133 showPat tm ++ " = ?" ++ nm' ++

149 showPat tm ++ " = ?" ++ nm' ++

150+ (if null rest then "" else

134− "\n" ++ rest)

151+ "\n" ++ rest))

135 showNew nm i _ [] = return ""

152 showNew nm i _ [] = return ""

136

153

137 getIndent i n [] = 0

154 getIndent i n [] = 0

src/Idris/ParseExpr.hs+3−3

@@ -1084,10 +1084,10 @@ normalImplicit opts st syn = do

1084 sc <- expr syn

1085 let (im,cl)

1086 = if implicitAllowed syn

1087− then (Imp opts st False Nothing,

1087+ then (Imp opts st False (Just (Impl False True)),

1088 constraint)

1089− else (Imp opts st False (Just (Impl False)),

1089+ else (Imp opts st False (Just (Impl False False)),

1090− Imp opts st False (Just (Impl True)))

1090+ Imp opts st False (Just (Impl True False)))

1091 return (bindList (PPi im) xt

1092 (bindList (PPi cl) cs sc))

1093

src/Idris/Parser.hs+44−24

@@ -153,7 +153,7 @@ import_ = do fc <- getFC

153prog :: SyntaxInfo -> IdrisParser [PDecl]

154prog syn = do whiteSpace

155 decls <- many (decl syn)

156− let c = (concat decls)

156+ let c = concat decls

157 case maxline syn of

158 Nothing -> do notOpenBraces; eof

159 _ -> return ()

@@ -189,19 +189,29 @@ decl syn = try (externalDecl syn)

189 <?> "declaration"

190

191internalDecl :: SyntaxInfo -> IdrisParser [PDecl]

192−internalDecl syn

192+internalDecl syn

193 = do fc <- getFC

194− -- if we're after maxline, stop here

194+ -- if we're after maxline, stop at the next type declaration

195+ -- (so we get all cases of a definition to preserve totality

196+ -- results, in particular).

195 let continue = case maxline syn of

197 let continue = case maxline syn of

196 Nothing -> True

198 Nothing -> True

197 Just l -> if fst (fc_end fc) > l

199 Just l -> if fst (fc_end fc) > l

198 then mut_nesting syn /= 0

200 then mut_nesting syn /= 0

199 else True

201 else True

202+ -- What I'd really like to do here is explicitly save the

203+ -- current state, then if reading ahead finds we've passed

204+ -- the end of the definition, reset the state. But I've lost

205+ -- patience with trying to find out how to do that from the

206+ -- trifecta docs, so this does the job instead.

207+ if continue then

200− if continue then do notEndBlock

208+ do notEndBlock

201− declBody

209+ declBody continue

210+ else try (do notEndBlock

211+ declBody continue)

202− else fail "End of readable input"

212+ <|> fail "End of readable input"

203− where declBody :: IdrisParser [PDecl]

213+ where declBody :: Bool -> IdrisParser [PDecl]

204− declBody = declBody'

214+ declBody b = declBody' b

205 <|> using_ syn

215 <|> using_ syn

206 <|> params syn

216 <|> params syn

207 <|> mutual syn

217 <|> mutual syn

@@ -214,11 +224,17 @@ internalDecl syn

214 <|> transform syn

224 <|> transform syn

215 <|> do import_; fail "imports must be at top of file"

225 <|> do import_; fail "imports must be at top of file"

216 <?> "declaration"

226 <?> "declaration"

217− declBody' :: IdrisParser [PDecl]

227+ declBody' :: Bool -> IdrisParser [PDecl]

218− declBody' = do d <- decl' syn

228+ declBody' cont = do d <- decl' syn

219− i <- get

229+ i <- get

220− let d' = fmap (debindApp syn . (desugar syn i)) d

230+ let d' = fmap (debindApp syn . (desugar syn i)) d

231+ if continue cont d'

221− return [d']

232+ then return [d']

233+ else fail "End of readable input"

234+

235+ -- Keep going while we're still parsing clauses

236+ continue False (PClauses _ _ _ _) = True

237+ continue c _ = c

222

238

223{- | Parses a top-level declaration with possible syntax sugar

239{- | Parses a top-level declaration with possible syntax sugar

224

240

@@ -267,7 +283,7 @@ declExtensions syn rules = declExtension syn [] (filter isDeclRule rules)

267 isDeclRule (DeclRule _ _) = True

283 isDeclRule (DeclRule _ _) = True

268 isDeclRule _ = False

284 isDeclRule _ = False

269

285

270−declExtension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax]

286+declExtension :: SyntaxInfo -> [Maybe (Name, SynMatch)] -> [Syntax]

271 -> IdrisParser [PDecl]

287 -> IdrisParser [PDecl]

272declExtension syn ns rules =

288declExtension syn ns rules =

273 choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->

289 choice $ flip map (groupBy (ruleGroup `on` syntaxSymbols) rules) $ \rs ->

@@ -302,7 +318,7 @@ declExtension syn ns rules =

302 updateNs :: [(Name, SynMatch)] -> PDecl -> PDecl

318 updateNs :: [(Name, SynMatch)] -> PDecl -> PDecl

303 updateNs ns (PTy doc argdoc s fc o n fc' t)

319 updateNs ns (PTy doc argdoc s fc o n fc' t)

304 = PTy doc argdoc s fc o (updateB ns n) fc' t

320 = PTy doc argdoc s fc o (updateB ns n) fc' t

305− updateNs ns (PClauses fc o n cs)

321+ updateNs ns (PClauses fc o n cs)

306 = PClauses fc o (updateB ns n) (map (updateClause ns) cs)

322 = PClauses fc o (updateB ns n) (map (updateClause ns) cs)

307 updateNs ns (PCAF fc n t) = PCAF fc (updateB ns n) t

323 updateNs ns (PCAF fc n t) = PCAF fc (updateB ns n) t

308 updateNs ns (PData ds cds s fc o dat)

324 updateNs ns (PData ds cds s fc o dat)

@@ -322,10 +338,10 @@ declExtension syn ns rules =

322 cdocs

338 cdocs

323 updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)

339 updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)

324 = PInstance docs pdocs s fc cs (updateB ns cn) fc'

340 = PInstance docs pdocs s fc cs (updateB ns cn) fc'

325− ps ity (fmap (updateB ns) ni)

341+ ps ity (fmap (updateB ns) ni)

326 (map (updateNs ns) ds)

342 (map (updateNs ns) ds)

327 updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)

343 updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)

328− updateNs ns (PProvider docs s fc fc' pw n)

344+ updateNs ns (PProvider docs s fc fc' pw n)

329 = PProvider docs s fc fc' pw (updateB ns n)

345 = PProvider docs s fc fc' pw (updateB ns n)

330 updateNs ns d = d

346 updateNs ns d = d

331

347

@@ -466,7 +482,7 @@ syntaxRule syn

466 where ts = dropWhile isSpace . dropWhileEnd isSpace $ s

482 where ts = dropWhile isSpace . dropWhileEnd isSpace $ s

467 mkSimple' (e : es) = e : mkSimple' es

483 mkSimple' (e : es) = e : mkSimple' es

468 mkSimple' [] = []

484 mkSimple' [] = []

469−

485+

470 -- Prevent syntax variable capture by making all binders under syntax unique

486 -- Prevent syntax variable capture by making all binders under syntax unique

471 -- (the ol' Common Lisp GENSYM approach)

487 -- (the ol' Common Lisp GENSYM approach)

472 uniquifyBinders :: [Name] -> PTerm -> IdrisParser PTerm

488 uniquifyBinders :: [Name] -> PTerm -> IdrisParser PTerm

@@ -1307,6 +1323,10 @@ directive syn = do try (lchar '%' *> reserved "lib")

1307 return [PDirective (DErrorHandlers fn nfc arg afc ns) ]

1323 return [PDirective (DErrorHandlers fn nfc arg afc ns) ]

1308 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1324 <|> do try (lchar '%' *> reserved "language"); ext <- pLangExt;

1309 return [PDirective (DLanguage ext)]

1325 return [PDirective (DLanguage ext)]

1326+ <|> do try (lchar '%' *> reserved "deprecate")

1327+ n <- fst <$> fnName

1328+ alt <- option "" (fst <$> stringLiteral)

1329+ return [PDirective (DDeprecate n alt)]

1310 <|> do fc <- getFC

1330 <|> do fc <- getFC

1311 try (lchar '%' *> reserved "used")

1331 try (lchar '%' *> reserved "used")

1312 fn <- fst <$> fnName

1332 fn <- fst <$> fnName

@@ -1532,7 +1552,7 @@ loadModule' f

1532 ids <- allImportDirs

1552 ids <- allImportDirs

1533 fp <- findImport ids ibcsd file

1553 fp <- findImport ids ibcsd file

1534 if file `elem` imported i

1554 if file `elem` imported i

1535− then do logLvl 1 $ "Already read " ++ file

1555+ then do logParser 1 $ "Already read " ++ file

1536 return Nothing

1556 return Nothing

1537 else do putIState (i { imported = file : imported i })

1557 else do putIState (i { imported = file : imported i })

1538 case fp of

1558 case fp of

@@ -1540,7 +1560,7 @@ loadModule' f

1540 LIDR fn -> loadSource True fn Nothing

1560 LIDR fn -> loadSource True fn Nothing

1541 IBC fn src ->

1561 IBC fn src ->

1542 idrisCatch (loadIBC True fn)

1562 idrisCatch (loadIBC True fn)

1543− (\c -> do logLvl 1 $ fn ++ " failed " ++ pshow i c

1563+ (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

1544 case src of

1564 case src of

1545 IDR sfn -> loadSource False sfn Nothing

1565 IDR sfn -> loadSource False sfn Nothing

1546 LIDR sfn -> loadSource True sfn Nothing)

1566 LIDR sfn -> loadSource True sfn Nothing)

@@ -1549,7 +1569,7 @@ loadModule' f

1549{- | Load idris code from file -}

1569{- | Load idris code from file -}

1550loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1570loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1551loadFromIFile reexp i@(IBC fn src) maxline

1571loadFromIFile reexp i@(IBC fn src) maxline

1552− = do logLvl 1 $ "Skipping " ++ getSrcFile i

1572+ = do logParser 1 $ "Skipping " ++ getSrcFile i

1553 idrisCatch (loadIBC reexp fn)

1573 idrisCatch (loadIBC reexp fn)

1554 (\err -> ierror $ LoadingFailed fn err)

1574 (\err -> ierror $ LoadingFailed fn err)

1555 where

1575 where

@@ -1573,7 +1593,7 @@ loadSource' lidr r maxline

1573{- | Load Idris source code-}

1593{- | Load Idris source code-}

1574loadSource :: Bool -> FilePath -> Maybe Int -> Idris ()

1594loadSource :: Bool -> FilePath -> Maybe Int -> Idris ()

1575loadSource lidr f toline

1595loadSource lidr f toline

1576− = do logLvl 1 ("Reading " ++ f)

1596+ = do logParser 1 ("Reading " ++ f)

1577 i <- getIState

1597 i <- getIState

1578 let def_total = default_total i

1598 let def_total = default_total i

1579 file_in <- runIO $ readSource f

1599 file_in <- runIO $ readSource f

@@ -1617,7 +1637,7 @@ loadSource lidr f toline

1617 ]

1637 ]

1618 histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames

1638 histogram = groupBy ((==) `on` fst) . sortBy (comparing fst) $ aliasNames

1619 case map head . filter ((/= 1) . length) $ histogram of

1639 case map head . filter ((/= 1) . length) $ histogram of

1620− [] -> logLvl 3 $ "Module aliases: " ++ show (M.toList modAliases)

1640+ [] -> logParser 3 $ "Module aliases: " ++ show (M.toList modAliases)

1621 (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n

1641 (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n

1622

1642

1623 i <- getIState

1643 i <- getIState

@@ -1656,7 +1676,7 @@ loadSource lidr f toline

1656 -- Parsing done, now process declarations

1676 -- Parsing done, now process declarations

1657

1677

1658 let ds = namespaces mname ds'

1678 let ds = namespaces mname ds'

1659− logLvl 3 (show $ showDecls verbosePPOption ds)

1679+ logParser 3 (show $ showDecls verbosePPOption ds)

1660 i <- getIState

1680 i <- getIState

1661 logLvl 10 (show (toAlist (idris_implicits i)))

1681 logLvl 10 (show (toAlist (idris_implicits i)))

1662 logLvl 3 (show (idris_infixes i))

1682 logLvl 3 (show (idris_infixes i))

src/Idris/ProofSearch.hs+16−9

@@ -178,7 +178,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

178 cantsolve (CantSolveGoal _ _) = True

179 cantsolve (IncompleteTerm _) = True

180 cantsolve (At _ e) = cantsolve e

181− cantsolve (Elaborating _ _ e) = cantsolve e

181+ cantsolve (Elaborating _ _ _ e) = cantsolve e

182 cantsolve (ElaboratingArg _ _ _ e) = cantsolve e

183 cantsolve err = False

184

@@ -196,7 +196,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

196 Nothing -> -- local variable, go for it

197 return True

198 TType _ -> return True

199− _ -> fail "Not a data type"

199+ _ -> typeNotSearchable ty

200

201 conReady :: [Term] -> Name -> ElabD Bool

202 conReady as n

@@ -282,8 +282,8 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

282 -- since that's part of the point...)

283 $ checkConstructor ist others

284 tryCons d locs tys (others ++ getFn d fn)

285− Nothing -> fail "Not a data type"

285+ Nothing -> typeNotSearchable t

286− _ -> fail "Not a data type"

286+ _ -> typeNotSearchable t

287

288 -- if there are local variables which have a function type, try

289 -- applying them too

@@ -326,11 +326,20 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

326 let newhs = filter (\ (x, y) -> not x) (zip (map fst imps) args)

327 mapM_ (\ (_, h) -> do focus h

328 aty <- goal

329− psRec True d locs tys) newhs

329+ psRec True d locs tys) newhs

330 solve

331

332 isImp (PImp p _ _ _ _) = (True, p)

333− isImp arg = (False, priority arg)

333+ isImp arg = (False, priority arg)

334+

335+ typeNotSearchable ty =

336+ lift $ tfail $ FancyMsg $

337+ [TextPart "Attempted to find an element of type",

338+ TermPart ty,

339+ TextPart "using proof search, but proof search only works on datatypes with constructors."] ++

340+ case ty of

341+ (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

342+ _ -> []

334

343

335-- In interactive mode, only search for things if there is some

344-- In interactive mode, only search for things if there is some

336-- index to help pick a relevant constructor

345-- index to help pick a relevant constructor

@@ -453,9 +462,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

453 boundVar (P Bound _ _) = True

462 boundVar (P Bound _ _) = True

454 boundVar _ = False

463 boundVar _ = False

455

464

456− blunderbuss t d stk [] = do -- c <- get_env

457− -- ps <- get_probs

458− lift $ tfail $ CantResolve False topg

465+ blunderbuss t d stk [] = lift $ tfail $ CantResolve False topg

459 blunderbuss t d stk (n:ns)

466 blunderbuss t d stk (n:ns)

460 | n /= fn -- && (n `elem` stk)

467 | n /= fn -- && (n `elem` stk)

461 = tryCatch (resolve n d)

468 = tryCatch (resolve n d)

src/Idris/REPL.hs+65−42

@@ -189,11 +189,13 @@ processNetCmd orig i h fn cmd

189 where

190 processNet fn Reload = processNet fn (Load fn Nothing)

191 processNet fn (Load f toline) =

192+ -- The $!! here prevents a space leak on reloading.

193+ -- This isn't a solution - but it's a temporary stopgap.

194+ -- See issue #2386

192− do let ist = orig { idris_options = idris_options i

195+ do putIState $!! orig { idris_options = idris_options i

193− , idris_colourTheme = idris_colourTheme i

196+ , idris_colourTheme = idris_colourTheme i

194− , idris_colourRepl = False

197+ , idris_colourRepl = False

195− }

198+ }

196− putIState ist

197 setErrContext True

199 setErrContext True

198 setOutH h

200 setOutH h

199 setQuiet True

201 setQuiet True

@@ -755,6 +757,9 @@ edit f orig

755 let args = line ++ [fixName f]

757 let args = line ++ [fixName f]

756 runIO $ rawSystem editor args

758 runIO $ rawSystem editor args

757 clearErr

759 clearErr

760+ -- The $!! here prevents a space leak on reloading.

761+ -- This isn't a solution - but it's a temporary stopgap.

762+ -- See issue #2386

758 putIState $!! orig { idris_options = idris_options i

763 putIState $!! orig { idris_options = idris_options i

759 , idris_colourTheme = idris_colourTheme i

764 , idris_colourTheme = idris_colourTheme i

760 }

765 }

@@ -796,25 +801,30 @@ process fn (ModImport f) = do fmod <- loadModule f

796 Nothing -> iPrintError $ "Can't find import " ++ f

801 Nothing -> iPrintError $ "Can't find import " ++ f

797process fn (Eval t)

802process fn (Eval t)

798 = withErrorReflection $

803 = withErrorReflection $

799− do logLvl 5 $ show t

804+ do logParser 5 $ show t

800 getIState >>= flip warnDisamb t

805 getIState >>= flip warnDisamb t

801 (tm, ty) <- elabREPL recinfo ERHS t

806 (tm, ty) <- elabREPL recinfo ERHS t

802 ctxt <- getContext

807 ctxt <- getContext

803− let tm' = perhapsForce $ normaliseAll ctxt [] tm

808+ let tm' = perhapsForce $ normaliseBlocking ctxt []

809+ [sUN "foreign",

810+ sUN "prim_read",

811+ sUN "prim_write"]

812+ tm

804 let ty' = perhapsForce $ normaliseAll ctxt [] ty

813 let ty' = perhapsForce $ normaliseAll ctxt [] ty

805 -- Add value to context, call it "it"

814 -- Add value to context, call it "it"

806 updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

815 updateContext (addCtxtDef (sUN "it") (Function ty' tm'))

807 ist <- getIState

816 ist <- getIState

808− logLvl 3 $ "Raw: " ++ show (tm', ty')

817+ logParser 3 $ "Raw: " ++ show (tm', ty')

809− logLvl 10 $ "Debug: " ++ showEnvDbg [] tm'

818+ logParser 10 $ "Debug: " ++ showEnvDbg [] tm'

810 let tmDoc = pprintDelab ist tm'

819 let tmDoc = pprintDelab ist tm'

820+ -- errReverse to make type more readable

811− tyDoc = pprintDelab ist ty'

821+ tyDoc = pprintDelab ist (errReverse ist ty')

812 iPrintTermWithType tmDoc tyDoc

822 iPrintTermWithType tmDoc tyDoc

813 where perhapsForce tm | termSmallerThan 100 tm = force tm

823 where perhapsForce tm | termSmallerThan 100 tm = force tm

814 | otherwise = tm

824 | otherwise = tm

815

825

816process fn (NewDefn decls) = do

826process fn (NewDefn decls) = do

817− logLvl 3 ("Defining names using these decls: " ++ show (showDecls verbosePPOption decls))

827+ logParser 3 ("Defining names using these decls: " ++ show (showDecls verbosePPOption decls))

818 mapM_ defineName namedGroups where

828 mapM_ defineName namedGroups where

819 namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls

829 namedGroups = groupBy (\d1 d2 -> getName d1 == getName d2) decls

820 getName :: PDecl -> Maybe Name

830 getName :: PDecl -> Maybe Name

@@ -933,16 +943,19 @@ process fn (Check (PRef _ _ n))

933 where

943 where

934 showMetavarInfo ppo ist n i

944 showMetavarInfo ppo ist n i

935 = case lookupTy n (tt_ctxt ist) of

945 = case lookupTy n (tt_ctxt ist) of

946+ (ty:_) -> let ty' = normaliseC (tt_ctxt ist) [] ty in

936− (ty:_) -> putTy ppo ist i [] (delab ist (errReverse ist ty))

947+ putTy ppo ist i [] (delab ist (errReverse ist ty'))

937 putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

948 putTy :: PPOption -> IState -> Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

938 putTy ppo ist 0 bnd sc = putGoal ppo ist bnd sc

949 putTy ppo ist 0 bnd sc = putGoal ppo ist bnd sc

939 putTy ppo ist i bnd (PPi _ n _ t sc)

950 putTy ppo ist i bnd (PPi _ n _ t sc)

940− = let current = text " " <>

951+ = let current = case n of

941− (case n of

942− MN _ _ -> text "_"

952+ MN _ _ -> text ""

943− UN nm | ('_':'_':_) <- str nm -> text "_"

953+ UN nm | ('_':'_':_) <- str nm -> text ""

954+ _ -> text " " <>

944− _ -> bindingOf n False) <+>

955+ bindingOf n False

956+ <+> colon

945− colon <+> align (tPretty bnd ist t) <> line

957+ <+> align (tPretty bnd ist t)

958+ <> line

946 in

959 in

947 current <> putTy ppo ist (i-1) ((n,False):bnd) sc

960 current <> putTy ppo ist (i-1) ((n,False):bnd) sc

948 putTy ppo ist _ bnd sc = putGoal ppo ist ((n,False):bnd) sc

961 putTy ppo ist _ bnd sc = putGoal ppo ist ((n,False):bnd) sc

@@ -973,8 +986,8 @@ process fn (Core t)

973 iPrintTermWithType (pprintTT [] tm) (pprintTT [] ty)

986 iPrintTermWithType (pprintTT [] tm) (pprintTT [] ty)

974

987

975process fn (DocStr (Left n) w)

988process fn (DocStr (Left n) w)

976− | UN ty <- n, ty == T.pack "Type" = getIState >>= iRenderResult . pprintTypeDoc

989+ | UN ty <- n, ty == T.pack "Type" = getIState >>= iRenderResult . pprintTypeDoc

977− | otherwise = do

990+ | otherwise = do

978 ist <- getIState

991 ist <- getIState

979 let docs = lookupCtxtName n (idris_docstrings ist) ++

992 let docs = lookupCtxtName n (idris_docstrings ist) ++

980 map (\(n,d)-> (n, (d, [])))

993 map (\(n,d)-> (n, (d, [])))

@@ -997,7 +1010,7 @@ process fn (DocStr (Right c) _) -- constants only have overviews

997process fn Universes

1010process fn Universes

998 = do i <- getIState

1011 = do i <- getIState

999 let cs = idris_constraints i

1012 let cs = idris_constraints i

1000− let cslist = S.toAscList cs

1013+ let cslist = S.toAscList cs

1001-- iputStrLn $ showSep "\n" (map show cs)

1014-- iputStrLn $ showSep "\n" (map show cs)

1002 iputStrLn $ show (map uconstraint cslist)

1015 iputStrLn $ show (map uconstraint cslist)

1003 let n = length cslist

1016 let n = length cslist

@@ -1052,6 +1065,8 @@ process fn (DebugInfo n)

1052 when (not (null si)) $ iputStrLn (show si)

1065 when (not (null si)) $ iputStrLn (show si)

1053 let di = lookupCtxt n (idris_datatypes i)

1066 let di = lookupCtxt n (idris_datatypes i)

1054 when (not (null di)) $ iputStrLn (show di)

1067 when (not (null di)) $ iputStrLn (show di)

1068+ let imps = lookupCtxt n (idris_implicits i)

1069+ when (not (null imps)) $ iputStrLn (show imps)

1055 let d = lookupDef n (tt_ctxt i)

1070 let d = lookupDef n (tt_ctxt i)

1056 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1071 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1057 let cg = lookupCtxtName n (idris_callgraph i)

1072 let cg = lookupCtxtName n (idris_callgraph i)

@@ -1182,7 +1197,7 @@ process fn (Execute tm)

1182 = idrisCatch

1197 = idrisCatch

1183 (do ist <- getIState

1198 (do ist <- getIState

1184 (m, _) <- elabVal recinfo ERHS (elabExec fc tm)

1199 (m, _) <- elabVal recinfo ERHS (elabExec fc tm)

1185− (tmpn, tmph) <- runIO tempfile

1200+ (tmpn, tmph) <- runIO $ tempfile ""

1186 runIO $ hClose tmph

1201 runIO $ hClose tmph

1187 t <- codegen

1202 t <- codegen

1188 -- gcc adds .exe when it builds windows programs

1203 -- gcc adds .exe when it builds windows programs

@@ -1211,6 +1226,7 @@ process fn (Compile codegen f)

1211 runIO $ generate codegen (fst (head (idris_imported i))) ir

1226 runIO $ generate codegen (fst (head (idris_imported i))) ir

1212 where fc = fileFC "main"

1227 where fc = fileFC "main"

1213process fn (LogLvl i) = setLogLevel i

1228process fn (LogLvl i) = setLogLevel i

1229+process fn (LogCategory cs) = setLogCats cs

1214-- Elaborate as if LHS of a pattern (debug command)

1230-- Elaborate as if LHS of a pattern (debug command)

1215process fn (Pattelab t)

1231process fn (Pattelab t)

1216 = do (tm, ty) <- elabVal recinfo ELHS t

1232 = do (tm, ty) <- elabVal recinfo ELHS t

@@ -1218,12 +1234,16 @@ process fn (Pattelab t)

1218

1234

1219process fn (Missing n)

1235process fn (Missing n)

1220 = do i <- getIState

1236 = do i <- getIState

1221− let i' = i { idris_options = (idris_options i) { opt_showimp = True } }

1237+ ppOpts <- fmap ppOptionIst getIState

1222 case lookupCtxt n (idris_patdefs i) of

1238 case lookupCtxt n (idris_patdefs i) of

1223− [] -> iPrintError $ "Unknown operator " ++ show n

1239+ [] -> iPrintError $ "Unknown name " ++ show n

1224− [(_, tms)] ->

1240+ [(_, tms)] ->

1225− iPrintResult (showSep "\n" (map (showTm i') tms))

1241+ iRenderResult (vsep (map (pprintPTerm ppOpts {ppopt_impl = True}

1242+ []

1243+ []

1244+ (idris_infixes i))

1245+ tms))

1226− _ -> iPrintError $ "Ambiguous name"

1246+ _ -> iPrintError $ "Ambiguous name"

1227process fn (DynamicLink l)

1247process fn (DynamicLink l)

1228 = do i <- getIState

1248 = do i <- getIState

1229 let importdirs = opt_importdirs (idris_options i)

1249 let importdirs = opt_importdirs (idris_options i)

@@ -1233,7 +1253,7 @@ process fn (DynamicLink l)

1233 Nothing -> iPrintError $ "Could not load dynamic lib \"" ++ l ++ "\""

1253 Nothing -> iPrintError $ "Could not load dynamic lib \"" ++ l ++ "\""

1234 Just x -> do let libs = idris_dynamic_libs i

1254 Just x -> do let libs = idris_dynamic_libs i

1235 if x `elem` libs

1255 if x `elem` libs

1236− then do logLvl 1 ("Tried to load duplicate library " ++ lib_name x)

1256+ then do logParser 1 ("Tried to load duplicate library " ++ lib_name x)

1237 return ()

1257 return ()

1238 else putIState $ i { idris_dynamic_libs = x:libs }

1258 else putIState $ i { idris_dynamic_libs = x:libs }

1239 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

1259 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

@@ -1431,11 +1451,11 @@ pprintDef n =

1431 return $ map (ppDef ambiguous ist) (lookupCtxtName n patdefs) ++

1451 return $ map (ppDef ambiguous ist) (lookupCtxtName n patdefs) ++

1432 map (ppTy ambiguous ist) (lookupCtxtName n tyinfo) ++

1452 map (ppTy ambiguous ist) (lookupCtxtName n tyinfo) ++

1433 map (ppCon ambiguous ist) (filter (flip isDConName ctxt) (lookupNames n ctxt))

1453 map (ppCon ambiguous ist) (filter (flip isDConName ctxt) (lookupNames n ctxt))

1434− where ppDef :: Bool -> IState -> (Name, ([([Name], Term, Term)], [PTerm])) -> Doc OutputAnnotation

1454+ where ppDef :: Bool -> IState -> (Name, ([([(Name, Term)], Term, Term)], [PTerm])) -> Doc OutputAnnotation

1435 ppDef amb ist (n, (clauses, missing)) =

1455 ppDef amb ist (n, (clauses, missing)) =

1436 prettyName True amb [] n <+> colon <+>

1456 prettyName True amb [] n <+> colon <+>

1437 align (pprintDelabTy ist n) <$>

1457 align (pprintDelabTy ist n) <$>

1438− ppClauses ist clauses <> ppMissing missing

1458+ ppClauses ist (map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) clauses) <> ppMissing missing

1439 ppClauses ist [] = text "No clauses."

1459 ppClauses ist [] = text "No clauses."

1440 ppClauses ist cs = vsep (map pp cs)

1460 ppClauses ist cs = vsep (map pp cs)

1441 where pp (vars, lhs, rhs) =

1461 where pp (vars, lhs, rhs) =

@@ -1502,15 +1522,20 @@ loadInputs inputs toline -- furthest line to read in input source files

1502 -- For each ifile list, check it and build ibcs in the same clean IState

1522 -- For each ifile list, check it and build ibcs in the same clean IState

1503 -- so that they don't interfere with each other when checking

1523 -- so that they don't interfere with each other when checking

1504

1524

1525+ importlists <- getImports [] inputs

1526+

1527+ logParser 1 (show (map (\(i,m) -> (i, map import_path m)) importlists))

1528+

1505 let ninputs = zip [1..] inputs

1529 let ninputs = zip [1..] inputs

1506 ifiles <- mapWhileOK (\(num, input) ->

1530 ifiles <- mapWhileOK (\(num, input) ->

1507 do putIState ist

1531 do putIState ist

1508 modTree <- buildTree

1532 modTree <- buildTree

1509 (map snd (take (num-1) ninputs))

1533 (map snd (take (num-1) ninputs))

1534+ importlists

1510 input

1535 input

1511 let ifiles = getModuleFiles modTree

1536 let ifiles = getModuleFiles modTree

1512− logLvl 1 ("MODULE TREE : " ++ show modTree)

1537+ logParser 1 ("MODULE TREE : " ++ show modTree)

1513− logLvl 1 ("RELOAD: " ++ show ifiles)

1538+ logParser 1 ("RELOAD: " ++ show ifiles)

1514 when (not (all ibc ifiles) || loadCode) $

1539 when (not (all ibc ifiles) || loadCode) $

1515 tryLoad False (filter (not . ibc) ifiles)

1540 tryLoad False (filter (not . ibc) ifiles)

1516 -- return the files that need rechecking

1541 -- return the files that need rechecking

@@ -1518,7 +1543,6 @@ loadInputs inputs toline -- furthest line to read in input source files

1518 ninputs

1543 ninputs

1519 inew <- getIState

1544 inew <- getIState

1520 let tidata = idris_tyinfodata inew

1545 let tidata = idris_tyinfodata inew

1521− let patdefs = idris_patdefs inew

1522 -- If it worked, load the whole thing from all the ibcs together

1546 -- If it worked, load the whole thing from all the ibcs together

1523 case errSpan inew of

1547 case errSpan inew of

1524 Nothing ->

1548 Nothing ->

@@ -1526,9 +1550,6 @@ loadInputs inputs toline -- furthest line to read in input source files

1526 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1550 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1527 tryLoad True (mapMaybe id ibcfiles)

1551 tryLoad True (mapMaybe id ibcfiles)

1528 _ -> return ()

1552 _ -> return ()

1529− ist <- getIState

1530− putIState $! ist { idris_tyinfodata = tidata,

1531− idris_patdefs = patdefs }

1532 exports <- findExports

1553 exports <- findExports

1533

1554

1534 case opt getOutput opts of

1555 case opt getOutput opts of

@@ -1704,6 +1725,7 @@ idrisMain opts =

1704 iputStrLn banner

1725 iputStrLn banner

1705

1726

1706 orig <- getIState

1727 orig <- getIState

1728+

1707 mods <- if idesl then return [] else loadInputs inputs Nothing

1729 mods <- if idesl then return [] else loadInputs inputs Nothing

1708 let efile = case inputs of

1730 let efile = case inputs of

1709 [] -> ""

1731 [] -> ""

@@ -1756,12 +1778,13 @@ idrisMain opts =

1756 ok <- noErrors

1778 ok <- noErrors

1757 when (not ok) $ runIO (exitWith (ExitFailure 1))

1779 when (not ok) $ runIO (exitWith (ExitFailure 1))

1758 where

1780 where

1759− makeOption (OLogging i) = setLogLevel i

1781+ makeOption (OLogging i) = setLogLevel i

1782+ makeOption (OLogCats cs) = setLogCats cs

1760− makeOption TypeCase = setTypeCase True

1783+ makeOption TypeCase = setTypeCase True

1761− makeOption TypeInType = setTypeInType True

1784+ makeOption TypeInType = setTypeInType True

1762− makeOption NoCoverage = setCoverage False

1785+ makeOption NoCoverage = setCoverage False

1763− makeOption ErrContext = setErrContext True

1786+ makeOption ErrContext = setErrContext True

1764− makeOption _ = return ()

1787+ makeOption _ = return ()

1765

1788

1766 addPkgDir :: String -> Idris ()

1789 addPkgDir :: String -> Idris ()

1767 addPkgDir p = do ddir <- runIO $ getIdrisLibDir

1790 addPkgDir p = do ddir <- runIO $ getIdrisLibDir

src/Idris/REPLParser.hs+60−24

@@ -1,5 +1,5 @@

1

2−module Idris.REPLParser (parseCmd, help, allHelp) where

2+module Idris.REPLParser (parseCmd, help, allHelp, setOptions) where

3

4import System.FilePath ((</>))

5import System.Console.ANSI (Color(..))

@@ -32,12 +32,22 @@ parseCmd i inputname = P.runparser pCmd i inputname . trim

32type CommandTable = [ ( [String], CmdArg, String

33 , String -> P.IdrisParser (Either String Command) ) ]

34

35+setOptions :: [(String, Opt)]

36+setOptions = [("errorcontext", ErrContext),

37+ ("showimplicits", ShowImpl),

38+ ("originalerrors", ShowOrigErr),

39+ ("autosolve", AutoSolve),

40+ ("nobanner", NoBanner),

41+ ("warnreach", WarnReach),

42+ ("evaltypes", EvalTypes),

43+ ("desugarnats", DesugarNats)]

44+

35help :: [([String], CmdArg, String)]

45help :: [([String], CmdArg, String)]

36−help = (["<expr>"], NoArg, "Evaluate an expression") :

46+help = (["<expr>"], NoArg, "Evaluate an expression") :

37 [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ]

47 [ (map (':' :) names, args, text) | (names, args, text, _) <- parserCommandsForHelp ]

38

48

39allHelp :: [([String], CmdArg, String)]

49allHelp :: [([String], CmdArg, String)]

40−allHelp = [ (map (':' :) names, args, text)

50+allHelp = [ (map (':' :) names, args, text)

41 | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ]

51 | (names, args, text, _) <- parserCommandsForHelp ++ parserCommands ]

42

52

43parserCommandsForHelp :: CommandTable

53parserCommandsForHelp :: CommandTable

@@ -80,7 +90,7 @@ parserCommandsForHelp =

80 , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)

90 , (["dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)", cmd_dynamic)

81 , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)

91 , (["dynamic"], NoArg, "List dynamically loaded C libraries", cmd_dynamic)

82 , noArgCmd ["?", "h", "help"] Help "Display this help text"

92 , noArgCmd ["?", "h", "help"] Help "Display this help text"

83− , optArgCmd ["set"] SetOpt "Set an option (errorcontext, showimplicits)"

93+ , optArgCmd ["set"] SetOpt $ "Set an option (" ++ optionsList ++ ")"

84 , optArgCmd ["unset"] UnsetOpt "Unset an option"

94 , optArgCmd ["unset"] UnsetOpt "Unset an option"

85 , (["color", "colour"], ColourArg

95 , (["color", "colour"], ColourArg

86 , "Turn REPL colours on or off; set a specific colour"

96 , "Turn REPL colours on or off; set a specific colour"

@@ -100,6 +110,7 @@ parserCommandsForHelp =

100 , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."

110 , "Pretty prints an Idris function in either LaTeX or HTML and for a specified width."

101 , cmd_pprint)

111 , cmd_pprint)

102 ]

112 ]

113+ where optionsList = intercalate ", " $ map fst setOptions

103

114

104parserCommands =

115parserCommands =

105 [ noArgCmd ["u", "universes"] Universes "Display universe constraints"

116 [ noArgCmd ["u", "universes"] Universes "Display universe constraints"

@@ -113,7 +124,7 @@ parserCommands =

113 , exprArgCmd ["spec"] Spec "?"

124 , exprArgCmd ["spec"] Spec "?"

114 , exprArgCmd ["whnf"] WHNF "(Debugging) Show weak head normal form of an expression"

125 , exprArgCmd ["whnf"] WHNF "(Debugging) Show weak head normal form of an expression"

115 , exprArgCmd ["inline"] TestInline "?"

126 , exprArgCmd ["inline"] TestInline "?"

116− , proofArgCmd ["cs", "casesplit"] CaseSplitAt

127+ , proofArgCmd ["cs", "casesplit"] CaseSplitAt

117 ":cs <line> <name> splits the pattern variable on the line"

128 ":cs <line> <name> splits the pattern variable on the line"

118 , proofArgCmd ["apc", "addproofclause"] AddProofClauseFrom

129 , proofArgCmd ["apc", "addproofclause"] AddProofClauseFrom

119 ":apc <line> <name> adds a pattern-matching proof clause to name on line"

130 ":apc <line> <name> adds a pattern-matching proof clause to name on line"

@@ -127,6 +138,10 @@ parserCommands =

127 ":mc <line> <name> adds a case block for the definition of the metavariable on the line"

138 ":mc <line> <name> adds a case block for the definition of the metavariable on the line"

128 , proofArgCmd ["ml", "makelemma"] MakeLemma "?"

139 , proofArgCmd ["ml", "makelemma"] MakeLemma "?"

129 , (["log"], NumberArg, "Set logging verbosity level", cmd_log)

140 , (["log"], NumberArg, "Set logging verbosity level", cmd_log)

141+ , ( ["logcats"]

142+ , ManyArgs NameArg

143+ , "Set logging categories"

144+ , cmd_cats)

130 , (["lto", "loadto"], SeqArgs NumberArg FileArg

145 , (["lto", "loadto"], SeqArgs NumberArg FileArg

131 , "Load file up to line number", cmd_loadto)

146 , "Load file up to line number", cmd_loadto)

132 , (["ps", "proofsearch"], NoArg

147 , (["ps", "proofsearch"], NoArg

@@ -137,8 +152,8 @@ parserCommands =

137 , cmd_refine)

152 , cmd_refine)

138 , (["debugunify"], SeqArgs ExprArg ExprArg

153 , (["debugunify"], SeqArgs ExprArg ExprArg

139 , "(Debugging) Try to unify two expressions", const $ do

154 , "(Debugging) Try to unify two expressions", const $ do

140− l <- P.simpleExpr defaultSyntax

155+ l <- P.simpleExpr defaultSyntax

141− r <- P.simpleExpr defaultSyntax

156+ r <- P.simpleExpr defaultSyntax

142 eof

157 eof

143 return (Right (DebugUnify l r))

158 return (Right (DebugUnify l r))

144 )

159 )

@@ -160,13 +175,12 @@ proofArgCmd names command doc =

160 (names, NoArg, doc, proofArg command)

175 (names, NoArg, doc, proofArg command)

161

176

162pCmd :: P.IdrisParser (Either String Command)

177pCmd :: P.IdrisParser (Either String Command)

163−pCmd = choice [ do c <- cmd names; parser c

178+pCmd = choice [ do c <- cmd names; parser c

164 | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]

179 | (names, _, _, parser) <- parserCommandsForHelp ++ parserCommands ]

165− <|> unrecognized

180+ <|> unrecognized

166− <|> nop

181+ <|> nop

167 <|> eval

182 <|> eval

168 where nop = do eof; return (Right NOP)

183 where nop = do eof; return (Right NOP)

169− eval = exprArg Eval ""

170 unrecognized = do

184 unrecognized = do

171 P.lchar ':'

185 P.lchar ':'

172 cmd <- many anyChar

186 cmd <- many anyChar

@@ -194,20 +208,30 @@ noArgs cmd name = do

194

208

195 emptyArgs <|> failure

209 emptyArgs <|> failure

196

210

211+eval :: P.IdrisParser (Either String Command)

212+eval = do

213+ t <- P.fullExpr defaultSyntax

214+ return $ Right (Eval t)

215+

197exprArg :: (PTerm -> Command) -> String -> P.IdrisParser (Either String Command)

216exprArg :: (PTerm -> Command) -> String -> P.IdrisParser (Either String Command)

198exprArg cmd name = do

217exprArg cmd name = do

199 let noArg = do

218 let noArg = do

200 eof

219 eof

201 return $ Left ("Usage is :" ++ name ++ " <expression>")

220 return $ Left ("Usage is :" ++ name ++ " <expression>")

202

221

222+ let justOperator = do

223+ (op, fc) <- P.operatorFC

224+ eof

225+ return $ Right $ cmd (PRef fc [] (sUN op))

226+

203 let properArg = do

227 let properArg = do

204 t <- P.fullExpr defaultSyntax

228 t <- P.fullExpr defaultSyntax

205 return $ Right (cmd t)

229 return $ Right (cmd t)

206− try noArg <|> properArg

230+ try noArg <|> try justOperator <|> properArg

207

231

208

232

209

233

210−genArg :: String -> P.IdrisParser a -> (a -> Command)

234+genArg :: String -> P.IdrisParser a -> (a -> Command)

211 -> String -> P.IdrisParser (Either String Command)

235 -> String -> P.IdrisParser (Either String Command)

212genArg argName argParser cmd name = do

236genArg argName argParser cmd name = do

213 let emptyArgs = do eof; failure

237 let emptyArgs = do eof; failure

@@ -226,12 +250,12 @@ strArg :: (String -> Command) -> String -> P.IdrisParser (Either String Command)

226strArg = genArg "string" (many anyChar)

250strArg = genArg "string" (many anyChar)

227

251

228moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)

252moduleArg :: (FilePath -> Command) -> String -> P.IdrisParser (Either String Command)

229−moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)

253+moduleArg = genArg "module" (fmap (toPath . fst) P.identifier)

230 where

254 where

231 toPath n = foldl1' (</>) $ splitOn "." n

255 toPath n = foldl1' (</>) $ splitOn "." n

232

256

233namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)

257namespaceArg :: ([String] -> Command) -> String -> P.IdrisParser (Either String Command)

234−namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)

258+namespaceArg = genArg "namespace" (fmap (toNS . fst) P.identifier)

235 where

259 where

236 toNS = splitOn "."

260 toNS = splitOn "."

237

261

@@ -253,14 +277,7 @@ optArg cmd name = do

253

277

254 where

278 where

255 pOption :: P.IdrisParser Opt

279 pOption :: P.IdrisParser Opt

256− pOption = do discard (P.symbol "errorcontext"); return ErrContext

257− <|> do discard (P.symbol "showimplicits"); return ShowImpl

258− <|> do discard (P.symbol "originalerrors"); return ShowOrigErr

259− <|> do discard (P.symbol "autosolve"); return AutoSolve

260− <|> do discard (P.symbol "nobanner") ; return NoBanner

261− <|> do discard (P.symbol "warnreach"); return WarnReach

262− <|> do discard (P.symbol "evaltypes"); return EvalTypes

280+ pOption = foldl (<|>) empty $ map (\(a, b) -> do discard (P.symbol a); return b) setOptions

263− <|> do discard (P.symbol "desugarnats"); return DesugarNats

264

281

265proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command)

282proofArg :: (Bool -> Int -> Name -> Command) -> String -> P.IdrisParser (Either String Command)

266proofArg cmd name = do

283proofArg cmd name = do

@@ -277,7 +294,7 @@ cmd_doc name = do

277 c <- fmap fst P.constant

294 c <- fmap fst P.constant

278 eof

295 eof

279 return $ Right (DocStr (Right c) FullDocs)

296 return $ Right (DocStr (Right c) FullDocs)

280−

297+

281 let pType = do

298 let pType = do

282 P.reserved "Type"

299 P.reserved "Type"

283 eof

300 eof

@@ -379,6 +396,25 @@ cmd_log name = do

379 eof

396 eof

380 return (Right (LogLvl i))

397 return (Right (LogLvl i))

381

398

399+cmd_cats :: String -> P.IdrisParser (Either String Command)

400+cmd_cats name = do

401+ cs <- sepBy pLogCats (P.whiteSpace)

402+ eof

403+ return $ Right $ LogCategory (concat cs)

404+ where

405+ badCat = do

406+ c <- fst <$> P.identifier

407+ fail $ "Category: " ++ c ++ " is not recognised."

408+

409+ pLogCats :: P.IdrisParser [LogCat]

410+ pLogCats = try (P.symbol (strLogCat IParse) >> return parserCats)

411+ <|> try (P.symbol (strLogCat IElab) >> return elabCats)

412+ <|> try (P.symbol (strLogCat ICodeGen) >> return codegenCats)

413+ <|> try (P.symbol (strLogCat ICoverage) >> return [ICoverage])

414+ <|> try (P.symbol (strLogCat IIBC) >> return [IIBC])

415+ <|> try (P.symbol (strLogCat IErasure) >> return [IErasure])

416+ <|> badCat

417+

382cmd_let :: String -> P.IdrisParser (Either String Command)

418cmd_let :: String -> P.IdrisParser (Either String Command)

383cmd_let name = do

419cmd_let name = do

384 defn <- concat <$> many (P.decl defaultSyntax)

420 defn <- concat <$> many (P.decl defaultSyntax)

src/Idris/Reflection.hs+80−56

@@ -1,11 +1,15 @@

1{-| Code related to Idris's reflection system. This module contains

2quoters and unquoters along with some supporting datatypes.

3-}

4−{-# LANGUAGE PatternGuards #-}

4+{-# LANGUAGE PatternGuards, CPP #-}

5{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-unused-imports #-}

6module Idris.Reflection where

7

8+#if __GLASGOW_HASKELL__ < 710

8import Control.Applicative ((<$>), (<*>), pure)

9import Control.Applicative ((<$>), (<*>), pure)

10+import Prelude hiding (mapM)

11+import Data.Traversable (mapM)

12+#endif

9import Control.Monad (liftM, liftM2, liftM4)

13import Control.Monad (liftM, liftM2, liftM4)

10import Control.Monad.State.Strict (lift)

14import Control.Monad.State.Strict (lift)

11import Data.Maybe (catMaybes)

15import Data.Maybe (catMaybes)

@@ -17,7 +21,7 @@ import Idris.Core.Elaborate (claim, fill, focus, getNameFrom, initElaborator,

17import Idris.Core.Evaluate (Def(TyDecl), initContext, lookupDefExact, lookupTyExact)

21import Idris.Core.Evaluate (Def(TyDecl), initContext, lookupDefExact, lookupTyExact)

18import Idris.Core.TT

22import Idris.Core.TT

19

23

20−import Idris.AbsSyntaxTree (ArgOpt(..),ElabD, IState(tt_ctxt, idris_implicits,idris_datatypes),

24+import Idris.AbsSyntaxTree (ArgOpt(..),ElabD, IState(tt_ctxt, idris_implicits,idris_datatypes, idris_patdefs),

21 PArg'(..), PArg, PTactic, PTactic'(..), PTerm(..), Fixity (..),

25 PArg'(..), PArg, PTactic, PTactic'(..), PTerm(..), Fixity (..),

22 initEState, pairCon, pairTy)

26 initEState, pairCon, pairTy)

23import Idris.Delaborate (delab)

27import Idris.Delaborate (delab)

@@ -53,11 +57,11 @@ rFunArgToPArg (RFunArg n _ RExplicit e) = PExp 0 (rArgOpts e) n Placeholder

53rFunArgToPArg (RFunArg n _ RImplicit e) = PImp 0 False (rArgOpts e) n Placeholder

57rFunArgToPArg (RFunArg n _ RImplicit e) = PImp 0 False (rArgOpts e) n Placeholder

54rFunArgToPArg (RFunArg n _ RConstraint e) = PConstraint 0 (rArgOpts e) n Placeholder

58rFunArgToPArg (RFunArg n _ RConstraint e) = PConstraint 0 (rArgOpts e) n Placeholder

55

59

56−data RFunClause = RMkFunClause Raw Raw

60+data RFunClause a = RMkFunClause a a

57− | RMkImpossibleClause Raw

61+ | RMkImpossibleClause a

58− deriving Show

62+ deriving Show

59

63

60−data RFunDefn = RDefineFun Name [RFunClause] deriving Show

64+data RFunDefn a = RDefineFun Name [RFunClause a] deriving Show

61

65

62-- | Prefix a name with the "Language.Reflection" namespace

66-- | Prefix a name with the "Language.Reflection" namespace

63reflm :: String -> Name

67reflm :: String -> Name

@@ -217,8 +221,6 @@ reifyRawApp t [n, b, x]

217 return $ RBind n' b' x'

221 return $ RBind n' b' x'

218reifyRawApp t [f, x]

222reifyRawApp t [f, x]

219 | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)

223 | t == reflm "RApp" = liftM2 RApp (reifyRaw f) (reifyRaw x)

220−reifyRawApp t [t']

221− | t == reflm "RForce" = liftM RForce (reifyRaw t')

222reifyRawApp t [c]

224reifyRawApp t [c]

223 | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)

225 | t == reflm "RConstant" = liftM RConstant (reifyTTConst c)

224reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))

226reifyRawApp t args = fail ("Unknown reflection raw term in reifyRawApp: " ++ show (t, args))

@@ -257,9 +259,9 @@ reifyTTNameApp t [sn]

257 reifySN t [n]

259 reifySN t [n]

258 | t == reflm "MethodN" =

260 | t == reflm "MethodN" =

259 MethodN <$> reifyTTName n

261 MethodN <$> reifyTTName n

260− reifySN t [n]

262+ reifySN t [fc, n]

261 | t == reflm "CaseN" =

263 | t == reflm "CaseN" =

262− CaseN <$> reifyTTName n

264+ CaseN <$> (FC' <$> reifyFC fc) <*> reifyTTName n

263 reifySN t [n]

265 reifySN t [n]

264 | t == reflm "ElimN" =

266 | t == reflm "ElimN" =

265 ElimN <$> reifyTTName n

267 ElimN <$> reifyTTName n

@@ -270,8 +272,6 @@ reifyTTNameApp t [sn]

270 | t == reflm "MetaN" =

272 | t == reflm "MetaN" =

271 MetaN <$> reifyTTName n1 <*> reifyTTName n2

273 MetaN <$> reifyTTName n1 <*> reifyTTName n2

272 reifySN t args = fail $ "Can't reify special name " ++ show t ++ show args

274 reifySN t args = fail $ "Can't reify special name " ++ show t ++ show args

273−reifyTTNameApp t []

274− | t == reflm "NErased" = return NErased

275reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

276

277reifyTTNamespace :: Term -> ElabD [String]

@@ -310,8 +310,6 @@ reifyTTBinderApp reif f [t, k]

310 | f == reflm "Pi" = liftM2 (Pi Nothing) (reif t) (reif k)

311reifyTTBinderApp reif f [x, y]

312 | f == reflm "Let" = liftM2 Let (reif x) (reif y)

313−reifyTTBinderApp reif f [x, y]

314− | f == reflm "NLet" = liftM2 NLet (reif x) (reif y)

315reifyTTBinderApp reif f [t]

313reifyTTBinderApp reif f [t]

316 | f == reflm "Hole" = liftM Hole (reif t)

314 | f == reflm "Hole" = liftM Hole (reif t)

317reifyTTBinderApp reif f [t]

315reifyTTBinderApp reif f [t]

@@ -361,8 +359,8 @@ reifyTTConstApp f v@(P _ _ _) =

361reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))

359reifyTTConstApp f arg = fail ("Unknown reflection constant: " ++ show (f, arg))

362

360

363reifyArithTy :: Term -> ElabD ArithTy

361reifyArithTy :: Term -> ElabD ArithTy

364−reifyArithTy (App _ (P _ n _) intTy) | n == reflm "ATInt" = fmap ATInt (reifyIntTy intTy)

362+reifyArithTy (App _ (P _ n _) intTy) | n == reflm "ATInt" = fmap ATInt (reifyIntTy intTy)

365−reifyArithTy (P _ n _) | n == reflm "ATFloat" = return ATFloat

363+reifyArithTy (P _ n _) | n == reflm "ATDouble" = return ATFloat

366reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

364reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

367

365

368reifyNativeTy :: Term -> ElabD NativeTy

366reifyNativeTy :: Term -> ElabD NativeTy

@@ -473,18 +471,15 @@ reflectTTQuotePattern unq (Constant c)

473 = do fill $ reflCall "TConst" [reflectConstant c]

471 = do fill $ reflCall "TConst" [reflectConstant c]

474 solve

472 solve

475reflectTTQuotePattern unq (Proj t i)

473reflectTTQuotePattern unq (Proj t i)

476− = do t' <- claimTy (sMN 0 "t") (Var (reflm "TT")) ; movelast t'

474+ = lift . tfail . InternalMsg $

477− fill $ reflCall "Proj" [Var t', RConstant (I i)]

475+ "Phase error! The Proj constructor is for optimization only and should not have been reflected during elaboration."

478− solve

479− focus t'; reflectTTQuotePattern unq t

480−reflectTTQuotePattern unq (Erased)

476+reflectTTQuotePattern unq Erased

481 = do erased <- claimTy (sMN 0 "erased") (Var (reflm "TT"))

477 = do erased <- claimTy (sMN 0 "erased") (Var (reflm "TT"))

482 movelast erased

478 movelast erased

483 fill $ (Var erased)

479 fill $ (Var erased)

484− solve

485−reflectTTQuotePattern unq (Impossible)

480+reflectTTQuotePattern unq Impossible

486− = do fill $ Var (reflm "Impossible")

481+ = lift . tfail . InternalMsg $

487− solve

482+ "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."

488reflectTTQuotePattern unq (TType exp)

483reflectTTQuotePattern unq (TType exp)

489 = do ue <- getNameFrom (sMN 0 "uexp")

484 = do ue <- getNameFrom (sMN 0 "uexp")

490 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

485 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

@@ -537,7 +532,6 @@ reflectRawQuotePattern unq (RBind n b sc) =

537 freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x

532 freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x

538 freeNamesR RType = []

533 freeNamesR RType = []

539 freeNamesR (RUType _) = []

534 freeNamesR (RUType _) = []

540− freeNamesR (RForce r) = freeNamesR r

541 freeNamesR (RConstant _) = []

535 freeNamesR (RConstant _) = []

542reflectRawQuotePattern unq (RApp f x) =

536reflectRawQuotePattern unq (RApp f x) =

543 do fH <- getNameFrom (sMN 0 "f")

537 do fH <- getNameFrom (sMN 0 "f")

@@ -560,13 +554,6 @@ reflectRawQuotePattern unq (RUType univ) =

560 fill $ reflCall "RUType" [Var uH]

554 fill $ reflCall "RUType" [Var uH]

561 solve

555 solve

562 focus uH; fill (reflectUniverse univ); solve

556 focus uH; fill (reflectUniverse univ); solve

563−reflectRawQuotePattern unq (RForce r) =

564− do rH <- getNameFrom (sMN 0 "raw")

565− claim rH (Var (reflm "Raw"))

566− movelast rH

567− fill $ reflCall "RForce" [Var rH]

568− solve

569− focus rH; reflectRawQuotePattern unq r

570reflectRawQuotePattern unq (RConstant c) =

557reflectRawQuotePattern unq (RConstant c) =

571 do cH <- getNameFrom (sMN 0 "const")

558 do cH <- getNameFrom (sMN 0 "const")

572 claim cH (Var (reflm "Constant"))

559 claim cH (Var (reflm "Constant"))

@@ -597,7 +584,7 @@ reflectBinderQuotePattern q ty unq (Let x y)

597reflectBinderQuotePattern q ty unq (NLet x y)

584reflectBinderQuotePattern q ty unq (NLet x y)

598 = do x' <- claimTy (sMN 0 "ty") ty; movelast x'

585 = do x' <- claimTy (sMN 0 "ty") ty; movelast x'

599 y' <- claimTy (sMN 0 "v") ty; movelast y'

586 y' <- claimTy (sMN 0 "v") ty; movelast y'

600− fill $ reflCall "NLet" [ty, Var x', Var y']

587+ fill $ reflCall "Let" [ty, Var x', Var y']

601 solve

588 solve

602 focus x'; q unq x

589 focus x'; q unq x

603 focus y'; q unq y

590 focus y'; q unq y

@@ -649,12 +636,13 @@ reflectTTQuote unq (App _ f x)

649 = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]

636 = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]

650reflectTTQuote unq (Constant c)

637reflectTTQuote unq (Constant c)

651 = reflCall "TConst" [reflectConstant c]

638 = reflCall "TConst" [reflectConstant c]

652−reflectTTQuote unq (Proj t i)

653− = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]

654−reflectTTQuote unq (Erased) = Var (reflm "Erased")

655−reflectTTQuote unq (Impossible) = Var (reflm "Impossible")

656reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

639reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

657reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]

640reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]

641+reflectTTQuote _ (Proj _ _) =

642+ error "Phase error! The Proj constructor is for optimization only and should not have been reflected during elaboration."

643+reflectTTQuote unq Erased = Var (reflm "Erased")

644+reflectTTQuote _ Impossible =

645+ error "Phase error! The Impossible constructor is for optimization only and should not have been reflected during elaboration."

658

646

659reflectRawQuote :: [Name] -> Raw -> Raw

647reflectRawQuote :: [Name] -> Raw -> Raw

660reflectRawQuote unq (Var n)

648reflectRawQuote unq (Var n)

@@ -667,7 +655,6 @@ reflectRawQuote unq (RApp f x) =

667reflectRawQuote unq RType = Var (reflm "RType")

655reflectRawQuote unq RType = Var (reflm "RType")

668reflectRawQuote unq (RUType u) =

656reflectRawQuote unq (RUType u) =

669 reflCall "RUType" [reflectUniverse u]

657 reflCall "RUType" [reflectUniverse u]

670−reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]

671reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]

658reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]

672

659

673reflectNameType :: NameType -> Raw

660reflectNameType :: NameType -> Raw

@@ -692,7 +679,6 @@ reflectName (NS n ns)

692 ]

679 ]

693reflectName (MN i n)

680reflectName (MN i n)

694 = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

681 = reflCall "MN" [RConstant (I i), RConstant (Str (str n))]

695−reflectName NErased = Var (reflm "NErased")

696reflectName (SN sn) = raw_apply (Var (reflm "SN")) [reflectSpecialName sn]

682reflectName (SN sn) = raw_apply (Var (reflm "SN")) [reflectSpecialName sn]

697reflectName (SymRef _) = error "The impossible happened: symbol table ref survived IBC loading"

683reflectName (SymRef _) = error "The impossible happened: symbol table ref survived IBC loading"

698

684

@@ -711,8 +697,8 @@ reflectSpecialName (ParentN n s) =

711 reflCall "ParentN" [reflectName n, RConstant (Str (T.unpack s))]

697 reflCall "ParentN" [reflectName n, RConstant (Str (T.unpack s))]

712reflectSpecialName (MethodN n) =

698reflectSpecialName (MethodN n) =

713 reflCall "MethodN" [reflectName n]

699 reflCall "MethodN" [reflectName n]

714−reflectSpecialName (CaseN n) =

700+reflectSpecialName (CaseN fc n) =

715− reflCall "CaseN" [reflectName n]

701+ reflCall "CaseN" [reflectFC (unwrapFC fc), reflectName n]

716reflectSpecialName (ElimN n) =

702reflectSpecialName (ElimN n) =

717 reflCall "ElimN" [reflectName n]

703 reflCall "ElimN" [reflectName n]

718reflectSpecialName (InstanceCtorN n) =

704reflectSpecialName (InstanceCtorN n) =

@@ -754,7 +740,7 @@ reflectBinderQuote q ty unq (Pi _ t k)

754reflectBinderQuote q ty unq (Let x y)

740reflectBinderQuote q ty unq (Let x y)

755 = reflCall "Let" [Var ty, q unq x, q unq y]

741 = reflCall "Let" [Var ty, q unq x, q unq y]

756reflectBinderQuote q ty unq (NLet x y)

742reflectBinderQuote q ty unq (NLet x y)

757− = reflCall "NLet" [Var ty, q unq x, q unq y]

743+ = reflCall "Let" [Var ty, q unq x, q unq y]

758reflectBinderQuote q ty unq (Hole t)

744reflectBinderQuote q ty unq (Hole t)

759 = reflCall "Hole" [Var ty, q unq t]

745 = reflCall "Hole" [Var ty, q unq t]

760reflectBinderQuote q ty unq (GHole _ _ t)

746reflectBinderQuote q ty unq (GHole _ _ t)

@@ -784,7 +770,7 @@ reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]

784reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]

770reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]

785reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]

771reflectConstant (AType (ATInt ITNative)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITNative")]]

786reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]

772reflectConstant (AType (ATInt ITBig)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITBig")]]

787−reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATFloat")]

773+reflectConstant (AType ATFloat) = reflCall "AType" [Var (reflm "ATDouble")]

788reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]

774reflectConstant (AType (ATInt ITChar)) = reflCall "AType" [reflCall "ATInt" [Var (reflm "ITChar")]]

789reflectConstant StrType = Var (reflm "StrType")

775reflectConstant StrType = Var (reflm "StrType")

790reflectConstant (AType (ATInt (ITFixed IT8))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]

776reflectConstant (AType (ATInt (ITFixed IT8))) = reflCall "AType" [reflCall "ATInt" [reflCall "ITFixed" [Var (reflm "IT8")]]]

@@ -916,7 +902,7 @@ reflectErr (CantResolveAlts ss) =

916 raw_apply (Var $ reflErrName "CantResolveAlts")

902 raw_apply (Var $ reflErrName "CantResolveAlts")

917 [rawList (Var $ reflm "TTName") (map reflectName ss)]

903 [rawList (Var $ reflm "TTName") (map reflectName ss)]

918reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

904reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

919−reflectErr (NoEliminator str t)

905+reflectErr (NoEliminator str t)

920 = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),

906 = raw_apply (Var $ reflErrName "NoEliminator") [RConstant (Str str),

921 reflect t]

907 reflect t]

922reflectErr (UniverseError fc ue old new tys) =

908reflectErr (UniverseError fc ue old new tys) =

@@ -954,6 +940,12 @@ reflectFC fc = raw_apply (Var (reflm "FileLoc"))

954 ]

940 ]

955 where intTy = RConstant (AType (ATInt ITNative))

941 where intTy = RConstant (AType (ATInt ITNative))

956

942

943+reifyFC :: Term -> ElabD FC

944+reifyFC tm

945+ | (P (DCon _ _ _) cn _, [Constant (Str fn), st, end]) <- unApply tm

946+ , cn == reflm "FileLoc" = FC fn <$> reifyPair reifyInt reifyInt st <*> reifyPair reifyInt reifyInt end

947+ | otherwise = fail $ "Not a source location: " ++ show tm

948+

957fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

949fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

958fromTTMaybe (App _ (App _ (P (DCon _ _ _) (NS (UN just) _) _) ty) tm)

950fromTTMaybe (App _ (App _ (P (DCon _ _ _) (NS (UN just) _) _) ty) tm)

959 | just == txt "Just" = Just tm

951 | just == txt "Just" = Just tm

@@ -970,7 +962,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "

970 Right (TextPart msg)

962 Right (TextPart msg)

971reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

963reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

972 | n == reflm "NamePart" =

964 | n == reflm "NamePart" =

973− case runElab initEState (reifyTTName ttn) (initElaborator NErased initContext emptyContext Erased) of

965+ case runElab initEState (reifyTTName ttn) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

974 Error e -> Left . InternalMsg $

966 Error e -> Left . InternalMsg $

975 "could not reify name term " ++

967 "could not reify name term " ++

976 show ttn ++

968 show ttn ++

@@ -978,7 +970,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

978 OK (n', _)-> Right $ NamePart n'

970 OK (n', _)-> Right $ NamePart n'

979reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

971reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

980 | n == reflm "TermPart" =

972 | n == reflm "TermPart" =

981− case runElab initEState (reifyTT tm) (initElaborator NErased initContext emptyContext Erased) of

973+ case runElab initEState (reifyTT tm) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

982 Error e -> Left . InternalMsg $

974 Error e -> Left . InternalMsg $

983 "could not reify reflected term " ++

975 "could not reify reflected term " ++

984 show tm ++

976 show tm ++

@@ -986,7 +978,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

986 OK (tm', _) -> Right $ TermPart tm'

978 OK (tm', _) -> Right $ TermPart tm'

987reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

979reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

988 | n == reflm "RawPart" =

980 | n == reflm "RawPart" =

989− case runElab initEState (reifyRaw tm) (initElaborator NErased initContext emptyContext Erased) of

981+ case runElab initEState (reifyRaw tm) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

990 Error e -> Left . InternalMsg $

982 Error e -> Left . InternalMsg $

991 "could not reify reflected raw term " ++

983 "could not reify reflected raw term " ++

992 show tm ++

984 show tm ++

@@ -1033,21 +1025,21 @@ reifyTyDecl (App _ (App _ (App _ (P (DCon _ _ _) n _) tyN) args) ret)

1033 return $ RDeclare tyN' args' ret'

1025 return $ RDeclare tyN' args' ret'

1034reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."

1026reifyTyDecl tm = fail $ "Couldn't reify " ++ show tm ++ " as a type declaration."

1035

1027

1036−reifyFunDefn :: Term -> ElabD RFunDefn

1028+reifyFunDefn :: Term -> ElabD (RFunDefn Raw)

1037−reifyFunDefn (App _ (App _ (P _ n _) fnN) clauses)

1029+reifyFunDefn (App _ (App _ (App _ (P _ n _) (P _ t _)) fnN) clauses)

1038− | n == tacN "DefineFun" =

1030+ | n == tacN "DefineFun" && t == reflm "Raw" =

1039 do fnN' <- reifyTTName fnN

1031 do fnN' <- reifyTTName fnN

1040 clauses' <- case unList clauses of

1032 clauses' <- case unList clauses of

1041 Nothing -> fail $ "Couldn't reify " ++ show clauses ++ " as a clause list"

1033 Nothing -> fail $ "Couldn't reify " ++ show clauses ++ " as a clause list"

1042 Just cs -> mapM reifyC cs

1034 Just cs -> mapM reifyC cs

1043 return $ RDefineFun fnN' clauses'

1035 return $ RDefineFun fnN' clauses'

1044− where reifyC :: Term -> ElabD RFunClause

1036+ where reifyC :: Term -> ElabD (RFunClause Raw)

1045− reifyC (App _ (App _ (P (DCon _ _ _) n _) lhs) rhs)

1037+ reifyC (App _ (App _ (App _ (P (DCon _ _ _) n _) (P _ t _)) lhs) rhs)

1046− | n == tacN "MkFunClause" = liftM2 RMkFunClause

1038+ | n == tacN "MkFunClause" && t == reflm "Raw" = liftM2 RMkFunClause

1047 (reifyRaw lhs)

1039 (reifyRaw lhs)

1048 (reifyRaw rhs)

1040 (reifyRaw rhs)

1049− reifyC (App _ (P (DCon _ _ _) n _) lhs)

1041+ reifyC (App _ (App _ (P (DCon _ _ _) n _) (P _ t _)) lhs)

1050− | n == tacN "MkImpossibleClause" = fmap RMkImpossibleClause $ reifyRaw lhs

1042+ | n == tacN "MkImpossibleClause" && t == reflm "Raw" = fmap RMkImpossibleClause $ reifyRaw lhs

1051 reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

1043 reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

1052reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

1044reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

1053

1045

@@ -1057,6 +1049,12 @@ envTupleType

1057 , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

1049 , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

1058 ]

1050 ]

1059

1051

1052+reflectList :: Raw -> [Raw] -> Raw

1053+reflectList ty [] = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty

1054+reflectList ty (x:xs) = RApp (RApp (RApp (Var (sNS (sUN "::") ["List", "Prelude"])) ty)

1055+ x)

1056+ (reflectList ty xs)

1057+

1060-- | Apply Idris's implicit info to get a signature. The [PArg] should

1058-- | Apply Idris's implicit info to get a signature. The [PArg] should

1061-- come from a lookup in idris_implicits on IState.

1059-- come from a lookup in idris_implicits on IState.

1062getArgs :: [PArg] -> Raw -> ([RFunArg], Raw)

1060getArgs :: [PArg] -> Raw -> ([RFunArg], Raw)

@@ -1078,6 +1076,22 @@ unApplyRaw tm = ua [] tm

1078 ua args (RApp f a) = ua (a:args) f

1076 ua args (RApp f a) = ua (a:args) f

1079 ua args t = (t, args)

1077 ua args t = (t, args)

1080

1078

1079+-- | Build the reflected function definition(s) that correspond(s) to

1080+-- a provided unqualifed name

1081+buildFunDefns :: IState -> Name -> [RFunDefn Term]

1082+buildFunDefns ist n =

1083+ [ mkFunDefn name clauses

1084+ | (name, (clauses, _)) <- lookupCtxtName n $ idris_patdefs ist

1085+ ]

1086+

1087+ where mkFunDefn name clauses = RDefineFun name (map mkFunClause clauses)

1088+

1089+ mkFunClause ([], lhs, Impossible) = RMkImpossibleClause lhs

1090+ mkFunClause ([], lhs, rhs) = RMkFunClause lhs rhs

1091+ mkFunClause (((n, ty) : ns), lhs, rhs) = mkFunClause (ns, bind lhs, bind rhs) where

1092+ bind Impossible = Impossible

1093+ bind tm = Bind n (PVar ty) tm

1094+

1081-- | Build the reflected datatype definition(s) that correspond(s) to

1095-- | Build the reflected datatype definition(s) that correspond(s) to

1082-- a provided unqualified name

1096-- a provided unqualified name

1083buildDatatypes :: IState -> Name -> [RDatatype]

1097buildDatatypes :: IState -> Name -> [RDatatype]

@@ -1167,3 +1181,13 @@ reflectDatatype (RDatatype tyn tyConArgs tyConRes constrs) =

1167 RApp (Var $ tacN "TyConParameter") (reflectArg a)

1181 RApp (Var $ tacN "TyConParameter") (reflectArg a)

1168 reflectConArg (RIndex a) =

1182 reflectConArg (RIndex a) =

1169 RApp (Var $ tacN "TyConIndex") (reflectArg a)

1183 RApp (Var $ tacN "TyConIndex") (reflectArg a)

1184+

1185+reflectFunClause :: RFunClause Term -> Raw

1186+reflectFunClause (RMkFunClause lhs rhs) = raw_apply (Var $ tacN "MkFunClause") $ (Var $ reflm "TT") : map reflect [ lhs, rhs ]

1187+reflectFunClause (RMkImpossibleClause lhs) = raw_apply (Var $ tacN "MkImpossibleClause") $ [ Var $ reflm "TT", reflect lhs ]

1188+

1189+reflectFunDefn :: RFunDefn Term -> Raw

1190+reflectFunDefn (RDefineFun name clauses) = raw_apply (Var $ tacN "DefineFun") [ Var $ reflm "TT"

1191+ , reflectName name

1192+ , rawList (RApp (Var $ tacN "FunClause") (Var $ reflm "TT")) (map reflectFunClause clauses)

1193+ ]

src/Pkg/PParser.hs+49−3

@@ -1,4 +1,4 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP, ConstraintKinds #-}

2#if !(MIN_VERSION_base(4,8,0))

3{-# LANGUAGE OverlappingInstances #-}

4#endif

@@ -14,6 +14,8 @@ import Idris.CmdOptions

14

15import Control.Monad.State.Strict

16import Control.Applicative

17+import System.FilePath (takeFileName, isValid)

18+import Data.Maybe (isNothing, fromJust)

17

19

18import Util.System

20import Util.System

19

21

@@ -62,11 +64,55 @@ pPkg = do

62 eof

64 eof

63 return st

65 return st

64

66

67+

68+-- | Parses a filename.

69+-- |

70+-- | Treated for now as an identifier or a double-quoted string.

71+filename :: (MonadicParsing m, HasLastTokenSpan m) => m String

72+filename = (do

73+ filename <- token $

74+ -- Treat a double-quoted string as a filename to support spaces.

75+ -- This also moves away from tying filenames to identifiers, so

76+ -- it will also accept hyphens

77+ -- (https://github.com/idris-lang/Idris-dev/issues/2721)

78+ stringLiteral

79+ <|>

80+ -- Through at least version 0.9.19.1, IPKG executable values were

81+ -- possibly namespaced identifiers, like foo.bar.baz.

82+ show <$> fst <$> iName []

83+ case filenameErrorMessage filename of

84+ Just errorMessage -> fail errorMessage

85+ Nothing -> return filename)

86+ <?> "filename"

87+ where

88+ -- TODO: Report failing span better! We could lookAhead,

89+ -- or do something with DeltaParsing?

90+ filenameErrorMessage :: FilePath -> Maybe String

91+ filenameErrorMessage path = either Just (const Nothing) $ do

92+ checkEmpty path

93+ checkValid path

94+ checkNoDirectoryComponent path

95+ where

96+ checkThat ok message =

97+ if ok then Right () else Left message

98+

99+ checkEmpty path =

100+ checkThat (path /= "") "filename must not be empty"

101+

102+ checkValid path =

103+ checkThat (System.FilePath.isValid path)

104+ "filename must contain only valid characters"

105+

106+ checkNoDirectoryComponent path =

107+ checkThat (path == takeFileName path)

108+ "filename must contain no directory component"

109+

110+

65pClause :: PParser ()

111pClause :: PParser ()

66pClause = do reserved "executable"; lchar '=';

112pClause = do reserved "executable"; lchar '=';

67− exec <- fst <$> iName []

113+ exec <- filename

68 st <- get

114 st <- get

69− put (st { execout = Just (show exec) })

115+ put (st { execout = Just exec })

70 <|> do reserved "main"; lchar '=';

116 <|> do reserved "main"; lchar '=';

71 main <- fst <$> iName []

117 main <- fst <$> iName []

72 st <- get

118 st <- get

src/Pkg/Package.hs+3−6

@@ -164,7 +164,7 @@ testPkg fp

164 do m_ist <- inPkgDir pkgdesc $

165 do make (makefile pkgdesc)

166 -- Get a temporary file to save the tests' source in

167− (tmpn, tmph) <- tempIdr

167+ (tmpn, tmph) <- tempfile ".idr"

168 hPutStrLn tmph $

169 "module Test_______\n" ++

170 concat ["import " ++ show m ++ "\n"

@@ -175,7 +175,7 @@ testPkg fp

175 concat [show t ++ "\n "

176 | t <- idris_tests pkgdesc]

177 hClose tmph

178− (tmpn', tmph') <- tempfile

178+ (tmpn', tmph') <- tempfile ""

179 hClose tmph'

180 m_ist <- idris (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)

181 rawSystem tmpn' []

@@ -187,9 +187,6 @@ testPkg fp

187 case errSpan ist of

188 Just _ -> exitWith (ExitFailure 1)

189 _ -> return ()

190− where tempIdr :: IO (FilePath, Handle)

191− tempIdr = do dir <- getTemporaryDirectory

192− openTempFile (normalise dir) "idristests.idr"

193

190

194-- | Install package

191-- | Install package

195installPkg :: PkgDesc -> IO ()

192installPkg :: PkgDesc -> IO ()

@@ -214,7 +211,7 @@ testLib :: Bool -> String -> String -> IO Bool

214testLib warn p f

211testLib warn p f

215 = do d <- getDataDir

212 = do d <- getDataDir

216 gcc <- getCC

213 gcc <- getCC

217− (tmpf, tmph) <- tempfile

214+ (tmpf, tmph) <- tempfile ""

218 hClose tmph

215 hClose tmph

219 let libtest = d </> "rts" </> "libtest.c"

216 let libtest = d </> "rts" </> "libtest.c"

220 e <- rawSystem gcc [libtest, "-l" ++ f, "-o", tmpf]

217 e <- rawSystem gcc [libtest, "-l" ++ f, "-o", tmpf]

src/Util/System.hs+17−10

@@ -16,15 +16,16 @@ import System.Directory (getTemporaryDirectory

16 , removeFile

17 , removeDirectoryRecursive

18 , createDirectoryIfMissing

19− , doesDirectoryExist

20 )

19 )

21−import System.FilePath ((</>), normalise, isAbsolute, dropFileName)

20+import System.FilePath ((</>), normalise)

22import System.IO

21import System.IO

23import System.Info

22import System.Info

24import System.IO.Error

23import System.IO.Error

25

24

26#ifdef FREESTANDING

25#ifdef FREESTANDING

27import Tools_idris

26import Tools_idris

27+import System.FilePath (isAbsolute, dropFileName)

28+import System.Directory (doesDirectoryExist)

28import System.Environment (getEnv, setEnv, getExecutablePath)

29import System.Environment (getEnv, setEnv, getExecutablePath)

29#endif

30#endif

30

31

@@ -37,9 +38,10 @@ throwIO = CE.throw

37isWindows :: Bool

38isWindows :: Bool

38isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

39isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

39

40

41+-- | Create a temp file with the extensiom ext (in the format ".xxx")

40−tempfile :: IO (FilePath, Handle)

42+tempfile :: String -> IO (FilePath, Handle)

41−tempfile = do dir <- getTemporaryDirectory

43+tempfile ext = do dir <- getTemporaryDirectory

42− openTempFile (normalise dir) "idris"

44+ openTempFile (normalise dir) $ "idris" ++ ext

43

45

44-- | Read a source file, same as readFile but make sure the encoding is utf-8.

46-- | Read a source file, same as readFile but make sure the encoding is utf-8.

45readSource :: FilePath -> IO String

47readSource :: FilePath -> IO String

@@ -65,7 +67,7 @@ isATTY = do

65withTempdir :: String -> (FilePath -> IO a) -> IO a

67withTempdir :: String -> (FilePath -> IO a) -> IO a

66withTempdir subdir callback

68withTempdir subdir callback

67 = do dir <- getTemporaryDirectory

69 = do dir <- getTemporaryDirectory

68− let tmpDir = (normalise dir) </> subdir

70+ let tmpDir = normalise dir </> subdir

69 removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)

71 removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)

70 (\ ioError -> if isAlreadyExistsError ioError then return False

72 (\ ioError -> if isAlreadyExistsError ioError then return False

71 else throw ioError

73 else throw ioError

@@ -75,10 +77,15 @@ withTempdir subdir callback

75 return result

77 return result

76

78

77rmFile :: FilePath -> IO ()

79rmFile :: FilePath -> IO ()

78−rmFile f = do putStrLn $ "Removing " ++ f

80+rmFile f = do

79− catchIO (removeFile f)

81+ result <- try (removeFile f)

82+ case result of

83+ Right _ -> putStrLn $ "Removed: " ++ f

84+ Left err -> handleExists err

85+ where handleExists e

86+ | isDoesNotExistError e = return ()

80− (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

87+ | otherwise = putStrLn $ "WARNING: Cannot remove file "

81− ++ f ++ ", Error msg:" ++ show ioerr)

88+ ++ f ++ ", Error msg:" ++ show e

82

89

83setupBundledCC :: IO()

90setupBundledCC :: IO()

84#ifdef FREESTANDING

91#ifdef FREESTANDING

stack.yaml+9−2

@@ -1,6 +1,13 @@

1−flags: {}

1+resolver: lts-3.16

2packages:

3- '.'

4+flags:

5+ idris:

6+ FFI: true

7+ GMP: True

8+ curses: True

4extra-deps:

9extra-deps:

10+- annotated-wl-pprint-0.7.0

5- cheapskate-0.1.0.4

11- cheapskate-0.1.0.4

6−resolver: nightly-2015-07-24

12+- hscurses-1.4.2.0

13+- libffi-0.1

test/Makefile+4−1

@@ -1,4 +1,4 @@

1−.PHONY: test test_java test_js update diff distclean $(TESTS)

1+.PHONY: test test_java test_js time update diff distclean $(TESTS)

2

3TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

4

@@ -16,6 +16,9 @@ update:

16diff:

17 /usr/bin/env perl ./runtest.pl all -d

18

19+time:

20+ /usr/bin/env perl ./runtest.pl all -t

21+

19distclean:

22distclean:

20 rm -f *~

23 rm -f *~

21 rm -f */output

24 rm -f */output

test/basic002/test006.idr+9−9

@@ -1,21 +1,21 @@

1module Main

2

3data Parity : Nat -> Type where

4− even : {n : Nat} -> Parity (n + n)

4+ Even : {n : Nat} -> Parity (n + n)

5− odd : {n : Nat} -> Parity (S (n + n))

5+ Odd : {n : Nat} -> Parity (S (n + n))

6

7parity : (n:Nat) -> Parity n

8−parity Z = even {n=Z}

8+parity Z = Even {n=Z}

9−parity (S Z) = odd {n=Z}

9+parity (S Z) = Odd {n=Z}

10parity (S (S k)) with (parity k)

11− parity (S (S (j + j))) | (even {n = j}) ?= even {n=S j}

11+ parity (S (S (j + j))) | (Even {n = j}) ?= Even {n=S j}

12− parity (S (S (S (j + j)))) | (odd {n = j}) ?= odd {n=S j}

12+ parity (S (S (S (j + j)))) | (Odd {n = j}) ?= Odd {n=S j}

13

14natToBin : Nat -> List Bool

15natToBin Z = Nil

16natToBin k with (parity k)

17− natToBin (j + j) | even {n = j} = False :: natToBin j

17+ natToBin (j + j) | Even {n = j} = False :: natToBin j

18− natToBin (S (j + j)) | odd {n = j} = True :: natToBin j

18+ natToBin (S (j + j)) | Odd {n = j} = True :: natToBin j

19

20main : IO ()

21main = do printLn (natToBin 42)

@@ -23,7 +23,7 @@ main = do printLn (natToBin 42)

23---------- Proofs ----------

24

25Main.parity_lemma_2 = proof {

26− intro;

26+ intro j;

27 intro;

28 rewrite sym (plusSuccRightSucc j j);

29 trivial;

test/basic006/expected+4−1

@@ -1,4 +1,7 @@

1+test020a.idr:16:18:

1−test020a.idr:16:18:When checking right hand side of foo:

2+When checking right hand side of foo with expected type

3+ List a

4+

2When checking an application of function Prelude.List.reverse:

5When checking an application of function Prelude.List.reverse:

3 Type mismatch between

6 Type mismatch between

4 Vect n a (Type of xs)

7 Vect n a (Type of xs)

test/basic009/expected+4−1

@@ -1,5 +1,8 @@

1MAIN-PASS

2+Faulty.idr:7:7:

2−Faulty.idr:7:7:When checking right hand side of fault:

3+When checking right hand side of fault with expected type

4+ num = 0

5+

3Type mismatch between

6Type mismatch between

4 0 = 0 (Type of Refl)

7 0 = 0 (Type of Refl)

5and

8and

test/basic010/Main.idr+13−13

@@ -9,32 +9,32 @@ qib (S Z) = 2

9qib (S (S n)) = qib n * qib (S n)

10

11-- An equality whose size reflects the size of numbers.

12−data equals : Nat -> Nat -> Type where

12+data Equals : Nat -> Nat -> Type where

13− eqZ : Z `equals` Z

13+ EqZ : Z `Equals` Z

14− eqS : m `equals` n -> S m `equals` S n

14+ EqS : m `Equals` n -> S m `Equals` S n

15

16−eq_refl : {n : Nat} -> n `equals` n

16+eq_refl : {n : Nat} -> n `Equals` n

17−eq_refl {n = Z} = eqZ

17+eq_refl {n = Z} = EqZ

18−eq_refl {n = S n} = eqS eq_refl

18+eq_refl {n = S n} = EqS eq_refl

19

20-- Here, the proof is very expensive to compute.

21-- We add a recursive argument to prevent Idris from inlining the function.

22−f : (r, n : Nat) -> Subset Nat (\k => qib n `equals` qib k)

22+f : (r, n : Nat) -> Subset Nat (\k => qib n `Equals` qib k)

23f Z n = Element n eq_refl

24f (S r) n = f r n

25

26-- A (contrived) relation, just to have something to show.

27−data represents : Nat -> Nat -> Type where

27+data Represents : Nat -> Nat -> Type where

28− axiom : (n : Nat) -> qib n `represents` n

28+ Axiom : (n : Nat) -> qib n `Represents` n

29

30-- Here, the witness is very expensive to compute.

31-- We add a recursive argument to prevent Idris from inlining the function.

32−g : (r, n : Nat) -> Exists (\k : Nat => k `represents` n)

32+g : (r, n : Nat) -> Exists (\k : Nat => k `Represents` n)

33−g Z n = Evidence (qib n) (axiom n)

33+g Z n = Evidence (qib n) (Axiom n)

34g (S r) n = g r n

35

36−fmt : qib n `represents` n -> String

36+fmt : qib n `Represents` n -> String

37−fmt (axiom n) = "axiom " ++ show n

37+fmt (Axiom n) = "Axiom " ++ show n

38

39main : IO ()

40main = do

test/basic010/expected+1−1

@@ -1,3 +1,3 @@

1*oink*

210000

3−axiom 10000

3+Axiom 10000

test/basic016/CycleA.idrnew file+4

@@ -0,0 +1,4 @@

1+module CycleA

2+

3+import CycleB

4+

test/basic016/CycleB.idrnew file+5

@@ -0,0 +1,5 @@

1+module CycleB

2+

3+import CycleC

4+

5+

test/basic016/CycleC.idrnew file+4

@@ -0,0 +1,4 @@

1+module CycleC

2+

3+import CycleA

4+

test/basic016/expectednew file+1

@@ -0,0 +1 @@

1+Cycle detected in imports: CycleA.idr -> CycleB -> CycleC -> CycleA -> CycleB

test/basic016/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ CycleA.idr --consolewidth 80 --nocolour --check

3+rm -f *.ibc

test/docs003/expected+4−3

@@ -1,12 +1,13 @@

1Type class Functor

2− Functors

2+ Functors allow a uniform action over a parameterised type.

3

4Parameters:

5− f -- the action of the functor on objects

5+ f -- a parameterised type

6

7Methods:

8 map : Functor f => (m : a -> b) -> f a -> f b

9− The action of the functor on morphisms

9+ Apply a function across everything of type 'a' in a

10+ parameterised type

10

11

11 The function is Total

12 The function is Total

12Instances:

13Instances:

test/dsl001/test001.idr+10−10

@@ -17,13 +17,13 @@ using (G : Vect n Ty)

17 (::) : interpTy a -> Env G -> Env (a :: G)

18

19 data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where

20− stop : HasType FZ (t :: G) t

20+ Stop : HasType FZ (t :: G) t

21− pop : HasType k G t -> HasType (FS k) (u :: G) t

21+ Pop : HasType k G t -> HasType (FS k) (u :: G) t

22

23 lookup : HasType i G t -> Env G -> interpTy t

24− lookup stop (x :: xs) = x

24+ lookup Stop (x :: xs) = x

25− lookup (pop k) (x :: xs) = lookup k xs

25+ lookup (Pop k) (x :: xs) = lookup k xs

26− lookup stop [] impossible

26+ lookup Stop [] impossible

27

28 data Expr : Vect n Ty -> Ty -> Type where

29 Var : HasType i G t -> Expr G t

@@ -41,8 +41,8 @@ using (G : Vect n Ty)

41 dsl expr

42 lambda = lam_

43 variable = Var

44− index_first = stop

44+ index_first = Stop

45− index_next = pop

45+ index_next = Pop

46

47 total

48 interp : Env G -> [static] (e : Expr G t) -> interpTy t

@@ -67,7 +67,7 @@ using (G : Vect n Ty)

67-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var FZ) (Var (FS FZ))))) (Var FZ)) (Var FZ))

68

69 eDouble : Expr G (TyFun TyInt TyInt)

70− eDouble = expr (\x => App (App eAdd x) (Var stop))

70+ eDouble = expr (\x => App (App eAdd x) (Var Stop))

71

72-- app : Lazy (Expr G (TyFun a t)) -> Expr G a -> Expr G t

73-- app = \f, a => App (Force f) a

@@ -81,8 +81,8 @@ using (G : Vect n Ty)

81

82 eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt))

83 eProg = Lam (Lam

84− (Bind (App eDouble (Var (pop stop)))

84+ (Bind (App eDouble (Var (Pop Stop)))

85− (\x => Bind (App eDouble (Var stop))

85+ (\x => Bind (App eDouble (Var Stop))

86 (\y => Bind (App eDouble (Val x))

87 (\z => App (App eAdd (Val y)) (Val z))))))

88

test/dsl002/Resimp.idr+15−15

@@ -49,35 +49,35 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

49 interpTy (a :-> b) = a -> interpTy b

50

51 data HasType : Vect n Ty -> Fin n -> Ty -> Type where

52− stop : HasType (a :: gam) FZ a

52+ Stop : HasType (a :: gam) FZ a

53− pop : HasType gam i b -> HasType (a :: gam) (FS i) b

53+ Pop : HasType gam i b -> HasType (a :: gam) (FS i) b

54

55 data Env : Vect n Ty -> Type where

56 Nil : Env Nil

57 (::) : interpTy a -> Env gam -> Env (a :: gam)

58

59 envLookup : HasType gam i a -> Env gam -> interpTy a

60− envLookup stop (x :: xs) = x

60+ envLookup Stop (x :: xs) = x

61− envLookup (pop k) (x :: xs) = envLookup k xs

61+ envLookup (Pop k) (x :: xs) = envLookup k xs

62

63 update : (gam : Vect n Ty) -> HasType gam i b -> Ty -> Vect n Ty

64− update (x :: xs) stop y = y :: xs

64+ update (x :: xs) Stop y = y :: xs

65− update (x :: xs) (pop k) y = x :: update xs k y

65+ update (x :: xs) (Pop k) y = x :: update xs k y

66− update Nil stop _ impossible

66+ update Nil Stop _ impossible

67

68 total

69 envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->

70 Env gam -> Env (update gam p b)

71− envUpdate stop val (x :: xs) = val :: xs

71+ envUpdate Stop val (x :: xs) = val :: xs

72− envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs

72+ envUpdate (Pop k) val (x :: xs) = x :: envUpdate k val xs

73− envUpdate stop _ Nil impossible

73+ envUpdate Stop _ Nil impossible

74

75 total

76 envUpdateVal : (p:HasType gam i a) -> (val:b) ->

77 Env gam -> Env (update gam p (Val b))

78− envUpdateVal stop val (x :: xs) = val :: xs

78+ envUpdateVal Stop val (x :: xs) = val :: xs

79− envUpdateVal (pop k) val (x :: xs) = x :: envUpdateVal k val xs

79+ envUpdateVal (Pop k) val (x :: xs) = x :: envUpdateVal k val xs

80− envUpdateVal stop _ Nil impossible

80+ envUpdateVal Stop _ Nil impossible

81

82 envTail : Env (a :: gam) -> Env gam

83 envTail (x :: xs) = xs

@@ -169,8 +169,8 @@ syntax run [prog] = interp [] prog (\env, res => res)

169dsl res

170 variable = id

171 let = let_

172− index_first = stop

172+ index_first = Stop

173− index_next = pop

173+ index_next = Pop

174

175syntax RES [x] = {gam:Vect n Ty} -> Res gam gam (R x)

176

test/dsl002/test014.idr+7−6

@@ -15,19 +15,20 @@ syntax "ifM" [test] "then" [t] "else" [e]

15 = test >>= (\b => if b then t else e)

16

17open : String -> (p:Purpose) -> Creator (Either () (FILE p))

18−open fn p = ioc (do h <- fopen fn (pstring p)

18+open fn p = ioc (do Right h <- fopen fn (pstring p)

19− ifM validFile h

19+ | Left err => return (Left ())

20− then return (Right (OpenH h))

20+ return (Right (OpenH h)))

21− else return (Left ()))

22

21

23close : FILE p -> Updater ()

22close : FILE p -> Updater ()

24close (OpenH h) = iou (closeFile h)

23close (OpenH h) = iou (closeFile h)

25

24

26readLine : FILE Reading -> Reader String

25readLine : FILE Reading -> Reader String

27−readLine (OpenH h) = ior (fread h)

26+readLine (OpenH h) = ior (do Right str <- fGetLine h

27+ | return ""

28+ return str)

28

29

29eof : FILE Reading -> Reader Bool

30eof : FILE Reading -> Reader Bool

30−eof (OpenH h) = ior (feof h)

31+eof (OpenH h) = ior (fEOF h)

31

32

32syntax rclose [h] = Update close h

33syntax rclose [h] = Update close h

33syntax rreadLine [h] = Use readLine h

34syntax rreadLine [h] = Use readLine h

test/effects003/foodeleted−9236