347fa38 · Idris-dev · git.iko.soy

.gitignore+2

compare with master

unifiedsplit

@@ -16,6 +16,7 @@ cabal.config

16*~

17.DS_Store

18.hpc

19+*.orig

19*.tix

20*.tix

20.projectile

21.projectile

21.dir-locals.el

22.dir-locals.el

@@ -27,6 +28,7 @@ libs/contrib/contrib_doc/

27test/output

28test/output

28test/*[0-9][0-9][0-9]/output

29test/*[0-9][0-9][0-9]/output

29test/*[0-9][0-9][0-9]/*.exe

30test/*[0-9][0-9][0-9]/*.exe

31+test/runtest.exe

30tags

32tags

31TAGS

33TAGS

32src/Version_idris.hs

34src/Version_idris.hs

CHANGELOG+60

@@ -1,3 +1,63 @@

1+New in 0.11:

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

3+

4+Updated export rules

5+--------------------

6+

7+* The export rules are:

8+ - 'private' means that the definition is not exported at all

9+ - 'export' means that the top level type is exported, but not the

10+ definition. In the case of 'data', this means the type constructor is

11+ exported but not the data constructors.

12+ - 'public export' means that the entire definition is exported.

13+* By default, names are 'private'. This can be altered with an %access

14+ directive as before.

15+* Exported types can only refer to other exported names

16+* Publicly exported definitions can only refer to publicly exported names

17+

18+Improved C FFI

19+--------------

20+

21+* Idris functions can now be passed as callbacks to C functions or wrapped

22+in a C function pointer.

23+* C function pointers can be called.

24+* Idris can access pointers to C globals.

25+

26+Minor language changes

27+----------------------

28+

29+* The '[static]' annotation is changed to '%static' to be consistent with the

30+ other annotations.

31+* Added '%auto_implicits' directive. The default is '%auto_implicits on'.

32+ Placing '%auto_implicits off' in a source file means that after that

33+ point, any implicit arguments must be bound, e.g.:

34+ append : {n,m,a:_} -> Vect n a -> Vect m a -> Vect (n + m) a

35+

36+ Only names which are used explicitly in the type need to be bound, e.g.:

37+ Here : {x, xs : _} -> Elem x (x :: xs)

38+

39+ In 'Here', there is no need to bind any of the variables in the type of

40+ 'xs' (it could be e.g. List a or Vect n a; 'a' and 'n' will still be

41+ implicitly bound).

42+

43+ You can still implicitly bind with 'using':

44+

45+ using (xs : Vect _ _)

46+ data Elem : {a, n : _} -> a -> Vect n a -> Type where

47+ Here : {x : _} -> Elem x (x :: xs)

48+ There : {x, y : _} -> Elem x xs -> Elem x (y :: xs)

49+

50+ However, note that *only* names which appear in *both* the using block

51+ *and* the type being defined will be implicitly bound. The following will

52+ therefore fail because 'n' isn't implicitly bound:

53+

54+ using (xs : Vect n a)

55+ bad : Elem x xs -> Elem x (y :: xs)

56+* `Sigma` has been renamed to `DPair`.

57+* Accessor functions for dependent pairs have been renamed to bring them into

58+ line with standard accessor functions for pairs. The function `getWitness`

59+ is now `fst`, and `getProof` is `snd`.

60+

1New in 0.10:

61New in 0.10:

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

62============

3

63

INSTALL.md+8−3

@@ -63,9 +63,9 @@ contribute.

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

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

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

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

66+building Idris from source with stack.

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

67+This installation has been tested on Ubuntu 14.04.2 LTS, and the current

68−only.

68+NixOS unstable.

69

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

71

@@ -77,6 +77,11 @@ haven't used stack before this will also setup the related

77infrastructure. For more information about Stack please visit the

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

79

80+On NixOS, please use the following command instead, to make sure

81+the required libraries and header files are available:

82+

83+* `stack build --nix`

84+

80### System GHC

85### System GHC

81

86

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

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

Makefile+3−14

@@ -20,24 +20,13 @@ build: dist/setup-config

20test: doc test_c

21

22test_c:

23− $(MAKE) -C test IDRIS=../dist/build/idris

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

24−

25−test_java:

26− $(MAKE) -C test IDRIS=../dist/build/idris test_java

27−

28−test_llvm:

29− $(MAKE) -C test IDRIS=../dist/build/idris test_llvm

30

24

31test_js:

25test_js:

32− $(MAKE) -C test IDRIS=../dist/build/idris test_js

26+ $(MAKE) -C test IDRIS=../dist/build/idris/idris test_js

33−

34−test_all:

35− $(MAKE) test

36− $(MAKE) test_llvm

37− $(MAKE) test_java

38

27

39test_timed:

28test_timed:

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

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

41

30

42lib_clean:

31lib_clean:

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

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

Setup.hs+19

@@ -10,6 +10,7 @@ import Distribution.Simple.LocalBuildInfo as L

10import qualified Distribution.Simple.Setup as S

11import qualified Distribution.Simple.Program as P

12import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile)

13+import Distribution.Compiler

13import Distribution.PackageDescription

14import Distribution.PackageDescription

14import Distribution.Text

15import Distribution.Text

15

16

@@ -45,6 +46,9 @@ mymake = "make"

45make verbosity =

46make verbosity =

46 P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake

47 P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake

47

48

49+#ifdef mingw32_HOST_OS

50+windres verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "windres"

51+#endif

48-- -----------------------------------------------------------------------------

52-- -----------------------------------------------------------------------------

49-- Flags

53-- Flags

50

54

@@ -198,6 +202,20 @@ getVersion args flags = do

198 let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo

202 let buildinfo = (emptyBuildInfo { cppOptions = ["-DVERSION="++hash] }) :: BuildInfo

199 return (Just buildinfo, [])

203 return (Just buildinfo, [])

200

204

205+

206+

207+idrisPreBuild args flags = do

208+#ifdef mingw32_HOST_OS

209+ createDirectoryIfMissingVerbose verbosity True dir

210+ windres verbosity ["icons/idris_icon.rc","-o", dir++"idris_icon.o"]

211+ return (Nothing, [("idris", emptyBuildInfo { ldOptions = [dir ++ "idris_icon.o"] })])

212+ where

213+ verbosity = S.fromFlag $ S.buildVerbosity flags

214+ dir = S.fromFlagOrDefault "dist" $ S.buildDistPref flags

215+#else

216+ return (Nothing, [])

217+#endif

218+

201idrisBuild _ flags _ local = unless (execOnly (configFlags local)) $ do

219idrisBuild _ flags _ local = unless (execOnly (configFlags local)) $ do

202 buildStdLib

220 buildStdLib

203 buildRTS

221 buildRTS

@@ -247,6 +265,7 @@ idrisInstall verbosity copy pkg local = unless (execOnly (configFlags local)) $

247main = defaultMainWithHooks $ simpleUserHooks

265main = defaultMainWithHooks $ simpleUserHooks

248 { postClean = idrisClean

266 { postClean = idrisClean

249 , postConf = idrisConfigure

267 , postConf = idrisConfigure

268+ , preBuild = idrisPreBuild

250 , postBuild = idrisBuild

269 , postBuild = idrisBuild

251 , postCopy = \_ flags pkg local ->

270 , postCopy = \_ flags pkg local ->

252 idrisInstall (S.fromFlag $ S.copyVerbosity flags)

271 idrisInstall (S.fromFlag $ S.copyVerbosity flags)

benchmarks/quasigroups/Parser.idr+2

@@ -5,6 +5,8 @@ import Data.Vect

5

6import Solver

7

8+%access public export

9+

8ParseErr : Type

10ParseErr : Type

9ParseErr = String

11ParseErr = String

10

12

benchmarks/quasigroups/Solver.idr+2−1

@@ -6,6 +6,7 @@ import Data.Vect

6import Data.Vect.Quantifiers

7

8%default total

9+%access public export

9

10

10Cell : Nat -> Type

11Cell : Nat -> Type

11Cell n = Maybe (Fin n)

12Cell n = Maybe (Fin n)

@@ -32,7 +33,7 @@ unlines (l::ls) = pack (foldl addLine (unpack l) (map unpack ls))

32 addLine : List Char -> List Char -> List Char

33 addLine : List Char -> List Char -> List Char

33 addLine w s = w ++ ('\n' :: s)

34 addLine w s = w ++ ('\n' :: s)

34

35

35−instance Show (Board n) where

36+Show (Board n) where

36 show (MkBoard rs) = unlines (map showRow rs)

37 show (MkBoard rs) = unlines (map showRow rs)

37

38

38updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a

39updateAt : Fin n -> Vect n a -> (a -> a) -> Vect n a

docs/conf.py+4−4

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

59# built documents.

60#

61# The short X.Y version.

62−version = '0.9.19'

62+version = '0.10.1'

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

64−release = '0.9.19.1'

64+release = '0.10.1'

65

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

67# for a list of supported languages.

@@ -234,9 +234,9 @@ latex_elements = {

234# (source start file, target name, title,

235# author, documentclass [howto, manual, or own class]).

236latex_documents = [

237− ('guides/index', 'idris-guides.tex', u'Idris Tutorial Series', u'The Idris Community', 'manual'),

238− ('reference/index', 'idris-reference.tex', u'The Idris Reference', u'The Idris Community', 'manual'),

239 ('tutorial/index', 'idris-tutorial.tex', u'The Idris Tutorial', u'The Idris Community', 'manual'),

237 ('tutorial/index', 'idris-tutorial.tex', u'The Idris Tutorial', u'The Idris Community', 'manual'),

238+ ('guides/index', 'idris-guides.tex', u'Idris Tutorial Series', u'The Idris Community', 'manual'),

239+# ('reference/index', 'idris-reference.tex', u'The Idris Reference', u'The Idris Community', 'manual'),

240 ('effects/index', 'eff-tutorial.tex', u'The Effects Tutorial', u'The Idris Community', 'manual')

241 ]

242

docs/faq/faq.rst+7−4

@@ -187,13 +187,16 @@ It’s not a priority, though not a bad idea in the long run. It would be a

187worthwhile effort in the short term to implement libraries to support

188self-hosting, such as a good parsing library.

189

190−Does Idris have Universe Polymorphism? What is the type of ``Type``?

190+Does Idris have universe polymorphism? What is the type of ``Type``?

191====================================================================

192

193−Rather than Universe polymorphism, Idris has a cumulative hierarchy of

193+Rather than universe polymorphism, Idris has a cumulative hierarchy of

194universes; ``Type : Type 1``, ``Type 1 : Type 2``, etc.

195−Cumulativity means that if ``x : Type n`` then also ``x : Type m``,

195+Cumulativity means that if ``x : Type n`` and ``n <= m``, then

196−provided that ``n <= m``.

196+``x : Type m``. Universe levels are always inferred by Idris, and

197+cannot be specified explicitly. The REPL command ``:type Type 1`` will

198+result in an errror, as will attempting to specify the universe level

199+of any type.

197

200

198Why does Idris use ``Float`` and ``Double`` instead of ``Float32`` and ``Float64``?

201Why does Idris use ``Float`` and ``Double`` instead of ``Float32`` and ``Float64``?

199===================================================================================

202===================================================================================

docs/reference/language-features.rst+1−1

@@ -46,7 +46,7 @@ Core Language Features

46 using the ``UniqueType`` universe.

47- `Partial

48 evaluation <https://github.com/idris-lang/Idris-dev/wiki/Static-Arguments-and-Partial-Evaluation>`__

49− by ``[static]`` argument annotations.

49+ by ``%static`` argument annotations.

50- Error message reflection

51- Eliminators

52- Label types ``'name``

docs/reference/syntax-guide.rst+3−3

@@ -303,8 +303,8 @@ Visibility

303

304::

305

306− public

306+ public export

307− abstract

307+ export

308 private

309

310Totality

@@ -372,7 +372,7 @@ Comments

372 -- Single Line

373 {- Multiline -}

374 ||| Docstring (goes before definition)

375−

375+

376Multi line String literals

377~~~~~~~~~~~~~~~~~~~~~~~~~~

378

docs/tutorial/modules.rst+79−31

@@ -75,56 +75,101 @@ main module, with the ``main`` function, must be called

75Export Modifiers

76================

77

78+Idris allows for fine-grained control over the visibility of a

78−By default, all names defined in a module are exported for use by other

79+module's contents. By default, all names defined in a module are kept

79−modules. However, it is good practice only to export a minimal interface

80+private. This aides in specification of a minimal interface and for

80−and keep internal details abstract. Idris allows functions, types,

81+internal details to be left hidden. Idris allows for functions,

81−and interfaces to be marked as: ``public``, ``abstract`` or ``private``:

82+types, and interfaces to be marked as: ``private``, ``export``, or

82−

83+``public export``. Their general meaning is as follows:

83−- ``public`` means that both the name and definition are exported. For

84+

84− functions, this means that the implementation is exported (which

85+- ``private`` meaning that it's not exported at all. This is the

85− means, for example, it can be used in a dependent type). For data

86+ default.

86− types, this means that the type name and the constructors are

87+

87− exported. For interfaces, this means that the interface name and method

88+- ``export`` meaning that its top level type is exported.

88− names are exported.

89+

89−

90+- ``public export`` meaning that the entire definition is exported.

90−- ``abstract`` means that only the name is exported. For functions,

91+

91− this means that the implementation is not exported. For data types,

92+

92− this means that the type name is exported but not the constructors.

93+A further restriction in modifying the visibility is that definitions

93− For interfaces, this means that the interface name is exported but not the

94+must not refer to anything within a lower level of visibility. For

94− method names.

95+example, ``public export`` definitions cannot use private names, and

95−

96+``export`` types cannot use private names. This is to prevent private

96−- ``private`` means that neither the name nor the definition is

97+names leaking into a module's interface.

97− exported.

98+

99+Meaning for Functions

100+---------------------

101+

102+- ``export`` the type is exported

103+

104+- ``public export`` the type and definition are exported, and the

105+ definition can be used after it is imported. In other words, the

106+ definition itself is considered part of the module's interface. The

107+ long name ``public export`` is intended to make you think twice

108+ about doing this.

98

109

99.. note::

110.. note::

100− If any definition is given an export modifier, then all names with no modifier are assumed to be ``private``.

101

111

112+ Type synonyms in Idris are created by writing a function. When

113+ setting the visibility for a module, it might be a good idea to

114+ ``public export`` all type synonyms if they are to be used outside

115+ the module. Otherwise, Idris won't know what the synonym is a

116+ synonym for.

117+

118+

119+Meaning for Data Types

120+----------------------

121+

122+For data types, the meanings are:

123+

124+- ``export`` the type constructor is exported

125+

126+- ``public export`` the type constructor and data constructors are

127+ exported

128+

129+

130+Meaning for Interfaces

131+----------------------

132+

133+For interfaces, the meanings are:

134+

135+- ``export`` the interface name is exported

136+- ``public export`` the interface name, method names and default

137+ definitions are exported

138+

139+

140+

141+``BTree`` Revisited

142++++++++++++++++++++

143+

102−For our ``Btree`` module, it makes sense for the tree data type and the

144+For our ``BTree`` module, it makes sense for the tree data type and the

103−functions to be exported as ``abstract``, as we see below:

145+functions to be exported as ``export``, as we see below:

104

146

105.. code-block:: idris

147.. code-block:: idris

106

148

107− module Btree

149+ module BTree

108

150

109− abstract data BTree a = Leaf

151+ export data BTree a = Leaf

110− | Node (BTree a) a (BTree a)

152+ | Node (BTree a) a (BTree a)

111

153

112− abstract

154+ export

113 insert : Ord a => a -> BTree a -> BTree a

155 insert : Ord a => a -> BTree a -> BTree a

114 insert x Leaf = Node Leaf x Leaf

156 insert x Leaf = Node Leaf x Leaf

115 insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)

157 insert x (Node l v r) = if (x < v) then (Node (insert x l) v r)

116 else (Node l v (insert x r))

158 else (Node l v (insert x r))

117

159

118− abstract

160+ export

119 toList : BTree a -> List a

161 toList : BTree a -> List a

120 toList Leaf = []

162 toList Leaf = []

121 toList (Node l v r) = Btree.toList l ++ (v :: Btree.toList r)

163 toList (Node l v r) = Btree.toList l ++ (v :: Btree.toList r)

122

164

123− abstract

165+ export

124 toTree : Ord a => List a -> BTree a

166 toTree : Ord a => List a -> BTree a

125 toTree [] = Leaf

167 toTree [] = Leaf

126 toTree (x :: xs) = insert x (toTree xs)

168 toTree (x :: xs) = insert x (toTree xs)

127

169

170+``%access`` Directive

171+----------------------

172+

128Finally, the default export mode can be changed with the ``%access``

173Finally, the default export mode can be changed with the ``%access``

129directive, for example:

174directive, for example:

130

175

@@ -132,7 +177,7 @@ directive, for example:

132

177

133 module Btree

178 module Btree

134

179

135− %access abstract

180+ %access export

136

181

137 data BTree a = Leaf

182 data BTree a = Leaf

138 | Node (BTree a) a (BTree a)

183 | Node (BTree a) a (BTree a)

@@ -151,7 +196,10 @@ directive, for example:

151 toTree (x :: xs) = insert x (toTree xs)

196 toTree (x :: xs) = insert x (toTree xs)

152

197

153In this case, any function with no access modifier will be exported as

198In this case, any function with no access modifier will be exported as

154−``abstract``, rather than left ``private``.

199+``export``, rather than left ``private``.

200+

201+Propagating Inner Module API's

202+-------------------------------

155

203

156Additionally, a module can re-export a module it has imported, by using

204Additionally, a module can re-export a module it has imported, by using

157the ``public`` modifier on an ``import``. For example:

205the ``public`` modifier on an ``import``. For example:

icons/idris_icon.rcnew file+1

@@ -0,0 +1 @@

1+0 ICON "idris.ico"

idris-tutorial.pdf

Binary file not shown.

idris.cabal+47−13

@@ -150,7 +150,7 @@ Extra-source-files:

150 libs/pruviloj/Pruviloj/Internals/*.idr

151

152 test/Makefile

153− test/runtest.pl

153+ test/runtest.hs

154 test/reg001/run

155 test/reg001/*.idr

156 test/reg001/expected

@@ -163,6 +163,9 @@ Extra-source-files:

163 test/reg004/run

164 test/reg004/*.idr

165 test/reg004/expected

166+ test/reg005/run

167+ test/reg005/*.idr

168+ test/reg005/expected

166 test/reg006/run

169 test/reg006/run

167 test/reg006/*.idr

170 test/reg006/*.idr

168 test/reg006/expected

171 test/reg006/expected

@@ -361,6 +364,9 @@ Extra-source-files:

361 test/basic016/run

364 test/basic016/run

362 test/basic016/*.idr

365 test/basic016/*.idr

363 test/basic016/expected

366 test/basic016/expected

367+ test/basic017/run

368+ test/basic017/*.idr

369+ test/basic017/expected

364

370

365 test/bignum001/run

371 test/bignum001/run

366 test/bignum001/*.idr

372 test/bignum001/*.idr

@@ -462,6 +468,11 @@ Extra-source-files:

462 test/ffi006/*.c

468 test/ffi006/*.c

463 test/ffi006/run

469 test/ffi006/run

464 test/ffi006/expected

470 test/ffi006/expected

471+ test/ffi007/*.idr

472+ test/ffi007/*.c

473+ test/ffi007/*.h

474+ test/ffi007/run

475+ test/ffi007/expected

465

476

466 test/folding001/*.idr

477 test/folding001/*.idr

467 test/folding001/run

478 test/folding001/run

@@ -587,12 +598,14 @@ Extra-source-files:

587 test/primitives003/expected

598 test/primitives003/expected

588 test/primitives005/run

599 test/primitives005/run

589 test/primitives005/*.idr

600 test/primitives005/*.idr

590− test/primitives005/array.c

591− test/primitives005/array.h

592− test/primitives005/Data/Bytes.idr

593− test/primitives005/Data/ByteArray.idr

594 test/primitives005/expected

601 test/primitives005/expected

595

602

603+ test/primitives006/array.c

604+ test/primitives006/array.h

605+ test/primitives006/Data/Bytes.idr

606+ test/primitives006/Data/ByteArray.idr

607+ test/primitives006/expected

608+

596 test/pkg001/run

609 test/pkg001/run

597 test/pkg001/test.ipkg

610 test/pkg001/test.ipkg

598 test/pkg001/*.idr

611 test/pkg001/*.idr

@@ -795,6 +808,9 @@ Extra-source-files:

795 benchmarks/trivial/sortvec.idr

808 benchmarks/trivial/sortvec.idr

796 benchmarks/trivial/sortvec.ipkg

809 benchmarks/trivial/sortvec.ipkg

797

810

811+ icons/idris_icon.rc

812+ icons/idris.ico

813+

798source-repository head

814source-repository head

799 type: git

815 type: git

800 location: git://github.com/idris-lang/Idris-dev.git

816 location: git://github.com/idris-lang/Idris-dev.git

@@ -866,6 +882,7 @@ Library

866 , Idris.Elab.Transform

882 , Idris.Elab.Transform

867 , Idris.Elab.Value

883 , Idris.Elab.Value

868 , Idris.Elab.Term

884 , Idris.Elab.Term

885+ , Idris.Elab.Quasiquote

869

886

870 , Idris.REPL.Browse

887 , Idris.REPL.Browse

871

888

@@ -886,7 +903,6 @@ Library

886 , Idris.Docs

903 , Idris.Docs

887 , Idris.Docstrings

904 , Idris.Docstrings

888 , Idris.ElabDecls

905 , Idris.ElabDecls

889− , Idris.ElabQuasiquote

890 , Idris.Erasure

906 , Idris.Erasure

891 , Idris.Error

907 , Idris.Error

892 , Idris.ErrReverse

908 , Idris.ErrReverse

@@ -899,10 +915,10 @@ Library

899 , Idris.Interactive

915 , Idris.Interactive

900 , Idris.Output

916 , Idris.Output

901 , Idris.Parser

917 , Idris.Parser

902− , Idris.ParseHelpers

918+ , Idris.Parser.Helpers

903− , Idris.ParseOps

919+ , Idris.Parser.Ops

904− , Idris.ParseExpr

920+ , Idris.Parser.Expr

905− , Idris.ParseData

921+ , Idris.Parser.Data

906 , Idris.PartialEval

922 , Idris.PartialEval

907 , Idris.Primitives

923 , Idris.Primitives

908 , Idris.ProofSearch

924 , Idris.ProofSearch

@@ -910,7 +926,7 @@ Library

910 , Idris.Providers

926 , Idris.Providers

911 , Idris.Reflection

927 , Idris.Reflection

912 , Idris.REPL

928 , Idris.REPL

913− , Idris.REPLParser

929+ , Idris.REPL.Parser

914 , Idris.Transforms

930 , Idris.Transforms

915 , Idris.TypeSearch

931 , Idris.TypeSearch

916 , Idris.Unlit

932 , Idris.Unlit

@@ -985,7 +1001,8 @@ Library

985 , zip-archive > 0.2.3.5 && < 0.2.4

1001 , zip-archive > 0.2.3.5 && < 0.2.4

986 , safe

1002 , safe

987 , fsnotify < 2.2

1003 , fsnotify < 2.2

988− , async < 2.1

1004+ , async < 2.2

1005+

989 -- zlib >= 0.6.1 is broken with GHC < 7.10.3

1006 -- zlib >= 0.6.1 is broken with GHC < 7.10.3

990 if impl(ghc < 7.10.3)

1007 if impl(ghc < 7.10.3)

991 build-depends: zlib < 0.6.1

1008 build-depends: zlib < 0.6.1

@@ -999,7 +1016,6 @@ Library

999 , TemplateHaskell

1016 , TemplateHaskell

1000

1017

1001 ghc-prof-options: -auto-all -caf-all

1018 ghc-prof-options: -auto-all -caf-all

1002− ghc-options: -threaded -rtsopts

1003

1019

1004 if os(linux)

1020 if os(linux)

1005 cpp-options: -DLINUX

1021 cpp-options: -DLINUX

@@ -1046,6 +1062,24 @@ Executable idris

1046 ghc-prof-options: -auto-all -caf-all

1062 ghc-prof-options: -auto-all -caf-all

1047 ghc-options: -threaded -rtsopts -funbox-strict-fields

1063 ghc-options: -threaded -rtsopts -funbox-strict-fields

1048

1064

1065+Test-suite regression-and-sanity-tests

1066+ Type: exitcode-stdio-1.0

1067+ Main-is: runtest.hs

1068+ hs-source-dirs: test

1069+

1070+ Build-depends: idris

1071+ , base

1072+ , containers

1073+ , process

1074+ , time

1075+ , filepath

1076+ , directory

1077+ , haskeline >= 0.7

1078+ , transformers

1079+

1080+ ghc-prof-options: -auto-all -caf-all

1081+ ghc-options: -threaded -rtsopts -funbox-strict-fields

1082+

1049Executable idris-codegen-c

1083Executable idris-codegen-c

1050 Main-is: Main.hs

1084 Main-is: Main.hs

1051 hs-source-dirs: codegen/idris-codegen-c

1085 hs-source-dirs: codegen/idris-codegen-c

libs/base/Control/Arrow.idr+1−1

@@ -3,7 +3,7 @@ module Control.Arrow

3import Data.Morphisms

4import Control.Category

5

6−%access public

6+%access public export

7

8infixr 5 <++>

9infixr 3 ***

libs/base/Control/Catchable.idr+2

@@ -2,6 +2,8 @@ module Control.Catchable

2

3import Control.IOExcept

4

5+%access public export

6+

5interface Catchable (m : Type -> Type) t where

7interface Catchable (m : Type -> Type) t where

6 throw : t -> m a

8 throw : t -> m a

7 catch : m a -> (t -> m a) -> m a

9 catch : m a -> (t -> m a) -> m a

libs/base/Control/Category.idr+1−1

@@ -2,7 +2,7 @@ module Control.Category

2

3import Data.Morphisms

4

5−%access public

5+%access public export

6

7interface Category (cat : Type -> Type -> Type) where

8 id : cat a a

libs/base/Control/IOExcept.idr+2

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

1module Control.IOExcept

2

3+%access public export

4+

3-- An IO monad with exception handling

5-- An IO monad with exception handling

4

6

5record IOExcept' (f:FFI) err a where

7record IOExcept' (f:FFI) err a where

libs/base/Control/Isomorphism.idr+1

@@ -4,6 +4,7 @@ import Syntax.PreorderReasoning

4import Data.Fin

5

6%default total

7+%access public export

7

8

8||| An isomorphism between two types

9||| An isomorphism between two types

9data Iso : Type -> Type -> Type where

10data Iso : Type -> Type -> Type where

libs/base/Control/Monad/Identity.idr+3−1

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

1module Control.Monad.Identity

2

3+%access public export

4+

3−public record Identity (a : Type) where

5+public export record Identity (a : Type) where

4 constructor Id

6 constructor Id

5 runIdentity : a

7 runIdentity : a

6

8

libs/base/Control/Monad/RWS.idr+1−1

@@ -5,7 +5,7 @@ import Control.Monad.State

5import Control.Monad.Writer

6import Control.Monad.Reader

7

8−%access public

8+%access public export

9

10||| A combination of the Reader, Writer, and State monads

11interface (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m) => MonadRWS r w s (m : Type -> Type) where {}

libs/base/Control/Monad/Reader.idr+1−1

@@ -4,7 +4,7 @@ import Builtins

4import Control.Monad.Identity

5import Control.Monad.Trans

6

7−%access public

7+%access public export

8

9||| A monad representing a computation that runs in an immutable context

10interface Monad m => MonadReader r (m : Type -> Type) where

libs/base/Control/Monad/State.idr+1−1

@@ -3,7 +3,7 @@ module Control.Monad.State

3import public Control.Monad.Identity

4import public Control.Monad.Trans

5

6−%access public

6+%access public export

7

8||| A computation which runs in a context and produces an output

9interface Monad m => MonadState s (m : Type -> Type) | m where

libs/base/Control/Monad/Trans.idr+2

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

1module Control.Monad.Trans

2

3+%access public export

4+

3interface MonadTrans (t : (Type -> Type) -> Type -> Type) where

5interface MonadTrans (t : (Type -> Type) -> Type -> Type) where

4 lift : Monad m => m a -> t m a

6 lift : Monad m => m a -> t m a

libs/base/Control/Monad/Writer.idr+1−1

@@ -4,7 +4,7 @@ import Builtins

4import Control.Monad.Identity

5import Control.Monad.Trans

6

7−%access public

7+%access public export

8

9||| A monad representing a computation that produces a stream of output

10interface (Monoid w, Monad m) => MonadWriter w (m : Type -> Type) where

libs/base/Data/Bits.idr+51−32

@@ -4,7 +4,7 @@ import Data.Fin

4

5%default total

6

7−public

7+public export

8nextPow2 : Nat -> Nat

9nextPow2 Z = Z

10nextPow2 (S x) = if (S x) == (2 `power` l2x)

@@ -13,11 +13,11 @@ nextPow2 (S x) = if (S x) == (2 `power` l2x)

13 where

14 l2x = log2NZ (S x) SIsNotZ

15

16−public

16+public export

17nextBytes : Nat -> Nat

18nextBytes bits = (nextPow2 (divCeilNZ bits 8 SIsNotZ))

19

20−public

20+public export

21machineTy : Nat -> Type

22machineTy Z = Bits8

23machineTy (S Z) = Bits16

@@ -47,7 +47,7 @@ natToBits {n=n} x with (n)

47getPad : Nat -> machineTy n

48getPad n = natToBits (minus (bitsUsed (nextBytes n)) n)

49

50−public

50+public export

51data Bits : Nat -> Type where

52 MkBits : machineTy (nextBytes n) -> Bits n

53

@@ -92,6 +92,10 @@ pad64' n f x y = prim__lshrB64 (f (prim__shlB64 x pad) y) pad

92 where

93 pad = getPad {n=3} n

94

95+-- TODO: This (and all the other functions along these lings) is public export

96+-- because it is used by public export things. Do they really need to be

97+-- public export, or is export good enough?

98+public export

95shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

99shiftLeft' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

96shiftLeft' {n=n} x c with (nextBytes n)

100shiftLeft' {n=n} x c with (nextBytes n)

97 | Z = pad8' n prim__shlB8 x c

101 | Z = pad8' n prim__shlB8 x c

@@ -99,10 +103,11 @@ shiftLeft' {n=n} x c with (nextBytes n)

99 | S (S Z) = pad32' n prim__shlB32 x c

103 | S (S Z) = pad32' n prim__shlB32 x c

100 | S (S (S _)) = pad64' n prim__shlB64 x c

104 | S (S (S _)) = pad64' n prim__shlB64 x c

101

105

102−public

106+public export

103shiftLeft : Bits n -> Bits n -> Bits n

107shiftLeft : Bits n -> Bits n -> Bits n

104shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y)

108shiftLeft (MkBits x) (MkBits y) = MkBits (shiftLeft' x y)

105

109

110+public export

106shiftRightLogical' : machineTy n -> machineTy n -> machineTy n

111shiftRightLogical' : machineTy n -> machineTy n -> machineTy n

107shiftRightLogical' {n=n} x c with (n)

112shiftRightLogical' {n=n} x c with (n)

108 | Z = prim__lshrB8 x c

113 | Z = prim__lshrB8 x c

@@ -110,11 +115,12 @@ shiftRightLogical' {n=n} x c with (n)

110 | S (S Z) = prim__lshrB32 x c

115 | S (S Z) = prim__lshrB32 x c

111 | S (S (S _)) = prim__lshrB64 x c

116 | S (S (S _)) = prim__lshrB64 x c

112

117

113−public

118+public export

114shiftRightLogical : Bits n -> Bits n -> Bits n

119shiftRightLogical : Bits n -> Bits n -> Bits n

115shiftRightLogical {n} (MkBits x) (MkBits y)

120shiftRightLogical {n} (MkBits x) (MkBits y)

116 = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y)

121 = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y)

117

122

123+public export

118shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

124shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

119shiftRightArithmetic' {n=n} x c with (nextBytes n)

125shiftRightArithmetic' {n=n} x c with (nextBytes n)

120 | Z = pad8' n prim__ashrB8 x c

126 | Z = pad8' n prim__ashrB8 x c

@@ -122,10 +128,11 @@ shiftRightArithmetic' {n=n} x c with (nextBytes n)

122 | S (S Z) = pad32' n prim__ashrB32 x c

128 | S (S Z) = pad32' n prim__ashrB32 x c

123 | S (S (S _)) = pad64' n prim__ashrB64 x c

129 | S (S (S _)) = pad64' n prim__ashrB64 x c

124

130

125−public

131+public export

126shiftRightArithmetic : Bits n -> Bits n -> Bits n

132shiftRightArithmetic : Bits n -> Bits n -> Bits n

127shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y)

133shiftRightArithmetic (MkBits x) (MkBits y) = MkBits (shiftRightArithmetic' x y)

128

134

135+public export

129and' : machineTy n -> machineTy n -> machineTy n

136and' : machineTy n -> machineTy n -> machineTy n

130and' {n=n} x y with (n)

137and' {n=n} x y with (n)

131 | Z = prim__andB8 x y

138 | Z = prim__andB8 x y

@@ -133,10 +140,11 @@ and' {n=n} x y with (n)

133 | S (S Z) = prim__andB32 x y

140 | S (S Z) = prim__andB32 x y

134 | S (S (S _)) = prim__andB64 x y

141 | S (S (S _)) = prim__andB64 x y

135

142

136−public

143+public export

137and : Bits n -> Bits n -> Bits n

144and : Bits n -> Bits n -> Bits n

138and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y)

145and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y)

139

146

147+public export

140or' : machineTy n -> machineTy n -> machineTy n

148or' : machineTy n -> machineTy n -> machineTy n

141or' {n=n} x y with (n)

149or' {n=n} x y with (n)

142 | Z = prim__orB8 x y

150 | Z = prim__orB8 x y

@@ -144,10 +152,11 @@ or' {n=n} x y with (n)

144 | S (S Z) = prim__orB32 x y

152 | S (S Z) = prim__orB32 x y

145 | S (S (S _)) = prim__orB64 x y

153 | S (S (S _)) = prim__orB64 x y

146

154

147−public

155+public export

148or : Bits n -> Bits n -> Bits n

156or : Bits n -> Bits n -> Bits n

149or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y)

157or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y)

150

158

159+public export

151xor' : machineTy n -> machineTy n -> machineTy n

160xor' : machineTy n -> machineTy n -> machineTy n

152xor' {n=n} x y with (n)

161xor' {n=n} x y with (n)

153 | Z = prim__xorB8 x y

162 | Z = prim__xorB8 x y

@@ -155,10 +164,11 @@ xor' {n=n} x y with (n)

155 | S (S Z) = prim__xorB32 x y

164 | S (S Z) = prim__xorB32 x y

156 | S (S (S _)) = prim__xorB64 x y

165 | S (S (S _)) = prim__xorB64 x y

157

166

158−public

167+public export

159xor : Bits n -> Bits n -> Bits n

168xor : Bits n -> Bits n -> Bits n

160xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y)

169xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y)

161

170

171+public export

162plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

172plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

163plus' {n=n} x y with (nextBytes n)

173plus' {n=n} x y with (nextBytes n)

164 | Z = pad8 n prim__addB8 x y

174 | Z = pad8 n prim__addB8 x y

@@ -166,10 +176,11 @@ plus' {n=n} x y with (nextBytes n)

166 | S (S Z) = pad32 n prim__addB32 x y

176 | S (S Z) = pad32 n prim__addB32 x y

167 | S (S (S _)) = pad64 n prim__addB64 x y

177 | S (S (S _)) = pad64 n prim__addB64 x y

168

178

169−public

179+public export

170plus : Bits n -> Bits n -> Bits n

180plus : Bits n -> Bits n -> Bits n

171plus (MkBits x) (MkBits y) = MkBits (plus' x y)

181plus (MkBits x) (MkBits y) = MkBits (plus' x y)

172

182

183+public export

173minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

184minus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

174minus' {n=n} x y with (nextBytes n)

185minus' {n=n} x y with (nextBytes n)

175 | Z = pad8 n prim__subB8 x y

186 | Z = pad8 n prim__subB8 x y

@@ -177,10 +188,11 @@ minus' {n=n} x y with (nextBytes n)

177 | S (S Z) = pad32 n prim__subB32 x y

188 | S (S Z) = pad32 n prim__subB32 x y

178 | S (S (S _)) = pad64 n prim__subB64 x y

189 | S (S (S _)) = pad64 n prim__subB64 x y

179

190

180−public

191+public export

181minus : Bits n -> Bits n -> Bits n

192minus : Bits n -> Bits n -> Bits n

182minus (MkBits x) (MkBits y) = MkBits (minus' x y)

193minus (MkBits x) (MkBits y) = MkBits (minus' x y)

183

194

195+public export

184times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

196times' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

185times' {n=n} x y with (nextBytes n)

197times' {n=n} x y with (nextBytes n)

186 | Z = pad8 n prim__mulB8 x y

198 | Z = pad8 n prim__mulB8 x y

@@ -188,11 +200,12 @@ times' {n=n} x y with (nextBytes n)

188 | S (S Z) = pad32 n prim__mulB32 x y

200 | S (S Z) = pad32 n prim__mulB32 x y

189 | S (S (S _)) = pad64 n prim__mulB64 x y

201 | S (S (S _)) = pad64 n prim__mulB64 x y

190

202

191−public

203+public export

192times : Bits n -> Bits n -> Bits n

204times : Bits n -> Bits n -> Bits n

193times (MkBits x) (MkBits y) = MkBits (times' x y)

205times (MkBits x) (MkBits y) = MkBits (times' x y)

194

206

195partial

207partial

208+public export

196sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

209sdiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

197sdiv' {n=n} x y with (nextBytes n)

210sdiv' {n=n} x y with (nextBytes n)

198 | Z = prim__sdivB8 x y

211 | Z = prim__sdivB8 x y

@@ -200,11 +213,12 @@ sdiv' {n=n} x y with (nextBytes n)

200 | S (S Z) = prim__sdivB32 x y

213 | S (S Z) = prim__sdivB32 x y

201 | S (S (S _)) = prim__sdivB64 x y

214 | S (S (S _)) = prim__sdivB64 x y

202

215

203−public partial

216+public export partial

204sdiv : Bits n -> Bits n -> Bits n

217sdiv : Bits n -> Bits n -> Bits n

205sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y)

218sdiv (MkBits x) (MkBits y) = MkBits (sdiv' x y)

206

219

207partial

220partial

221+public export

208udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

222udiv' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

209udiv' {n=n} x y with (nextBytes n)

223udiv' {n=n} x y with (nextBytes n)

210 | Z = prim__udivB8 x y

224 | Z = prim__udivB8 x y

@@ -212,11 +226,11 @@ udiv' {n=n} x y with (nextBytes n)

212 | S (S Z) = prim__udivB32 x y

226 | S (S Z) = prim__udivB32 x y

213 | S (S (S _)) = prim__udivB64 x y

227 | S (S (S _)) = prim__udivB64 x y

214

228

215−public partial

229+public export partial

216udiv : Bits n -> Bits n -> Bits n

230udiv : Bits n -> Bits n -> Bits n

217udiv (MkBits x) (MkBits y) = MkBits (udiv' x y)

231udiv (MkBits x) (MkBits y) = MkBits (udiv' x y)

218

232

219−partial

233+public export partial

220srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

234srem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

221srem' {n=n} x y with (nextBytes n)

235srem' {n=n} x y with (nextBytes n)

222 | Z = prim__sremB8 x y

236 | Z = prim__sremB8 x y

@@ -224,11 +238,11 @@ srem' {n=n} x y with (nextBytes n)

224 | S (S Z) = prim__sremB32 x y

238 | S (S Z) = prim__sremB32 x y

225 | S (S (S _)) = prim__sremB64 x y

239 | S (S (S _)) = prim__sremB64 x y

226

240

227−public partial

241+public export partial

228srem : Bits n -> Bits n -> Bits n

242srem : Bits n -> Bits n -> Bits n

229srem (MkBits x) (MkBits y) = MkBits (srem' x y)

243srem (MkBits x) (MkBits y) = MkBits (srem' x y)

230

244

231−partial

245+public export partial

232urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

246urem' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

233urem' {n=n} x y with (nextBytes n)

247urem' {n=n} x y with (nextBytes n)

234 | Z = prim__uremB8 x y

248 | Z = prim__uremB8 x y

@@ -236,7 +250,7 @@ urem' {n=n} x y with (nextBytes n)

236 | S (S Z) = prim__uremB32 x y

250 | S (S Z) = prim__uremB32 x y

237 | S (S (S _)) = prim__uremB64 x y

251 | S (S (S _)) = prim__uremB64 x y

238

252

239−public partial

253+public export partial

240urem : Bits n -> Bits n -> Bits n

254urem : Bits n -> Bits n -> Bits n

241urem (MkBits x) (MkBits y) = MkBits (urem' x y)

255urem (MkBits x) (MkBits y) = MkBits (urem' x y)

242

256

@@ -276,9 +290,11 @@ gt {n=n} x y with (nextBytes n)

276 | S (S Z) = prim__gtB32 x y

290 | S (S Z) = prim__gtB32 x y

277 | S (S (S _)) = prim__gtB64 x y

291 | S (S (S _)) = prim__gtB64 x y

278

292

293+public export

279implementation Eq (Bits n) where

294implementation Eq (Bits n) where

280 (MkBits x) == (MkBits y) = boolOp eq x y

295 (MkBits x) == (MkBits y) = boolOp eq x y

281

296

297+public export

282implementation Ord (Bits n) where

298implementation Ord (Bits n) where

283 (MkBits x) < (MkBits y) = boolOp lt x y

299 (MkBits x) < (MkBits y) = boolOp lt x y

284 (MkBits x) <= (MkBits y) = boolOp lte x y

300 (MkBits x) <= (MkBits y) = boolOp lte x y

@@ -291,6 +307,7 @@ implementation Ord (Bits n) where

291 then EQ

307 then EQ

292 else GT

308 else GT

293

309

310+public export

294complement' : machineTy (nextBytes n) -> machineTy (nextBytes n)

311complement' : machineTy (nextBytes n) -> machineTy (nextBytes n)

295complement' {n=n} x with (nextBytes n)

312complement' {n=n} x with (nextBytes n)

296 | Z = let pad = getPad {n=0} n in

313 | Z = let pad = getPad {n=0} n in

@@ -302,12 +319,12 @@ complement' {n=n} x with (nextBytes n)

302 | S (S (S _)) = let pad = getPad {n=3} n in

319 | S (S (S _)) = let pad = getPad {n=3} n in

303 prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad

320 prim__complB64 (x `prim__shlB64` pad) `prim__lshrB64` pad

304

321

305−public

322+public export

306complement : Bits n -> Bits n

323complement : Bits n -> Bits n

307complement (MkBits x) = MkBits (complement' x)

324complement (MkBits x) = MkBits (complement' x)

308

325

309-- TODO: Prove

326-- TODO: Prove

310−%assert_total -- can't verify coverage of with block

327+public export %assert_total -- can't verify coverage of with block

311zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

328zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

312zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

329zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

313 | (Z, Z) = believe_me x

330 | (Z, Z) = believe_me x

@@ -321,11 +338,11 @@ zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

321 | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x))

338 | (S (S Z), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x))

322 | (S (S (S _)), S (S (S _))) = believe_me x

339 | (S (S (S _)), S (S (S _))) = believe_me x

323

340

324−public

341+public export

325zeroExtend : Bits n -> Bits (n+m)

342zeroExtend : Bits n -> Bits (n+m)

326zeroExtend (MkBits x) = MkBits (zext' x)

343zeroExtend (MkBits x) = MkBits (zext' x)

327

344

328−%assert_total

345+public export %assert_total

329intToBits' : Integer -> machineTy (nextBytes n)

346intToBits' : Integer -> machineTy (nextBytes n)

330intToBits' {n=n} x with (nextBytes n)

347intToBits' {n=n} x with (nextBytes n)

331 | Z = let pad = getPad {n=0} n in

348 | Z = let pad = getPad {n=0} n in

@@ -337,13 +354,14 @@ intToBits' {n=n} x with (nextBytes n)

337 | S (S (S _)) = let pad = getPad {n=3} n in

354 | S (S (S _)) = let pad = getPad {n=3} n in

338 prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad

355 prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad

339

356

340−public

357+public export

341intToBits : Integer -> Bits n

358intToBits : Integer -> Bits n

342intToBits n = MkBits (intToBits' n)

359intToBits n = MkBits (intToBits' n)

343

360

344implementation Cast Integer (Bits n) where

361implementation Cast Integer (Bits n) where

345 cast = intToBits

362 cast = intToBits

346

363

364+public export

347bitsToInt' : machineTy (nextBytes n) -> Integer

365bitsToInt' : machineTy (nextBytes n) -> Integer

348bitsToInt' {n=n} x with (nextBytes n)

366bitsToInt' {n=n} x with (nextBytes n)

349 | Z = prim__zextB8_BigInt x

367 | Z = prim__zextB8_BigInt x

@@ -351,11 +369,12 @@ bitsToInt' {n=n} x with (nextBytes n)

351 | S (S Z) = prim__zextB32_BigInt x

369 | S (S Z) = prim__zextB32_BigInt x

352 | S (S (S _)) = prim__zextB64_BigInt x

370 | S (S (S _)) = prim__zextB64_BigInt x

353

371

354−public

372+public export

355bitsToInt : Bits n -> Integer

373bitsToInt : Bits n -> Integer

356bitsToInt (MkBits x) = bitsToInt' x

374bitsToInt (MkBits x) = bitsToInt' x

357

375

358-- Zero out the high bits of a truncated bitstring

376-- Zero out the high bits of a truncated bitstring

377+public export

359zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

378zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

360zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)

379zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)

361

380

@@ -393,12 +412,12 @@ sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

393 | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in

412 | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in

394 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

413 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

395

414

396−--public

415+--public export

397--signExtend : Bits n -> Bits (n+m)

416--signExtend : Bits n -> Bits (n+m)

398--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

417--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

399

418

400-- TODO: Prove

419-- TODO: Prove

401−%assert_total -- can't verify coverage of with block

420+public export %assert_total -- can't verify coverage of with block

402trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)

421trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)

403trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))

422trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))

404 | (Z, Z) = believe_me x

423 | (Z, Z) = believe_me x

@@ -412,23 +431,23 @@ trunc' {m=m} {n=n} x with (nextBytes n, nextBytes (m+n))

412 | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))

431 | (S (S Z), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))

413 | (S (S (S _)), S (S (S _))) = believe_me x

432 | (S (S (S _)), S (S (S _))) = believe_me x

414

433

415−public

434+public export

416truncate : Bits (m+n) -> Bits n

435truncate : Bits (m+n) -> Bits n

417truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

436truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

418

437

419−public

438+public export

420bitAt : Fin n -> Bits n

439bitAt : Fin n -> Bits n

421bitAt n = intToBits 1 `shiftLeft` intToBits (cast n)

440bitAt n = intToBits 1 `shiftLeft` intToBits (cast n)

422

441

423−public

442+public export

424getBit : Fin n -> Bits n -> Bool

443getBit : Fin n -> Bits n -> Bool

425getBit n x = (x `and` (bitAt n)) /= intToBits 0

444getBit n x = (x `and` (bitAt n)) /= intToBits 0

426

445

427−public

446+public export

428setBit : Fin n -> Bits n -> Bits n

447setBit : Fin n -> Bits n -> Bits n

429setBit n x = x `or` (bitAt n)

448setBit n x = x `or` (bitAt n)

430

449

431−public

450+public export

432unsetBit : Fin n -> Bits n -> Bits n

451unsetBit : Fin n -> Bits n -> Bits n

433unsetBit n x = x `and` complement (bitAt n)

452unsetBit n x = x `and` complement (bitAt n)

434

453

libs/base/Data/Complex.idr+2

@@ -5,6 +5,8 @@

5

6module Data.Complex

7

8+%access public export

9+

8------------------------------ Rectangular form

10------------------------------ Rectangular form

9

11

10infix 6 :+

12infix 6 :+

libs/base/Data/Erased.idr+1−1

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

1module Data.Erased

2

3−%access public

3+%access public export

4%default total

5

6||| The erasure monad.

libs/base/Data/Fin.idr+2−2

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

1module Data.Fin

2

3%default total

4−%access public

4+%access public export

5

6||| Numbers strictly less than some bound. The name comes from "finite sets".

7|||

@@ -149,7 +149,7 @@ mkFinIntegerErr lit finSize subErr

149 , TermPart `(Fin ~(getNat finSize))

150 , SubReport subErr

151 ]

152−total

152+total export

153finFromIntegerErrors : Err -> Maybe (List ErrorReportPart)

154finFromIntegerErrors (CantUnify x tm `(IsJust (integerToFin ~(TConst c) ~m)) err xs y)

155 = mkFinIntegerErr (TConst c) m

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

@@ -2,7 +2,7 @@ module Data.HVect

2

3import public Data.Vect

4

5−%access public

5+%access public export

6%default total

7

8||| Heterogeneous vectors where the type index gives, element-wise,

libs/base/Data/List.idr+2−2

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

1module Data.List

2

3−%access public

3+%access public export

4

5||| A proof that some element is found in a list.

6|||

@@ -13,7 +13,7 @@ data Elem : a -> List a -> Type where

13 ||| A proof that the element is after the front of the list

14 |||

15 ||| Example: `the (Elem "b" ["a", "b"]) (There Here)`

16− There : Elem x xs -> Elem x (y :: xs)

16+ There : (later : Elem x xs) -> Elem x (y :: xs)

17

18implementation Uninhabited (Elem {a} x []) where

19 uninhabited Here impossible

libs/base/Data/List/Quantifiers.idr+2

@@ -2,6 +2,8 @@ module Data.List.Quantifiers

2

3import Data.List

4

5+%access public export

6+

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

7||| A proof that some element of a list satisfies some property

6|||

8|||

7||| @ P the property to be satsified

9||| @ P the property to be satsified

libs/base/Data/Mod2.idr+5−4

@@ -5,26 +5,27 @@ import Data.Bits

5%default total

6

7||| Integers modulo 2^n

8−public

8+public export

9data Mod2 : Nat -> Type where

10 MkMod2 : {n : Nat} -> Bits n -> Mod2 n

11

12+public export

12modBin : (Bits n -> Bits n -> Bits n) -> Mod2 n -> Mod2 n -> Mod2 n

13modBin : (Bits n -> Bits n -> Bits n) -> Mod2 n -> Mod2 n -> Mod2 n

13modBin f (MkMod2 x) (MkMod2 y) = MkMod2 (f x y)

14modBin f (MkMod2 x) (MkMod2 y) = MkMod2 (f x y)

14

15

15modComp : (Bits n -> Bits n -> a) -> Mod2 n -> Mod2 n -> a

16modComp : (Bits n -> Bits n -> a) -> Mod2 n -> Mod2 n -> a

16modComp f (MkMod2 x) (MkMod2 y) = f x y

17modComp f (MkMod2 x) (MkMod2 y) = f x y

17

18

18−public partial

19+public export partial

19div : Mod2 n -> Mod2 n -> Mod2 n

20div : Mod2 n -> Mod2 n -> Mod2 n

20div = modBin udiv

21div = modBin udiv

21

22

22−public partial

23+public export partial

23rem : Mod2 n -> Mod2 n -> Mod2 n

24rem : Mod2 n -> Mod2 n -> Mod2 n

24rem = modBin urem

25rem = modBin urem

25

26

26%assert_total

27%assert_total

27−public

28+public export

28intToMod : {n : Nat} -> Integer -> Mod2 n

29intToMod : {n : Nat} -> Integer -> Mod2 n

29intToMod {n=n} x = MkMod2 (intToBits x)

30intToMod {n=n} x = MkMod2 (intToBits x)

30

31

libs/base/Data/Morphisms.idr+1−1

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

1module Data.Morphisms

2

3−%access public

3+%access public export

4

5data Morphism : Type -> Type -> Type where

6 Mor : (a -> b) -> Morphism a b

libs/base/Data/So.idr+1

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

1module Data.So

2

3%default total

4+%access public export

4

5

5||| Ensure that some run-time Boolean test has been performed.

6||| Ensure that some run-time Boolean test has been performed.

6|||

7|||

libs/base/Data/String.idr+1−1

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

1module Data.String

2−%access public

2+%access public export

3

4private

5parseNumWithoutSign : List Char -> Integer -> Maybe Integer

libs/base/Data/Vect.idr+11−4

@@ -3,7 +3,7 @@ module Data.Vect

3import public Data.Fin

4import Language.Reflection

5

6−%access public

6+%access public export

7%default total

8

9infixr 7 ::

@@ -198,8 +198,12 @@ replicate (S k) x = x :: replicate k x

198-- Zips and unzips

199--------------------------------------------------------------------------------

200

201−||| Combine two equal-length vectors pairwise with some function

201+||| Combine two equal-length vectors pairwise with some function.

202+|||

203+||| @ f the function to combine elements with

204+||| @ xs the first vector of elements

205+||| @ ys the second vector of elements

202−zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

206+zipWith : (f : a -> b -> c) -> (xs : Vect n a) -> (ys : Vect n b) -> Vect n c

203zipWith f [] [] = []

207zipWith f [] [] = []

204zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

208zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

205

209

@@ -573,12 +577,15 @@ implementation DecEq a => DecEq (Vect n a) where

573||| A proof that some element is found in a vector

577||| A proof that some element is found in a vector

574data Elem : a -> Vect k a -> Type where

578data Elem : a -> Vect k a -> Type where

575 Here : Elem x (x::xs)

579 Here : Elem x (x::xs)

576− There : Elem x xs -> Elem x (y::xs)

580+ There : (later : Elem x xs) -> Elem x (y::xs)

577

581

578||| Nothing can be in an empty Vect

582||| Nothing can be in an empty Vect

579noEmptyElem : {x : a} -> Elem x [] -> Void

583noEmptyElem : {x : a} -> Elem x [] -> Void

580noEmptyElem Here impossible

584noEmptyElem Here impossible

581

585

586+Uninhabited (Elem x []) where

587+ uninhabited = noEmptyElem

588+

582||| An item not in the head and not in the tail is not in the Vect at all

589||| An item not in the head and not in the tail is not in the Vect at all

583neitherHereNorThere : {x, y : a} -> {xs : Vect n a} -> Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))

590neitherHereNorThere : {x, y : a} -> {xs : Vect n a} -> Not (x = y) -> Not (Elem x xs) -> Not (Elem x (y :: xs))

584neitherHereNorThere xneqy xninxs Here = xneqy Refl

591neitherHereNorThere xneqy xninxs Here = xneqy Refl

libs/base/Data/Vect/Quantifiers.idr+2

@@ -2,6 +2,8 @@ module Data.Vect.Quantifiers

2

3import Data.Vect

4

5+%access public export

6+

5||| A proof that some element of a vector satisfies some property

7||| A proof that some element of a vector satisfies some property

6|||

8|||

7||| @ P the property to be satsified

9||| @ P the property to be satsified

libs/base/Debug/Error.idr+1−1

@@ -7,7 +7,7 @@ import System

7|||

8||| @ loc The source location to display for the error

9||| @ message The error to print

10−partial

10+partial export

11error : {default (%runElab sourceLocation) loc : SourceLocation} ->

12 (message : String) ->

13 a

libs/base/Debug/Trace.idr+1

@@ -3,6 +3,7 @@ module Debug.Trace

3||| Print a message for debugging purposes as a side effect

4||| @ msg what to print

5||| @ result the final result

6+export

6trace : (msg : String) -> (result : a) -> a

7trace : (msg : String) -> (result : a) -> a

7trace x val = unsafePerformIO {ffi=FFI_C} (do putStrLn x; return val)

8trace x val = unsafePerformIO {ffi=FFI_C} (do putStrLn x; return val)

8

9

libs/base/Language/Reflection/Utils.idr+4

@@ -4,6 +4,8 @@ import Language.Reflection

4import Language.Reflection.Elab

5import Language.Reflection.Errors

6

7+%access public export

8+

7--------------------------------------------------------

9--------------------------------------------------------

8-- Tactic construction conveniences

10-- Tactic construction conveniences

9--------------------------------------------------------

11--------------------------------------------------------

@@ -145,6 +147,8 @@ implementation Show Const where

145 showPrec d StrType = "StrType"

147 showPrec d StrType = "StrType"

146 showPrec d VoidType = "VoidType"

148 showPrec d VoidType = "VoidType"

147 showPrec d Forgot = "Forgot"

149 showPrec d Forgot = "Forgot"

150+ showPrec d WorldType = "WorldType"

151+ showPrec d TheWorld = "TheWorld"

148

152

149implementation Eq NativeTy where

153implementation Eq NativeTy where

150 IT8 == IT8 = True

154 IT8 == IT8 = True

libs/base/Syntax/PreorderReasoning.idr+2

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

1module Syntax.PreorderReasoning

2

3+%access public export

4+

3-- QED is first to get the precedence to work out. It's just Refl with an explicit argument.

5-- QED is first to get the precedence to work out. It's just Refl with an explicit argument.

4syntax [expr] "QED" = qed expr

6syntax [expr] "QED" = qed expr

5-- foo ={ prf }= bar ={ prf' }= fnord QED

7-- foo ={ prf }= bar ={ prf' }= fnord QED

libs/base/System.idr+1−1

@@ -2,7 +2,7 @@ module System

2

3%include C "unistd.h"

4%default partial

5−%access public

5+%access public export

6

7||| Retrieves a value from the environment if the given key is present,

8||| otherwise it returns Nothing.

libs/base/System/Concurrency/Raw.idr+2

@@ -6,6 +6,8 @@ module System.Concurrency.Raw

6

7import System

8

9+%access export

10+

9||| Send a message of any type to the thread with the given thread id

11||| Send a message of any type to the thread with the given thread id

10||| Returns 1 if the message was sent successfully, 0 otherwise

12||| Returns 1 if the message was sent successfully, 0 otherwise

11sendToThread : (thread_id : Ptr) -> a -> IO Int

13sendToThread : (thread_id : Ptr) -> a -> IO Int

libs/base/System/Info.idr+3

@@ -1,13 +1,16 @@

1module System.Info

2

3||| The Idris backend in use

4+export

4backend : String

5backend : String

5backend = prim__systemInfo 0

6backend = prim__systemInfo 0

6

7

7||| The operating system in use.

8||| The operating system in use.

9+export

8os : String

10os : String

9os = prim__systemInfo 1

11os = prim__systemInfo 1

10

12

11||| The triple this program was targeted for

13||| The triple this program was targeted for

14+export

12targetTriple : String

15targetTriple : String

13targetTriple = prim__systemInfo 2

16targetTriple = prim__systemInfo 2

libs/contrib/Classes/Verified.idr+9

@@ -4,6 +4,8 @@ import Control.Algebra

4import Control.Algebra.Lattice

5import Control.Algebra.VectorSpace

6

7+%access public export

8+

7-- Due to these being basically unused and difficult to implement,

9-- Due to these being basically unused and difficult to implement,

8-- they're in contrib for a bit. Once a design is found that lets them

10-- they're in contrib for a bit. Once a design is found that lets them

9-- be implemented for a number of implementations, and we get those

11-- be implemented for a number of implementations, and we get those

@@ -92,6 +94,11 @@ interface MeetSemilattice a => VerifiedMeetSemilattice a where

92 total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l

94 total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l

93 total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

95 total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

94

96

97+{- FIXME: Some maintenance required here.

98+ Algebra.top and Algebra.bottom don't exist!

99+-}

100+{-

101+

95interface (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where

102interface (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where

96 total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e

103 total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e Algebra.bottom = e

97

104

@@ -112,3 +119,5 @@ interface (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, V

112-- total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

119-- total moduleScalarMultDistributiveWRTModuleAddition : (s, t : a) -> (v : b) -> (s <+> t) <#> v = (s <#> v) <+> (t <#> v)

113

120

114--interface (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

121--interface (VerifiedField a, VerifiedModule a b) => VerifiedVectorSpace a b where {}

122+

123+-}

libs/contrib/Control/Algebra.idr+1

@@ -3,6 +3,7 @@ module Control.Algebra

3infixl 6 <->

4infixl 7 <.>

5

6+%access public export

6

7

7||| Sets equipped with a single binary operation that is associative, along with

8||| Sets equipped with a single binary operation that is associative, along with

8||| a neutral element for that binary operation and inverses for all elements.

9||| a neutral element for that binary operation and inverses for all elements.

libs/contrib/Control/Algebra/Lattice.idr+1

@@ -3,6 +3,7 @@ module Control.Algebra.Lattice

3import Control.Algebra

4import Data.Heap

5

6+%access public export

6

7

7||| Sets equipped with a binary operation that is commutative, associative and

8||| Sets equipped with a binary operation that is commutative, associative and

8||| idempotent. Must satisfy the following laws:

9||| idempotent. Must satisfy the following laws:

libs/contrib/Control/Algebra/NumericInstances.idr+1

@@ -7,6 +7,7 @@ import Control.Algebra.VectorSpace

7import Data.Complex

8import Data.ZZ

9

10+%access public export

10

11

11Semigroup Integer where

12Semigroup Integer where

12 (<+>) = (+)

13 (<+>) = (+)

libs/contrib/Control/Algebra/VectorSpace.idr+2

@@ -2,6 +2,8 @@ module Control.Algebra.VectorSpace

2

3import Control.Algebra

4

5+%access public export

6+

5infixl 5 <#>

7infixl 5 <#>

6infixr 2 <||>

8infixr 2 <||>

7

9

libs/contrib/Control/Isomorphism/Primitives.idr+1−1

@@ -4,7 +4,7 @@ import Control.Isomorphism

4import Data.ZZ

5

6%default total

7−%access public

7+%access public export

8

9-- This module contains isomorphisms between convenient inductive types and

10-- Idris primitives. Because primitives lack a convenient structure, these

libs/contrib/Control/Partial.idr+1−1

@@ -7,7 +7,7 @@ module Control.Partial

7||| @ p the predicate to wait for

8||| @ f the function to repeatedly apply

9||| @ v the starting value

10−partial

10+partial export

11until : (p : a -> Bool) -> (f : a -> a) -> (v : a) -> a

12until p f v with (p v)

13 | False = until p f (f v)

libs/contrib/Control/WellFounded.idr+1−1

@@ -6,7 +6,7 @@

6module Control.WellFounded

7

8%default total

9−

9+%access public export

10

11||| Accessibility: some element `x` is accessible if all `y` such that

12||| `rel y x` are themselves accessible.

libs/contrib/Data/BoundedList.idr+1−1

@@ -2,7 +2,7 @@ module Data.BoundedList

2

3import Data.Fin

4

5−%access public

5+%access public export

6%default total

7

8||| A list with an upper bound on its length.

libs/contrib/Data/CoList.idr+1−1

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

1module Data.CoList

2

3−%access public

3+%access public export

4%default total

5

6||| Idris will know that it always can produce a new element in finite time

libs/contrib/Data/Fun.idr+1

@@ -3,6 +3,7 @@ module Data.Fun

3import public Data.Vect

4

5%default total

6+%access public export

6

7

7||| Build an n-ary function type from a Vect of Types and a result type

8||| Build an n-ary function type from a Vect of Types and a result type

8Fun : Vect n Type -> Type -> Type

9Fun : Vect n Type -> Type -> Type

libs/contrib/Data/Hash.idr+1−1

@@ -2,7 +2,7 @@ module Data.Hash

2

3import Data.Vect

4

5−%access public

5+%access public export

6%default total

7

8{- A general purpose Hashing library (not cryptographic)

libs/contrib/Data/Heap.idr+2−2

@@ -7,9 +7,9 @@ module Data.Heap

7

8

9%default total

10−%access public

10+%access export

11

12−abstract data MaxiphobicHeap : Type -> Type where

12+export data MaxiphobicHeap : Type -> Type where

13 Empty : MaxiphobicHeap a

14 Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a

15

libs/contrib/Data/Matrix.idr+1

@@ -5,6 +5,7 @@ module Data.Matrix

5import public Data.Vect

6

7%default total

8+%access public export

8

9

9||| Matrix with n rows and m columns

10||| Matrix with n rows and m columns

10Matrix : Nat -> Nat -> Type -> Type

11Matrix : Nat -> Nat -> Type -> Type

libs/contrib/Data/Matrix/Algebraic.idr+1−1

@@ -9,7 +9,7 @@ import public Control.Algebra.NumericInstances

9

10import public Data.Matrix

11

12−

12+%access public export

13%default total

14

15infixr 2 <:> -- vector inner product

libs/contrib/Data/Matrix/Numeric.idr+1

@@ -5,6 +5,7 @@ module Data.Matrix.Numeric

5import public Data.Matrix

6

7%default total

8+%access public export

8

9

9infixr 2 <:> -- vector inner product

10infixr 2 <:> -- vector inner product

10infixr 2 >< -- vector outer product

11infixr 2 >< -- vector outer product

libs/contrib/Data/Nat/DivMod.idr+1

@@ -2,6 +2,7 @@

2module Data.Nat.DivMod

3

4%default total

5+%access public export

5

6

6||| The result of euclidean division of natural numbers

7||| The result of euclidean division of natural numbers

7|||

8|||

libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr+1−1

@@ -8,7 +8,7 @@ import Data.So

8import Control.WellFounded

9

10%default total

11−%access public

11+%access public export

12

13||| A strict less-than relation on `Nat`.

14|||

libs/contrib/Data/Rel.idr+1

@@ -2,6 +2,7 @@ module Data.Rel

2

3import Data.Fun

4

5+%access public export

5

6

6||| Build an n-ary relation type from a Vect of Types

7||| Build an n-ary relation type from a Vect of Types

7Rel : Vect n Type -> Type

8Rel : Vect n Type -> Type

libs/contrib/Data/Sign.idr+2

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

1module Data.Sign

2

3+%access public export

4+

3||| A representation of signs for signed datatypes such as `ZZ`

5||| A representation of signs for signed datatypes such as `ZZ`

4data Sign = Plus | Zero | Minus

6data Sign = Plus | Zero | Minus

5

7

libs/contrib/Data/SortedMap.idr+7−8

@@ -192,21 +192,21 @@ treeToList = treeToList' (:: [])

192 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

193 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

194

195−abstract

195+export

196data SortedMap : Type -> Type -> Type where

197 Empty : Ord k => SortedMap k v

198 M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v

199

200−public

200+export

201empty : Ord k => SortedMap k v

202empty = Empty

203

204−public

204+export

205lookup : k -> SortedMap k v -> Maybe v

206lookup _ Empty = Nothing

207lookup k (M _ t) = treeLookup k t

208

209−public

209+export

210insert : k -> v -> SortedMap k v -> SortedMap k v

211insert k v Empty = M Z (Leaf k v)

212insert k v (M _ t) =

@@ -214,7 +214,7 @@ insert k v (M _ t) =

214 Left t' => (M _ t')

215 Right t' => (M _ t')

216

217−public

217+export

218delete : k -> SortedMap k v -> SortedMap k v

219delete _ Empty = Empty

220delete k (M Z t) =

@@ -226,16 +226,15 @@ delete k (M (S _) t) =

226 Left t' => (M _ t')

227 Right t' => (M _ t')

228

229−public

229+export

230fromList : Ord k => List (k, v) -> SortedMap k v

231fromList l = foldl (flip (uncurry insert)) empty l

232

233−public

233+export

234toList : SortedMap k v -> List (k, v)

235toList Empty = []

236toList (M _ t) = treeToList t

237

238−public

239treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

238treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

240treeMap f (Leaf k v) = Leaf k (f v)

239treeMap f (Leaf k v) = Leaf k (f v)

241treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

240treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

libs/contrib/Data/SortedSet.idr+7−7

@@ -4,30 +4,30 @@ import Data.SortedMap

4

5-- TODO: add intersection, union, difference

6

7−abstract

7+export

8data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

9

10−public

10+export

11empty : Ord k => SortedSet k

12empty = SetWrapper Data.SortedMap.empty

13

14−public

14+export

15insert : k -> SortedSet k -> SortedSet k

16insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

17

18−public

18+export

19delete : k -> SortedSet k -> SortedSet k

20delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

21

22−public

22+export

23contains : k -> SortedSet k -> Bool

24contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

25

26−public

26+export

27fromList : Ord k => List k -> SortedSet k

28fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

29

30−public

30+export

31toList : SortedSet k -> List k

32toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

33

libs/contrib/Data/Storable.idrnew file+41

@@ -0,0 +1,41 @@

1+module Data.Storable

2+

3+%access public export

4+

5+interface Storable a where

6+ sizeOf : a -> Int

7+ alignOf : a -> Int

8+ peek : Ptr -> Int -> IO a

9+ poke : Ptr -> Int -> a -> IO ()

10+

11+Storable Bits8 where

12+ sizeOf _ = 1

13+ alignOf _ = 1

14+ peek p offset = prim_peek8 p offset

15+ poke p offset val = do

16+ _ <- prim_poke8 p offset val

17+ return ()

18+

19+Storable Bits16 where

20+ sizeOf _ = 2

21+ alignOf _ = 2

22+ peek p offset = prim_peek16 p offset

23+ poke p offset val = do

24+ _ <- prim_poke16 p offset val

25+ return ()

26+

27+Storable Bits32 where

28+ sizeOf _ = 4

29+ alignOf _ = 4

30+ peek p offset = prim_peek32 p offset

31+ poke p offset val = do

32+ _ <- prim_poke32 p offset val

33+ return ()

34+

35+Storable Bits64 where

36+ sizeOf _ = 8

37+ alignOf _ = 8

38+ peek p offset = prim_peek64 p offset

39+ poke p offset val = do

40+ _ <- prim_poke64 p offset val

41+ return ()

libs/contrib/Data/ZZ.idr+1−1

@@ -4,7 +4,7 @@ import Decidable.Equality

4import Data.Sign

5

6%default total

7−%access public

7+%access public export

8

9

10||| An integer is either a positive `Nat` or the negated successor of a `Nat`.

libs/contrib/Decidable/Decidable.idr+1−1

@@ -3,7 +3,7 @@ module Decidable.Decidable

3import Data.Rel

4import Data.Fun

5

6−%access public

6+%access public export

7

8--------------------------------------------------------------------------------

9-- Interface for decidable n-ary Relations

libs/contrib/Decidable/Order.idr+1−1

@@ -6,7 +6,7 @@ import Data.Fin

6import Data.Fun

7import Data.Rel

8

9−%access public

9+%access public export

10

11--------------------------------------------------------------------------------

12-- Utility Lemmas

libs/contrib/Network/Cgi.idr+11−11

@@ -4,7 +4,7 @@ import System

4

5%default total

6

7−public

7+public export

8Vars : Type

9Vars = List (String, String)

10

@@ -23,7 +23,7 @@ add_Headers str st = record { Headers = Headers st ++ str } st

23add_Output : String -> CGIInfo -> CGIInfo

24add_Output str st = record { Output = Output st ++ str } st

25

26−abstract

26+export

27data CGI : Type -> Type where

28 MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a

29

@@ -51,32 +51,32 @@ setInfo i = MkCGI (\s => return ((), i))

51getInfo : CGI CGIInfo

52getInfo = MkCGI (\s => return (s, s))

53

54−abstract

54+export

55lift : IO a -> CGI a

56lift op = MkCGI (\st => do { x <- op

57 return (x, st) } )

58

59−abstract

59+export

60output : String -> CGI ()

61output s = do i <- getInfo

62 setInfo (add_Output s i)

63

64−abstract

64+export

65queryVars : CGI Vars

66queryVars = do i <- getInfo

67 return (GET i)

68

69−abstract

69+export

70postVars : CGI Vars

71postVars = do i <- getInfo

72 return (POST i)

73

74−abstract

74+export

75cookieVars : CGI Vars

76cookieVars = do i <- getInfo

77 return (Cookies i)

78

79−abstract

79+export

80queryVar : String -> CGI (Maybe String)

81queryVar x = do vs <- queryVars

82 return (lookup x vs)

@@ -89,12 +89,12 @@ getHeaders : CGI String

89getHeaders = do i <- getInfo

90 return (Headers i)

91

92−abstract

92+export

93flushHeaders : CGI ()

94flushHeaders = do o <- getHeaders

95 lift (putStrLn o)

96

97−abstract

97+export

98flush : CGI ()

99flush = do o <- getOutput

100 lift (putStr o)

@@ -119,7 +119,7 @@ getCgiEnv key = do

119 val <- getEnv key

120 return $ maybe "" id val

121

122−abstract

122+export

123runCGI : CGI a -> IO a

124runCGI prog = do

125 clen_in <- getCgiEnv "CONTENT_LENGTH"

libs/contrib/Network/Socket.idr+7−8

@@ -8,9 +8,7 @@ module IdrisNet.Socket

8%include C "sys/socket.h"

9%include C "netdb.h"

10

11−%access public

12−

13−ByteLength : Type

11+public export ByteLength : Type

14ByteLength = Int

12ByteLength = Int

15

13

16interface ToCode a where

14interface ToCode a where

@@ -67,8 +65,9 @@ implementation ToCode SocketType where

67

65

68data RecvStructPtr = RSPtr Ptr

66data RecvStructPtr = RSPtr Ptr

69data RecvfromStructPtr = RFPtr Ptr

67data RecvfromStructPtr = RFPtr Ptr

68+

70−data BufPtr = BPtr Ptr

69+export data BufPtr = BPtr Ptr

71−data SockaddrPtr = SAPtr Ptr

70+export data SockaddrPtr = SAPtr Ptr

72

71

73||| Protocol Number.

72||| Protocol Number.

74|||

73|||

@@ -120,18 +119,18 @@ record UDPAddrInfo where

120 remote_port : Port

119 remote_port : Port

121

120

122||| Frees a given pointer

121||| Frees a given pointer

123−public

122+export

124sock_free : BufPtr -> IO ()

123sock_free : BufPtr -> IO ()

125sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

124sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

126

125

127−public

126+export

128sockaddr_free : SockaddrPtr -> IO ()

127sockaddr_free : SockaddrPtr -> IO ()

129sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

128sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

130

129

131||| Allocates an amount of memory given by the ByteLength parameter.

130||| Allocates an amount of memory given by the ByteLength parameter.

132|||

131|||

133||| Used to allocate a mutable pointer to be given to the Recv functions.

132||| Used to allocate a mutable pointer to be given to the Recv functions.

134−public

133+export

135sock_alloc : ByteLength -> IO BufPtr

134sock_alloc : ByteLength -> IO BufPtr

136sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl

135sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl

137

136

libs/contrib/System/Concurrency/Process.idr+10−2

@@ -4,9 +4,9 @@ module System.Concurrency.Process

4

5import System.Concurrency.Raw

6

7−%access public

7+%access public export

8

9−abstract

9+export

10data ProcID msg = MkPID Ptr

11

12||| Type safe message passing programs. Parameterised over the type of

@@ -30,24 +30,29 @@ run : Process msg x -> IO x

30run (Lift prog) = prog

31

32||| Get current process ID

33+export

33myID : Process msg (ProcID msg)

34myID : Process msg (ProcID msg)

34myID = Lift (return (MkPID prim__vm))

35myID = Lift (return (MkPID prim__vm))

35

36

36||| Send a message to another process

37||| Send a message to another process

37||| Returns whether the send was unsuccessful.

38||| Returns whether the send was unsuccessful.

39+export

38send : ProcID msg -> msg -> Process msg Bool

40send : ProcID msg -> msg -> Process msg Bool

39send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)

41send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)

40 return (x == 1))

42 return (x == 1))

41

43

42||| Return whether a message is waiting in the queue

44||| Return whether a message is waiting in the queue

45+export

43msgWaiting : Process msg Bool

46msgWaiting : Process msg Bool

44msgWaiting = Lift checkMsgs

47msgWaiting = Lift checkMsgs

45

48

46||| Return whether a message is waiting in the queue from a specific sender

49||| Return whether a message is waiting in the queue from a specific sender

50+export

47msgWaitingFrom : ProcID msg -> Process msg Bool

51msgWaitingFrom : ProcID msg -> Process msg Bool

48msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

52msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

49

53

50||| Receive a message - blocks if there is no message waiting

54||| Receive a message - blocks if there is no message waiting

55+export

51recv : Process msg msg

56recv : Process msg msg

52recv {msg} = do (senderid, m) <- Lift get

57recv {msg} = do (senderid, m) <- Lift get

53 return m

58 return m

@@ -55,6 +60,7 @@ recv {msg} = do (senderid, m) <- Lift get

55 get = getMsg

60 get = getMsg

56

61

57||| Receive a message from specific sender - blocks if there is no message waiting

62||| Receive a message from specific sender - blocks if there is no message waiting

63+export

58recvFrom : ProcID msg -> Process msg msg

64recvFrom : ProcID msg -> Process msg msg

59recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

65recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

60 return m

66 return m

@@ -62,6 +68,7 @@ recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

62 get = getMsgFrom p

68 get = getMsgFrom p

63

69

64||| receive a message, and return with the sender's process ID.

70||| receive a message, and return with the sender's process ID.

71+export

65recvWithSender : Process msg (ProcID msg, msg)

72recvWithSender : Process msg (ProcID msg, msg)

66recvWithSender {msg}

73recvWithSender {msg}

67 = do (senderid, m) <- Lift get

74 = do (senderid, m) <- Lift get

@@ -69,6 +76,7 @@ recvWithSender {msg}

69 where get : IO (Ptr, msg)

76 where get : IO (Ptr, msg)

70 get = getMsg

77 get = getMsg

71

78

79+export

72create : Process msg () -> Process msg (ProcID msg)

80create : Process msg () -> Process msg (ProcID msg)

73create (Lift p) = do ptr <- Lift (fork p)

81create (Lift p) = do ptr <- Lift (fork p)

74 return (MkPID ptr)

82 return (MkPID ptr)

libs/contrib/contrib.ipkg+3−1

@@ -7,7 +7,9 @@ modules = Control.Algebra,

7 Control.Isomorphism.Primitives,

8 Control.Partial,

9 Control.WellFounded,

10+

10 Classes.Verified,

11 Classes.Verified,

12+

11 Data.Fun, Data.Rel,

13 Data.Fun, Data.Rel,

12 Data.Hash,

14 Data.Hash,

13 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

15 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

@@ -16,7 +18,7 @@ modules = Control.Algebra,

16 Data.BoundedList,

18 Data.BoundedList,

17 Data.Heap,

19 Data.Heap,

18 Data.SortedMap, Data.SortedSet,

20 Data.SortedMap, Data.SortedSet,

19− Data.CoList,

21+ Data.CoList, Data.Storable,

20

22

21 Decidable.Decidable, Decidable.Order,

23 Decidable.Decidable, Decidable.Order,

22

24

libs/effects/Effect/Default.idr+2

@@ -2,6 +2,8 @@ module Effect.Default

2

3import Data.Vect

4

5+%access public export

6+

5interface Default a where

7interface Default a where

6 default : a

8 default : a

7

9

libs/effects/Effect/Exception.idr+2

@@ -4,6 +4,8 @@ import Effects

4import System

5import Control.IOExcept

6

7+%access public export

8+

7data Exception : Type -> Effect where

9data Exception : Type -> Effect where

8 Raise : a -> sig (Exception a) b

10 Raise : a -> sig (Exception a) b

9

11

libs/effects/Effect/File.idr+5−4

@@ -4,6 +4,7 @@ module Effect.File

4import Effects

5import Control.IOExcept

6

7+%access public export

7

8

8||| A Dependent type to describe File Handles. File handles are

9||| A Dependent type to describe File Handles. File handles are

9||| parameterised with the current state of the file: Closed; Open for

10||| parameterised with the current state of the file: Closed; Open for

@@ -63,7 +64,7 @@ data FileIO : Effect where

63 ||| Write a string to a file.

64 ||| Write a string to a file.

64 |||

65 |||

65 ||| Only file that are open for writing can be written to.

66 ||| Only file that are open for writing can be written to.

66− WriteString : String -> sig FileIO () (OpenFile Write)

67+ WriteString : String -> sig FileIO () (OpenFile WriteTruncate)

67

68

68 ||| End of file?

69 ||| End of file?

69 |||

70 |||

@@ -137,11 +138,11 @@ readLine : Eff String [FILE_IO (OpenFile Read)]

137readLine = call $ ReadLine

138readLine = call $ ReadLine

138

139

139||| Write a string to a file.

140||| Write a string to a file.

140−writeString : String -> Eff () [FILE_IO (OpenFile Write)]

141+writeString : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

141writeString str = call $ WriteString str

142writeString str = call $ WriteString str

142

143

143||| Write a line to a file.

144||| Write a line to a file.

144−writeLine : String -> Eff () [FILE_IO (OpenFile Write)]

145+writeLine : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

145writeLine str = call $ WriteString (str ++ "\n")

146writeLine str = call $ WriteString (str ++ "\n")

146

147

147||| End of file?

148||| End of file?

@@ -175,7 +176,7 @@ writeFile : (errFunc : String -> e)

175 -> (content : String)

176 -> (content : String)

176 -> Eff (Either e ()) [FILE_IO ()]

177 -> Eff (Either e ()) [FILE_IO ()]

177writeFile errFunc fname content = do

178writeFile errFunc fname content = do

178− case !(open fname Write) of

179+ case !(open fname WriteTruncate) of

179 True => do

180 True => do

180 writeString content

181 writeString content

181 close

182 close

libs/effects/Effect/Logging/Category.idr+2−2

@@ -14,7 +14,7 @@ module Effect.Logging.Category

14import Effects

15import public Effect.Logging.Level

16

17−%access public

17+%access public export

18

19-- -------------------------------------------------------- [ Logging Resource ]

20

@@ -147,7 +147,7 @@ logN : (Show a, Eq a) => (l : Nat)

147 -> (cs : List a)

148 -> (m : String)

149 -> Eff () [LOG a]

150−logN l cs msg = call $ Log (getProof lvl) cs msg

150+logN l cs msg = call $ Log (snd lvl) cs msg

151 where

152 lvl : (n ** LogLevel n)

153 lvl = case cast {to=String} (cast {to=Int} l) of

libs/effects/Effect/Logging/Default.idr+2−2

@@ -15,7 +15,7 @@ module Effect.Logging.Default

15import Effects

16import public Effect.Logging.Level

17

18−%access public

18+%access public export

19

20-- ------------------------------------------------------------ [ The Resource ]

21

@@ -84,7 +84,7 @@ log l msg = call $ Log l msg

84||| @l The level to log.

85||| @m The message to log.

86logN : (l : Nat) -> {auto prf : LTE l 70} -> (m : String) -> Eff () [LOG]

87−logN l msg = call $ Log (getProof lvl) msg

87+logN l msg = call $ Log (snd lvl) msg

88 where

89 lvl : (n ** LogLevel n)

90 lvl = case cast {to=String} (cast {to=Int} l) of

libs/effects/Effect/Logging/Level.idr+1−1

@@ -14,7 +14,7 @@

14||| loggers.

15module Effect.Logging.Level

16

17−%access public

17+%access public export

18%default total

19

20-- ---------------------------------------------------- [ Log Level Definition ]

libs/effects/Effect/Memory.idr+9−3

@@ -5,13 +5,13 @@ import Control.IOExcept

5import Data.Vect

6import public Data.So

7

8−%access public

8+%access public export

9

10−abstract

10+export

11data MemoryChunk : Nat -> Nat -> Type where

12 CH : Ptr -> MemoryChunk size initialized

13

14−abstract

14+export

15data RawMemory : Effect where

16 Allocate : (n : Nat) ->

17 RawMemory () () (\v => MemoryChunk n 0)

@@ -102,10 +102,12 @@ implementation Handler RawMemory (IOExcept String) where

102RAW_MEMORY : Type -> EFFECT

103RAW_MEMORY t = MkEff t RawMemory

104

105+export

105allocate : (n : Nat) ->

106allocate : (n : Nat) ->

106 Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

107 Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

107allocate size = call $ Allocate size

108allocate size = call $ Allocate size

108

109

110+export

109initialize : {i : Nat} ->

111initialize : {i : Nat} ->

110 {n : Nat} ->

112 {n : Nat} ->

111 Bits8 ->

113 Bits8 ->

@@ -115,9 +117,11 @@ initialize : {i : Nat} ->

115 (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

117 (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

116initialize c size prf = call $ Initialize c size prf

118initialize c size prf = call $ Initialize c size prf

117

119

120+export

118free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

121free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

119free = call Free

122free = call Free

120

123

124+export

121peek : {i : Nat} ->

125peek : {i : Nat} ->

122 (offset : Nat) ->

126 (offset : Nat) ->

123 (size : Nat) ->

127 (size : Nat) ->

@@ -125,6 +129,7 @@ peek : {i : Nat} ->

125 { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)

129 { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)

126peek offset size prf = call $ Peek offset size prf

130peek offset size prf = call $ Peek offset size prf

127

131

132+export

128poke : {n : Nat} ->

133poke : {n : Nat} ->

129 {i : Nat} ->

134 {i : Nat} ->

130 (offset : Nat) ->

135 (offset : Nat) ->

@@ -155,6 +160,7 @@ move' src_ptr dst_offset src_offset size dst_bounds src_bounds

155

160

156data MoveDescriptor = Dst | Src

161data MoveDescriptor = Dst | Src

157

162

163+export

158move : {dst_size : Nat} ->

164move : {dst_size : Nat} ->

159 {dst_init : Nat} ->

165 {dst_init : Nat} ->

160 {src_size : Nat} ->

166 {src_size : Nat} ->

libs/effects/Effect/Monad.idr+2

@@ -2,6 +2,8 @@ module Effect.Monad

2

3import Effects

4

5+%access public export

6+

5data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where

7data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where

6 MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a

8 MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a

7

9

libs/effects/Effect/Perf.idr+1−1

@@ -12,7 +12,7 @@ import System

12import Effects

13import Effect.Default

14

15−%access public

15+%access public export

16

17-- ---------------------------------------------------- [ Timer Data Structure ]

18

libs/effects/Effect/Random.idr+2

@@ -3,6 +3,8 @@ module Effect.Random

3import Effects

4import Data.Vect

5

6+%access public export

7+

6data Random : Effect where

8data Random : Effect where

7 GetRandom : sig Random Integer Integer

9 GetRandom : sig Random Integer Integer

8 SetSeed : Integer -> sig Random () Integer

10 SetSeed : Integer -> sig Random () Integer

libs/effects/Effect/Select.idr+2

@@ -2,6 +2,8 @@ module Effect.Select

2

3import Effects

4

5+%access public export

6+

5data Selection : Effect where

7data Selection : Effect where

6 Select : List a -> sig Selection a ()

8 Select : List a -> sig Selection a ()

7

9

libs/effects/Effect/State.idr+1−1

@@ -2,7 +2,7 @@ module Effect.State

2

3import Effects

4

5−%access public

5+%access public export

6

7data State : Effect where

8 Get : sig State a a

libs/effects/Effect/StdIO.idr+2

@@ -3,6 +3,8 @@ module Effect.StdIO

3import Effects

4import Control.IOExcept

5

6+%access public export

7+

6-------------------------------------------------------------

8-------------------------------------------------------------

7-- IO effects internals

9-- IO effects internals

8-------------------------------------------------------------

10-------------------------------------------------------------

libs/effects/Effect/System.idr+2

@@ -7,6 +7,8 @@ import Effects

7import System

8import Control.IOExcept

9

10+%access public export

11+

10data System : Effect where

12data System : Effect where

11 Args : sig System (List String)

13 Args : sig System (List String)

12 Time : sig System Integer

14 Time : sig System Integer

libs/effects/Effect/Trans.idr+1−1

@@ -2,7 +2,7 @@ module Effect.Trans

2

3import Effects

4

5−%access public

5+%access public export

6

7data Trans : (Type -> Type) -> Effect where

8 Lift : m a -> sig (Trans m) a

libs/effects/Effects.idr+25−1

@@ -7,7 +7,7 @@ import Data.Vect

7--- Effectful computations are described as algebraic data types that

8--- explain how an effect is interpreted in some underlying context.

9

10−%access public

10+%access export

11-- ----------------------------------------------------------------- [ Effects ]

12||| The Effect type describes effectful computations.

13|||

@@ -15,11 +15,13 @@ import Data.Vect

15||| + The return type of the computation.

16||| + The input resource.

17||| + The computation to run on the resource given the return value.

18+public export

18Effect : Type

19Effect : Type

19Effect = (x : Type) -> Type -> (x -> Type) -> Type

20Effect = (x : Type) -> Type -> (x -> Type) -> Type

20

21

21||| The `EFFECT` Data type describes how to promote the Effect

22||| The `EFFECT` Data type describes how to promote the Effect

22||| description into a concrete effect.

23||| description into a concrete effect.

24+public export

23%error_reverse

25%error_reverse

24data EFFECT : Type where

26data EFFECT : Type where

25 MkEff : Type -> Effect -> EFFECT

27 MkEff : Type -> Effect -> EFFECT

@@ -30,24 +32,29 @@ data EFFECT : Type where

30-- or a dependent change. These are easily disambiguated by type.

32-- or a dependent change. These are easily disambiguated by type.

31

33

32namespace NoResourceEffect

34namespace NoResourceEffect

35+ public export

33 sig : Effect -> Type -> Type

36 sig : Effect -> Type -> Type

34 sig e r = e r () (\v => ())

37 sig e r = e r () (\v => ())

35

38

36namespace NoUpdateEffect

39namespace NoUpdateEffect

40+ public export

37 sig : Effect -> (ret : Type) -> (resource : Type) -> Type

41 sig : Effect -> (ret : Type) -> (resource : Type) -> Type

38 sig e r e_in = e r e_in (\v => e_in)

42 sig e r e_in = e r e_in (\v => e_in)

39

43

40namespace UpdateEffect

44namespace UpdateEffect

45+ public export

41 sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

46 sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

42 sig e r e_in e_out = e r e_in (\v => e_out)

47 sig e r e_in e_out = e r e_in (\v => e_out)

43

48

44namespace DepUpdateEffect

49namespace DepUpdateEffect

50+ public export

45 sig : Effect ->

51 sig : Effect ->

46 (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

52 (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

47 sig e r e_in e_out = e r e_in e_out

53 sig e r e_in e_out = e r e_in e_out

48

54

49||| Handler interfaces describe how an effect `e` is translated to the

55||| Handler interfaces describe how an effect `e` is translated to the

50||| underlying computation context `m` for execution.

56||| underlying computation context `m` for execution.

57+public export

51interface Handler (e : Effect) (m : Type -> Type) where

58interface Handler (e : Effect) (m : Type -> Type) where

52 ||| How to handle the effect.

59 ||| How to handle the effect.

53 |||

60 |||

@@ -77,6 +84,7 @@ syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

77syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

84syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

78

85

79-- --------------------------------------- [ Properties and Proof Construction ]

86-- --------------------------------------- [ Properties and Proof Construction ]

87+public export

80data SubList : List a -> List a -> Type where

88data SubList : List a -> List a -> Type where

81 SubNil : SubList [] []

89 SubNil : SubList [] []

82 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

90 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

@@ -88,21 +96,25 @@ subListId {xs = Nil} = SubNil

88subListId {xs = x :: xs} = Keep subListId

96subListId {xs = x :: xs} = Keep subListId

89

97

90namespace Env

98namespace Env

99+ public export

91 data Env : (m : Type -> Type) -> List EFFECT -> Type where

100 data Env : (m : Type -> Type) -> List EFFECT -> Type where

92 Nil : Env m Nil

101 Nil : Env m Nil

93 (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

102 (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

94

103

104+public export

95data EffElem : Effect -> Type ->

105data EffElem : Effect -> Type ->

96 List EFFECT -> Type where

106 List EFFECT -> Type where

97 Here : EffElem x a (MkEff a x :: xs)

107 Here : EffElem x a (MkEff a x :: xs)

98 There : EffElem x a xs -> EffElem x a (y :: xs)

108 There : EffElem x a xs -> EffElem x a (y :: xs)

99

109

100||| make an environment corresponding to a sub-list

110||| make an environment corresponding to a sub-list

111+private

101dropEnv : Env m ys -> SubList xs ys -> Env m xs

112dropEnv : Env m ys -> SubList xs ys -> Env m xs

102dropEnv [] SubNil = []

113dropEnv [] SubNil = []

103dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

114dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

104dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

115dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

105

116

117+public export

106updateWith : (ys' : List a) -> (xs : List a) ->

118updateWith : (ys' : List a) -> (xs : List a) ->

107 SubList ys xs -> List a

119 SubList ys xs -> List a

108updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

120updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

@@ -112,6 +124,7 @@ updateWith (y :: ys) [] SubNil = y :: ys

112updateWith [] (x :: xs) (Keep rest) = []

124updateWith [] (x :: xs) (Keep rest) = []

113

125

114||| Put things back, replacing old with new in the sub-environment

126||| Put things back, replacing old with new in the sub-environment

127+private

115rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

128rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

116 Env m xs -> Env m (updateWith ys' xs prf)

129 Env m xs -> Env m (updateWith ys' xs prf)

117rebuildEnv [] SubNil env = env

130rebuildEnv [] SubNil env = env

@@ -123,6 +136,7 @@ rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

123

136

124-- -------------------------------------------------- [ The Effect EDSL itself ]

137-- -------------------------------------------------- [ The Effect EDSL itself ]

125

138

139+public export

126updateResTy : (val : t) ->

140updateResTy : (val : t) ->

127 (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

141 (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

128 List EFFECT

142 List EFFECT

@@ -131,9 +145,11 @@ updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

131

145

132infix 5 :::, :-, :=

146infix 5 :::, :-, :=

133

147

148+public export

134data LRes : lbl -> Type -> Type where

149data LRes : lbl -> Type -> Type where

135 (:=) : (x : lbl) -> res -> LRes x res

150 (:=) : (x : lbl) -> res -> LRes x res

136

151

152+public export

137(:::) : lbl -> EFFECT -> EFFECT

153(:::) : lbl -> EFFECT -> EFFECT

138(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

154(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

139

155

@@ -156,6 +172,7 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

156||| @ x The return type of the result.

172||| @ x The return type of the result.

157||| @ es The list of allowed side-effects.

173||| @ es The list of allowed side-effects.

158||| @ ce Function to compute a new list of allowed side-effects.

174||| @ ce Function to compute a new list of allowed side-effects.

175+public export

159data EffM : (m : Type -> Type) -> (x : Type)

176data EffM : (m : Type -> Type) -> (x : Type)

160 -> (es : List EFFECT)

177 -> (es : List EFFECT)

161 -> (ce : x -> List EFFECT) -> Type where

178 -> (ce : x -> List EFFECT) -> Type where

@@ -182,27 +199,33 @@ data EffM : (m : Type -> Type) -> (x : Type)

182

199

183namespace SimpleEff

200namespace SimpleEff

184 -- Simple effects, no updates

201 -- Simple effects, no updates

202+ public export

185 Eff : (x : Type) -> (es : List EFFECT) -> Type

203 Eff : (x : Type) -> (es : List EFFECT) -> Type

186 Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

204 Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

187

205

206+ public export

188 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

207 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

189 EffT m x es = EffM m x es (\v => es)

208 EffT m x es = EffM m x es (\v => es)

190

209

191namespace TransEff

210namespace TransEff

192 -- Dependent effects, updates not dependent on result

211 -- Dependent effects, updates not dependent on result

212+ public export

193 Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

213 Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

194 Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

214 Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

195

215

216+ public export

196 EffT : (m : Type -> Type) ->

217 EffT : (m : Type -> Type) ->

197 (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

218 (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

198 EffT m x es ce = EffM m x es (\_ => ce)

219 EffT m x es ce = EffM m x es (\_ => ce)

199

220

200namespace DepEff

221namespace DepEff

201 -- Dependent effects, updates dependent on result

222 -- Dependent effects, updates dependent on result

223+ public export

202 Eff : (x : Type) -> (es : List EFFECT)

224 Eff : (x : Type) -> (es : List EFFECT)

203 -> (ce : x -> List EFFECT) -> Type

225 -> (ce : x -> List EFFECT) -> Type

204 Eff x es ce = {m : Type -> Type} -> EffM m x es ce

226 Eff x es ce = {m : Type -> Type} -> EffM m x es ce

205

227

228+ public export

206 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

229 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

207 -> (ce : x -> List EFFECT) -> Type

230 -> (ce : x -> List EFFECT) -> Type

208 EffT m x es ce = EffM m x es ce

231 EffT m x es ce = EffM m x es ce

@@ -271,6 +294,7 @@ execEff (val :: env) (There p) eff k

271-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

294-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

272-- updates can be propagated even through failing computations?

295-- updates can be propagated even through failing computations?

273

296

297+export

274eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

298eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

275eff env (Value x) k = k x env

299eff env (Value x) k = k x env

276eff env (prog `EBind` c) k

300eff env (prog `EBind` c) k

libs/prelude/Builtins.idr+41−19

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

1%unqualified

2

3−%access public

3+%access public export

4%default total

5

6||| The canonical single-element type, also known as the trivially

@@ -37,23 +37,31 @@ namespace Builtins

37 %used MkUPair a

38 %used MkUPair b

39

40− ||| Dependent pairs

40+ ||| Dependent pairs aid in the construction of dependent types by

41+ ||| providing evidence that some value resides in the type.

41 |||

42 |||

43+ ||| Formally, speaking, dependent pairs represent existential

42− ||| Dependent pairs represent existential quantification - they consist of a

44+ ||| quantification - they consist of a witness for the existential

43− ||| witness for the existential claim and a proof that the property holds for

45+ ||| claim and a proof that the property holds for it.

44− ||| it. Another way to see dependent pairs is as just data - for instance, the

45− ||| length of a vector paired with that vector.

46 |||

47− ||| @ a the type of the witness

47+ ||| @a the value to place in the type.

48− ||| @ P the type of the proof

48+ ||| @P the dependent type that requires the value.

49− data Sigma : (a : Type) -> (P : a -> Type) -> Type where

49+ data DPair : (a : Type) -> (P : a -> Type) -> Type where

50− MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

50+ MkDPair : .{P : a -> Type} -> (x : a) -> (pf : P x) -> DPair a P

51+

52+ Sigma : (a : Type) -> (P : a -> Type) -> Type

53+ Sigma wit prf = DPair wit prf

54+ %deprecate Sigma "This name is being deprecated in favour of `DPair`."

55+

56+ MkSigma : .{P : a -> Type} -> (x : a) -> (prf : P x) -> DPair a P

57+ MkSigma wit prf = MkDPair wit prf

58+ %deprecate MkSigma "This constructor is being deprecated in favour of `MkDPair`."

51

59

52||| The empty type, also known as the trivially false proposition.

60||| The empty type, also known as the trivially false proposition.

53|||

61|||

54−||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

62+||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

55−%elim data Void : Type where

63+%elim data Void : Type where

56−

64+

57||| The eliminator for the `Void` type.

65||| The eliminator for the `Void` type.

58void : Void -> a

66void : Void -> a

59-- We can't define void yet. We can't define a function with no clauses without

67-- We can't define void yet. We can't define a function with no clauses without

@@ -155,13 +163,13 @@ assert_total x = x

155

163

156||| Subvert the type checker. This function is abstract, so it will not reduce in

164||| Subvert the type checker. This function is abstract, so it will not reduce in

157||| the type checker. Use it with care - it can result in segfaults or worse!

165||| the type checker. Use it with care - it can result in segfaults or worse!

158−abstract %assert_total -- need to pretend

166+export %assert_total -- need to pretend

159believe_me : a -> b

167believe_me : a -> b

160believe_me x = prim__believe_me _ _ x

168believe_me x = prim__believe_me _ _ x

161

169

162||| Subvert the type checker. This function *will* reduce in the type checker.

170||| Subvert the type checker. This function *will* reduce in the type checker.

163||| Use it with extreme care - it can result in segfaults or worse!

171||| Use it with extreme care - it can result in segfaults or worse!

164−public %assert_total

172+public export %assert_total

165really_believe_me : a -> b

173really_believe_me : a -> b

166really_believe_me x = prim__believe_me _ _ x

174really_believe_me x = prim__believe_me _ _ x

167

175

@@ -174,9 +182,9 @@ Float = Double

174-- Pointers as external primitive; there's no literals for these, so no

182-- Pointers as external primitive; there's no literals for these, so no

175-- need for them to be part of the compiler.

183-- need for them to be part of the compiler.

176

184

177−abstract data Ptr : Type

185+export data Ptr : Type

178−abstract data ManagedPtr : Type

186+export data ManagedPtr : Type

179−abstract data CData : Type

187+export data CData : Type

180

188

181%extern prim__readFile : prim__WorldType -> Ptr -> String

189%extern prim__readFile : prim__WorldType -> Ptr -> String

182%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int

190%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int

@@ -191,4 +199,18 @@ abstract data CData : Type

191%extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int

199%extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int

192%extern prim__registerPtr : Ptr -> Int -> ManagedPtr

200%extern prim__registerPtr : Ptr -> Int -> ManagedPtr

193

201

194−

202+-- primitives for accessing memory.

203+%extern prim__asPtr : ManagedPtr -> Ptr

204+%extern prim__sizeofPtr : Int

205+%extern prim__peek8 : prim__WorldType -> Ptr -> Int -> Bits8

206+%extern prim__peek16 : prim__WorldType -> Ptr -> Int -> Bits16

207+%extern prim__peek32 : prim__WorldType -> Ptr -> Int -> Bits32

208+%extern prim__peek64 : prim__WorldType -> Ptr -> Int -> Bits64

209+

210+%extern prim__poke8 : prim__WorldType -> Ptr -> Int -> Bits8 -> Int

211+%extern prim__poke16 : prim__WorldType -> Ptr -> Int -> Bits16 -> Int

212+%extern prim__poke32 : prim__WorldType -> Ptr -> Int -> Bits32 -> Int

213+%extern prim__poke64 : prim__WorldType -> Ptr -> Int -> Bits64 -> Int

214+

215+%extern prim__peekPtr : prim__WorldType -> Ptr -> Int -> Ptr

216+%extern prim__pokePtr : prim__WorldType -> Ptr -> Int -> Ptr -> Int

libs/prelude/Decidable/Equality.idr+4−5

@@ -3,12 +3,14 @@ module Decidable.Equality

3import Builtins

4import Prelude.Basics

5import Prelude.Bool

6−import Prelude.Classes

6+import Prelude.Interfaces

7import Prelude.Either

8import Prelude.List

9import Prelude.Nat

10import Prelude.Maybe

11

12+%access public export

13+

12--------------------------------------------------------------------------------

14--------------------------------------------------------------------------------

13-- Utility lemmas

15-- Utility lemmas

14--------------------------------------------------------------------------------

16--------------------------------------------------------------------------------

@@ -141,7 +143,7 @@ implementation DecEq a => DecEq (List a) where

141 decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)

143 decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)

142 decEq (x :: xs) (y :: ys) with (decEq x y)

144 decEq (x :: xs) (y :: ys) with (decEq x y)

143 decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)

145 decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)

144− decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl

146+ decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl

145 decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)

147 decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)

146 decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)

148 decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)

147 decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq)

149 decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq)

@@ -211,6 +213,3 @@ implementation DecEq ManagedPtr where

211 where primitiveEq : x = y

213 where primitiveEq : x = y

212 primitiveEq = believe_me (Refl {x})

214 primitiveEq = believe_me (Refl {x})

213 postulate primitiveNotEq : x = y -> Void

215 postulate primitiveNotEq : x = y -> Void

214−

215−

216−

libs/prelude/IO.idr+92−30

@@ -3,25 +3,24 @@

3import Builtins

4import Prelude.List

5

6−%access public

6+%access export

7

8||| Idris's primitive IO, for building abstractions on top of

9−abstract

10data PrimIO : Type -> Type where

9data PrimIO : Type -> Type where

11 Prim__IO : a -> PrimIO a

10 Prim__IO : a -> PrimIO a

12

11

13||| A token representing the world, for use in `IO`

12||| A token representing the world, for use in `IO`

14−abstract data World = TheWorld prim__WorldType

13+data World = TheWorld prim__WorldType

15

14

16−private

17world : World -> prim__WorldType

15world : World -> prim__WorldType

18world (TheWorld w) = w

16world (TheWorld w) = w

19

17

20−abstract WorldRes : Type -> Type

18+WorldRes : Type -> Type

21WorldRes x = x

19WorldRes x = x

22

20

23||| An FFI specifier, which describes how a particular compiler

21||| An FFI specifier, which describes how a particular compiler

24||| backend handles foreign function calls.

22||| backend handles foreign function calls.

23+public export

25record FFI where

24record FFI where

26 constructor MkFFI

25 constructor MkFFI

27 ||| A family describing which types are available in the FFI

26 ||| A family describing which types are available in the FFI

@@ -35,10 +34,10 @@ record FFI where

35

34

36||| The IO type, parameterised over the FFI that is available within

35||| The IO type, parameterised over the FFI that is available within

37||| it.

36||| it.

38−abstract

39data IO' : (lang : FFI) -> Type -> Type where

37data IO' : (lang : FFI) -> Type -> Type where

40 MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a

38 MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a

41

39

40+public export

42data FTy : FFI -> List Type -> Type -> Type where

41data FTy : FFI -> List Type -> Type -> Type where

43 FRet : ffi_types f t -> FTy f xs (IO' f t)

42 FRet : ffi_types f t -> FTy f xs (IO' f t)

44 FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)

43 FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)

@@ -47,15 +46,16 @@ namespace ForeignEnv

47 data FEnv : FFI -> List Type -> Type where

46 data FEnv : FFI -> List Type -> Type where

48 Nil : FEnv f []

47 Nil : FEnv f []

49 (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)

48 (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)

50−

49+

51ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type

50ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type

52ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

51ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

53−ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t

52+ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t

54 = (ffi_types ffi x, x) -> ForeignPrimType xs env t

53 = (ffi_types ffi x, x) -> ForeignPrimType xs env t

55

54

56%inline

55%inline

56+private

57−applyEnv : (env : FEnv ffi xs) ->

57+applyEnv : (env : FEnv ffi xs) ->

58− ForeignPrimType xs env t ->

58+ ForeignPrimType xs env t ->

59 World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

60applyEnv [] f = f

61applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x)

@@ -66,7 +66,8 @@ mkForeignPrim : {xs : _} -> {ffi : _} -> {env : FEnv ffi xs} -> {t : Type} ->

66-- explicit here.

67

68%inline

69+private

69−foreign_prim : (f : FFI) ->

70+foreign_prim : (f : FFI) ->

70 (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty

71 (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty

71foreign_prim f fname (FRet y) env

72foreign_prim f fname (FRet y) env

72 = MkIO (\w => applyEnv env mkForeignPrim w fname y)

73 = MkIO (\w => applyEnv env mkForeignPrim w fname y)

@@ -91,25 +92,21 @@ foreign : (f : FFI) -> (fname : ffi_fn f) -> (ty : Type) ->

91 {auto fty : FTy f [] ty} -> ty

92 {auto fty : FTy f [] ty} -> ty

92foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

93foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

93

94

94−abstract

95prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b

96prim_io_bind (Prim__IO v) k = k v

97

98unsafePerformPrimIO : PrimIO a -> a

99-- compiled as primitive

100

101−abstract

102prim_io_return : a -> PrimIO a

101prim_io_return : a -> PrimIO a

103prim_io_return x = Prim__IO x

102prim_io_return x = Prim__IO x

104

103

105−abstract

106io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

104io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

107io_bind (MkIO fn) k

105io_bind (MkIO fn) k

108 = MkIO (\w => prim_io_bind (fn w)

106 = MkIO (\w => prim_io_bind (fn w)

109 (\ b => case k b of

107 (\ b => case k b of

110 MkIO fkb => fkb w))

108 MkIO fkb => fkb w))

111

109

112−abstract

113io_return : a -> IO' l a

110io_return : a -> IO' l a

114io_return x = MkIO (\w => prim_io_return x)

111io_return x = MkIO (\w => prim_io_return x)

115

112

@@ -131,27 +128,32 @@ prim_read : IO' l String

131prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))

128prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))

132

129

133prim_write : String -> IO' l Int

130prim_write : String -> IO' l Int

134−prim_write s

131+prim_write s

135 = MkIO (\w => prim_io_return (prim__writeString (world w) s))

132 = MkIO (\w => prim_io_return (prim__writeString (world w) s))

136

133

137prim_fread : Ptr -> IO' l String

134prim_fread : Ptr -> IO' l String

138prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))

135prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))

139

136

140prim_fwrite : Ptr -> String -> IO' l Int

137prim_fwrite : Ptr -> String -> IO' l Int

141−prim_fwrite h s

138+prim_fwrite h s

142 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

139 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

143

140

144--------- The C FFI

141--------- The C FFI

145namespace FFI_C

142namespace FFI_C

143+ public export

146 data Raw : Type -> Type where

144 data Raw : Type -> Type where

147 -- code generated can assume it's compiled just as 't'

145 -- code generated can assume it's compiled just as 't'

148 MkRaw : (x : t) -> Raw t

146 MkRaw : (x : t) -> Raw t

149

147

150− -- Tell erasure analysis not to erase the argument

148+ public export

151− %used MkRaw x

149+ data CFnPtr : Type -> Type where

150+ MkCFnPtr : (x : t) -> CFnPtr t

151+

152

153+ mutual

153− ||| Supported C integer types

154+ ||| Supported C integer types

155+ public export

154− data C_IntTypes : Type -> Type where

156+ data C_IntTypes : Type -> Type where

155 C_IntChar : C_IntTypes Char

157 C_IntChar : C_IntTypes Char

156 C_IntNative : C_IntTypes Int

158 C_IntNative : C_IntTypes Int

157 C_IntBits8 : C_IntTypes Bits8

159 C_IntBits8 : C_IntTypes Bits8

@@ -159,29 +161,44 @@ namespace FFI_C

159 C_IntBits32 : C_IntTypes Bits32

161 C_IntBits32 : C_IntTypes Bits32

160 C_IntBits64 : C_IntTypes Bits64

162 C_IntBits64 : C_IntTypes Bits64

161

163

164+ public export

165+ data C_FnTypes : Type -> Type where

166+ C_Fn : C_Types s -> C_FnTypes t -> C_FnTypes (s -> t)

167+ C_FnIO : C_Types t -> C_FnTypes (IO' FFI_C t)

168+ C_FnBase : C_Types t -> C_FnTypes t

169+

162− ||| Supported C foreign types

170+ ||| Supported C foreign types

171+ public export

163− data C_Types : Type -> Type where

172+ data C_Types : Type -> Type where

164 C_Str : C_Types String

173 C_Str : C_Types String

165 C_Float : C_Types Double

174 C_Float : C_Types Double

166 C_Ptr : C_Types Ptr

175 C_Ptr : C_Types Ptr

167 C_MPtr : C_Types ManagedPtr

176 C_MPtr : C_Types ManagedPtr

168 C_Unit : C_Types ()

177 C_Unit : C_Types ()

169 C_Any : C_Types (Raw a)

178 C_Any : C_Types (Raw a)

179+ C_FnT : C_FnTypes t -> C_Types (CFnPtr t)

170 C_IntT : C_IntTypes i -> C_Types i

180 C_IntT : C_IntTypes i -> C_Types i

171 C_CData : C_Types CData

181 C_CData : C_Types CData

172

182

173− ||| A descriptor for the C FFI. See the constructors of `C_Types`

183+ ||| A descriptor for the C FFI. See the constructors of `C_Types`

174− ||| and `C_IntTypes` for the concrete types that are available.

184+ ||| and `C_IntTypes` for the concrete types that are available.

175 %error_reverse

185 %error_reverse

186+ public export

176− FFI_C : FFI

187+ FFI_C : FFI

177− FFI_C = MkFFI C_Types String String

188+ FFI_C = MkFFI C_Types String String

178

189

179||| Interactive programs, describing I/O actions and returning a value.

190||| Interactive programs, describing I/O actions and returning a value.

180−||| @res The result type of the program

191+||| @res The result type of the program

181%error_reverse

192%error_reverse

193+public export

194+

182IO : (res : Type) -> Type

195IO : (res : Type) -> Type

183IO = IO' FFI_C

196IO = IO' FFI_C

184

197

198+ -- Tell erasure analysis not to erase the argument

199+%used MkRaw x

200+%used MkCFnPtr x

201+

185-- Cannot be relaxed as is used by type providers and they expect IO a

202-- Cannot be relaxed as is used by type providers and they expect IO a

186-- in the first argument.

203-- in the first argument.

187run__provider : IO a -> PrimIO a

204run__provider : IO a -> PrimIO a

@@ -208,18 +225,22 @@ namespace IO

208

225

209-- Supported JS foreign types

226-- Supported JS foreign types

210mutual

227mutual

228+ public export

211 data JsFn : Type -> Type where

229 data JsFn : Type -> Type where

212 MkJsFn : (x : t) -> JsFn t

230 MkJsFn : (x : t) -> JsFn t

213

231

232+ public export

214 data JS_IntTypes : Type -> Type where

233 data JS_IntTypes : Type -> Type where

215 JS_IntChar : JS_IntTypes Char

234 JS_IntChar : JS_IntTypes Char

216 JS_IntNative : JS_IntTypes Int

235 JS_IntNative : JS_IntTypes Int

217

236

237+ public export

218 data JS_FnTypes : Type -> Type where

238 data JS_FnTypes : Type -> Type where

219 JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)

239 JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)

220 JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)

240 JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)

221 JS_FnBase : JS_Types t -> JS_FnTypes t

241 JS_FnBase : JS_Types t -> JS_FnTypes t

222

242

243+ public export

223 data JS_Types : Type -> Type where

244 data JS_Types : Type -> Type where

224 JS_Str : JS_Types String

245 JS_Str : JS_Types String

225 JS_Float : JS_Types Double

246 JS_Float : JS_Types Double

@@ -237,10 +258,12 @@ mutual

237||| JavaScript code snippets, into which the arguments are substituted

258||| JavaScript code snippets, into which the arguments are substituted

238||| for the placeholders `%0`, `%1`, etc.

259||| for the placeholders `%0`, `%1`, etc.

239%error_reverse

260%error_reverse

261+public export

240FFI_JS : FFI

262FFI_JS : FFI

241FFI_JS = MkFFI JS_Types String String

263FFI_JS = MkFFI JS_Types String String

242

264

243%error_reverse

265%error_reverse

266+public export

244JS_IO : Type -> Type

267JS_IO : Type -> Type

245JS_IO = IO' FFI_JS

268JS_IO = IO' FFI_JS

246

269

@@ -250,10 +273,12 @@ JS_IO = IO' FFI_JS

250namespace FFI_Export

273namespace FFI_Export

251-- It's just like Data.List.Elem, but we don't need all the other stuff

274-- It's just like Data.List.Elem, but we don't need all the other stuff

252-- that comes with it, just a proof that a data type is defined.

275-- that comes with it, just a proof that a data type is defined.

276+ public export

253 data DataDefined : Type -> List (Type, s) -> s -> Type where

277 data DataDefined : Type -> List (Type, s) -> s -> Type where

254 DHere : DataDefined x ((x, t) :: xs) t

278 DHere : DataDefined x ((x, t) :: xs) t

255 DThere : DataDefined x xs t -> DataDefined x (y :: xs) t

279 DThere : DataDefined x xs t -> DataDefined x (y :: xs) t

256

280

281+ public export

257 data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

282 data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

258 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

283 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

259 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

284 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

@@ -262,6 +287,7 @@ namespace FFI_Export

262 %used FFI_ExpType def

287 %used FFI_ExpType def

263 %used FFI_Prim prim

288 %used FFI_Prim prim

264

289

290+ public export

265 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

291 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

266 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

292 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

267 FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)

293 FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)

@@ -272,10 +298,11 @@ namespace FFI_Export

272 %used FFI_Fun a

298 %used FFI_Fun a

273 %used FFI_Ret b

299 %used FFI_Ret b

274

300

301+ public export

275 data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where

302 data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where

276− Data : (x : Type) -> (n : ffi_data f) ->

303+ Data : (x : Type) -> (n : ffi_data f) ->

277 (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs

304 (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs

278− Fun : (fn : t) -> (n : ffi_fn f) -> {auto prf : FFI_Exportable f xs t} ->

305+ Fun : (fn : t) -> (n : ffi_fn f) -> {auto prf : FFI_Exportable f xs t} ->

279 (es : FFI_Export f h xs) -> FFI_Export f h xs

306 (es : FFI_Export f h xs) -> FFI_Export f h xs

280 End : FFI_Export f h xs

307 End : FFI_Export f h xs

281

308

@@ -287,3 +314,38 @@ namespace FFI_Export

287%used Fun es

314%used Fun es

288%used Fun prf

315%used Fun prf

289

316

317+-- Accessing memory

318+prim_peek8 : Ptr -> Int -> IO Bits8

319+prim_peek8 ptr offset = MkIO (\w => prim_io_return (prim__peek8 (world w) ptr offset))

320+

321+prim_poke8 : Ptr -> Int -> Bits8 -> IO Int

322+prim_poke8 ptr offset val = MkIO (\w => prim_io_return (

323+ prim__poke8 (world w) ptr offset val))

324+

325+prim_peek16 : Ptr -> Int -> IO Bits16

326+prim_peek16 ptr offset = MkIO (\w => prim_io_return (prim__peek16 (world w) ptr offset))

327+

328+prim_poke16 : Ptr -> Int -> Bits16 -> IO Int

329+prim_poke16 ptr offset val = MkIO (\w => prim_io_return (

330+ prim__poke16 (world w) ptr offset val))

331+

332+prim_peek32 : Ptr -> Int -> IO Bits32

333+prim_peek32 ptr offset = MkIO (\w => prim_io_return (prim__peek32 (world w) ptr offset))

334+

335+prim_poke32 : Ptr -> Int -> Bits32 -> IO Int

336+prim_poke32 ptr offset val = MkIO (\w => prim_io_return (

337+ prim__poke32 (world w) ptr offset val))

338+

339+prim_peek64 : Ptr -> Int -> IO Bits64

340+prim_peek64 ptr offset = MkIO (\w => prim_io_return (prim__peek64 (world w) ptr offset))

341+

342+prim_poke64 : Ptr -> Int -> Bits64 -> IO Int

343+prim_poke64 ptr offset val = MkIO (\w => prim_io_return (

344+ prim__poke64 (world w) ptr offset val))

345+

346+prim_peekPtr : Ptr -> Int -> IO Ptr

347+prim_peekPtr ptr offset = MkIO (\w => prim_io_return (prim__peekPtr (world w) ptr offset))

348+

349+prim_pokePtr : Ptr -> Int -> Ptr -> IO Int

350+prim_pokePtr ptr offset val = MkIO (\w => prim_io_return (

351+ prim__pokePtr (world w) ptr offset val))

libs/prelude/Language/Reflection.idr+3−3

@@ -9,7 +9,7 @@ import Prelude.List

9import Prelude.Nat

10import Prelude.Traversable

11

12−%access public

12+%access public export

13

14||| A source location in an Idris file

15record SourceLocation where

@@ -80,7 +80,7 @@ data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

80 | WorldType | TheWorld

81%name Const c, c'

82

83−abstract interface ReflConst (a : Type) where

83+export interface ReflConst (a : Type) where

84 toConst : a -> Const

85

86implementation ReflConst Int where

@@ -110,7 +110,7 @@ implementation ReflConst Bits32 where

110implementation ReflConst Bits64 where

111 toConst = B64

112

113−implicit

113+implicit export

114reflectConstant: (ReflConst a) => a -> Const

115reflectConstant = toConst

116

libs/prelude/Language/Reflection/Elab.idr+54−2

@@ -16,6 +16,8 @@ import Prelude.Monad

16import Prelude.Nat

17import Language.Reflection

18

19+%access public export

20+

19data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat

21data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat

20

22

21||| Erasure annotations reflect Idris's idea of what is intended to be

23||| Erasure annotations reflect Idris's idea of what is intended to be

@@ -100,7 +102,7 @@ record Datatype where

100 constructors : List (TTName, List CtorArg, Raw)

102 constructors : List (TTName, List CtorArg, Raw)

101

103

102||| A reflected elaboration script.

104||| A reflected elaboration script.

103−abstract

105+export

104data Elab : Type -> Type where

106data Elab : Type -> Type where

105 -- obligatory control stuff

107 -- obligatory control stuff

106 Prim__PureElab : a -> Elab a

108 Prim__PureElab : a -> Elab a

@@ -164,7 +166,7 @@ data Elab : Type -> Type where

164-------------

166-------------

165-- Public API

167-- Public API

166-------------

168-------------

167−%access public

169+%access public export

168namespace Tactics

170namespace Tactics

169 implementation Functor Elab where

171 implementation Functor Elab where

170 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

172 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

@@ -186,31 +188,38 @@ namespace Tactics

186 x >>= f = Prim__BindElab x f

188 x >>= f = Prim__BindElab x f

187

189

188 ||| Halt elaboration with an error

190 ||| Halt elaboration with an error

191+ export

189 fail : List ErrorReportPart -> Elab a

192 fail : List ErrorReportPart -> Elab a

190 fail err = Prim__Fail err

193 fail err = Prim__Fail err

191

194

192 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

195 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

196+ export

193 getEnv : Elab (List (TTName, Binder TT))

197 getEnv : Elab (List (TTName, Binder TT))

194 getEnv = Prim__Env

198 getEnv = Prim__Env

195

199

196 ||| Get the name and type of the focused hole. Fails if not holes are present.

200 ||| Get the name and type of the focused hole. Fails if not holes are present.

201+ export

197 getGoal : Elab (TTName, TT)

202 getGoal : Elab (TTName, TT)

198 getGoal = Prim__Goal

203 getGoal = Prim__Goal

199

204

200 ||| Get the hole queue, in order.

205 ||| Get the hole queue, in order.

206+ export

201 getHoles : Elab (List TTName)

207 getHoles : Elab (List TTName)

202 getHoles = Prim__Holes

208 getHoles = Prim__Holes

203

209

204 ||| If the current hole contains a guess, return it. Otherwise, fail.

210 ||| If the current hole contains a guess, return it. Otherwise, fail.

211+ export

205 getGuess : Elab TT

212 getGuess : Elab TT

206 getGuess = Prim__Guess

213 getGuess = Prim__Guess

207

214

208 ||| Look up the types of every overloading of a name.

215 ||| Look up the types of every overloading of a name.

216+ export

209 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

217 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

210 lookupTy n = Prim__LookupTy n

218 lookupTy n = Prim__LookupTy n

211

219

212 ||| Get the type of a fully-qualified name. Fail if it doesn not

220 ||| Get the type of a fully-qualified name. Fail if it doesn not

213 ||| resolve uniquely.

221 ||| resolve uniquely.

222+ export

214 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

223 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

215 lookupTyExact n = case !(lookupTy n) of

224 lookupTyExact n = case !(lookupTy n) of

216 [res] => return res

225 [res] => return res

@@ -219,12 +228,14 @@ namespace Tactics

219

228

220 ||| Find the reflected representation of all datatypes whose names

229 ||| Find the reflected representation of all datatypes whose names

221 ||| are overloadings of some name.

230 ||| are overloadings of some name.

231+ export

222 lookupDatatype : TTName -> Elab (List Datatype)

232 lookupDatatype : TTName -> Elab (List Datatype)

223 lookupDatatype n = Prim__LookupDatatype n

233 lookupDatatype n = Prim__LookupDatatype n

224

234

225 ||| Find the reflected representation of a datatype, given its

235 ||| Find the reflected representation of a datatype, given its

226 ||| fully-qualified name. Fail if the name does not uniquely resolve

236 ||| fully-qualified name. Fail if the name does not uniquely resolve

227 ||| to a datatype.

237 ||| to a datatype.

238+ export

228 lookupDatatypeExact : TTName -> Elab Datatype

239 lookupDatatypeExact : TTName -> Elab Datatype

229 lookupDatatypeExact n = case !(lookupDatatype n) of

240 lookupDatatypeExact n = case !(lookupDatatype n) of

230 [res] => return res

241 [res] => return res

@@ -233,12 +244,14 @@ namespace Tactics

233

244

234 ||| Find the reflected function definition of all functions whose names

245 ||| Find the reflected function definition of all functions whose names

235 ||| are overloadings of some name.

246 ||| are overloadings of some name.

247+ export

236 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

248 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

237 lookupFunDefn n = Prim__LookupFunDefn n

249 lookupFunDefn n = Prim__LookupFunDefn n

238

250

239 ||| Find the reflected function definition of a function, given its

251 ||| Find the reflected function definition of a function, given its

240 ||| fully-qualified name. Fail if the name does not uniquely resolve

252 ||| fully-qualified name. Fail if the name does not uniquely resolve

241 ||| to a function.

253 ||| to a function.

254+ export

242 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

255 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

243 lookupFunDefnExact n = case !(lookupFunDefn n) of

256 lookupFunDefnExact n = case !(lookupFunDefn n) of

244 [res] => return res

257 [res] => return res

@@ -246,11 +259,13 @@ namespace Tactics

246 xs => fail [TextPart "More than one function named", NamePart n]

259 xs => fail [TextPart "More than one function named", NamePart n]

247

260

248 ||| Get the argument specification for each overloading of a name.

261 ||| Get the argument specification for each overloading of a name.

262+ export

249 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

263 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

250 lookupArgs n = Prim__LookupArgs n

264 lookupArgs n = Prim__LookupArgs n

251

265

252 ||| Get the argument specification for a name. Fail if the name does

266 ||| Get the argument specification for a name. Fail if the name does

253 ||| not uniquely resolve.

267 ||| not uniquely resolve.

268+ export

254 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

269 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

255 lookupArgsExact n = case !(lookupArgs n) of

270 lookupArgsExact n = case !(lookupArgs n) of

256 [res] => return res

271 [res] => return res

@@ -261,6 +276,7 @@ namespace Tactics

261 |||

276 |||

262 ||| @ env the environment within which to check the type

277 ||| @ env the environment within which to check the type

263 ||| @ tm the term to check

278 ||| @ tm the term to check

279+ export

264 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

280 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

265 check env tm = Prim__Check env tm

281 check env tm = Prim__Check env tm

266

282

@@ -269,15 +285,18 @@ namespace Tactics

269 |||

285 |||

270 ||| **NB**: the generated name is unique _for this run of the

286 ||| **NB**: the generated name is unique _for this run of the

271 ||| elaborator_. Do not assume that they are globally unique.

287 ||| elaborator_. Do not assume that they are globally unique.

288+ export

272 gensym : (hint : String) -> Elab TTName

289 gensym : (hint : String) -> Elab TTName

273 gensym hint = Prim__Gensym hint

290 gensym hint = Prim__Gensym hint

274

291

275 ||| Substitute a guess into a hole.

292 ||| Substitute a guess into a hole.

293+ export

276 solve : Elab ()

294 solve : Elab ()

277 solve = Prim__Solve

295 solve = Prim__Solve

278

296

279 ||| Place a term into a hole, unifying its type. Fails if the focus

297 ||| Place a term into a hole, unifying its type. Fails if the focus

280 ||| is not a hole.

298 ||| is not a hole.

299+ export

281 fill : Raw -> Elab ()

300 fill : Raw -> Elab ()

282 fill tm = Prim__Fill tm

301 fill tm = Prim__Fill tm

283

302

@@ -295,6 +314,7 @@ namespace Tactics

295 ||| @ argSpec instructions for finding the arguments to the term,

314 ||| @ argSpec instructions for finding the arguments to the term,

296 ||| where the Boolean states whether or not to attempt to solve

315 ||| where the Boolean states whether or not to attempt to solve

297 ||| the argument by unification.

316 ||| the argument by unification.

317+ export

298 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

318 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

299 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

319 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

300

320

@@ -313,6 +333,7 @@ namespace Tactics

313 ||| where the Boolean states whether or not to attempt to solve

333 ||| where the Boolean states whether or not to attempt to solve

314 ||| the argument by matching.

334 ||| the argument by matching.

315

335

336+ export

316 matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

337 matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

317 matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec

338 matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec

318

339

@@ -320,11 +341,13 @@ namespace Tactics

320 ||| exist.

341 ||| exist.

321 |||

342 |||

322 ||| @ hole the hole to focus on

343 ||| @ hole the hole to focus on

344+ export

323 focus : (hole : TTName) -> Elab ()

345 focus : (hole : TTName) -> Elab ()

324 focus hole = Prim__Focus hole

346 focus hole = Prim__Focus hole

325

347

326 ||| Send the currently-focused hole to the end of the hole queue and

348 ||| Send the currently-focused hole to the end of the hole queue and

327 ||| focus on the next hole.

349 ||| focus on the next hole.

350+ export

328 unfocus : TTName -> Elab ()

351 unfocus : TTName -> Elab ()

329 unfocus hole = Prim__Unfocus hole

352 unfocus hole = Prim__Unfocus hole

330

353

@@ -336,6 +359,7 @@ namespace Tactics

336 ||| binding, or else the scopes of the generated terms won't make

359 ||| binding, or else the scopes of the generated terms won't make

337 ||| sense. This tactic creates a new hole of the proper form, and

360 ||| sense. This tactic creates a new hole of the proper form, and

338 ||| points the old hole at it.

361 ||| points the old hole at it.

362+ export

339 attack : Elab ()

363 attack : Elab ()

340 attack = Prim__Attack

364 attack = Prim__Attack

341

365

@@ -344,6 +368,7 @@ namespace Tactics

344 ||| The new hole will be focused, and the previously-focused hole

368 ||| The new hole will be focused, and the previously-focused hole

345 ||| will be immediately after it in the hole queue. Because this

369 ||| will be immediately after it in the hole queue. Because this

346 ||| tactic introduces a new binding, you may need to `attack` first.

370 ||| tactic introduces a new binding, you may need to `attack` first.

371+ export

347 claim : TTName -> Raw -> Elab ()

372 claim : TTName -> Raw -> Elab ()

348 claim n ty = Prim__Claim n ty

373 claim n ty = Prim__Claim n ty

349

374

@@ -352,6 +377,7 @@ namespace Tactics

352 ||| `attack`).

377 ||| `attack`).

353 |||

378 |||

354 ||| @ n the name to use for the argument

379 ||| @ n the name to use for the argument

380+ export

355 intro : (n : TTName) -> Elab ()

381 intro : (n : TTName) -> Elab ()

356 intro n = Prim__Intro (Just n)

382 intro n = Prim__Intro (Just n)

357

383

@@ -361,6 +387,7 @@ namespace Tactics

361 |||

387 |||

362 ||| Requires that the hole be immediately under its binder (use

388 ||| Requires that the hole be immediately under its binder (use

363 ||| `attack` if it might not be).

389 ||| `attack` if it might not be).

390+ export

364 intro' : Elab ()

391 intro' : Elab ()

365 intro' = Prim__Intro Nothing

392 intro' = Prim__Intro Nothing

366

393

@@ -369,10 +396,12 @@ namespace Tactics

369 |||

396 |||

370 ||| Requires that the hole be immediately under its binder (use

397 ||| Requires that the hole be immediately under its binder (use

371 ||| `attack` if it might not be).

398 ||| `attack` if it might not be).

399+ export

372 forall : TTName -> Raw -> Elab ()

400 forall : TTName -> Raw -> Elab ()

373 forall n ty = Prim__Forall n ty

401 forall n ty = Prim__Forall n ty

374

402

375 ||| Convert a hole into a pattern variable.

403 ||| Convert a hole into a pattern variable.

404+ export

376 patvar : TTName -> Elab ()

405 patvar : TTName -> Elab ()

377 patvar n = Prim__PatVar n

406 patvar n = Prim__PatVar n

378

407

@@ -380,6 +409,7 @@ namespace Tactics

380 |||

409 |||

381 ||| Requires that the hole be immediately under its binder (use

410 ||| Requires that the hole be immediately under its binder (use

382 ||| `attack` if it might not be).

411 ||| `attack` if it might not be).

412+ export

383 patbind : TTName -> Elab ()

413 patbind : TTName -> Elab ()

384 patbind n = Prim__PatBind n

414 patbind n = Prim__PatBind n

385

415

@@ -391,10 +421,12 @@ namespace Tactics

391 ||| @ n the name to let bind

421 ||| @ n the name to let bind

392 ||| @ ty the type of the term to be let-bound

422 ||| @ ty the type of the term to be let-bound

393 ||| @ tm the term to be bound

423 ||| @ tm the term to be bound

424+ export

394 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

425 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

395 letbind n ty tm = Prim__LetBind n ty tm

426 letbind n ty tm = Prim__LetBind n ty tm

396

427

397 ||| Normalise the goal.

428 ||| Normalise the goal.

429+ export

398 compute : Elab ()

430 compute : Elab ()

399 compute = Prim__Compute

431 compute = Prim__Compute

400

432

@@ -402,12 +434,14 @@ namespace Tactics

402 |||

434 |||

403 ||| @ env the environment in which to compute (get one of these from `getEnv`)

435 ||| @ env the environment in which to compute (get one of these from `getEnv`)

404 ||| @ term the term to normalise

436 ||| @ term the term to normalise

437+ export

405 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

438 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

406 normalise env term = Prim__Normalise env term

439 normalise env term = Prim__Normalise env term

407

440

408 ||| Reduce a closed term to weak-head normal form

441 ||| Reduce a closed term to weak-head normal form

409 |||

442 |||

410 ||| @ term the term to reduce

443 ||| @ term the term to reduce

444+ export

411 whnf : (term : TT) -> Elab TT

445 whnf : (term : TT) -> Elab TT

412 whnf term = Prim__Whnf term

446 whnf term = Prim__Whnf term

413

447

@@ -417,6 +451,7 @@ namespace Tactics

417 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

451 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

418 ||| @ term1 the first term to convert

452 ||| @ term1 the first term to convert

419 ||| @ term2 the second term to convert

453 ||| @ term2 the second term to convert

454+ export

420 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

455 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

421 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

456 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

422

457

@@ -424,14 +459,17 @@ namespace Tactics

424 |||

459 |||

425 ||| @ term1 the first term to convert

460 ||| @ term1 the first term to convert

426 ||| @ term2 the second term to convert

461 ||| @ term2 the second term to convert

462+ export

427 converts : (term1, term2 : TT) -> Elab ()

463 converts : (term1, term2 : TT) -> Elab ()

428 converts term1 term2 = convertsInEnv !getEnv term1 term2

464 converts term1 term2 = convertsInEnv !getEnv term1 term2

429

465

430 ||| Find the source context for the elaboration script

466 ||| Find the source context for the elaboration script

467+ export

431 getSourceLocation : Elab SourceLocation

468 getSourceLocation : Elab SourceLocation

432 getSourceLocation = Prim__SourceLocation

469 getSourceLocation = Prim__SourceLocation

433

470

434 ||| Attempt to solve the current goal with the source code location

471 ||| Attempt to solve the current goal with the source code location

472+ export

435 sourceLocation : Elab ()

473 sourceLocation : Elab ()

436 sourceLocation = do loc <- getSourceLocation

474 sourceLocation = do loc <- getSourceLocation

437 fill (quote loc)

475 fill (quote loc)

@@ -442,6 +480,7 @@ namespace Tactics

442 |||

480 |||

443 ||| The namespace is represented as a reverse-order list of strings,

481 ||| The namespace is represented as a reverse-order list of strings,

444 ||| just as in the representation of names.

482 ||| just as in the representation of names.

483+ export

445 currentNamespace : Elab (List String)

484 currentNamespace : Elab (List String)

446 currentNamespace = Prim__Namespace

485 currentNamespace = Prim__Namespace

447

486

@@ -455,16 +494,19 @@ namespace Tactics

455 ||| Because this tactic internally introduces a `let` binding, it

494 ||| Because this tactic internally introduces a `let` binding, it

456 ||| requires that the hole be immediately under its binder (use

495 ||| requires that the hole be immediately under its binder (use

457 ||| `attack` if it might not be).

496 ||| `attack` if it might not be).

497+ export

458 rewriteWith : Raw -> Elab ()

498 rewriteWith : Raw -> Elab ()

459 rewriteWith rule = Prim__Rewrite rule

499 rewriteWith rule = Prim__Rewrite rule

460

500

461 ||| Add a type declaration to the global context.

501 ||| Add a type declaration to the global context.

502+ export

462 declareType : TyDecl -> Elab ()

503 declareType : TyDecl -> Elab ()

463 declareType decl = Prim__DeclareType decl

504 declareType decl = Prim__DeclareType decl

464

505

465 ||| Define a function in the global context. The function must have

506 ||| Define a function in the global context. The function must have

466 ||| already been declared, either in ordinary Idris code or using

507 ||| already been declared, either in ordinary Idris code or using

467 ||| `declareType`.

508 ||| `declareType`.

509+ export

468 defineFunction : FunDefn Raw -> Elab ()

510 defineFunction : FunDefn Raw -> Elab ()

469 defineFunction defun = Prim__DefineFunction defun

511 defineFunction defun = Prim__DefineFunction defun

470

512

@@ -472,12 +514,14 @@ namespace Tactics

472 |||

514 |||

473 ||| @ ifaceName the name of the interface for which an implementation is being registered

515 ||| @ ifaceName the name of the interface for which an implementation is being registered

474 ||| @ instName the name of the definition to use in implementation search

516 ||| @ instName the name of the definition to use in implementation search

517+ export

475 addInstance : (ifaceName, instName : TTName) -> Elab ()

518 addInstance : (ifaceName, instName : TTName) -> Elab ()

476 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

519 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

477

520

478 ||| Determine whether a name denotes an interface.

521 ||| Determine whether a name denotes an interface.

479 |||

522 |||

480 ||| @ name a name that might denote an interface.

523 ||| @ name a name that might denote an interface.

524+ export

481 isTCName : (name : TTName) -> Elab Bool

525 isTCName : (name : TTName) -> Elab Bool

482 isTCName name = Prim__IsTCName name

526 isTCName name = Prim__IsTCName name

483

527

@@ -485,10 +529,12 @@ namespace Tactics

485 |||

529 |||

486 ||| @ fn the name of the definition being elaborated (to prevent Idris

530 ||| @ fn the name of the definition being elaborated (to prevent Idris

487 ||| from looping)

531 ||| from looping)

532+ export

488 resolveTC : (fn : TTName) -> Elab ()

533 resolveTC : (fn : TTName) -> Elab ()

489 resolveTC fn = Prim__ResolveTC fn

534 resolveTC fn = Prim__ResolveTC fn

490

535

491 ||| Use Idris's internal proof search.

536 ||| Use Idris's internal proof search.

537+ export

492 search : Elab ()

538 search : Elab ()

493 search = Prim__Search 100 []

539 search = Prim__Search 100 []

494

540

@@ -496,6 +542,7 @@ namespace Tactics

496 |||

542 |||

497 ||| @ depth the search depth

543 ||| @ depth the search depth

498 ||| @ hints additional names to try

544 ||| @ hints additional names to try

545+ export

499 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

546 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

500 search' depth hints = Prim__Search depth hints

547 search' depth hints = Prim__Search depth hints

501

548

@@ -505,6 +552,7 @@ namespace Tactics

505 ||| if the string is not a valid operator.

552 ||| if the string is not a valid operator.

506 |||

553 |||

507 ||| @ operator the operator string to look up

554 ||| @ operator the operator string to look up

555+ export

508 operatorFixity : (operator : String) -> Elab Fixity

556 operatorFixity : (operator : String) -> Elab Fixity

509 operatorFixity operator = Prim__Fixity operator

557 operatorFixity operator = Prim__Fixity operator

510

558

@@ -512,6 +560,7 @@ namespace Tactics

512 |||

560 |||

513 ||| This is intended for elaboration script developers, not for

561 ||| This is intended for elaboration script developers, not for

514 ||| end-users. Use `fail` for final scripts.

562 ||| end-users. Use `fail` for final scripts.

563+ export

515 debug : Elab a

564 debug : Elab a

516 debug = Prim__Debug []

565 debug = Prim__Debug []

517

566

@@ -522,18 +571,21 @@ namespace Tactics

522 ||| end-users. Use `fail` for final scripts.

571 ||| end-users. Use `fail` for final scripts.

523 |||

572 |||

524 ||| @ msg the message to display

573 ||| @ msg the message to display

574+ export

525 debugMessage : (msg : List ErrorReportPart) -> Elab a

575 debugMessage : (msg : List ErrorReportPart) -> Elab a

526 debugMessage msg = Prim__Debug msg

576 debugMessage msg = Prim__Debug msg

527

577

528 ||| Create a new top-level metavariable to solve the current hole.

578 ||| Create a new top-level metavariable to solve the current hole.

529 |||

579 |||

530 ||| @ name the name for the top-level variable

580 ||| @ name the name for the top-level variable

581+ export

531 metavar : (name : TTName) -> Elab ()

582 metavar : (name : TTName) -> Elab ()

532 metavar name = Prim__Metavar name

583 metavar name = Prim__Metavar name

533

584

534 ||| Recursively invoke the reflected elaborator with some goal.

585 ||| Recursively invoke the reflected elaborator with some goal.

535 |||

586 |||

536 ||| The result is the final term and its type.

587 ||| The result is the final term and its type.

588+ export

537 runElab : Raw -> Elab () -> Elab (TT, TT)

589 runElab : Raw -> Elab () -> Elab (TT, TT)

538 runElab goal script = Prim__RecursiveElab goal script

590 runElab goal script = Prim__RecursiveElab goal script

539

591

libs/prelude/Language/Reflection/Errors.idr+2

@@ -8,6 +8,8 @@ import Prelude.Bool

8import Prelude.List

9import Prelude.Maybe

10

11+%access public export

12+

11data Err = Msg String

13data Err = Msg String

12 | InternalMsg String

14 | InternalMsg String

13 | CantUnify Bool TT TT Err (List (TTName, TT)) Int

15 | CantUnify Bool TT TT Err (List (TTName, TT)) Int

libs/prelude/Prelude.idr+7−7

@@ -6,7 +6,7 @@ import public IO

6import public Prelude.Algebra

7import public Prelude.Basics

8import public Prelude.Bool

9−import public Prelude.Classes

9+import public Prelude.Interfaces

10import public Prelude.Cast

11import public Prelude.Nat

12import public Prelude.List

@@ -33,7 +33,7 @@ import public Language.Reflection

33import public Language.Reflection.Elab

34import public Language.Reflection.Errors

35

36−%access public

36+%access public export

37%default total

38

39-- Things that can't be elsewhere for import cycle reasons

@@ -210,7 +210,7 @@ Enum Int where

210Enum Char where

211 toNat c = toNat (ord c)

212 fromNat n = chr (fromNat n)

213−

213+

214 pred c = fromNat (pred (toNat c))

215

216syntax "[" [start] ".." [end] "]"

@@ -264,13 +264,13 @@ while t b = do v <- t

264------- Some error rewriting

265

266%language ErrorReflection

267−

267+

268private

269cast_part : TT -> ErrorReportPart

270cast_part (P Bound n t) = TextPart "unknown type"

271cast_part x = TermPart x

272−

272+

273−%error_handler

273+%error_handler export

274cast_error : Err -> Maybe (List ErrorReportPart)

275cast_error (CantResolve `(Cast ~x ~y))

276 = Just [TextPart "Can't cast from",

@@ -280,8 +280,8 @@ cast_error (CantResolve `(Cast ~x ~y))

280cast_error _ = Nothing

281

282%error_handler

283+export

283num_error : Err -> Maybe (List ErrorReportPart)

284num_error : Err -> Maybe (List ErrorReportPart)

284num_error (CantResolve `(Num ~x))

285num_error (CantResolve `(Num ~x))

285 = Just [TermPart x, TextPart "is not a numeric type"]

286 = Just [TermPart x, TextPart "is not a numeric type"]

286num_error _ = Nothing

287num_error _ = Nothing

287−

libs/prelude/Prelude/Algebra.idr+1−1

@@ -4,7 +4,7 @@ import Builtins

4

5infixl 6 <+>

6

7−%access public

7+%access public export

8

9--------------------------------------------------------------------------------

10-- A modest interface hierarchy

libs/prelude/Prelude/Applicative.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

4

5import Prelude.Basics

6import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

8import Prelude.Foldable

9import Prelude.Functor

10

11+%access public export

12+

11---- Applicative functors/Idioms

13---- Applicative functors/Idioms

12

14

13infixl 2 <*>

15infixl 2 <*>

libs/prelude/Prelude/Basics.idr+6−4

@@ -1,7 +1,9 @@

1module Prelude.Basics

2

3import Builtins

4−

4+

5+%access public export

6+

5Not : Type -> Type

7Not : Type -> Type

6Not a = a -> Void

8Not a = a -> Void

7

9

@@ -51,9 +53,9 @@ data Dec : Type -> Type where

51

53

52 ||| The case where the property holds

54 ||| The case where the property holds

53 ||| @ prf the proof

55 ||| @ prf the proof

54− Yes : {A : Type} -> (prf : A) -> Dec A

56+ Yes : (prf : prop) -> Dec prop

55

57

56 ||| The case where the property holding would be a contradiction

58 ||| The case where the property holding would be a contradiction

57− ||| @ contra a demonstration that A would be a contradiction

59+ ||| @ contra a demonstration that prop would be a contradiction

58− No : {A : Type} -> (contra : A -> Void) -> Dec A

60+ No : (contra : prop -> Void) -> Dec prop

59

61

libs/prelude/Prelude/Bits.idr+2−2

@@ -6,13 +6,13 @@ import Prelude.Basics

6import Prelude.Bool

7import Prelude.Cast

8import Prelude.Chars

9−import Prelude.Classes

9+import Prelude.Interfaces

10import Prelude.Foldable

11import Prelude.Nat

12import Prelude.List

13import Prelude.Strings

14

15−%access public

15+%access public export

16%default total

17

18b8ToString : Bits8 -> String

libs/prelude/Prelude/Bool.idr+2

@@ -4,6 +4,8 @@ import Builtins

4

5import Prelude.Uninhabited

6

7+%access public export

8+

7||| Boolean Data Type

9||| Boolean Data Type

8%case data Bool = False | True

10%case data Bool = False | True

9

11

libs/prelude/Prelude/Cast.idr+2

@@ -3,6 +3,8 @@ module Prelude.Cast

3import Prelude.Bool

4import public Builtins

5

6+%access public export

7+

6||| Interface for transforming an instance of a data type to another type.

8||| Interface for transforming an instance of a data type to another type.

7interface Cast from to where

9interface Cast from to where

8 ||| Perform a cast operation.

10 ||| Perform a cast operation.

libs/prelude/Prelude/Chars.idr+3−3

@@ -2,11 +2,13 @@ module Prelude.Chars

2-- Functions operating over Chars

3

4import Prelude.Bool

5−import Prelude.Classes

5+import Prelude.Interfaces

6import Prelude.List

7import Prelude.Cast

8import Builtins

9

10+%access public export

11+

10||| Convert the number to its ASCII equivalent.

12||| Convert the number to its ASCII equivalent.

11chr : Int -> Char

13chr : Int -> Char

12chr x = if (x >= 0 && x < 0x110000)

14chr x = if (x >= 0 && x < 0x110000)

@@ -74,5 +76,3 @@ isHexDigit x = elem (toUpper x) hexChars where

74||| Returns true if the character is an octal digit.

76||| Returns true if the character is an octal digit.

75isOctDigit : Char -> Bool

77isOctDigit : Char -> Bool

76isOctDigit x = (x >= '0' && x <= '7')

78isOctDigit x = (x >= '0' && x <= '7')

77−

78−

libs/prelude/Prelude/Doubles.idr+4−6

@@ -1,16 +1,16 @@

1−module Prelude.Doubles

1+module Prelude.Doubles

2

3import Builtins

4−import Prelude.Classes

4+import Prelude.Interfaces

5

6−%access public

6+%access public export

7%default total

8

9%include C "math.h"

10%lib C "m"

11

12pi : Double

13−pi = 3.14159265358979323846

13+pi = 3.14159265358979323846

14

15euler : Double

16euler = 2.7182818284590452354

@@ -59,5 +59,3 @@ floor x = prim__floatFloor x

59

60ceiling : Double -> Double

61ceiling x = prim__floatCeil x

62−

63−

libs/prelude/Prelude/Either.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

4

5import Prelude.Basics

6import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

8import Prelude.Maybe

9import Prelude.List

10

11+%access public export

12+

11||| A sum type

13||| A sum type

12%elim data Either : (a, b : Type) -> Type where

14%elim data Either : (a, b : Type) -> Type where

13 ||| One possibility of the sum, conventionally used to represent errors

15 ||| One possibility of the sum, conventionally used to represent errors

libs/prelude/Prelude/File.idr+60−20

@@ -9,15 +9,15 @@ import Prelude.Strings

9import Prelude.Cast

10import Prelude.Bool

11import Prelude.Basics

12−import Prelude.Classes

12+import Prelude.Interfaces

13import Prelude.Either

14import Prelude.Show

15import IO

16

17−%access public

17+%access public export

18

19||| A file handle

20−abstract

20+export

21data File : Type where

22 FHandle : (p : Ptr) -> File

23

@@ -39,7 +39,7 @@ strError err = unsafePerformIO -- yeah, yeah...

39 (foreign FFI_C "idris_showerror" (Int -> IO String) err)

40

41getFileError : IO FileError

42−getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

42+getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

43 (Ptr -> IO (Raw FileError)) prim__vm

44 return err

45

@@ -49,25 +49,31 @@ Show FileError where

49 show (GenericFileError errno) = strError errno

50

51||| Standard input

52+export

52stdin : File

53stdin : File

53stdin = FHandle prim__stdin

54stdin = FHandle prim__stdin

54

55

55||| Standard output

56||| Standard output

57+export

56stdout : File

58stdout : File

57stdout = FHandle prim__stdout

59stdout = FHandle prim__stdout

58

60

59||| Standard output

61||| Standard output

62+export

60stderr : File

63stderr : File

61stderr = FHandle prim__stderr

64stderr = FHandle prim__stderr

62

65

66+private

63do_ferror : Ptr -> IO Int

67do_ferror : Ptr -> IO Int

64do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

68do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

65

69

70+export

66ferror : File -> IO Bool

71ferror : File -> IO Bool

67ferror (FHandle h) = do err <- do_ferror h

72ferror (FHandle h) = do err <- do_ferror h

68 return (not (err == 0))

73 return (not (err == 0))

69

74

70||| Call the RTS's file opening function

75||| Call the RTS's file opening function

76+private

71do_fopen : String -> String -> IO Ptr

77do_fopen : String -> String -> IO Ptr

72do_fopen f m

78do_fopen f m

73 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

79 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

@@ -75,6 +81,7 @@ do_fopen f m

75||| Open a file

81||| Open a file

76||| @ f the filename

82||| @ f the filename

77||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

83||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

84+export

78fopen : (f : String) -> (m : String) -> IO (Either FileError File)

85fopen : (f : String) -> (m : String) -> IO (Either FileError File)

79fopen f m = do h <- do_fopen f m

86fopen f m = do h <- do_fopen f m

80 if !(nullPtr h)

87 if !(nullPtr h)

@@ -83,60 +90,83 @@ fopen f m = do h <- do_fopen f m

83 else return (Right (FHandle h))

90 else return (Right (FHandle h))

84

91

85||| Check whether a file handle is actually a null pointer

92||| Check whether a file handle is actually a null pointer

93+export

86validFile : File -> IO Bool

94validFile : File -> IO Bool

87validFile (FHandle h) = do x <- nullPtr h

95validFile (FHandle h) = do x <- nullPtr h

88 return (not x)

96 return (not x)

89

97

90||| Modes for opening files

98||| Modes for opening files

91−data Mode = Read | Write | ReadWrite

100+

101+Write : Mode

102+Write = WriteTruncate

103+%deprecate Write "Please use WriteTruncate instead."

104+

105+modeStr : Mode -> String

106+modeStr Read = "r"

107+modeStr WriteTruncate = "w"

108+modeStr Append = "a"

109+modeStr ReadWrite = "r+"

110+modeStr ReadWriteTruncate = "w+"

111+modeStr ReadAppend = "a+"

92

112

93||| Open a file

113||| Open a file

94||| @ f the filename

114||| @ f the filename

95−||| @ m the mode; either Read, Write, or ReadWrite

115+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend

116+export

96openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

117openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

97−openFile f m = fopen f (modeStr m) where

118+openFile f m = fopen f (modeStr m)

98− modeStr Read = "r"

119+

99− modeStr Write = "w"

120+||| Open a file using C11 extended modes.

100− modeStr ReadWrite = "r+"

121+||| @ f the filename

122+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend

123+export

124+openFileX : (f : String) -> (m : Mode) -> IO (Either FileError File)

125+openFileX f m = fopen f $ modeStr m ++ "x"

101

126

127+private

102do_fclose : Ptr -> IO ()

128do_fclose : Ptr -> IO ()

103do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

129do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

104

130

131+export

105closeFile : File -> IO ()

132closeFile : File -> IO ()

106closeFile (FHandle h) = do_fclose h

133closeFile (FHandle h) = do_fclose h

107

134

135+private

108do_fread : Ptr -> IO' l String

136do_fread : Ptr -> IO' l String

109do_fread h = prim_fread h

137do_fread h = prim_fread h

110

138

139+export

111fgetc : File -> IO (Either FileError Char)

140fgetc : File -> IO (Either FileError Char)

112fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

141fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

113 if !(ferror (FHandle h))

142 if !(ferror (FHandle h))

114 then return (Left FileReadError)

143 then return (Left FileReadError)

115 else return (Right c)

144 else return (Right c)

116

145

146+export

117fflush : File -> IO ()

147fflush : File -> IO ()

118fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

148fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

119

149

150+private

120do_popen : String -> String -> IO Ptr

151do_popen : String -> String -> IO Ptr

121do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

152do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

122

153

154+export

123popen : String -> Mode -> IO (Either FileError File)

155popen : String -> Mode -> IO (Either FileError File)

124popen f m = do ptr <- do_popen f (modeStr m)

156popen f m = do ptr <- do_popen f (modeStr m)

125 if !(nullPtr ptr)

157 if !(nullPtr ptr)

126 then do err <- getFileError

158 then do err <- getFileError

127 return (Left err)

159 return (Left err)

128 else return (Right (FHandle ptr))

160 else return (Right (FHandle ptr))

129− where

130− modeStr Read = "r"

131− modeStr Write = "w"

132− modeStr ReadWrite = "r+"

133

161

162+export

134pclose : File -> IO ()

163pclose : File -> IO ()

135pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

164pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

136

165

137-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

166-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

138-- prim__vm h

167-- prim__vm h

139

168

169+export

140fread : File -> IO (Either FileError String)

170fread : File -> IO (Either FileError String)

141fread (FHandle h) = do str <- do_fread h

171fread (FHandle h) = do str <- do_fread h

142 if !(ferror (FHandle h))

172 if !(ferror (FHandle h))

@@ -145,56 +175,65 @@ fread (FHandle h) = do str <- do_fread h

145

175

146||| Read a line from a file

176||| Read a line from a file

147||| @h a file handle which must be open for reading

177||| @h a file handle which must be open for reading

178+export

148fGetLine : (h : File) -> IO (Either FileError String)

179fGetLine : (h : File) -> IO (Either FileError String)

149fGetLine = fread

180fGetLine = fread

150

181

151%deprecate fread "Use fGetLine instead"

182%deprecate fread "Use fGetLine instead"

152

183

184+private

153do_fwrite : Ptr -> String -> IO (Either FileError ())

185do_fwrite : Ptr -> String -> IO (Either FileError ())

154do_fwrite h s = do res <- prim_fwrite h s

186do_fwrite h s = do res <- prim_fwrite h s

155 if (res /= 0)

187 if (res /= 0)

156 then do errno <- getErrno

188 then do errno <- getErrno

157− if errno == 0

189+ if errno == 0

158 then return (Left FileWriteError)

190 then return (Left FileWriteError)

159 else do err <- getFileError

191 else do err <- getFileError

160 return (Left err)

192 return (Left err)

161 else return (Right ())

193 else return (Right ())

162

194

195+export

163fwrite : File -> String -> IO (Either FileError ())

196fwrite : File -> String -> IO (Either FileError ())

164fwrite (FHandle h) s = do_fwrite h s

197fwrite (FHandle h) s = do_fwrite h s

165

198

166||| Write a line to a file

199||| Write a line to a file

167||| @h a file handle which must be open for writing

200||| @h a file handle which must be open for writing

168||| @str the line to write to the file

201||| @str the line to write to the file

202+export

169fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

203fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

170fPutStr (FHandle h) s = do_fwrite h s

204fPutStr (FHandle h) s = do_fwrite h s

171

205

206+export

172fPutStrLn : File -> String -> IO (Either FileError ())

207fPutStrLn : File -> String -> IO (Either FileError ())

173fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

208fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

174

209

175%deprecate fwrite "Use fPutStr instead"

210%deprecate fwrite "Use fPutStr instead"

176

211

212+private

177do_feof : Ptr -> IO Int

213do_feof : Ptr -> IO Int

178do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

214do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

179

215

180||| Check if a file handle has reached the end

216||| Check if a file handle has reached the end

217+export

181fEOF : File -> IO Bool

218fEOF : File -> IO Bool

182fEOF (FHandle h) = do eof <- do_feof h

219fEOF (FHandle h) = do eof <- do_feof h

183 return (not (eof == 0))

220 return (not (eof == 0))

184

221

185||| Check if a file handle has reached the end

222||| Check if a file handle has reached the end

223+export

186feof : File -> IO Bool

224feof : File -> IO Bool

187feof = fEOF

225feof = fEOF

188

226

189%deprecate feof "Use fEOF instead"

227%deprecate feof "Use fEOF instead"

190

228

229+export

191fpoll : File -> IO Bool

230fpoll : File -> IO Bool

192fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

231fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

193 return (p > 0)

232 return (p > 0)

194

233

195||| Read the contents of a file into a string

234||| Read the contents of a file into a string

196−partial -- might be reading something infinitely long like /dev/null ...

235+partial -- might be reading something infinitely long like /dev/null ...

197−covering

236+covering export

198readFile : String -> IO (Either FileError String)

237readFile : String -> IO (Either FileError String)

199readFile fn = do Right h <- openFile fn Read

238readFile fn = do Right h <- openFile fn Read

200 | Left err => return (Left err)

239 | Left err => return (Left err)

@@ -212,10 +251,11 @@ readFile fn = do Right h <- openFile fn Read

212 else return (Right contents)

251 else return (Right contents)

213

252

214||| Write a string to a file

253||| Write a string to a file

254+export

215−writeFile : (filepath : String) -> (contents : String) ->

255+writeFile : (filepath : String) -> (contents : String) ->

216 IO (Either FileError ())

256 IO (Either FileError ())

217writeFile fn contents = do

257writeFile fn contents = do

218− Right h <- openFile fn Write | Left err => return (Left err)

258+ Right h <- openFile fn WriteTruncate | Left err => return (Left err)

219− Right () <- fPutStr h contents | Left err => return (Left err)

259+ Right () <- fPutStr h contents | Left err => return (Left err)

220 closeFile h

260 closeFile h

221 return (Right ())

261 return (Right ())

libs/prelude/Prelude/Foldable.idr+4−5

@@ -3,15 +3,15 @@ module Prelude.Foldable

3import Builtins

4import Prelude.Bool

5import Prelude.Basics

6−import Prelude.Classes

6+import Prelude.Interfaces

7import Prelude.Algebra

8

9−%access public

9+%access public export

10%default total

11

12interface Foldable (t : Type -> Type) where

13− foldr : (elt -> acc -> acc) -> acc -> t elt -> acc

13+ foldr : (elem -> acc -> acc) -> acc -> t elem -> acc

14− foldl : (acc -> elt -> acc) -> acc -> t elt -> acc

14+ foldl : (acc -> elem -> acc) -> acc -> t elem -> acc

15 foldl f z t = foldr (flip (.) . flip f) id t z

16

17||| Combine each element of a structure into a monoid

@@ -54,4 +54,3 @@ sum = foldr (+) 0

54||| Multiply together all elements of a structure

55product : (Foldable t, Num a) => t a -> a

56product = foldr (*) 1

57−

libs/prelude/Prelude/Functor.idr+7−5

@@ -2,21 +2,23 @@ module Prelude.Functor

2

3import Prelude.Basics

4

5+%access public export

6+

5||| Functors allow a uniform action over a parameterised type.

7||| Functors allow a uniform action over a parameterised type.

6||| @ f a parameterised type

8||| @ f a parameterised type

7interface Functor (f : Type -> Type) where

9interface Functor (f : Type -> Type) where

8 ||| Apply a function across everything of type 'a' in a

10 ||| Apply a function across everything of type 'a' in a

9 ||| parameterised type

11 ||| parameterised type

10 ||| @ f the parameterised type

12 ||| @ f the parameterised type

11− ||| @ m the function to apply

13+ ||| @ func the function to apply

12− map : (m : a -> b) -> f a -> f b

14+ map : (func : a -> b) -> f a -> f b

13

15

14infixl 4 <$>

16infixl 4 <$>

15

17

16||| An infix alias for `map`, applying a function across everything of

18||| An infix alias for `map`, applying a function across everything of

17||| type 'a' in a parameterised type

19||| type 'a' in a parameterised type

18||| @ f the parameterised type

20||| @ f the parameterised type

19−||| @ m the function to apply

21+||| @ func the function to apply

20−(<$>) : Functor f => (m : a -> b) -> f a -> f b

22+(<$>) : Functor f => (func : a -> b) -> f a -> f b

21−m <$> x = map m x

23+func <$> x = map func x

22

24

libs/prelude/Prelude/Interactive.idr+18−19

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

1||| Various helper functions for creating simple interactive systems.

2−|||

2+|||

3||| These are mostly intended for helping with teaching, in that they will allow

4||| the easy creation of interactive programs without needing to teach IO

5||| or Effects first, but they also capture some common patterns of interactive

@@ -10,7 +10,7 @@ import Builtins

10import Prelude.List

11import Prelude.File

12import Prelude.Bool

13−import Prelude.Classes

13+import Prelude.Interfaces

14import Prelude.Strings

15import Prelude.Chars

16import Prelude.Show

@@ -21,7 +21,7 @@ import Prelude.Either

21import Prelude.Monad

22import IO

23

24−%access public

24+%access public export

25

26---- some basic io

27

@@ -115,19 +115,19 @@ getArgs = do n <- numArgs

115||| @ onEOF the function to run on reaching end of file, returning a String

116||| to output

117partial

118−processHandle : File ->

118+processHandle : File ->

119 (state : a) ->

120− (onRead : a -> String -> (String, a)) ->

120+ (onRead : a -> String -> (String, a)) ->

121− (onEOF : a -> String) ->

121+ (onEOF : a -> String) ->

122 IO ()

123−processHandle h acc onRead onEOF

123+processHandle h acc onRead onEOF

124 = if !(fEOF h)

125 then putStr (onEOF acc)

126 else do Right x <- fGetLine h

127 | Left err => putStr (onEOF acc)

128 let (out, acc') = onRead acc x

129 putStr out

130− processHandle h acc' onRead onEOF

130+ processHandle h acc' onRead onEOF

131

132||| Process input from the standard input stream, while maintaining a state.

133||| @ state the input state

@@ -136,34 +136,33 @@ processHandle h acc onRead onEOF

136||| @ onEOI the function to run on reaching end of input, returning a String

137||| to output

138partial

139−processStdin : (state : a) ->

139+processStdin : (state : a) ->

140− (onRead : a -> String -> (String, a)) ->

140+ (onRead : a -> String -> (String, a)) ->

141 (onEOI : a -> String) -> IO ()

142processStdin = processHandle stdin

143

144||| A basic read-eval-print loop, maintaining a state

145||| @ state the input state

146−||| @ prompt the prompt to show

146+||| @ prompt the prompt to show

147||| @ onInput the function to run on reading input, returning a String to

148||| output and a new state. Returns Nothing if the repl should exit

149partial

150−replWith : (state : a) -> (prompt : String) ->

150+replWith : (state : a) -> (prompt : String) ->

151 (onInput : a -> String -> Maybe (String, a)) -> IO ()

152−replWith acc prompt fn

152+replWith acc prompt fn

153 = do putStr prompt

154 x <- getLine

155 case fn acc x of

156− Just (out, acc') => do putStr out

156+ Just (out, acc') => do putStr out

157 replWith acc' prompt fn

158 Nothing => return ()

159

160||| A basic read-eval-print loop

161−||| @ prompt the prompt to show

161+||| @ prompt the prompt to show

162||| @ onInput the function to run on reading input, returning a String to

163−||| output

163+||| output

164partial

165−repl : (prompt : String) ->

165+repl : (prompt : String) ->

166 (onInput : String -> String) -> IO ()

167−repl prompt fn

167+repl prompt fn

168 = replWith () prompt (\x, s => Just (fn s, ()))

169−

libs/prelude/Prelude/Classes.idr → libs/prelude/Prelude/Interfaces.idrrenamed+11−11

@@ -1,9 +1,11 @@

1−module Prelude.Classes

1+module Prelude.Interfaces

2

3import Builtins

4import Prelude.Basics

5import Prelude.Bool

6

7+%access public export

8+

7-- Numerical Operator Precedence

9-- Numerical Operator Precedence

8infixl 5 ==, /=

10infixl 5 ==, /=

9infixl 6 <, <=, >, >=

11infixl 6 <, <=, >, >=

@@ -57,7 +59,7 @@ Eq Bool where

57 True == False = False

59 True == False = False

58 False == True = False

60 False == True = False

59 False == False = True

61 False == False = True

60−

62+

61(Eq a, Eq b) => Eq (a, b) where

63(Eq a, Eq b) => Eq (a, b) where

62 (==) (a, c) (b, d) = (a == b) && (c == d)

64 (==) (a, c) (b, d) = (a == b) && (c == d)

63

65

@@ -357,7 +359,7 @@ divB8 x y = case y == 0 of

357modB8 : Bits8 -> Bits8 -> Bits8

359modB8 : Bits8 -> Bits8 -> Bits8

358modB8 x y = case y == 0 of

360modB8 x y = case y == 0 of

359 False => prim__sremB8 x y

361 False => prim__sremB8 x y

360−

362+

361Integral Bits8 where

363Integral Bits8 where

362 div = divB8

364 div = divB8

363 mod = modB8

365 mod = modB8

@@ -372,8 +374,8 @@ modB16 x y = case y == 0 of

372 False => prim__sremB16 x y

374 False => prim__sremB16 x y

373

375

374Integral Bits16 where

376Integral Bits16 where

375− div = divB16

377+ div = divB16

376− mod = modB16

378+ mod = modB16

377

379

378-- ------------------------------------------------------------------ [ Bits32 ]

380-- ------------------------------------------------------------------ [ Bits32 ]

379divB32 : Bits32 -> Bits32 -> Bits32

381divB32 : Bits32 -> Bits32 -> Bits32

@@ -385,8 +387,8 @@ modB32 x y = case y == 0 of

385 False => prim__sremB32 x y

387 False => prim__sremB32 x y

386

388

387Integral Bits32 where

389Integral Bits32 where

388− div = divB32

390+ div = divB32

389− mod = modB32

391+ mod = modB32

390

392

391-- ------------------------------------------------------------------ [ Bits64 ]

393-- ------------------------------------------------------------------ [ Bits64 ]

392divB64 : Bits64 -> Bits64 -> Bits64

394divB64 : Bits64 -> Bits64 -> Bits64

@@ -398,7 +400,5 @@ modB64 x y = case y == 0 of

398 False => prim__sremB64 x y

400 False => prim__sremB64 x y

399

401

400Integral Bits64 where

402Integral Bits64 where

401− div = divB64

403+ div = divB64

402− mod = modB64

404+ mod = modB64

403−

404−

libs/prelude/Prelude/List.idr+5−6

@@ -5,14 +5,14 @@ import Builtins

5import Prelude.Algebra

6import Prelude.Basics

7import Prelude.Bool

8−import Prelude.Classes

8+import Prelude.Interfaces

9import Prelude.Foldable

10import Prelude.Functor

11import Prelude.Maybe

12import Prelude.Uninhabited

13import Prelude.Nat

14

15−%access public

15+%access public export

16%default total

17

18infix 5 \\

@@ -174,7 +174,7 @@ init' [] = Nothing

174init' (x::xs) =

175 case xs of

176 [] => Just []

177− y::ys =>

177+ y::ys =>

178 case init' $ y::ys of

179 Nothing => Nothing

180 Just j => Just $ x :: j

@@ -305,7 +305,7 @@ zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

305||| @ z the third list

306zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->

307 (z : List c) -> List d

308−zipWith3 f _ [] (z::zs) = []

308+zipWith3 f _ [] (z::zs) = []

309zipWith3 f _ (y::ys) [] = []

310zipWith3 f [] (y::ys) _ = []

311zipWith3 f (x::xs) [] _ = []

@@ -761,7 +761,7 @@ mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a

761mergeBy order [] right = right

762mergeBy order left [] = left

763mergeBy order (x::xs) (y::ys) =

764− if order x y == LT

764+ if order x y == LT

765 then x :: mergeBy order xs (y::ys)

766 else y :: mergeBy order (x::xs) ys

767

@@ -888,4 +888,3 @@ foldlAsFoldr f z t = foldr (flip (.) . flip f) id t z

888foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs

889foldlMatchesFoldr f q [] = Refl

890foldlMatchesFoldr f q (x :: xs) = foldlMatchesFoldr f (f q x) xs

891−

libs/prelude/Prelude/Maybe.idr+2−2

@@ -5,10 +5,10 @@ import Prelude.Algebra

5import Prelude.Basics

6import Prelude.Bool

7import Prelude.Cast

8−import Prelude.Classes

8+import Prelude.Interfaces

9import Prelude.Foldable

10

11−%access public

11+%access public export

12%default total

13

14||| An optional value. This can be used to represent the possibility of

libs/prelude/Prelude/Monad.idr+1−1

@@ -8,7 +8,7 @@ import Prelude.Applicative

8import Prelude.Basics

9import IO

10

11−%access public

11+%access public export

12

13infixl 5 >>=

14

libs/prelude/Prelude/Nat.idr+18−19

@@ -6,10 +6,10 @@ import Prelude.Algebra

6import Prelude.Basics

7import Prelude.Bool

8import Prelude.Cast

9−import Prelude.Classes

9+import Prelude.Interfaces

10import Prelude.Uninhabited

11

12−%access public

12+%access public export

13%default total

14

15||| Natural numbers: unbounded, unsigned integers which can be pattern

@@ -224,9 +224,9 @@ record Multiplicative where

224

225||| A wrapper for Nat that specifies the semigroup and monad implementations that use (+)

226record Additive where

227− constructor GetAdditive

227+ constructor GetAdditive

228 _ : Nat

229−

229+

230Semigroup Multiplicative where

231 (<+>) left right = GetMultiplicative $ left' * right'

232 where

@@ -424,7 +424,7 @@ total plusCommutative : (left : Nat) -> (right : Nat) ->

424plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl

425plusCommutative (S left) right =

426 let inductiveHypothesis = plusCommutative left right in

427− rewrite inductiveHypothesis in

427+ rewrite inductiveHypothesis in

428 rewrite plusSuccRightSucc right left in Refl

429

430total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -450,21 +450,21 @@ total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->

450plusLeftCancel Z right right' p = p

451plusLeftCancel (S left) right right' p =

452 let inductiveHypothesis = plusLeftCancel left right right' in

453− inductiveHypothesis (succInjective _ _ p)

453+ inductiveHypothesis (succInjective _ _ p)

454

455total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->

456 (p : left + right = left' + right) -> left = left'

457plusRightCancel left left' Z p = rewrite sym (plusZeroRightNeutral left) in

458 rewrite sym (plusZeroRightNeutral left') in

459− p

459+ p

460plusRightCancel left left' (S right) p =

461− plusRightCancel left left' right

461+ plusRightCancel left left' right

462− (succInjective _ _ (rewrite plusSuccRightSucc left right in

462+ (succInjective _ _ (rewrite plusSuccRightSucc left right in

463 rewrite plusSuccRightSucc left' right in p))

464

465total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->

466 (p : left + right = left) -> right = Z

467−plusLeftLeftRightZero Z right p = p

467+plusLeftLeftRightZero Z right p = p

468plusLeftLeftRightZero (S left) right p =

469 plusLeftLeftRightZero left right (succInjective _ _ p)

470

@@ -481,7 +481,7 @@ total multRightSuccPlus : (left : Nat) -> (right : Nat) ->

481multRightSuccPlus Z right = Refl

482multRightSuccPlus (S left) right =

483 let inductiveHypothesis = multRightSuccPlus left right in

484− rewrite inductiveHypothesis in

484+ rewrite inductiveHypothesis in

485 rewrite plusAssociative left right (mult left right) in

486 rewrite plusAssociative right left (mult left right) in

487 rewrite plusCommutative right left in

@@ -493,11 +493,11 @@ multLeftSuccPlus left right = Refl

493

494total multCommutative : (left : Nat) -> (right : Nat) ->

495 left * right = right * left

496−multCommutative Z right = rewrite multZeroRightZero right in Refl

496+multCommutative Z right = rewrite multZeroRightZero right in Refl

497multCommutative (S left) right =

498 let inductiveHypothesis = multCommutative left right in

499 rewrite inductiveHypothesis in

500− rewrite multRightSuccPlus right left in

500+ rewrite multRightSuccPlus right left in

501 Refl

502

503total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -505,7 +505,7 @@ total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right :

505multDistributesOverPlusRight Z centre right = Refl

506multDistributesOverPlusRight (S left) centre right =

507 let inductiveHypothesis = multDistributesOverPlusRight left centre right in

508− rewrite inductiveHypothesis in

508+ rewrite inductiveHypothesis in

509 rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in

510 rewrite sym (plusAssociative centre (mult left centre) right) in

511 rewrite plusCommutative (mult left centre) right in

@@ -527,7 +527,7 @@ total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

527multAssociative Z centre right = Refl

528multAssociative (S left) centre right =

529 let inductiveHypothesis = multAssociative left centre right in

530− rewrite inductiveHypothesis in

530+ rewrite inductiveHypothesis in

531 rewrite multDistributesOverPlusLeft centre (mult left centre) right in

532 Refl

533

@@ -619,7 +619,7 @@ powerSuccPowerLeft base exp = Refl

619

620total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

621 (power base exp) * (power base exp') = power base (exp + exp')

622−multPowerPowerPlus base Z exp' =

622+multPowerPowerPlus base Z exp' =

623 rewrite sym (plusZeroRightNeutral (power base exp')) in Refl

624multPowerPowerPlus base (S exp) exp' =

625 let inductiveHypothesis = multPowerPowerPlus base exp exp' in

@@ -651,7 +651,7 @@ total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

651powerPowerMultPower base exp Z = rewrite multZeroRightZero exp in Refl

652powerPowerMultPower base exp (S exp') =

653 let inductiveHypothesis = powerPowerMultPower base exp exp' in

654− rewrite inductiveHypothesis in

654+ rewrite inductiveHypothesis in

655 rewrite multRightSuccPlus exp exp' in

656 rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in

657 Refl

@@ -664,7 +664,7 @@ total minusSuccPred : (left : Nat) -> (right : Nat) ->

664 minus left (S right) = pred (minus left right)

665minusSuccPred Z right = Refl

666minusSuccPred (S left) Z =

667− rewrite minusZeroRight left in Refl

667+ rewrite minusZeroRight left in Refl

668minusSuccPred (S left) (S right) =

669 let inductiveHypothesis = minusSuccPred left right in

670 rewrite inductiveHypothesis in Refl

@@ -782,4 +782,3 @@ sucMinL (S l) = cong (sucMinL l)

782total sucMinR : (l : Nat) -> minimum l (S l) = l

783sucMinR Z = Refl

784sucMinR (S l) = cong (sucMinR l)

785−

libs/prelude/Prelude/Pairs.idr+15−7

@@ -2,7 +2,7 @@ module Prelude.Pairs

2

3import Builtins

4

5−%access public

5+%access public export

6%default total

7

8swap : (a, b) -> (b, a)

@@ -14,7 +14,7 @@ using (a : Type, P : a -> Type)

14 data Exists : (P : a -> Type) -> Type where

15 Evidence : .(x : a) -> (pf : P x) -> Exists P

16

17− ||| Dependent pair where the second field is erased.

17+ ||| Dependent pair where the second field is erased.

18 data Subset : (a : Type) -> (P : a -> Type) -> Type where

19 Element : (x : a) -> .(pf : P x) -> Subset a P

20

@@ -34,12 +34,20 @@ using (a : Type, P : a -> Type)

34 getProof : (x : Subset a P) -> P (getWitness x)

35 getProof (Element x pf) = pf

36

37− namespace Sigma

37+ namespace DPair

38− getWitness : Sigma a P -> a

38+ fst : DPair a P -> a

39− getWitness (x ** pf) = x

39+ fst (x ** pf) = x

40

41− getProof : (x : Sigma a P) -> P (getWitness x)

41+ snd : (x : DPair a P) -> P (fst x)

42− getProof (x ** pf) = pf

42+ snd (x ** pf) = pf

43+

44+ getWitness : DPair a P -> a

45+ getWitness = fst

46+ %deprecate DPair.getWitness "This is being deprecated in favour of `fst`."

47+

48+ getProof : (x : DPair a P) -> P (fst x)

49+ getProof = snd

50+ %deprecate DPair.getProof "This is being deprecated in favour of `snd`."

43

51

44 -- Polymorphic (class-based) projections have been removed

52 -- Polymorphic (class-based) projections have been removed

45 -- because type-directed name disambiguation works better.

53 -- because type-directed name disambiguation works better.

libs/prelude/Prelude/Providers.idr+3−1

@@ -4,8 +4,10 @@ import Prelude.Functor

4import Prelude.Applicative

5import Prelude.Monad

6

7+%access public export

8+

7||| Type providers must build one of these in an IO computation.

9||| Type providers must build one of these in an IO computation.

8−public

10+public export

9data Provider : (a : Type) -> Type where

11data Provider : (a : Type) -> Type where

10 ||| Return a term to be spliced in

12 ||| Return a term to be spliced in

11 ||| @ x the term to be spliced (i.e. the proof)

13 ||| @ x the term to be spliced (i.e. the proof)

libs/prelude/Prelude/Show.idr+4−3

@@ -7,13 +7,15 @@ import Prelude.Bits

7import Prelude.Bool

8import Prelude.Cast

9import Prelude.Chars

10−import Prelude.Classes

10+import Prelude.Interfaces

11import Prelude.List

12import Prelude.Maybe

13import Prelude.Either

14import Prelude.Nat

15import Prelude.Strings

16

17+%access public export

18+

17%default total

19%default total

18

20

19||| The precedence of an Idris operator or syntactic context.

21||| The precedence of an Idris operator or syntactic context.

@@ -190,6 +192,5 @@ Show a => Show (Maybe a) where

190 showPrec d (Left x) = showCon d "Left" $ showArg x

192 showPrec d (Left x) = showCon d "Left" $ showArg x

191 showPrec d (Right x) = showCon d "Right" $ showArg x

193 showPrec d (Right x) = showCon d "Right" $ showArg x

192

194

193−(Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

195+(Show a, {y : a} -> Show (p y)) => Show (DPair a p) where

194 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

196 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

195−

libs/prelude/Prelude/Stream.idr+7−3

@@ -9,7 +9,7 @@ import Prelude.Monad

9import Prelude.Nat

10import Prelude.List

11

12−%access public

12+%access public export

13%default total

14

15||| An infinite stream

@@ -62,8 +62,12 @@ index : Nat -> Stream a -> a

62index Z (x::xs) = x

63index (S k) (x::xs) = index k xs

64

65−||| Combine two streams element-wise using a function

65+||| Combine two streams element-wise using a function.

66+|||

67+||| @ f the function to combine elements with

68+||| @ xs the first stream of elements

69+||| @ ys the second stream of elements

66−zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

70+zipWith : (f : a -> b -> c) -> (xs : Stream a) -> (ys : Stream b) -> Stream c

67zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

71zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

68

72

69||| Combine three streams by applying a function element-wise along them

73||| Combine three streams by applying a function element-wise along them

libs/prelude/Prelude/Strings.idr+4−3

@@ -8,7 +8,7 @@ import Prelude.Basics

8import Prelude.Bool

9import Prelude.Chars

10import Prelude.Cast

11−import Prelude.Classes

11+import Prelude.Interfaces

12import Prelude.Either

13import Prelude.Foldable

14import Prelude.Functor

@@ -17,6 +17,8 @@ import Prelude.Nat

17import Prelude.Monad

18import Decidable.Equality

19

20+%access public export

21+

20partial

22partial

21foldr1 : (a -> a -> a) -> List a -> a

23foldr1 : (a -> a -> a) -> List a -> a

22foldr1 _ [x] = x

24foldr1 _ [x] = x

@@ -112,7 +114,7 @@ strTail' x p = assert_total $ prim__strTail x

112-- we need the 'believe_me' because the operations are primitives

114-- we need the 'believe_me' because the operations are primitives

113strM : (x : String) -> StrM x

115strM : (x : String) -> StrM x

114strM x with (decEq (not (x == "")) True)

116strM x with (decEq (not (x == "")) True)

115− strM x | (Yes p) = really_believe_me $

117+ strM x | (Yes p) = really_believe_me $

116 StrCons (assert_total (strHead' x p))

118 StrCons (assert_total (strHead' x p))

117 (assert_total (strTail' x p))

119 (assert_total (strTail' x p))

118 strM x | (No p) = really_believe_me StrNil

120 strM x | (No p) = really_believe_me StrNil

@@ -364,4 +366,3 @@ partial

364nullStr : String -> IO Bool

366nullStr : String -> IO Bool

365nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p

367nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p

366 return (ok /= 0)

368 return (ok /= 0)

367−

libs/prelude/Prelude/Traversable.idr+2

@@ -7,6 +7,8 @@ import Prelude.Applicative

7import Prelude.Foldable

8import Prelude.Functor

9

10+%access public export

11+

10traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()

12traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()

11traverse_ f = foldr ((*>) . f) (pure ())

13traverse_ f = foldr ((*>) . f) (pure ())

12

14

libs/prelude/Prelude/Uninhabited.idr+2

@@ -5,6 +5,8 @@ module Prelude.Uninhabited

5

6import Builtins

7

8+%access public export

9+

8||| A canonical proof that some type is empty

10||| A canonical proof that some type is empty

9interface Uninhabited t where

11interface Uninhabited t where

10 ||| If I have a t, I've had a contradiction

12 ||| If I have a t, I've had a contradiction

libs/prelude/prelude.ipkg+1−2

@@ -4,7 +4,7 @@ opts = "--nobuiltins --total --no-elim-deprecation-warnings"

4modules = Builtins, Prelude, IO,

5

6 Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,

7− Prelude.Classes, Prelude.Nat, Prelude.List,

7+ Prelude.Interfaces, Prelude.Nat, Prelude.List,

8 Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,

9 Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor,

10 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

@@ -14,4 +14,3 @@ modules = Builtins, Prelude, IO,

14 Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,

15

16 Decidable.Equality

17−

libs/pruviloj/Pruviloj/Core.idr+2

@@ -5,6 +5,8 @@ module Pruviloj.Core

5

6import Language.Reflection.Utils

7

8+%access public export

9+

8||| Run something for effects, throwing away the return value

10||| Run something for effects, throwing away the return value

9ignore : Functor f => f a -> f ()

11ignore : Functor f => f a -> f ()

10ignore x = map (const ()) x

12ignore x = map (const ()) x

libs/pruviloj/Pruviloj/Derive/DecEq.idr+1−1

@@ -133,7 +133,7 @@ mkRhs fn fam k =

133||| equality.

134|||

135||| @ fn the name of the function whose type has been declared

136−abstract partial -- because of mkRhs

136+export partial -- because of mkRhs

137deriveDecEq : (fn : TTName) -> Elab ()

138deriveDecEq fn =

139 do (_, Ref, sig') <- lookupTyExact fn

libs/pruviloj/Pruviloj/Derive/Eliminators.idr+1−1

@@ -248,7 +248,7 @@ getElimClauses info elimn ctors =

248 in traverse (\(i, con) => getElimClause info elimn methodCount con i)

249 (enumerate ctors)

250

251−abstract

251+export

252deriveElim : (tyn, elimn : TTName) -> Elab ()

253deriveElim tyn elimn =

254 do -- Begin with some basic sanity checking: the type name uniquely

libs/pruviloj/Pruviloj/Disjoint.idr+1−1

@@ -67,7 +67,7 @@ getDisjointness l r = exists <|> declare

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

70+public export covering

71disjoint : Elab ()

72disjoint =

73 do compute

libs/pruviloj/Pruviloj/Induction.idr+1−1

@@ -125,7 +125,7 @@ makeMotive info sub subjTy goal =

125

126||| Perform induction on some expression to solve the current

127||| goal. Return a list of new holes to be solved.

128−public

128+public export

129induction : Raw -> Elab (List TTName)

130induction subj =

131 do g <- goalType

libs/pruviloj/Pruviloj/Injective.idr+1−1

@@ -92,7 +92,7 @@ countBinders _ = Z

92|||

93||| @ tm the equality to exploit injectivity on

94||| @ n the name at which to bind the result

95−covering public

95+covering public export

96injective : (tm : Raw) -> (n : TTName) -> Elab ()

97injective tm n =

98 do (_, ty) <- check !getEnv tm

libs/pruviloj/Pruviloj/Internals.idr+2

@@ -7,6 +7,8 @@ import Pruviloj.Renamers

7

8import Data.Vect

9

10+%access public export

11+

10||| Get the name of a reflected type constructor argument.

12||| Get the name of a reflected type constructor argument.

11tyConArgName : TyConArg -> TTName

13tyConArgName : TyConArg -> TTName

12tyConArgName (TyConParameter a) = name a

14tyConArgName (TyConParameter a) = name a

libs/pruviloj/Pruviloj/Internals/TyConInfo.idr+1−1

@@ -6,7 +6,7 @@ import Pruviloj.Renamers

6

7import Language.Reflection.Utils

8

9−

9+%access public export

10

11||| A representation of a type constructor in which all argument names

12||| are made unique and they are separated into params and then

libs/pruviloj/Pruviloj/Renamers.idr+2

@@ -2,6 +2,8 @@ module Pruviloj.Renamers

2

3import Language.Reflection.Utils

4

5+%access public export

6+

5||| A renamer keeps track of names to be substituted

7||| A renamer keeps track of names to be substituted

6Renamer : Type

8Renamer : Type

7Renamer = TTName -> Maybe TTName

9Renamer = TTName -> Maybe TTName

rts/idris_bitstring.c+35

@@ -822,3 +822,38 @@ VAL idris_b64T32(VM *vm, VAL a) {

822 return cl;

823}

824

825+VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {

826+ return MKB8(vm, *(uint8_t*)(GETPTR(ptr) + GETINT(offset)));

827+}

828+

829+VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {

830+ *(uint8_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);

831+ return MKINT(0);

832+}

833+

834+VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {

835+ return MKB16(vm, *(uint16_t*)(GETPTR(ptr) + GETINT(offset)));

836+}

837+

838+VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {

839+ *(uint16_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);

840+ return MKINT(0);

841+}

842+

843+VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {

844+ return MKB32(vm, *(uint32_t*)(GETPTR(ptr) + GETINT(offset)));

845+}

846+

847+VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {

848+ *(uint32_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);

849+ return MKINT(0);

850+}

851+

852+VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {

853+ return MKB64(vm, *(uint64_t*)(GETPTR(ptr) + GETINT(offset)));

854+}

855+

856+VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {

857+ *(uint64_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);

858+ return MKINT(0);

859+}

rts/idris_bitstring.h+10

@@ -126,4 +126,14 @@ VAL idris_b64T8(VM *vm, VAL a);

126VAL idris_b64T16(VM *vm, VAL a);

127VAL idris_b64T32(VM *vm, VAL a);

128

129+// memory access

130+VAL idris_peekB8(VM* vm, VAL ptr, VAL offset);

131+VAL idris_pokeB8(VAL ptr, VAL offset, VAL data);

132+VAL idris_peekB16(VM* vm, VAL ptr, VAL offset);

133+VAL idris_pokeB16(VAL ptr, VAL offset, VAL data);

134+VAL idris_peekB32(VM* vm, VAL ptr, VAL offset);

135+VAL idris_pokeB32(VAL ptr, VAL offset, VAL data);

136+VAL idris_peekB64(VM* vm, VAL ptr, VAL offset);

137+VAL idris_pokeB64(VAL ptr, VAL offset, VAL data);

138+

129#endif

139#endif

rts/idris_rts.c+25−5

@@ -80,6 +80,14 @@ VM* idris_vm() {

80 return vm;

81}

82

83+VM* get_vm(void) {

84+#ifdef HAS_PTHREAD

85+ return pthread_getspecific(vm_key);

86+#else

87+ return global_vm;

88+#endif

89+}

90+

83void close_vm(VM* vm) {

91void close_vm(VM* vm) {

84 terminate(vm);

92 terminate(vm);

85}

93}

@@ -116,7 +124,7 @@ Stats terminate(VM* vm) {

116 pthread_mutex_destroy(&(vm -> inbox_block));

124 pthread_mutex_destroy(&(vm -> inbox_block));

117 pthread_cond_destroy(&(vm -> inbox_waiting));

125 pthread_cond_destroy(&(vm -> inbox_waiting));

118#endif

126#endif

119− // free(vm);

127+ // free(vm);

120 // Set the VM as inactive, so that if any message gets sent to it

128 // Set the VM as inactive, so that if any message gets sent to it

121 // it will not get there, rather than crash the entire system.

129 // it will not get there, rather than crash the entire system.

122 // (TODO: We really need to be cleverer than this if we're going to

130 // (TODO: We really need to be cleverer than this if we're going to

@@ -444,6 +452,18 @@ void idris_poke(void* ptr, i_int offset, uint8_t data) {

444 *(((uint8_t*)ptr) + offset) = data;

452 *(((uint8_t*)ptr) + offset) = data;

445}

453}

446

454

455+

456+VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {

457+ void** addr = GETPTR(ptr) + GETINT(offset);

458+ return MKPTR(vm, *addr);

459+}

460+

461+VAL idris_pokePtr(VAL ptr, VAL offset, VAL data) {

462+ void** addr = GETPTR(ptr) + GETINT(offset);

463+ *addr = GETPTR(data);

464+ return MKINT(0);

465+}

466+

447void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

467void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

448 memmove(dest + dest_offset, src + src_offset, size);

468 memmove(dest + dest_offset, src + src_offset, size);

449}

469}

@@ -819,12 +839,12 @@ int idris_sendMessage(VM* sender, VM* dest, VAL msg) {

819 }

839 }

820

840

821 pthread_mutex_lock(&(dest->inbox_lock));

841 pthread_mutex_lock(&(dest->inbox_lock));

822−

842+

823 if (dest->inbox_write >= dest->inbox_end) {

843 if (dest->inbox_write >= dest->inbox_end) {

824 // FIXME: This is obviously bad in the long run. This should

844 // FIXME: This is obviously bad in the long run. This should

825 // either block, make the inbox bigger, or return an error code,

845 // either block, make the inbox bigger, or return an error code,

826 // or possibly make it user configurable

846 // or possibly make it user configurable

827− fprintf(stderr, "Inbox full");

847+ fprintf(stderr, "Inbox full");

828 exit(-1);

848 exit(-1);

829 }

849 }

830

850

@@ -850,7 +870,7 @@ VM* idris_checkMessages(VM* vm) {

850

870

851VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

871VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

852 Msg* msg;

872 Msg* msg;

853−

873+

854 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

874 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

855 if (sender == NULL || msg->sender == sender) {

875 if (sender == NULL || msg->sender == sender) {

856 return msg->sender;

876 return msg->sender;

@@ -884,7 +904,7 @@ VM* idris_checkMessagesTimeout(VM* vm, int delay) {

884

904

885Msg* idris_getMessageFrom(VM* vm, VM* sender) {

905Msg* idris_getMessageFrom(VM* vm, VM* sender) {

886 Msg* msg;

906 Msg* msg;

887−

907+

888 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

908 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

889 if (sender == NULL || msg->sender == sender) {

909 if (sender == NULL || msg->sender == sender) {

890 return msg;

910 return msg;

rts/idris_rts.h+7−1

@@ -144,6 +144,9 @@ CData cdata_manage(void * data, CDataFinalizer * finalizer);

144// Create a new VM

145VM* init_vm(int stack_size, size_t heap_size,

146 int max_threads);

147+

148+// Get the VM for the current thread

149+VM* get_vm(void);

147// Initialise thread-local data for this VM

150// Initialise thread-local data for this VM

148void init_threaddata(VM *vm);

151void init_threaddata(VM *vm);

149// Clean up a VM once it's no longer needed

152// Clean up a VM once it's no longer needed

@@ -336,9 +339,12 @@ VAL idris_castStrFloat(VM* vm, VAL i);

336

339

337// Raw memory manipulation

340// Raw memory manipulation

338void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);

341void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);

342+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

339uint8_t idris_peek(void* ptr, i_int offset);

343uint8_t idris_peek(void* ptr, i_int offset);

340void idris_poke(void* ptr, i_int offset, uint8_t data);

344void idris_poke(void* ptr, i_int offset, uint8_t data);

341−void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

345+

346+VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset);

347+VAL idris_pokePtr(VAL ptr, VAL offset, VAL data);

342

348

343// String primitives

349// String primitives

344VAL idris_concat(VM* vm, VAL l, VAL r);

350VAL idris_concat(VM* vm, VAL l, VAL r);

samples/tutorial/interp.idr+1−1

@@ -33,7 +33,7 @@ using (G : Vect n Ty)

33 Expr G c

34 If : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

35

36− interp : Env G -> [static] (e : Expr G t) -> interpTy t

36+ interp : Env G -> %static (e : Expr G t) -> interpTy t

37 interp env (Var i) = lookup i env

38 interp env (Val x) = x

39 interp env (Lam sc) = \x => interp (x :: env) sc

src/IRTS/CodegenC.hs+184−24

@@ -13,7 +13,7 @@ import Util.System

13import Numeric

14import Data.Char

15import Data.Bits

16−import Data.List (intercalate)

16+import Data.List (intercalate, nubBy)

17import System.Process

18import System.Exit

19import System.IO

@@ -48,19 +48,20 @@ codegenC' :: [(Name, SDecl)] ->

48 [String] -> -- extra object files

49 [String] -> -- extra compiler flags (libraries)

50 [String] -> -- extra compiler flags (anything)

51− [ExportIFace] ->

51+ [ExportIFace] ->

52 Bool -> -- interfaces too (so make a .o instead)

53 DbgLevel ->

54 IO ()

55codegenC' defs out exec incs objs libs flags exports iface dbg

56 = do -- print defs

57 let bc = map toBC defs

58+ let wrappers = genWrappers bc

58 let h = concatMap toDecl (map fst bc)

59 let h = concatMap toDecl (map fst bc)

59 let cc = concatMap (uncurry toC) bc

60 let cc = concatMap (uncurry toC) bc

60 let hi = concatMap ifaceC (concatMap getExp exports)

61 let hi = concatMap ifaceC (concatMap getExp exports)

61 d <- getDataDir

62 d <- getDataDir

62 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63− let cout = headers incs ++ debug dbg ++ h ++ cc ++

64+ let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++

64 (if (exec == Executable) then mprog else hi)

65 (if (exec == Executable) then mprog else hi)

65 case exec of

66 case exec of

66 MavenProject -> putStrLn ("FAILURE: output type not supported")

67 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -81,10 +82,10 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

81 "-I."] ++ objs ++ envFlags ++

82 "-I."] ++ objs ++ envFlags ++

82 (if (exec == Executable) then [] else ["-c"]) ++

83 (if (exec == Executable) then [] else ["-c"]) ++

83 [tmpn] ++

84 [tmpn] ++

84− (if not iface then concatMap words libFlags else []) ++

85+ (if not iface then libFlags else []) ++

85− concatMap words incFlags ++

86+ incFlags ++

86− (if not iface then concatMap words libs else []) ++

87+ (if not iface then libs else []) ++

87− concatMap words flags ++

88+ flags ++

88 ["-o", out]

89 ["-o", out]

89-- putStrLn (show args)

90-- putStrLn (show args)

90 exit <- rawSystem comp args

91 exit <- rawSystem comp args

@@ -153,7 +154,7 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

153 headHex h (length bytes) : map toHex bytes

154 headHex h (length bytes) : map toHex bytes

154 where

155 where

155 split acc 0 = acc

156 split acc 0 = acc

156− split acc x = let xbits = x .&. 0x3f

157+ split acc x = let xbits = x .&. 0x3f

157 xrest = shiftR x 6 in

158 xrest = shiftR x 6 in

158 split (xbits : acc) xrest

159 split (xbits : acc) xrest

159

160

@@ -185,7 +186,7 @@ bcc i (ASSIGNCONST l c)

185 -- if it's a type constant, we won't use it, but equally it shouldn't

186 -- if it's a type constant, we won't use it, but equally it shouldn't

186 -- report an error. These might creep into generated for various reasons

187 -- report an error. These might creep into generated for various reasons

187 -- (especially if erasure is disabled).

188 -- (especially if erasure is disabled).

188− mkConst c | isTypeConst c = "MKINT(42424242)"

189+ mkConst c | isTypeConst c = "MKINT(42424242)"

189 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

190 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

190

191

191bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

192bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

@@ -317,18 +318,29 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

317bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

320bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

321+bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])

322+ = indent i ++

323+ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"

324+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"

325+ = indent i ++

326+ c_irts (toFType rty) (creg l ++ " = ")

327+ ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"

328+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"

329+ = indent i ++ c_irts (toFType rty) (creg l ++ " = ")

330+ ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++

331+ "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"

320bcc i (FOREIGNCALL l rty (FStr fn) args)

332bcc i (FOREIGNCALL l rty (FStr fn) args)

321 = indent i ++

333 = indent i ++

322 c_irts (toFType rty) (creg l ++ " = ")

334 c_irts (toFType rty) (creg l ++ " = ")

323 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

335 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

324− where fcall (t, arg) = irts_c (toFType t) (creg arg)

325bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

336bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

326bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

337bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

327-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

338-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

328

339

340+fcall (t, arg) = irts_c (toFType t) (creg arg)

329-- Deconstruct the Foreign type in the defunctionalised expression and build

341-- Deconstruct the Foreign type in the defunctionalised expression and build

330-- a foreign type description for c_irts and irts_c

342-- a foreign type description for c_irts and irts_c

331−toAType (FCon i)

343+toAType (FCon i)

332 | i == sUN "C_IntChar" = ATInt ITChar

344 | i == sUN "C_IntChar" = ATInt ITChar

333 | i == sUN "C_IntNative" = ATInt ITNative

345 | i == sUN "C_IntNative" = ATInt ITNative

334 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

346 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

@@ -337,19 +349,27 @@ toAType (FCon i)

337 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

349 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

338toAType t = error (show t ++ " not defined in toAType")

350toAType t = error (show t ++ " not defined in toAType")

339

351

340−toFType (FCon c)

352+toFType (FCon c)

341 | c == sUN "C_Str" = FString

353 | c == sUN "C_Str" = FString

342 | c == sUN "C_Float" = FArith ATFloat

354 | c == sUN "C_Float" = FArith ATFloat

343 | c == sUN "C_Ptr" = FPtr

355 | c == sUN "C_Ptr" = FPtr

344 | c == sUN "C_MPtr" = FManagedPtr

356 | c == sUN "C_MPtr" = FManagedPtr

345 | c == sUN "C_CData" = FCData

357 | c == sUN "C_CData" = FCData

346 | c == sUN "C_Unit" = FUnit

358 | c == sUN "C_Unit" = FUnit

347−toFType (FApp c [_,ity])

359+toFType (FApp c [_,ity])

348 | c == sUN "C_IntT" = FArith (toAType ity)

360 | c == sUN "C_IntT" = FArith (toAType ity)

361+ | c == sUN "C_FnT" = toFunType ity

349−toFType (FApp c [_])

362+toFType (FApp c [_])

350 | c == sUN "C_Any" = FAny

363 | c == sUN "C_Any" = FAny

351toFType t = FAny

364toFType t = FAny

352

365

366+toFunType (FApp c [_,ity])

367+ | c == sUN "C_FnBase" = FFunction

368+ | c == sUN "C_FnIO" = FFunctionIO

369+toFunType (FApp c [_,_,_,ity])

370+ | c == sUN "C_Fn" = toFunType ity

371+toFunType _ = FAny

372+

353c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

373c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

354c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

374c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

355c_irts (FArith (ATInt (ITFixed ity))) l x

375c_irts (FArith (ATInt (ITFixed ity))) l x

@@ -361,6 +381,8 @@ c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

361c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

381c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

362c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"

382c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"

363c_irts FAny l x = l ++ x

383c_irts FAny l x = l ++ x

384+c_irts FFunction l x = error "Return of function from foreign call is not supported"

385+c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"

364

386

365irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

387irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

366irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

388irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

@@ -373,6 +395,14 @@ irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

373irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

395irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

374irts_c FCData x = "GETCDATA(" ++ x ++ ")"

396irts_c FCData x = "GETCDATA(" ++ x ++ ")"

375irts_c FAny x = x

397irts_c FAny x = x

398+irts_c FFunctionIO x = wrapped x

399+irts_c FFunction x = wrapped x

400+

401+cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "

402+cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("

403+ ++ showSep "," (map (ctype . fst) args) ++ ") "

404+

405+wrapped x = "_idris_get_wrapper(" ++ x ++ ")"

376

406

377bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

407bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

378

408

@@ -554,7 +584,7 @@ doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

554doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

584doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

555

585

556doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

586doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

557−doOp v LWriteStr [_,s]

587+doOp v LWriteStr [_,s]

558 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

588 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

559 ++ ",GETSTR("

589 ++ ",GETSTR("

560 ++ creg s ++ "))))"

590 ++ creg s ++ "))))"

@@ -580,10 +610,10 @@ doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

580doOp v LNoOp args = v ++ creg (last args)

610doOp v LNoOp args = v ++ creg (last args)

581

611

582-- Pointer primitives (declared as %extern in Builtins.idr)

612-- Pointer primitives (declared as %extern in Builtins.idr)

583−doOp v (LExternal rf) [_,x]

613+doOp v (LExternal rf) [_,x]

584 | rf == sUN "prim__readFile"

614 | rf == sUN "prim__readFile"

585 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

615 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

586−doOp v (LExternal wf) [_,x,s]

616+doOp v (LExternal wf) [_,x,s]

587 | wf == sUN "prim__writeFile"

617 | wf == sUN "prim__writeFile"

588 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

618 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

589 ++ "),GETSTR("

619 ++ "),GETSTR("

@@ -594,15 +624,38 @@ doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"

594doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

624doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

595

625

596doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"

626doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"

597−doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"

627+doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"

598 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"

628 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"

599−doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"

629+doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"

600 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

630 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

601doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

631doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

602 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"

632 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"

603−

633+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"

634+ = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"

635+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"

636+ = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

637+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"

638+ = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"

639+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"

640+ = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

641+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"

642+ = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"

643+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"

644+ = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

645+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"

646+ = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"

647+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"

648+ = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

649+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"

650+ = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"

651+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"

652+ = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

653+doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"

654+ = v ++ "MKINT(sizeof(void*))"

655+doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr" = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"

604doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

656doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

605

657

658+

606flUnOp :: String -> String -> String

659flUnOp :: String -> String -> String

607flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

660flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

608

661

@@ -613,7 +666,7 @@ flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

613ifaceC :: Export -> String

666ifaceC :: Export -> String

614ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

667ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

615ifaceC (ExportFun n cn ret args)

668ifaceC (ExportFun n cn ret args)

616− = ctype ret ++ " " ++ cdesc cn ++

669+ = ctype ret ++ " " ++ cdesc cn ++

617 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

670 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

618 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

671 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

619 where showArgs [] = ""

672 where showArgs [] = ""

@@ -626,7 +679,7 @@ mkBody n as t = indent 1 ++ "INITFRAME;\n" ++

626 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

679 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

627 push 0 as ++ call n ++ retval t

680 push 0 as ++ call n ++ retval t

628 where push i [] = ""

681 where push i [] = ""

629− push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)

682+ push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)

630 ("TOP(" ++ show i ++ ") = ") n

683 ("TOP(" ++ show i ++ ") = ") n

631 ++ ";\n" ++ push (i + 1) ts

684 ++ ";\n" ++ push (i + 1) ts

632

685

@@ -692,7 +745,7 @@ hdr_guard x = "__" ++ map hchar x

692hdr_export :: Export -> String

745hdr_export :: Export -> String

693hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

746hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

694hdr_export (ExportFun n cn ret args)

747hdr_export (ExportFun n cn ret args)

695− = ctype ret ++ " " ++ cdesc cn ++

748+ = ctype ret ++ " " ++ cdesc cn ++

696 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

749 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

697 where showArgs [] = ""

750 where showArgs [] = ""

698 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

751 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

@@ -700,5 +753,112 @@ hdr_export (ExportFun n cn ret args)

700

753

701 argNames = zipWith (++) (repeat "arg") (map show [0..])

754 argNames = zipWith (++) (repeat "arg") (map show [0..])

702

755

756+------------------ Callback wrapper generation ----------------

757+-- Generate callback wrappers and a function to select the

758+-- correct wrapper function to pass.

759+-- TODO: This is limited to functions that are specified in

760+-- the foreign call. Otherwise we would have to generate wrappers for all

761+-- functions with correct arity or do flow analysis

762+-- to find all possible inputs to the foreign call.

763+genWrappers :: [(Name, [BC])] -> String

764+genWrappers bcs = let

765+ tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs

766+ in

767+ case tags of

768+ [] -> ""

769+ t -> concatMap genWrapper t ++ genDispatcher t

770+

771+genDispatcher :: [(FDesc, Int)] -> String

772+genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++

773+ "{\n" ++

774+ indent 1 ++ "switch(TAG(con)) {\n" ++

775+ concatMap makeSwitch tags ++

776+ indent 1 ++ "}\n" ++

777+ indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++

778+ indent 1 ++ "exit(-1);\n" ++

779+ "}\n\n"

780+ where

781+ makeSwitch (_, tag) =

782+ indent 1 ++ "case " ++ show tag ++ ":\n" ++

783+ indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"

784+

785+genWrapper :: (FDesc, Int) -> String

786+genWrapper (desc, tag) | (toFType desc) == FFunctionIO =

787+ error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"

788+genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++

789+ renderArgs argList ++")\n" ++

790+ "{\n" ++

791+ (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++

792+ indent 1 ++ "VM* vm = get_vm();\n" ++

793+ indent 1 ++ "if (vm == NULL) {\n" ++

794+ indent 2 ++ "fprintf(stderr, \"No vm available in callback.\");\n" ++

795+ indent 2 ++ "exit(-1);\n" ++

796+ indent 1 ++ "}\n" ++

797+ indent 1 ++ "INITFRAME;\n" ++

798+ indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++

799+ indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++

800+ indent 1 ++ "TOP(0) = REG1;\n" ++

801+

802+ push 1 argList ++

803+ indent 1 ++ "STOREOLD;\n" ++

804+ indent 1 ++ "BASETOP(0);\n" ++

805+ indent 1 ++ "ADDTOP(" ++ show (len + 1) ++ ");\n" ++

806+ indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" ++

807+ if ret /= "void"

808+ then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"

809+ ++ indent 1 ++ "return ret;\n}\n\n"

810+ else "}\n\n"

811+ where

812+ (ret, ft) = rty desc

813+ argList = zip (args desc) [0..]

814+ len = length argList

815+ renderArgs [] = "void"

816+ renderArgs [((s, _), n)] = s ++ " a" ++ (show n)

817+ renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++

818+ renderArgs xs

819+ rty (FApp c [_,ty])

820+ | c == sUN "C_FnBase" = (ctype ty, ty)

821+ | c == sUN "C_FnIO" = (ctype ty, ty)

822+ | c == sUN "C_FnT" = rty ty

823+ rty (FApp c [_,_,ty,fn])

824+ | c == sUN "C_Fn" = rty fn

825+ rty x = ("", x)

826+ args (FApp c [_,ty])

827+ | c == sUN "C_FnBase" = []

828+ | c == sUN "C_FnIO" = []

829+ | c == sUN "C_FnT" = args ty

830+ args (FApp c [_,_,ty,fn])

831+ | toFType ty == FUnit = []

832+ | c == sUN "C_Fn" = (ctype ty, ty) : args fn

833+ args _ = []

834+ push i [] = ""

835+ push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)

836+ ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)

837+ ++ ";\n" ++ push (i + 1) ts

703

838

704−

839+wrapperName :: Int -> String

840+wrapperName tag = "_idris_wrapper_" ++ show tag

841+

842+getCallback :: [BC] -> [(FDesc, Int)]

843+getCallback bc = getCallback' (reverse bc)

844+ where

845+ getCallback' (x:xs) = case hasCallback x of

846+ [] -> getCallback' xs

847+ cbs -> case findCons cbs xs of

848+ [] -> error "Idris function couldn't be wrapped."

849+ x -> x

850+ getCallback' [] = []

851+ findCons (c:cs) xs = findCon c xs ++ findCons cs xs

852+ findCons [] _ = []

853+ findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]

854+ findCon c (_:xs) = findCon c xs

855+ findCon c [] = []

856+

857+hasCallback :: BC -> [(FDesc, Reg)]

858+hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args

859+ where

860+ isFn (desc,_) = case toFType desc of

861+ FFunction -> True

862+ FFunctionIO -> True

863+ _ -> False

864+hasCallback _ = []

src/IRTS/CodegenCommon.hs−10

@@ -3,20 +3,10 @@ module IRTS.CodegenCommon where

3import Idris.Core.TT

4import IRTS.Simplified

5import IRTS.Defunctionalise

6−import IRTS.Lang

7−

8−import Control.Exception

9−import Data.Word

10−import System.Environment

11

6

12data DbgLevel = NONE | DEBUG | TRACE deriving Eq

7data DbgLevel = NONE | DEBUG | TRACE deriving Eq

13data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)

8data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)

14

9

15−environment :: String -> IO (Maybe String)

16−environment x = Control.Exception.catch (do e <- getEnv x

17− return (Just e))

18− (\y-> do return (y::SomeException); return Nothing)

19−

20-- Everything which might be needed in a code generator - a CG can choose which

10-- Everything which might be needed in a code generator - a CG can choose which

21-- level of Decls to generate code from (simplified, defunctionalised or merely

11-- level of Decls to generate code from (simplified, defunctionalised or merely

22-- lambda lifted) and has access to the list of object files, libraries, etc.

12-- lambda lifted) and has access to the list of object files, libraries, etc.

src/IRTS/Compiler.hs+1−1

@@ -462,7 +462,7 @@ doForeign vs env (ret : fname : world : args)

462 = do let l' = toFDesc l

463 r' <- irTerm vs env r

464 return (l', r')

465− splitArg _ = ifail "Badly formed foreign function call"

465+ splitArg _ = ifail $ "Badly formed foreign function call"

466

467 toFDesc (Constant (Str str)) = FStr str

468 toFDesc tm

src/IRTS/System.hs+9−25

@@ -1,8 +1,7 @@

1{-# LANGUAGE CPP #-}

2module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,

3− getIncFlags, getEnvFlags, getMvn,getExecutablePom, version) where

3+ getIncFlags, getEnvFlags, version) where

4

5−import Util.System

6import Data.List.Split

5import Data.List.Split

7

6

8import Control.Applicative ((<$>))

7import Control.Applicative ((<$>))

@@ -17,28 +16,18 @@ import Paths_idris (version)

17import Paths_idris

16import Paths_idris

18#endif

17#endif

19

18

19+overrideDataDirWith :: String -> IO FilePath

20+overrideDataDirWith envVar = do envValue <- lookupEnv envVar

21+ maybe getDataDir return envValue

22+

20getCC :: IO String

23getCC :: IO String

21−getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"

24+getCC = fromMaybe "gcc" <$> lookupEnv "IDRIS_CC"

22

25

23getEnvFlags :: IO [String]

26getEnvFlags :: IO [String]

24−getEnvFlags = maybe [] (splitOn " ") <$> environment "IDRIS_CFLAGS"

27+getEnvFlags = maybe [] (splitOn " ") <$> lookupEnv "IDRIS_CFLAGS"

25−

26−mvnCommand :: String

27−#ifdef mingw32_HOST_OS

28−mvnCommand = "mvn.bat"

29−#else

30−mvnCommand = "mvn"

31−#endif

32−

33−getMvn :: IO String

34−getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN"

35−

36−environment :: String -> IO (Maybe String)

37−environment x = catchIO (Just <$> getEnv x)

38− (\_ -> return Nothing)

39

28

40getTargetDir :: IO String

29getTargetDir :: IO String

41−getTargetDir = environment "TARGET" >>= maybe getDataDir return

30+getTargetDir = overrideDataDirWith "TARGET"

42

31

43#if defined(FREEBSD) || defined(DRAGONFLY)

32#if defined(FREEBSD) || defined(DRAGONFLY)

44extraLib = ["-L/usr/local/lib"]

33extraLib = ["-L/usr/local/lib"]

@@ -56,9 +45,7 @@ getLibFlags = do dir <- getDataDir

56 return $ ["-L" ++ (dir </> "rts"),

45 return $ ["-L" ++ (dir </> "rts"),

57 "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]

46 "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]

58

47

59−getIdrisLibDir = do libPath <- environment "IDRIS_LIBRARY_PATH"

60− dir <- maybe getDataDir return libPath

61− return $ addTrailingPathSeparator dir

48+getIdrisLibDir = addTrailingPathSeparator <$> overrideDataDirWith "IDRIS_LIBRARY_PATH"

62

49

63#if defined(FREEBSD) || defined(DRAGONFLY)

50#if defined(FREEBSD) || defined(DRAGONFLY)

64extraInclude = ["-I/usr/local/include"]

51extraInclude = ["-I/usr/local/include"]

@@ -67,6 +54,3 @@ extraInclude = []

67#endif

54#endif

68getIncFlags = do dir <- getDataDir

55getIncFlags = do dir <- getDataDir

69 return $ ("-I" ++ dir </> "rts") : extraInclude

56 return $ ("-I" ++ dir </> "rts") : extraInclude

70−

71−getExecutablePom = do dir <- getDataDir

72− return $ dir </> "java" </> "executable_pom.xml"

src/Idris/ASTUtils.hs+1−4

@@ -118,17 +118,14 @@ opt_detaggable = Field detaggable (\v opt -> opt{ detaggable = v })

118ist_callgraph :: Name -> Field IState CGInfo

119ist_callgraph n =

120 maybe_default CGInfo

121− { argsdef = [], calls = [], scg = []

121+ { calls = [], scg = [], usedpos = []

122− , argsused = [], usedpos = []

123 }

122 }

124 . ctxt_lookup n

123 . ctxt_lookup n

125 . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

124 . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

126

125

127−-- some fields of the CGInfo record

128cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

126cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

129cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

127cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

130

128

131−

132-- Commandline flags

129-- Commandline flags

133--------------------

130--------------------

134

131

src/Idris/AbsSyntax.hs+99−46

@@ -77,7 +77,7 @@ addDyLib libs = do i <- getIState

77 (\_ -> return Nothing)) $ libs

78 case msum handle of

79 Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++

80− concat (intersperse "," libs) ++ "\"")

80+ intercalate "," libs ++ "\"")

81 Just x -> do putIState $ i { idris_dynamic_libs = x:ls }

82 return (Left x)

83 where findDyLib :: [DynamicLib] -> String -> Maybe DynamicLib

@@ -96,6 +96,33 @@ addAutoImport fp = do i <- getIState

96 put (i { idris_options = opts { opt_autoImport =

97 fp : opt_autoImport opts } } )

98

99+addDefinedName :: Name -> Idris ()

100+addDefinedName n = do ist <- getIState

101+ putIState $ ist { idris_inmodule = S.insert n (idris_inmodule ist) }

102+

103+getDefinedNames :: Idris [Name]

104+getDefinedNames = do ist <- getIState

105+ return (S.toList (idris_inmodule ist))

106+

107+addTT :: Term -> Idris (Maybe Term)

108+addTT t = do ist <- getIState

109+ case M.lookup t (idris_ttstats ist) of

110+ Nothing -> do let tt' = M.insert t (1, t) (idris_ttstats ist)

111+ putIState $ ist { idris_ttstats = tt' }

112+ return Nothing

113+ Just (i, t') -> do let tt' = M.insert t' (i + 1, t') (idris_ttstats ist)

114+ putIState $ ist { idris_ttstats = tt' }

115+ return (Just t')

116+

117+dumpTT :: Idris ()

118+dumpTT = do ist <- get

119+ let sts = sortBy count (M.toList (idris_ttstats ist))

120+ mapM_ dump sts

121+ return ()

122+ where

123+ count (_,x) (_,y) = compare y x

124+ dump (tm, val) = runIO $ putStrLn (show val ++ ": " ++ show tm)

125+

99addHdr :: Codegen -> String -> Idris ()

126addHdr :: Codegen -> String -> Idris ()

100addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

127addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

101

128

@@ -180,6 +207,11 @@ setAccessibility n a

180 let ctxt = setAccess n a (tt_ctxt i)

207 let ctxt = setAccess n a (tt_ctxt i)

181 putIState $ i { tt_ctxt = ctxt }

208 putIState $ i { tt_ctxt = ctxt }

182

209

210+-- | get the accessibility of a name outside this module

211+getFromHideList :: Name -> Idris (Maybe Accessibility)

212+getFromHideList n = do i <- getIState

213+ return $ lookupCtxtExact n (hide_list i)

214+

183setTotality :: Name -> Totality -> Idris ()

215setTotality :: Name -> Totality -> Idris ()

184setTotality n a

216setTotality n a

185 = do i <- getIState

217 = do i <- getIState

@@ -203,8 +235,7 @@ getCoercionsTo i ty =

203 findCoercions t (n : ns) =

235 findCoercions t (n : ns) =

204 let ps = case lookupTy n (tt_ctxt i) of

236 let ps = case lookupTy n (tt_ctxt i) of

205 [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of

237 [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of

206− (t', _) ->

238+ (t', _) -> [n | t == t']

207− if t == t' then [n] else []

208 _ -> [] in

239 _ -> [] in

209 ps ++ findCoercions t ns

240 ps ++ findCoercions t ns

210

241

@@ -213,6 +244,14 @@ addToCG n cg

213 = do i <- getIState

244 = do i <- getIState

214 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

245 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

215

246

247+addCalls :: Name -> [Name] -> Idris ()

248+addCalls n calls

249+ = do i <- getIState

250+ case lookupCtxtExact n (idris_callgraph i) of

251+ Nothing -> addToCG n (CGInfo calls [] [])

252+ Just (CGInfo cs scg used) ->

253+ addToCG n (CGInfo (nub (calls ++ cs)) scg used)

254+

216addTyInferred :: Name -> Idris ()

255addTyInferred :: Name -> Idris ()

217addTyInferred n

256addTyInferred n

218 = do i <- getIState

257 = do i <- getIState

@@ -228,7 +267,7 @@ addTyInfConstraints fc ts = do logLvl 2 $ "TI missing: " ++ show ts

228 findMVApps x y

267 findMVApps x y

229 = do let (fx, argsx) = unApply x

268 = do let (fx, argsx) = unApply x

230 let (fy, argsy) = unApply y

269 let (fy, argsy) = unApply y

231− if (not (fx == fy))

270+ if (fx /= fy)

232 then do

271 then do

233 tryAddMV fx y

272 tryAddMV fx y

234 tryAddMV fy x

273 tryAddMV fy x

@@ -309,7 +348,7 @@ allNames :: [Name] -> Name -> Idris [Name]

309allNames ns n | n `elem` ns = return []

348allNames ns n | n `elem` ns = return []

310allNames ns n = do i <- getIState

349allNames ns n = do i <- getIState

311 case lookupCtxtExact n (idris_callgraph i) of

350 case lookupCtxtExact n (idris_callgraph i) of

312− Just ns' -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

351+ Just ns' -> do more <- mapM (allNames (n:ns)) (calls ns')

313 return (nub (n : concat more))

352 return (nub (n : concat more))

314 _ -> return [n]

353 _ -> return [n]

315

354

@@ -341,11 +380,6 @@ getNameHints i n =

341 [ns] -> ns

380 [ns] -> ns

342 _ -> []

381 _ -> []

343

382

344−-- Issue #1737 in the Issue Tracker.

345−-- https://github.com/idris-lang/Idris-dev/issues/1737

346−addToCalledG :: Name -> [Name] -> Idris ()

347−addToCalledG n ns = return () -- TODO

348−

349addDeprecated :: Name -> String -> Idris ()

383addDeprecated :: Name -> String -> Idris ()

350addDeprecated n reason = do i <- getIState

384addDeprecated n reason = do i <- getIState

351 putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

385 putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

@@ -439,7 +473,8 @@ addIBC ibc@(IBCDef n)

439addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

473addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

440

474

441clearIBC :: Idris ()

475clearIBC :: Idris ()

442−clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

476+clearIBC = do i <- getIState; putIState $ i { ibc_write = [],

477+ idris_inmodule = S.empty }

443

478

444resetNameIdx :: Idris ()

479resetNameIdx :: Idris ()

445resetNameIdx = do i <- getIState

480resetNameIdx = do i <- getIState

@@ -738,6 +773,16 @@ logLevel :: Idris Int

738logLevel = do i <- getIState

773logLevel = do i <- getIState

739 return (opt_logLevel (idris_options i))

774 return (opt_logLevel (idris_options i))

740

775

776+setAutoImpls :: Bool -> Idris ()

777+setAutoImpls b = do i <- getIState

778+ let opts = idris_options i

779+ let opt' = opts { opt_autoimpls = b }

780+ putIState $ i { idris_options = opt' }

781+

782+getAutoImpls :: Idris Bool

783+getAutoImpls = do i <- getIState

784+ return (opt_autoimpls (idris_options i))

785+

741setErrContext :: Bool -> Idris ()

786setErrContext :: Bool -> Idris ()

742setErrContext t = do i <- getIState

787setErrContext t = do i <- getIState

743 let opts = idris_options i

788 let opts = idris_options i

@@ -1024,7 +1069,7 @@ logLvlCats cs l str = do

1024 runIO . hPutStrLn h $ convSExp "log" good n

1069 runIO . hPutStrLn h $ convSExp "log" good n

1025 where

1070 where

1026 inCat :: [LogCat] -> [LogCat] -> Bool

1071 inCat :: [LogCat] -> [LogCat] -> Bool

1027− inCat cs cats = or $ map (\x -> elem x cats) cs

1072+ inCat cs cats = any (`elem` cats) cs

1028

1073

1029cmdOptType :: Opt -> Idris Bool

1074cmdOptType :: Opt -> Idris Bool

1030cmdOptType x = do i <- getIState

1075cmdOptType x = do i <- getIState

@@ -1101,25 +1146,25 @@ expandParams dec ps ns infs tm = en 0 tm

1101 | n `nselem` ns = PQuote (Var (dec n))

1146 | n `nselem` ns = PQuote (Var (dec n))

1102 en 0 (PApp fc (PInferRef fc' hl n) as)

1147 en 0 (PApp fc (PInferRef fc' hl n) as)

1103 | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))

1148 | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))

1104− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1149+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

1105 en 0 (PApp fc (PRef fc' hl n) as)

1150 en 0 (PApp fc (PRef fc' hl n) as)

1106 | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))

1151 | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))

1107− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1152+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

1108 | n `nselem` ns = PApp fc (PRef fc' hl (dec n))

1153 | n `nselem` ns = PApp fc (PRef fc' hl (dec n))

1109− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1154+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

1110 en 0 (PAppBind fc (PRef fc' hl n) as)

1155 en 0 (PAppBind fc (PRef fc' hl n) as)

1111 | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))

1156 | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))

1112− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1157+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

1113 | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))

1158 | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))

1114− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1159+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

1115 en 0 (PRef fc hl n)

1160 en 0 (PRef fc hl n)

1116 | n `elem` infs = PApp fc (PInferRef fc hl (dec n))

1161 | n `elem` infs = PApp fc (PInferRef fc hl (dec n))

1117− (map (pexp . (PRef fc hl)) (map fst ps))

1162+ (map ((pexp . (PRef fc hl)) . fst) ps)

1118 | n `nselem` ns = PApp fc (PRef fc hl (dec n))

1163 | n `nselem` ns = PApp fc (PRef fc hl (dec n))

1119− (map (pexp . (PRef fc hl)) (map fst ps))

1164+ (map ((pexp . (PRef fc hl)) . fst) ps)

1120 en 0 (PInferRef fc hl n)

1165 en 0 (PInferRef fc hl n)

1121 | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))

1166 | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))

1122− (map (pexp . (PRef fc hl)) (map fst ps))

1167+ (map ((pexp . (PRef fc hl)) . fst) ps)

1123 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

1168 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

1124 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

1169 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

1125 en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)

1170 en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)

@@ -1191,7 +1236,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1191 removeBound lhs ns = ns \\ nub (bnames lhs)

1236 removeBound lhs ns = ns \\ nub (bnames lhs)

1192

1237

1193 bnames (PRef _ _ n) = [n]

1238 bnames (PRef _ _ n) = [n]

1194− bnames (PApp _ _ args) = concatMap bnames (map getTm args)

1239+ bnames (PApp _ _ args) = concatMap (bnames . getTm) args

1195 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

1240 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

1196 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

1241 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

1197 bnames _ = []

1242 bnames _ = []

@@ -1227,10 +1272,10 @@ expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds dec

1227 (map (expandParamsD rhs ist dec ps ns) decls)

1272 (map (expandParamsD rhs ist dec ps ns) decls)

1228 cn

1273 cn

1229 cd

1274 cd

1230−expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n nfc params ty cn decls)

1275+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs acc n nfc params ty cn decls)

1231 = PInstance doc argDocs info f

1276 = PInstance doc argDocs info f

1232 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1277 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1233− n

1278+ acc n

1234 nfc

1279 nfc

1235 (map (expandParams dec ps ns []) params)

1280 (map (expandParams dec ps ns []) params)

1236 (expandParams dec ps ns [] ty)

1281 (expandParams dec ps ns [] ty)

@@ -1258,9 +1303,9 @@ getPriority i tm = 1 -- pri tm

1258 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

1303 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

1259 pri (PTrue _ _) = 0

1304 pri (PTrue _ _) = 0

1260 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

1305 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

1261− pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

1306+ pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1262− pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

1307+ pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1263− pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

1308+ pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))

1264 pri (PTyped l r) = pri l

1309 pri (PTyped l r) = pri l

1265 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

1310 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

1266 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

1311 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -1277,11 +1322,11 @@ addStatics n tm ptm =

1277 let paramnames

1322 let paramnames

1278 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

1323 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

1279 Just p -> getNamesFrom 0 (fn_params p) tm ++

1324 Just p -> getNamesFrom 0 (fn_params p) tm ++

1280− concatMap (getParamNames ist) (map snd statics)

1325+ concatMap (getParamNames ist . snd) statics

1281− _ -> concatMap (getParamNames ist) (map snd statics)

1326+ _ -> concatMap (getParamNames ist . snd) statics

1282

1327

1283− let stnames = nub $ concatMap freeArgNames (map snd statics)

1328+ let stnames = nub $ concatMap (freeArgNames . snd) statics

1284− let dnames = (nub $ concatMap freeArgNames (map snd dynamics))

1329+ let dnames = (nub $ concatMap (freeArgNames . snd) dynamics)

1285 \\ paramnames

1330 \\ paramnames

1286 -- also get the arguments which are 'uniquely inferrable' from

1331 -- also get the arguments which are 'uniquely inferrable' from

1287 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

1332 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

@@ -1290,7 +1335,7 @@ addStatics n tm ptm =

1290 filter (\x -> not (elem x dnames)) stnames

1335 filter (\x -> not (elem x dnames)) stnames

1291 let stpos = staticList statics' tm

1336 let stpos = staticList statics' tm

1292 i <- getIState

1337 i <- getIState

1293− when (not (null statics)) $

1338+ unless (null statics) $

1294 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

1339 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

1295 ++ showTmImpls ptm ++ "\n"

1340 ++ showTmImpls ptm ++ "\n"

1296 ++ show statics ++ "\n" ++ show dynamics

1341 ++ show statics ++ "\n" ++ show dynamics

@@ -1376,7 +1421,7 @@ addUsingConstraints syn fc t

1376 | otherwise = doAdd cs ns t

1421 | otherwise = doAdd cs ns t

1377

1422

1378 mkConst c args = PApp fc (PRef fc [] c)

1423 mkConst c args = PApp fc (PRef fc [] c)

1379− (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc [] n)) args)

1424+ (map (PExp 0 [] (sMN 0 "carg") . PRef fc []) args)

1380

1425

1381 getConstraints (PPi (Constraint _ _) _ _ c sc)

1426 getConstraints (PPi (Constraint _ _) _ _ c sc)

1382 = getcapp c ++ getConstraints sc

1427 = getcapp c ++ getConstraints sc

@@ -1395,10 +1440,14 @@ addUsingConstraints syn fc t

1395addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

1440addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

1396addUsingImpls syn n fc t

1441addUsingImpls syn n fc t

1397 = do ist <- getIState

1442 = do ist <- getIState

1443+ autoimpl <- getAutoImpls

1398− let ns = implicitNamesIn (map iname uimpls) ist t

1444+ let ns_in = implicitNamesIn (map iname uimpls) ist t

1445+ let ns = if autoimpl then ns_in

1446+ else filter (\n -> n `elem` (map iname uimpls)) ns_in

1447+

1399 let badnames = filter (\n -> not (implicitable n) &&

1448 let badnames = filter (\n -> not (implicitable n) &&

1400 n `notElem` (map iname uimpls)) ns

1449 n `notElem` (map iname uimpls)) ns

1401− when (not (null badnames)) $

1450+ unless (null badnames) $

1402 throwError (At fc (Elaborating "type of " n Nothing

1451 throwError (At fc (Elaborating "type of " n Nothing

1403 (NoSuchVariable (head badnames))))

1452 (NoSuchVariable (head badnames))))

1404 let cs = getArgnames t -- get already bound names

1453 let cs = getArgnames t -- get already bound names

@@ -1481,15 +1530,19 @@ implicit info syn n ptm = implicit' info syn [] n ptm

1481implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1530implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1482implicit' info syn ignore n ptm

1531implicit' info syn ignore n ptm

1483 = do i <- getIState

1532 = do i <- getIState

1533+ auto <- getAutoImpls

1534+ if not auto

1535+ then return ptm

1536+ else do

1484− let (tm', impdata) = implicitise syn ignore i ptm

1537+ let (tm', impdata) = implicitise syn ignore i ptm

1485− defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1538+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1486−-- let (tm'', spos) = findStatics i tm'

1539+ -- let (tm'', spos) = findStatics i tm'

1487− putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1540+ putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1488− addIBC (IBCImp n)

1541+ addIBC (IBCImp n)

1489− logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1542+ logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1490−-- i <- get

1543+ -- i <- get

1491−-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1544+ -- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1492− return tm'

1545+ return tm'

1493 where

1546 where

1494 -- Detect unknown names in default arguments and throw error if found.

1547 -- Detect unknown names in default arguments and throw error if found.

1495 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

1548 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

@@ -1534,12 +1587,12 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1534 -- Find names in argument position in a type, suitable for implicit

1587 -- Find names in argument position in a type, suitable for implicit

1535 -- binding

1588 -- binding

1536 -- Not the function position, but do everything else...

1589 -- Not the function position, but do everything else...

1537− implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)

1590+ implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv . getTm) args

1538 implNamesIn uv t = namesIn uv ist t

1591 implNamesIn uv t = namesIn uv ist t

1539

1592

1540− imps top env (PApp _ f as)

1593+ imps top env ty@(PApp _ f as)

1541 = do (decls, ns) <- get

1594 = do (decls, ns) <- get

1542− let isn = concatMap (namesIn uvars ist) (map getTm as)

1595+ let isn = nub (implNamesIn uvars ty)

1543 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1596 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1544 imps top env (PPi (Imp l _ _ _) n _ ty sc)

1597 imps top env (PPi (Imp l _ _ _) n _ ty sc)

1545 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

1598 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

src/Idris/AbsSyntaxTree.hs+468−460

@@ -94,6 +94,7 @@ data IOption = IOption {

94 , opt_printdepth :: Maybe Int

95 , opt_evaltypes :: Bool -- ^ normalise types in :t

96 , opt_desugarnats :: Bool

97+ , opt_autoimpls :: Bool

97 } deriving (Show, Eq)

98 } deriving (Show, Eq)

98

99

99defaultOpts = IOption { opt_logLevel = 0

100defaultOpts = IOption { opt_logLevel = 0

@@ -121,6 +122,7 @@ defaultOpts = IOption { opt_logLevel = 0

121 , opt_printdepth = Just 5000

122 , opt_printdepth = Just 5000

122 , opt_evaltypes = True

123 , opt_evaltypes = True

123 , opt_desugarnats = False

124 , opt_desugarnats = False

125+ , opt_autoimpls = True

124 }

126 }

125

127

126data PPOption = PPOption {

128data PPOption = PPOption {

@@ -194,7 +196,6 @@ data IState = IState {

194 -- ^ list of lhs/rhs, and a list of missing clauses

196 -- ^ list of lhs/rhs, and a list of missing clauses

195 idris_flags :: Ctxt [FnOpt],

197 idris_flags :: Ctxt [FnOpt],

196 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

198 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

197− idris_calledgraph :: Ctxt [Name],

198 idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),

199 idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),

199 idris_moduledocs :: Ctxt (Docstring DocTerm),

200 idris_moduledocs :: Ctxt (Docstring DocTerm),

200 -- ^ module documentation is saved in a special MN so the context

201 -- ^ module documentation is saved in a special MN so the context

@@ -235,7 +236,7 @@ data IState = IState {

235 brace_stack :: [Maybe Int],

236 brace_stack :: [Maybe Int],

236 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

237 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

237 idris_parsedSpan :: Maybe FC,

238 idris_parsedSpan :: Maybe FC,

238− hide_list :: [(Name, Maybe Accessibility)],

239+ hide_list :: Ctxt Accessibility,

239 default_access :: Accessibility,

240 default_access :: Accessibility,

240 default_total :: Bool,

241 default_total :: Bool,

241 ibc_write :: [IBCWrite],

242 ibc_write :: [IBCWrite],

@@ -262,7 +263,9 @@ data IState = IState {

262 idris_exports :: [Name], -- ^ Functions with ExportList

263 idris_exports :: [Name], -- ^ Functions with ExportList

263 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

264 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

264 idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser

265 idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser

265− idris_deprecated :: Ctxt String -- ^ Deprecated names and explanation

266+ idris_deprecated :: Ctxt String, -- ^ Deprecated names and explanation

267+ idris_inmodule :: S.Set Name, -- ^ Names defined in current module

268+ idris_ttstats :: M.Map Term (Int, Term)

266 }

269 }

267

270

268-- Required for parsers library, and therefore trifecta

271-- Required for parsers library, and therefore trifecta

@@ -279,11 +282,10 @@ deriving instance NFData SizeChange

279type SCGEntry = (Name, [Maybe (Int, SizeChange)])

282type SCGEntry = (Name, [Maybe (Int, SizeChange)])

280type UsageReason = (Name, Int) -- fn_name, its_arg_number

283type UsageReason = (Name, Int) -- fn_name, its_arg_number

281

284

282−data CGInfo = CGInfo { argsdef :: [Name],

285+data CGInfo = CGInfo { calls :: [Name],

283− calls :: [(Name, [[Name]])],

284 scg :: [SCGEntry],

286 scg :: [SCGEntry],

285− argsused :: [Name],

286− usedpos :: [(Int, [UsageReason])] }

287+ usedpos :: [(Int, [UsageReason])]

288+ }

287 deriving Show

289 deriving Show

288{-!

290{-!

289deriving instance Binary CGInfo

291deriving instance Binary CGInfo

@@ -348,12 +350,13 @@ idrisInit = IState initContext S.empty []

348 emptyContext emptyContext emptyContext emptyContext

350 emptyContext emptyContext emptyContext emptyContext

349 emptyContext emptyContext emptyContext emptyContext

351 emptyContext emptyContext emptyContext emptyContext

350 emptyContext emptyContext emptyContext emptyContext

352 emptyContext emptyContext emptyContext emptyContext

351− emptyContext emptyContext

353+ emptyContext

352 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

354 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

353− [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

355+ [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Hidden False [] Nothing [] []

354 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

356 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

355 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

357 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

356− emptyContext

358+ emptyContext S.empty M.empty

359+

357

360

358-- | The monad for the main REPL - reading and processing files and updating

361-- | The monad for the main REPL - reading and processing files and updating

359-- global state (hence the IO inner monad).

362-- global state (hence the IO inner monad).

@@ -631,13 +634,17 @@ is_scoped :: Plicity -> Maybe ImplicitInfo

631is_scoped (Imp _ _ _ s) = s

634is_scoped (Imp _ _ _ s) = s

632is_scoped _ = Nothing

635is_scoped _ = Nothing

633

636

634−impl = Imp [] Dynamic False (Just (Impl False True))

637+impl = Imp [] Dynamic False (Just (Impl False True))

638+

635−forall_imp = Imp [] Dynamic False (Just (Impl False False))

639+forall_imp = Imp [] Dynamic False (Just (Impl False False))

636forall_constraint = Imp [] Dynamic False (Just (Impl True False))

640forall_constraint = Imp [] Dynamic False (Just (Impl True False))

641+

637−expl = Exp [] Dynamic False

642+expl = Exp [] Dynamic False

638−expl_param = Exp [] Dynamic True

643+expl_param = Exp [] Dynamic True

644+

639−constraint = Constraint [] Static

645+constraint = Constraint [] Static

646+

640−tacimpl t = TacImp [] Dynamic t

647+tacimpl t = TacImp [] Dynamic t

641

648

642data FnOpt = Inlinable -- always evaluate when simplifying

649data FnOpt = Inlinable -- always evaluate when simplifying

643 | TotalFn | PartialFn | CoveringFn

650 | TotalFn | PartialFn | CoveringFn

@@ -695,7 +702,7 @@ data PDecl' t

695 FC -- Record name precise location

702 FC -- Record name precise location

696 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

703 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

697 [(Name, Docstring (Either Err t))] -- Param Docs

704 [(Name, Docstring (Either Err t))] -- Param Docs

698− [((Maybe (Name, FC)), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields

705+ [(Maybe (Name, FC), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields

699 (Maybe (Name, FC)) -- Optional constructor name and location

706 (Maybe (Name, FC)) -- Optional constructor name and location

700 (Docstring (Either Err t)) -- Constructor doc

707 (Docstring (Either Err t)) -- Constructor doc

701 SyntaxInfo -- Constructor SyntaxInfo

708 SyntaxInfo -- Constructor SyntaxInfo

@@ -717,6 +724,7 @@ data PDecl' t

717 [(Name, Docstring (Either Err t))] -- Parameter docs

724 [(Name, Docstring (Either Err t))] -- Parameter docs

718 SyntaxInfo

725 SyntaxInfo

719 FC [(Name, t)] -- constraints

726 FC [(Name, t)] -- constraints

727+ Accessibility

720 Name -- class

728 Name -- class

721 FC -- precise location of class

729 FC -- precise location of class

722 [t] -- parameters

730 [t] -- parameters

@@ -756,6 +764,7 @@ data Directive = DLib Codegen String |

756 DErrorHandlers Name FC Name FC [(Name, FC)] |

764 DErrorHandlers Name FC Name FC [(Name, FC)] |

757 DLanguage LanguageExt |

765 DLanguage LanguageExt |

758 DDeprecate Name String |

766 DDeprecate Name String |

767+ DAutoImplicits Bool |

759 DUsed FC Name Name

768 DUsed FC Name Name

760

769

761-- | A set of instructions for things that need to happen in IState

770-- | A set of instructions for things that need to happen in IState

@@ -875,10 +884,10 @@ mapPDeclFC f g (PClass doc syn fc constrs n nfc params paramDocs det body ctor c

875 (map (mapPDeclFC f g) body)

884 (map (mapPDeclFC f g) body)

876 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

885 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

877 ctorDoc

886 ctorDoc

878−mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn cnfc params instTy instN body) =

887+mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn acc cnfc params instTy instN body) =

879 PInstance doc paramDocs syn (f fc)

888 PInstance doc paramDocs syn (f fc)

880 (map (\(constrN, constrT) -> (constrN, mapPTermFC f g constrT)) constrs)

889 (map (\(constrN, constrT) -> (constrN, mapPTermFC f g constrT)) constrs)

881− cn (g cnfc) (map (mapPTermFC f g) params)

890+ cn acc (g cnfc) (map (mapPTermFC f g) params)

882 (mapPTermFC f g instTy)

891 (mapPTermFC f g instTy)

883 instN

892 instN

884 (map (mapPDeclFC f g) body)

893 (map (mapPDeclFC f g) body)

@@ -918,7 +927,7 @@ declared (PParams _ _ ds) = concatMap declared ds

918declared (PNamespace _ _ ds) = concatMap declared ds

927declared (PNamespace _ _ ds) = concatMap declared ds

919declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

928declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

920declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

929declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

921−declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

930+declared (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

922declared (PDSL n _) = [n]

931declared (PDSL n _) = [n]

923declared (PSyntax _ _) = []

932declared (PSyntax _ _) = []

924declared (PMutual _ ds) = concatMap declared ds

933declared (PMutual _ ds) = concatMap declared ds

@@ -927,39 +936,39 @@ declared _ = []

927

936

928-- get the names declared, not counting nested parameter blocks

937-- get the names declared, not counting nested parameter blocks

929tldeclared :: PDecl -> [Name]

938tldeclared :: PDecl -> [Name]

930−tldeclared (PFix _ _ _) = []

939+tldeclared (PFix _ _ _) = []

931−tldeclared (PTy _ _ _ _ _ n _ t) = [n]

940+tldeclared (PTy _ _ _ _ _ n _ t) = [n]

932−tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

941+tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

933−tldeclared (PClauses _ _ n _) = [] -- not a declaration

942+tldeclared (PClauses _ _ n _) = [] -- not a declaration

934−tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

943+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

935tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

944tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

936 where fstt (_, _, a, _, _, _, _) = a

945 where fstt (_, _, a, _, _, _, _) = a

937−tldeclared (PParams _ _ ds) = []

946+tldeclared (PParams _ _ ds) = []

938−tldeclared (PMutual _ ds) = concatMap tldeclared ds

947+tldeclared (PMutual _ ds) = concatMap tldeclared ds

939−tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

948+tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

940−tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

949+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

941−tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

950+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

942−tldeclared _ = []

951+tldeclared _ = []

943

952

944defined :: PDecl -> [Name]

953defined :: PDecl -> [Name]

945−defined (PFix _ _ _) = []

954+defined (PFix _ _ _) = []

946−defined (PTy _ _ _ _ _ n _ t) = []

955+defined (PTy _ _ _ _ _ n _ t) = []

947−defined (PPostulate _ _ _ _ _ _ n t) = []

956+defined (PPostulate _ _ _ _ _ _ n t) = []

948−defined (PClauses _ _ n _) = [n] -- not a declaration

957+defined (PClauses _ _ n _) = [n] -- not a declaration

949−defined (PCAF _ n _) = [n]

958+defined (PCAF _ n _) = [n]

950−defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

959+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

951 where fstt (_, _, a, _, _, _, _) = a

960 where fstt (_, _, a, _, _, _, _) = a

952−defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

961+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

953−defined (PParams _ _ ds) = concatMap defined ds

962+defined (PParams _ _ ds) = concatMap defined ds

954−defined (PNamespace _ _ ds) = concatMap defined ds

963+defined (PNamespace _ _ ds) = concatMap defined ds

955−defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

964+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

956−defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

965+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

957−defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

966+defined (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

958−defined (PDSL n _) = [n]

967+defined (PDSL n _) = [n]

959−defined (PSyntax _ _) = []

968+defined (PSyntax _ _) = []

960−defined (PMutual _ ds) = concatMap defined ds

969+defined (PMutual _ ds) = concatMap defined ds

961−defined (PDirective _) = []

970+defined (PDirective _) = []

962−defined _ = []

971+defined _ = []

963

972

964updateN :: [(Name, Name)] -> Name -> Name

973updateN :: [(Name, Name)] -> Name -> Name

965updateN ns n | Just n' <- lookup n ns = n'

974updateN ns n | Just n' <- lookup n ns = n'

@@ -1040,33 +1049,33 @@ data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed

1040-- general-purpose FCs, and the second transforms those that are used

1049-- general-purpose FCs, and the second transforms those that are used

1041-- for semantic source highlighting, so they can be treated specially.

1050-- for semantic source highlighting, so they can be treated specially.

1042mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm

1051mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm

1043−mapPTermFC f g (PQuote q) = PQuote q

1052+mapPTermFC f g (PQuote q) = PQuote q

1044−mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n

1053+mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n

1045−mapPTermFC f g (PInferRef fc fcs n) = PInferRef (g fc) (map g fcs) n

1054+mapPTermFC f g (PInferRef fc fcs n) = PInferRef (g fc) (map g fcs) n

1046−mapPTermFC f g (PPatvar fc n) = PPatvar (g fc) n

1055+mapPTermFC f g (PPatvar fc n) = PPatvar (g fc) n

1047−mapPTermFC f g (PLam fc n fc' t1 t2) = PLam (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2)

1056+mapPTermFC f g (PLam fc n fc' t1 t2) = PLam (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2)

1048−mapPTermFC f g (PPi plic n fc t1 t2) = PPi plic n (g fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1057+mapPTermFC f g (PPi plic n fc t1 t2) = PPi plic n (g fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1049−mapPTermFC f g (PLet fc n fc' t1 t2 t3) = PLet (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1058+mapPTermFC f g (PLet fc n fc' t1 t2 t3) = PLet (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1050−mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)

1059+mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)

1051−mapPTermFC f g (PApp fc t args) = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1060+mapPTermFC f g (PApp fc t args) = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1052−mapPTermFC f g (PAppImpl t1 impls) = PAppImpl (mapPTermFC f g t1) impls

1061+mapPTermFC f g (PAppImpl t1 impls) = PAppImpl (mapPTermFC f g t1) impls

1053−mapPTermFC f g (PAppBind fc t args) = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1062+mapPTermFC f g (PAppBind fc t args) = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1054−mapPTermFC f g (PMatchApp fc n) = PMatchApp (f fc) n

1063+mapPTermFC f g (PMatchApp fc n) = PMatchApp (f fc) n

1055−mapPTermFC f g (PIfThenElse fc t1 t2 t3) = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1064+mapPTermFC f g (PIfThenElse fc t1 t2 t3) = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1056−mapPTermFC f g (PCase fc t cases) = PCase (f fc) (mapPTermFC f g t) (map (\(l,r) -> (mapPTermFC f g l, mapPTermFC f g r)) cases)

1065+mapPTermFC f g (PCase fc t cases) = PCase (f fc) (mapPTermFC f g t) (map (\(l,r) -> (mapPTermFC f g l, mapPTermFC f g r)) cases)

1057−mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1066+mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1058−mapPTermFC f g (PResolveTC fc) = PResolveTC (f fc)

1067+mapPTermFC f g (PResolveTC fc) = PResolveTC (f fc)

1059−mapPTermFC f g (PRewrite fc t1 t2 t3) = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)

1068+mapPTermFC f g (PRewrite fc t1 t2 t3) = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)

1060−mapPTermFC f g (PPair fc hls info t1 t2) = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2)

1069+mapPTermFC f g (PPair fc hls info t1 t2) = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2)

1061−mapPTermFC f g (PDPair fc hls info t1 t2 t3) = PDPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1070+mapPTermFC f g (PDPair fc hls info t1 t2 t3) = PDPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1062−mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)

1071+mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)

1063−mapPTermFC f g (PAlternative ns ty ts) = PAlternative ns ty (map (mapPTermFC f g) ts)

1072+mapPTermFC f g (PAlternative ns ty ts) = PAlternative ns ty (map (mapPTermFC f g) ts)

1064−mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1073+mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1065−mapPTermFC f g (PType fc) = PType (f fc)

1074+mapPTermFC f g (PType fc) = PType (f fc)

1066−mapPTermFC f g (PUniverse u) = PUniverse u

1075+mapPTermFC f g (PUniverse u) = PUniverse u

1067−mapPTermFC f g (PGoal fc t1 n t2) = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)

1076+mapPTermFC f g (PGoal fc t1 n t2) = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)

1068−mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1077+mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1069−mapPTermFC f g Placeholder = Placeholder

1078+mapPTermFC f g Placeholder = Placeholder

1070mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

1079mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

1071 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

1080 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

1072 mapPDoFC (DoBind fc n nfc t) = DoBind (f fc) n (g nfc) (mapPTermFC f g t)

1081 mapPDoFC (DoBind fc n nfc t) = DoBind (f fc) n (g nfc) (mapPTermFC f g t)

@@ -1074,22 +1083,22 @@ mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

1074 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

1083 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

1075 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1084 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1076 mapPDoFC (DoLetP fc t1 t2) = DoLetP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1085 mapPDoFC (DoLetP fc t1 t2) = DoLetP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1077−mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)

1086+mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)

1078−mapPTermFC f g (PReturn fc) = PReturn (f fc)

1087+mapPTermFC f g (PReturn fc) = PReturn (f fc)

1079−mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1088+mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1080−mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)

1089+mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)

1081−mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)

1090+mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)

1082−mapPTermFC f g (PElabError err) = PElabError err

1091+mapPTermFC f g (PElabError err) = PElabError err

1083−mapPTermFC f g PImpossible = PImpossible

1092+mapPTermFC f g PImpossible = PImpossible

1084−mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1093+mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1085−mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1094+mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1086−mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1095+mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1087−mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)

1096+mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)

1088−mapPTermFC f g (PQuasiquote t1 t2) = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)

1097+mapPTermFC f g (PQuasiquote t1 t2) = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)

1089−mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t)

1098+mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t)

1090−mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns

1099+mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns

1091−mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)

1100+mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)

1092−mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)

1101+mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)

1093

1102

1094{-!

1103{-!

1095dg instance Binary PTerm

1104dg instance Binary PTerm

@@ -1098,28 +1107,27 @@ deriving instance NFData PTerm

1098

1107

1099mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

1108mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

1100mapPT f t = f (mpt t) where

1109mapPT f t = f (mpt t) where

1101− mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)

1110+ mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)

1102− mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)

1111+ mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)

1103− mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)

1112+ mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)

1104− mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)

1113+ mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)

1105− (fmap (mapPT f) g)

1106− mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

1114+ mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

1107− mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)

1115+ mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)

1108− mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)

1116+ mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)

1109− mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)

1117+ mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)

1110− mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)

1118+ mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)

1111− mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)

1119+ mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)

1112 mpt (PDPair fc hls p l t r) = PDPair fc hls p (mapPT f l) (mapPT f t) (mapPT f r)

1120 mpt (PDPair fc hls p l t r) = PDPair fc hls p (mapPT f l) (mapPT f t) (mapPT f r)

1113− mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)

1121+ mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)

1114− mpt (PHidden t) = PHidden (mapPT f t)

1122+ mpt (PHidden t) = PHidden (mapPT f t)

1115− mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1123+ mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1116− mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1124+ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1117− mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1125+ mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1118− mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1126+ mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1119− mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1127+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1120− mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1128+ mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1121− mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1129+ mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1122− mpt x = x

1130+ mpt x = x

1123

1131

1124

1132

1125data PTactic' t = Intro [Name] | Intros | Focus Name

1133data PTactic' t = Intro [Name] | Intros | Focus Name

@@ -1160,39 +1168,39 @@ deriving instance Binary PTactic'

1160deriving instance NFData PTactic'

1168deriving instance NFData PTactic'

1161!-}

1169!-}

1162instance Sized a => Sized (PTactic' a) where

1170instance Sized a => Sized (PTactic' a) where

1163− size (Intro nms) = 1 + size nms

1171+ size (Intro nms) = 1 + size nms

1164− size Intros = 1

1172+ size Intros = 1

1165− size (Focus nm) = 1 + size nm

1173+ size (Focus nm) = 1 + size nm

1166− size (Refine nm bs) = 1 + size nm + length bs

1174+ size (Refine nm bs) = 1 + size nm + length bs

1167− size (Rewrite t) = 1 + size t

1175+ size (Rewrite t) = 1 + size t

1168− size (Induction t) = 1 + size t

1176+ size (Induction t) = 1 + size t

1169− size (LetTac nm t) = 1 + size nm + size t

1177+ size (LetTac nm t) = 1 + size nm + size t

1170− size (Exact t) = 1 + size t

1178+ size (Exact t) = 1 + size t

1171− size Compute = 1

1179+ size Compute = 1

1172− size Trivial = 1

1180+ size Trivial = 1

1173− size Solve = 1

1181+ size Solve = 1

1174− size Attack = 1

1182+ size Attack = 1

1175− size ProofState = 1

1183+ size ProofState = 1

1176− size ProofTerm = 1

1184+ size ProofTerm = 1

1177− size Undo = 1

1185+ size Undo = 1

1178− size (Try l r) = 1 + size l + size r

1186+ size (Try l r) = 1 + size l + size r

1179− size (TSeq l r) = 1 + size l + size r

1187+ size (TSeq l r) = 1 + size l + size r

1180− size (ApplyTactic t) = 1 + size t

1188+ size (ApplyTactic t) = 1 + size t

1181− size (Reflect t) = 1 + size t

1189+ size (Reflect t) = 1 + size t

1182− size (Fill t) = 1 + size t

1190+ size (Fill t) = 1 + size t

1183− size Qed = 1

1191+ size Qed = 1

1184− size Abandon = 1

1192+ size Abandon = 1

1185− size Skip = 1

1193+ size Skip = 1

1186− size (TFail ts) = 1 + size ts

1194+ size (TFail ts) = 1 + size ts

1187− size SourceFC = 1

1195+ size SourceFC = 1

1188− size DoUnify = 1

1196+ size DoUnify = 1

1189− size (CaseTac x) = 1 + size x

1197+ size (CaseTac x) = 1 + size x

1190− size (Equiv t) = 1 + size t

1198+ size (Equiv t) = 1 + size t

1191− size (Claim x y) = 1 + size x + size y

1199+ size (Claim x y) = 1 + size x + size y

1192− size Unfocus = 1

1200+ size Unfocus = 1

1193− size (MatchRefine x) = 1 + size x

1201+ size (MatchRefine x) = 1 + size x

1194 size (LetTacTy x y z) = 1 + size x + size y + size z

1202 size (LetTacTy x y z) = 1 + size x + size y + size z

1195− size TCInstance = 1

1203+ size TCInstance = 1

1196

1204

1197type PTactic = PTactic' PTerm

1205type PTactic = PTactic' PTerm

1198

1206

@@ -1208,11 +1216,11 @@ deriving instance NFData PDo'

1208!-}

1216!-}

1209

1217

1210instance Sized a => Sized (PDo' a) where

1218instance Sized a => Sized (PDo' a) where

1211− size (DoExp fc t) = 1 + size fc + size t

1219+ size (DoExp fc t) = 1 + size fc + size t

1212− size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t

1220+ size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t

1213− size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

1221+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

1214− size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r

1222+ size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r

1215− size (DoLetP fc l r) = 1 + size fc + size l + size r

1223+ size (DoLetP fc l r) = 1 + size fc + size l + size r

1216

1224

1217type PDo = PDo' PTerm

1225type PDo = PDo' PTerm

1218

1226

@@ -1244,10 +1252,10 @@ data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg | UnknownImp

1244 deriving (Show, Eq, Data, Typeable)

1252 deriving (Show, Eq, Data, Typeable)

1245

1253

1246instance Sized a => Sized (PArg' a) where

1254instance Sized a => Sized (PArg' a) where

1247− size (PImp p _ l nm trm) = 1 + size nm + size trm

1255+ size (PImp p _ l nm trm) = 1 + size nm + size trm

1248− size (PExp p l nm trm) = 1 + size nm + size trm

1256+ size (PExp p l nm trm) = 1 + size nm + size trm

1249− size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

1257+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

1250− size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

1258+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

1251

1259

1252{-!

1260{-!

1253deriving instance Binary PArg'

1261deriving instance Binary PArg'

@@ -1255,43 +1263,43 @@ deriving instance NFData PArg'

1255!-}

1263!-}

1256

1264

1257pimp n t mach = PImp 1 mach [] n t

1265pimp n t mach = PImp 1 mach [] n t

1258−pexp t = PExp 1 [] (sMN 0 "arg") t

1266+pexp t = PExp 1 [] (sMN 0 "arg") t

1259−pconst t = PConstraint 1 [] (sMN 0 "carg") t

1267+pconst t = PConstraint 1 [] (sMN 0 "carg") t

1260ptacimp n s t = PTacImplicit 2 [] n s t

1268ptacimp n s t = PTacImplicit 2 [] n s t

1261

1269

1262type PArg = PArg' PTerm

1270type PArg = PArg' PTerm

1263

1271

1264-- | Get the highest FC in a term, if one exists

1272-- | Get the highest FC in a term, if one exists

1265highestFC :: PTerm -> Maybe FC

1273highestFC :: PTerm -> Maybe FC

1266−highestFC (PQuote _) = Nothing

1274+highestFC (PQuote _) = Nothing

1267−highestFC (PRef fc _ _) = Just fc

1275+highestFC (PRef fc _ _) = Just fc

1268−highestFC (PInferRef fc _ _) = Just fc

1276+highestFC (PInferRef fc _ _) = Just fc

1269−highestFC (PPatvar fc _) = Just fc

1277+highestFC (PPatvar fc _) = Just fc

1270−highestFC (PLam fc _ _ _ _) = Just fc

1278+highestFC (PLam fc _ _ _ _) = Just fc

1271−highestFC (PPi _ _ _ _ _) = Nothing

1279+highestFC (PPi _ _ _ _ _) = Nothing

1272−highestFC (PLet fc _ _ _ _ _) = Just fc

1280+highestFC (PLet fc _ _ _ _ _) = Just fc

1273−highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1281+highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1274−highestFC (PApp fc _ _) = Just fc

1282+highestFC (PApp fc _ _) = Just fc

1275−highestFC (PAppBind fc _ _) = Just fc

1283+highestFC (PAppBind fc _ _) = Just fc

1276−highestFC (PMatchApp fc _) = Just fc

1284+highestFC (PMatchApp fc _) = Just fc

1277−highestFC (PCase fc _ _) = Just fc

1285+highestFC (PCase fc _ _) = Just fc

1278−highestFC (PIfThenElse fc _ _ _) = Just fc

1286+highestFC (PIfThenElse fc _ _ _) = Just fc

1279−highestFC (PTrue fc _) = Just fc

1287+highestFC (PTrue fc _) = Just fc

1280−highestFC (PResolveTC fc) = Just fc

1288+highestFC (PResolveTC fc) = Just fc

1281−highestFC (PRewrite fc _ _ _) = Just fc

1289+highestFC (PRewrite fc _ _ _) = Just fc

1282−highestFC (PPair fc _ _ _ _) = Just fc

1290+highestFC (PPair fc _ _ _ _) = Just fc

1283−highestFC (PDPair fc _ _ _ _ _) = Just fc

1291+highestFC (PDPair fc _ _ _ _ _) = Just fc

1284−highestFC (PAs fc _ _) = Just fc

1292+highestFC (PAs fc _ _) = Just fc

1285highestFC (PAlternative _ _ args) =

1293highestFC (PAlternative _ _ args) =

1286 case mapMaybe highestFC args of

1294 case mapMaybe highestFC args of

1287 [] -> Nothing

1295 [] -> Nothing

1288 (fc:_) -> Just fc

1296 (fc:_) -> Just fc

1289−highestFC (PHidden _) = Nothing

1297+highestFC (PHidden _) = Nothing

1290−highestFC (PType fc) = Just fc

1298+highestFC (PType fc) = Just fc

1291−highestFC (PUniverse _) = Nothing

1299+highestFC (PUniverse _) = Nothing

1292−highestFC (PGoal fc _ _ _) = Just fc

1300+highestFC (PGoal fc _ _ _) = Just fc

1293−highestFC (PConstant fc _) = Just fc

1301+highestFC (PConstant fc _) = Just fc

1294−highestFC Placeholder = Nothing

1302+highestFC Placeholder = Nothing

1295highestFC (PDoBlock lines) =

1303highestFC (PDoBlock lines) =

1296 case map getDoFC lines of

1304 case map getDoFC lines of

1297 [] -> Nothing

1305 [] -> Nothing

@@ -1303,23 +1311,23 @@ highestFC (PDoBlock lines) =

1303 getDoFC (DoLet fc nm nfc l r) = fc

1311 getDoFC (DoLet fc nm nfc l r) = fc

1304 getDoFC (DoLetP fc l r) = fc

1312 getDoFC (DoLetP fc l r) = fc

1305

1313

1306−highestFC (PIdiom fc _) = Just fc

1314+highestFC (PIdiom fc _) = Just fc

1307−highestFC (PReturn fc) = Just fc

1315+highestFC (PReturn fc) = Just fc

1308−highestFC (PMetavar fc _) = Just fc

1316+highestFC (PMetavar fc _) = Just fc

1309−highestFC (PProof _) = Nothing

1317+highestFC (PProof _) = Nothing

1310−highestFC (PTactics _) = Nothing

1318+highestFC (PTactics _) = Nothing

1311−highestFC (PElabError _) = Nothing

1319+highestFC (PElabError _) = Nothing

1312−highestFC PImpossible = Nothing

1320+highestFC PImpossible = Nothing

1313−highestFC (PCoerced tm) = highestFC tm

1321+highestFC (PCoerced tm) = highestFC tm

1314−highestFC (PDisamb _ opts) = highestFC opts

1322+highestFC (PDisamb _ opts) = highestFC opts

1315−highestFC (PUnifyLog tm) = highestFC tm

1323+highestFC (PUnifyLog tm) = highestFC tm

1316−highestFC (PNoImplicits tm) = highestFC tm

1324+highestFC (PNoImplicits tm) = highestFC tm

1317−highestFC (PQuasiquote _ _) = Nothing

1325+highestFC (PQuasiquote _ _) = Nothing

1318−highestFC (PUnquote tm) = highestFC tm

1326+highestFC (PUnquote tm) = highestFC tm

1319−highestFC (PQuoteName _ _ fc) = Just fc

1327+highestFC (PQuoteName _ _ fc) = Just fc

1320−highestFC (PRunElab fc _ _) = Just fc

1328+highestFC (PRunElab fc _ _) = Just fc

1321−highestFC (PConstSugar fc _) = Just fc

1329+highestFC (PConstSugar fc _) = Just fc

1322−highestFC (PAppImpl t _) = highestFC t

1330+highestFC (PAppImpl t _) = highestFC t

1323

1331

1324-- Type class data

1332-- Type class data

1325

1333

@@ -1397,11 +1405,11 @@ data Syntax = Rule [SSymbol] PTerm SynContext

1397

1405

1398syntaxNames :: Syntax -> [Name]

1406syntaxNames :: Syntax -> [Name]

1399syntaxNames (Rule syms _ _) = mapMaybe ename syms

1407syntaxNames (Rule syms _ _) = mapMaybe ename syms

1400− where ename (Keyword n) = Just n

1408+ where ename (Keyword n) = Just n

1401− ename _ = Nothing

1409+ ename _ = Nothing

1402syntaxNames (DeclRule syms _) = mapMaybe ename syms

1410syntaxNames (DeclRule syms _) = mapMaybe ename syms

1403− where ename (Keyword n) = Just n

1411+ where ename (Keyword n) = Just n

1404− ename _ = Nothing

1412+ ename _ = Nothing

1405

1413

1406syntaxSymbols :: Syntax -> [SSymbol]

1414syntaxSymbols :: Syntax -> [SSymbol]

1407syntaxSymbols (Rule ss _ _) = ss

1415syntaxSymbols (Rule ss _ _) = ss

@@ -1434,9 +1442,9 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

1434 where

1442 where

1435 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

1443 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

1436

1444

1437− ruleSort [] [] = EQ

1445+ ruleSort [] [] = EQ

1438− ruleSort [] _ = LT

1446+ ruleSort [] _ = LT

1439− ruleSort _ [] = GT

1447+ ruleSort _ [] = GT

1440 ruleSort (s1:ss1) (s2:ss2) =

1448 ruleSort (s1:ss1) (s2:ss2) =

1441 case symCompare s1 s2 of

1449 case symCompare s1 s2 of

1442 EQ -> ruleSort ss1 ss2

1450 EQ -> ruleSort ss1 ss2

@@ -1444,25 +1452,25 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

1444

1452

1445 -- Better than creating Ord instance for SSymbol since

1453 -- Better than creating Ord instance for SSymbol since

1446 -- in general this ordering does not really make sense.

1454 -- in general this ordering does not really make sense.

1447− symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1455+ symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1448− symCompare (Keyword _) _ = LT

1456+ symCompare (Keyword _) _ = LT

1449− symCompare (Symbol _) (Keyword _) = GT

1457+ symCompare (Symbol _) (Keyword _) = GT

1450− symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1458+ symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1451− symCompare (Symbol _) _ = LT

1459+ symCompare (Symbol _) _ = LT

1452− symCompare (Binding _) (Keyword _) = GT

1460+ symCompare (Binding _) (Keyword _) = GT

1453− symCompare (Binding _) (Symbol _) = GT

1461+ symCompare (Binding _) (Symbol _) = GT

1454− symCompare (Binding b1) (Binding b2) = compare b1 b2

1462+ symCompare (Binding b1) (Binding b2) = compare b1 b2

1455− symCompare (Binding _) _ = LT

1463+ symCompare (Binding _) _ = LT

1456− symCompare (Expr _) (Keyword _) = GT

1464+ symCompare (Expr _) (Keyword _) = GT

1457− symCompare (Expr _) (Symbol _) = GT

1465+ symCompare (Expr _) (Symbol _) = GT

1458− symCompare (Expr _) (Binding _) = GT

1466+ symCompare (Expr _) (Binding _) = GT

1459− symCompare (Expr e1) (Expr e2) = compare e1 e2

1467+ symCompare (Expr e1) (Expr e2) = compare e1 e2

1460− symCompare (Expr _) _ = LT

1468+ symCompare (Expr _) _ = LT

1461− symCompare (SimpleExpr _) (Keyword _) = GT

1469+ symCompare (SimpleExpr _) (Keyword _) = GT

1462− symCompare (SimpleExpr _) (Symbol _) = GT

1470+ symCompare (SimpleExpr _) (Symbol _) = GT

1463− symCompare (SimpleExpr _) (Binding _) = GT

1471+ symCompare (SimpleExpr _) (Binding _) = GT

1464− symCompare (SimpleExpr _) (Expr _) = GT

1472+ symCompare (SimpleExpr _) (Expr _) = GT

1465− symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

1473+ symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

1466

1474

1467initDSL = DSL (PRef f [] (sUN ">>="))

1475initDSL = DSL (PRef f [] (sUN ">>="))

1468 (PRef f [] (sUN "return"))

1476 (PRef f [] (sUN "return"))

@@ -1534,10 +1542,10 @@ getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

1534getInferTerm (App _ (App _ _ _) tm) = tm

1542getInferTerm (App _ (App _ _ _) tm) = tm

1535getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1543getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1536

1544

1537−getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1545+getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1538− where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1546+ where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1539− toTy (PVar t) = PVTy t

1547+ toTy (PVar t) = PVTy t

1540− toTy b = b

1548+ toTy b = b

1541getInferType (App _ (App _ _ ty) _) = ty

1549getInferType (App _ (App _ _ ty) _) = ty

1542

1550

1543

1551

@@ -1562,9 +1570,9 @@ pairCon = sNS (sUN "MkPair") ["Builtins"]

1562upairTy = sNS (sUN "UPair") ["Builtins"]

1570upairTy = sNS (sUN "UPair") ["Builtins"]

1563upairCon = sNS (sUN "MkUPair") ["Builtins"]

1571upairCon = sNS (sUN "MkUPair") ["Builtins"]

1564

1572

1565−eqTy = sUN "="

1573+eqTy = sUN "="

1566eqCon = sUN "Refl"

1574eqCon = sUN "Refl"

1567−eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1575+eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1568 "The propositional equality type. A proof that `x` = `y`." ++

1576 "The propositional equality type. A proof that `x` = `y`." ++

1569 "\n\n" ++

1577 "\n\n" ++

1570 "To use such a proof, pattern-match on it, and the two equal things will " ++

1578 "To use such a proof, pattern-match on it, and the two equal things will " ++

@@ -1607,8 +1615,8 @@ modDocName :: Name

1607modDocName = sMN 0 "ModuleDocs"

1615modDocName = sMN 0 "ModuleDocs"

1608

1616

1609-- Defined in builtins.idr

1617-- Defined in builtins.idr

1610−sigmaTy = sNS (sUN "Sigma") ["Builtins"]

1618+sigmaTy = sNS (sUN "DPair") ["Builtins"]

1611−sigmaCon = sNS (sUN "MkSigma") ["Builtins"]

1619+sigmaCon = sNS (sUN "MkDPair") ["Builtins"]

1612

1620

1613piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1621piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1614piBind = piBindp expl

1622piBind = piBindp expl

@@ -1648,11 +1656,11 @@ annotationColour ist (AnnConst c) =

1648 in Just $ if constIsType c

1656 in Just $ if constIsType c

1649 then typeColour theme

1657 then typeColour theme

1650 else dataColour theme

1658 else dataColour theme

1651−annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1659+annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1652−annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1660+annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1653−annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

1661+annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

1654annotationColour ist (AnnBoundName _ False) = Just $ boundVarColour (idris_colourTheme ist)

1662annotationColour ist (AnnBoundName _ False) = Just $ boundVarColour (idris_colourTheme ist)

1655−annotationColour ist AnnKeyword = Just $ keywordColour (idris_colourTheme ist)

1663+annotationColour ist AnnKeyword = Just $ keywordColour (idris_colourTheme ist)

1656annotationColour ist (AnnName n _ _ _) =

1664annotationColour ist (AnnName n _ _ _) =

1657 let ctxt = tt_ctxt ist

1665 let ctxt = tt_ctxt ist

1658 theme = idris_colourTheme ist

1666 theme = idris_colourTheme ist

@@ -1738,7 +1746,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1738

1746

1739 st =

1747 st =

1740 case s of

1748 case s of

1741− Static -> text "[static]" <> space

1749+ Static -> text "%static" <> space

1742 _ -> empty

1750 _ -> empty

1743 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

1751 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

1744 | ppopt_impl ppo =

1752 | ppopt_impl ppo =

@@ -1749,12 +1757,12 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1749 where

1757 where

1750 st =

1758 st =

1751 case s of

1759 case s of

1752− Static -> text "[static]" <> space

1760+ Static -> text "%static" <> space

1753 _ -> empty

1761 _ -> empty

1754 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

1762 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

1755 depth d . bracket p startPrec $

1763 depth d . bracket p startPrec $

1756 prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1764 prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1757− prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch _ _ _ _ _ _])) n _ ty sc) =

1765+ prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch{}])) n _ ty sc) =

1758 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

1766 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

1759 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1767 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1760 prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =

1768 prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =

@@ -1791,7 +1799,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1791 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

1799 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

1792 [l,r] -> let precedence = maybe (startPrec - 1) prec f

1800 [l,r] -> let precedence = maybe (startPrec - 1) prec f

1793 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1801 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1794− (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) ->

1802+ (l@(PExp{}) : r@(PExp{}) : rest) ->

1795 depth d . bracket p funcAppPrec $

1803 depth d . bracket p funcAppPrec $

1796 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

1804 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

1797 align (group (vsep (map (prettyArgS d bnd) rest)))

1805 align (group (vsep (map (prettyArgS d bnd) rest)))

@@ -1842,20 +1850,20 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1842 -- disambiguation on PDPair.

1850 -- disambiguation on PDPair.

1843 vars tm = filter noNS (allNamesIn tm)

1851 vars tm = filter noNS (allNamesIn tm)

1844 noNS (NS _ _) = False

1852 noNS (NS _ _) = False

1845− noNS _ = True

1853+ noNS _ = True

1846

1854

1847 prettySe d p bnd (PIfThenElse _ c t f) =

1855 prettySe d p bnd (PIfThenElse _ c t f) =

1848 depth d . bracket p funcAppPrec . group . align . hang 2 . vsep $

1856 depth d . bracket p funcAppPrec . group . align . hang 2 . vsep $

1849− [ kwd "if" <+> prettySe (decD d) startPrec bnd c

1857+ [ kwd "if" <+> prettySe (decD d) startPrec bnd c

1850 , kwd "then" <+> prettySe (decD d) startPrec bnd t

1858 , kwd "then" <+> prettySe (decD d) startPrec bnd t

1851 , kwd "else" <+> prettySe (decD d) startPrec bnd f

1859 , kwd "else" <+> prettySe (decD d) startPrec bnd f

1852 ]

1860 ]

1853− prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1861+ prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1854− prettySe d p bnd (PResolveTC _) = kwd "%instance"

1862+ prettySe d p bnd (PResolveTC _) = kwd "%instance"

1855− prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1863+ prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1856− prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1864+ prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1857 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1865 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1858− prettySe d p bnd (PRewrite _ l r _) =

1866+ prettySe d p bnd (PRewrite _ l r _) =

1859 depth d . bracket p startPrec $

1867 depth d . bracket p startPrec $

1860 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

1868 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

1861 prettySe d p bnd (PTyped l r) =

1869 prettySe d p bnd (PTyped l r) =

@@ -1865,9 +1873,9 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1865 align . group . vsep . punctuate (ann comma) $

1873 align . group . vsep . punctuate (ann comma) $

1866 map (prettySe (decD d) startPrec bnd) elts

1874 map (prettySe (decD d) startPrec bnd) elts

1867 where ann = case pun of

1875 where ann = case pun of

1868− TypeOrTerm -> id

1876+ TypeOrTerm -> id

1869− IsType -> annName pairTy

1877+ IsType -> annName pairTy

1870− IsTerm -> annName pairCon

1878+ IsTerm -> annName pairCon

1871 prettySe d p bnd (PDPair _ _ pun l t r) =

1879 prettySe d p bnd (PDPair _ _ pun l t r) =

1872 depth d $

1880 depth d $

1873 annotated lparen <>

1881 annotated lparen <>

@@ -1876,30 +1884,32 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1876 prettySe (decD d) startPrec (addBinding bnd) r <>

1884 prettySe (decD d) startPrec (addBinding bnd) r <>

1877 annotated rparen

1885 annotated rparen

1878 where annotated = case pun of

1886 where annotated = case pun of

1879− IsType -> annName sigmaTy

1887+ IsType -> annName sigmaTy

1880− IsTerm -> annName sigmaCon

1888+ IsTerm -> annName sigmaCon

1881− TypeOrTerm -> id

1889+ TypeOrTerm -> id

1882 (left, addBinding) = case (l, pun) of

1890 (left, addBinding) = case (l, pun) of

1883 (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))

1891 (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))

1884− _ -> (prettySe (decD d) startPrec bnd l, id)

1892+ _ -> (prettySe (decD d) startPrec bnd l, id)

1885 prettySe d p bnd (PAlternative ns a as) =

1893 prettySe d p bnd (PAlternative ns a as) =

1886 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1894 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1887 where

1895 where

1888 prettyAs =

1896 prettyAs =

1897+ foldr ((\ l r -> l <+> text "," <+> r) .

1889− foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (depth d . prettySe (decD d) startPrec bnd) as

1898+ depth d . prettySe (decD d) startPrec bnd)

1899+ empty as

1890− prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1900+ prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1891− prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1901+ prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1892− prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

1902+ prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

1893 -- XXX: add pretty for tactics

1903 -- XXX: add pretty for tactics

1894− prettySe d p bnd (PProof ts) =

1904+ prettySe d p bnd (PProof ts) =

1895 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1905 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1896− prettySe d p bnd (PTactics ts) =

1906+ prettySe d p bnd (PTactics ts) =

1897 kwd "tactics" <+> lbrace <> ellipsis <> rbrace

1907 kwd "tactics" <+> lbrace <> ellipsis <> rbrace

1898− prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $ text "?" <> pretty n

1908+ prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $ text "?" <> pretty n

1899− prettySe d p bnd (PReturn f) = kwd "return"

1909+ prettySe d p bnd (PReturn f) = kwd "return"

1900− prettySe d p bnd PImpossible = kwd "impossible"

1910+ prettySe d p bnd PImpossible = kwd "impossible"

1901− prettySe d p bnd Placeholder = text "_"

1911+ prettySe d p bnd Placeholder = text "_"

1902− prettySe d p bnd (PDoBlock dos) =

1912+ prettySe d p bnd (PDoBlock dos) =

1903 bracket p startPrec $

1913 bracket p startPrec $

1904 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

1914 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

1905 where ppdo bnd (DoExp _ tm:dos) = prettySe (decD d) startPrec bnd tm : ppdo bnd dos

1915 where ppdo bnd (DoExp _ tm:dos) = prettySe (decD d) startPrec bnd tm : ppdo bnd dos

@@ -1921,47 +1931,46 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1921 text "no pretty printer for pattern-matching do binding" :

1931 text "no pretty printer for pattern-matching do binding" :

1922 ppdo bnd dos

1932 ppdo bnd dos

1923 ppdo _ [] = []

1933 ppdo _ [] = []

1924− prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1934+ prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1925− prettySe d p bnd (PElabError s) = pretty s

1935+ prettySe d p bnd (PElabError s) = pretty s

1926 -- Quasiquote pprinting ignores bound vars

1936 -- Quasiquote pprinting ignores bound vars

1927− prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"

1937+ prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"

1928 prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")"

1938 prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")"

1929− prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t

1939+ prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t

1930− prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

1940+ prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

1931 where start = if res then "`{" else "`{{"

1941 where start = if res then "`{" else "`{{"

1932 end = if res then "}" else "}}"

1942 end = if res then "}" else "}}"

1933− prettySe d p bnd (PRunElab _ tm _) =

1943+ prettySe d p bnd (PRunElab _ tm _) =

1934 bracket p funcAppPrec . group . align . hang 2 $

1944 bracket p funcAppPrec . group . align . hang 2 $

1935 text "%runElab" <$>

1945 text "%runElab" <$>

1936 prettySe (decD d) funcAppPrec bnd tm

1946 prettySe (decD d) funcAppPrec bnd tm

1937− prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1947+ prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1938−

1939− prettySe d p bnd _ = text "missing pretty-printer for term"

1948+ prettySe d p bnd _ = text "missing pretty-printer for term"

1940

1949

1941 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

1950 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

1942 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

1951 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

1943 where display (UN n) = T.unpack n

1952 where display (UN n) = T.unpack n

1944 display (MN _ n) = T.unpack n

1953 display (MN _ n) = T.unpack n

1945 -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings

1954 -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings

1946− display (NS n ns) = (concat . intersperse "." . map T.unpack . reverse) ns ++ "." ++ display n

1955+ display (NS n ns) = (intercalate "." . map T.unpack . reverse) ns ++ "." ++ display n

1947 display n = show n

1956 display n = show n

1948

1957

1949− prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1958+ prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1950− prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1959+ prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1951− prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1960+ prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1952− prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

1961+ prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

1953

1962

1954− prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg

1963+ prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg

1955− prettyArgSi d bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1964+ prettyArgSi d bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1956− prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

1965+ prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

1957 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1966 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1958

1967

1959 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1968 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1960 annName n = annotate (AnnName n Nothing Nothing Nothing)

1969 annName n = annotate (AnnName n Nothing Nothing Nothing)

1961

1970

1962 opStr :: Name -> String

1971 opStr :: Name -> String

1963− opStr (NS n _) = opStr n

1972+ opStr (NS n _) = opStr n

1964− opStr (UN n) = T.unpack n

1973+ opStr (UN n) = T.unpack n

1965

1974

1966 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

1975 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

1967 slist' (Just d) _ _ _ | d <= 0 = Nothing

1976 slist' (Just d) _ _ _ | d <= 0 = Nothing

@@ -2023,7 +2032,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

2023 ellipsis = text "..."

2032 ellipsis = text "..."

2024

2033

2025 depth Nothing = id

2034 depth Nothing = id

2026− depth (Just d) = if d <= 0 then const (ellipsis) else id

2035+ depth (Just d) = if d <= 0 then const ellipsis else id

2027

2036

2028 decD = fmap (\x -> x - 1)

2037 decD = fmap (\x -> x - 1)

2029

2038

@@ -2038,7 +2047,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

2038-- | Strip away namespace information

2047-- | Strip away namespace information

2039basename :: Name -> Name

2048basename :: Name -> Name

2040basename (NS n _) = basename n

2049basename (NS n _) = basename n

2041−basename n = n

2050+basename n = n

2042

2051

2043-- | Determine whether a name was the one inserted for a hole or

2052-- | Determine whether a name was the one inserted for a hole or

2044-- guess by the delaborator

2053-- guess by the delaborator

@@ -2058,15 +2067,15 @@ prettyName

2058 -> Name -- ^^ the name to pprint

2067 -> Name -- ^^ the name to pprint

2059 -> Doc OutputAnnotation

2068 -> Doc OutputAnnotation

2060prettyName infixParen showNS bnd n

2069prettyName infixParen showNS bnd n

2061− | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2070+ | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2062− | (UN n') <- n, T.unpack n' == "_" = text "_"

2071+ | (UN n') <- n, T.unpack n' == "_" = text "_"

2063− | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2072+ | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2064− | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

2073+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

2065 where fullName = text nameSpace <> parenthesise (text (baseName n))

2074 where fullName = text nameSpace <> parenthesise (text (baseName n))

2066− baseName (UN n) = T.unpack n

2075+ baseName (UN n) = T.unpack n

2067− baseName (NS n ns) = baseName n

2076+ baseName (NS n ns) = baseName n

2068− baseName (MN i s) = T.unpack s

2077+ baseName (MN i s) = T.unpack s

2069− baseName other = show other

2078+ baseName other = show other

2070 nameSpace = case n of

2079 nameSpace = case n of

2071 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

2080 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

2072 _ -> ""

2081 _ -> ""

@@ -2081,13 +2090,13 @@ showCImp ppo (PClause _ n l ws r w)

2081 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

2090 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

2082 <+> text "where" <+> text (show w)

2091 <+> text "where" <+> text (show w)

2083 where

2092 where

2084− showWs [] = empty

2093+ showWs [] = empty

2085 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2094 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2086showCImp ppo (PWith _ n l ws r pn w)

2095showCImp ppo (PWith _ n l ws r pn w)

2087 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

2096 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

2088 <+> braces (text (show w))

2097 <+> braces (text (show w))

2089 where

2098 where

2090− showWs [] = empty

2099+ showWs [] = empty

2091 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2100 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2092

2101

2093

2102

@@ -2099,43 +2108,43 @@ showDImp ppo (PDatadecl n nfc ty cons)

2099showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

2108showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

2100showDecls o ds = vsep (map (showDeclImp o) ds)

2109showDecls o ds = vsep (map (showDeclImp o) ds)

2101

2110

2102−showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

2111+showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

2103showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

2112showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

2104−showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

2113+showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

2105 indent 2 (vsep (map (showCImp o) cs))

2114 indent 2 (vsep (map (showCImp o) cs))

2106−showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

2115+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

2107−showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

2116+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

2108−showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

2117+showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

2109showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

2118showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

2110showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

2119showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

2111 = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

2120 = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

2112−showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)

2121+showDeclImp o (PInstance _ _ _ _ cs acc n _ _ t _ ds)

2113 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

2122 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

2114showDeclImp _ _ = text "..."

2123showDeclImp _ _ = text "..."

2115-- showDeclImp (PImport o) = "import " ++ o

2124-- showDeclImp (PImport o) = "import " ++ o

2116

2125

2117getImps :: [PArg] -> [(Name, PTerm)]

2126getImps :: [PArg] -> [(Name, PTerm)]

2118getImps [] = []

2127getImps [] = []

2119−getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2128+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2120−getImps (_ : xs) = getImps xs

2129+getImps (_ : xs) = getImps xs

2121

2130

2122getExps :: [PArg] -> [PTerm]

2131getExps :: [PArg] -> [PTerm]

2123getExps [] = []

2132getExps [] = []

2124−getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2133+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2125−getExps (_ : xs) = getExps xs

2134+getExps (_ : xs) = getExps xs

2126

2135

2127getShowArgs :: [PArg] -> [PArg]

2136getShowArgs :: [PArg] -> [PArg]

2128getShowArgs [] = []

2137getShowArgs [] = []

2129getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

2138getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

2130getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

2139getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

2131 | PImp _ _ _ _ tm <- e

2140 | PImp _ _ _ _ tm <- e

2132− , containsHole tm = e : getShowArgs xs

2141+ , containsHole tm = e : getShowArgs xs

2133getShowArgs (_ : xs) = getShowArgs xs

2142getShowArgs (_ : xs) = getShowArgs xs

2134

2143

2135getConsts :: [PArg] -> [PTerm]

2144getConsts :: [PArg] -> [PTerm]

2136−getConsts [] = []

2145+getConsts [] = []

2137getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2146getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2138−getConsts (_ : xs) = getConsts xs

2147+getConsts (_ : xs) = getConsts xs

2139

2148

2140getAll :: [PArg] -> [PTerm]

2149getAll :: [PArg] -> [PTerm]

2141getAll = map getTm

2150getAll = map getTm

@@ -2149,13 +2158,13 @@ showName :: Maybe IState -- ^^ the Idris state, for information about names an

2149 -> Name -- ^^ the term to show

2158 -> Name -- ^^ the term to show

2150 -> String

2159 -> String

2151showName ist bnd ppo colour n = case ist of

2160showName ist bnd ppo colour n = case ist of

2152− Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2161+ Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2153− Nothing -> showbasic n

2162+ Nothing -> showbasic n

2154 where name = if ppopt_impl ppo then show n else showbasic n

2163 where name = if ppopt_impl ppo then show n else showbasic n

2155− showbasic n@(UN _) = showCG n

2164+ showbasic n@(UN _) = showCG n

2156− showbasic (MN i s) = str s

2165+ showbasic (MN i s) = str s

2157− showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2166+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2158− showbasic (SN s) = show s

2167+ showbasic (SN s) = show s

2159 fst3 (x, _, _) = x

2168 fst3 (x, _, _) = x

2160 colourise n t = let ctxt' = fmap tt_ctxt ist in

2169 colourise n t = let ctxt' = fmap tt_ctxt ist in

2161 case ctxt' of

2170 case ctxt' of

@@ -2187,42 +2196,42 @@ showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

2187

2196

2188

2197

2189instance Sized PTerm where

2198instance Sized PTerm where

2190− size (PQuote rawTerm) = size rawTerm

2199+ size (PQuote rawTerm) = size rawTerm

2191− size (PRef fc _ name) = size name

2200+ size (PRef fc _ name) = size name

2192− size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

2201+ size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

2193− size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

2202+ size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

2194− size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

2203+ size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

2195− size (PTyped trm ty) = 1 + size trm + size ty

2204+ size (PTyped trm ty) = 1 + size trm + size ty

2196− size (PApp fc name args) = 1 + size args

2205+ size (PApp fc name args) = 1 + size args

2197− size (PAppBind fc name args) = 1 + size args

2206+ size (PAppBind fc name args) = 1 + size args

2198− size (PCase fc trm bdy) = 1 + size trm + size bdy

2207+ size (PCase fc trm bdy) = 1 + size trm + size bdy

2199− size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2208+ size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2200− size (PTrue fc _) = 1

2209+ size (PTrue fc _) = 1

2201− size (PResolveTC fc) = 1

2210+ size (PResolveTC fc) = 1

2202− size (PRewrite fc left right _) = 1 + size left + size right

2211+ size (PRewrite fc left right _) = 1 + size left + size right

2203− size (PPair fc _ _ left right) = 1 + size left + size right

2212+ size (PPair fc _ _ left right) = 1 + size left + size right

2204− size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2213+ size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2205− size (PAlternative _ a alts) = 1 + size alts

2214+ size (PAlternative _ a alts) = 1 + size alts

2206− size (PHidden hidden) = size hidden

2215+ size (PHidden hidden) = size hidden

2207− size (PUnifyLog tm) = size tm

2216+ size (PUnifyLog tm) = size tm

2208− size (PDisamb _ tm) = size tm

2217+ size (PDisamb _ tm) = size tm

2209− size (PNoImplicits tm) = size tm

2218+ size (PNoImplicits tm) = size tm

2210− size (PType _) = 1

2219+ size (PType _) = 1

2211− size (PUniverse _) = 1

2220+ size (PUniverse _) = 1

2212− size (PConstant fc const) = 1 + size fc + size const

2221+ size (PConstant fc const) = 1 + size fc + size const

2213− size Placeholder = 1

2222+ size Placeholder = 1

2214− size (PDoBlock dos) = 1 + size dos

2223+ size (PDoBlock dos) = 1 + size dos

2215− size (PIdiom fc term) = 1 + size term

2224+ size (PIdiom fc term) = 1 + size term

2216− size (PReturn fc) = 1

2225+ size (PReturn fc) = 1

2217− size (PMetavar _ name) = 1

2226+ size (PMetavar _ name) = 1

2218− size (PProof tactics) = size tactics

2227+ size (PProof tactics) = size tactics

2219− size (PElabError err) = size err

2228+ size (PElabError err) = size err

2220− size PImpossible = 1

2229+ size PImpossible = 1

2221− size _ = 0

2230+ size _ = 0

2222

2231

2223getPArity :: PTerm -> Int

2232getPArity :: PTerm -> Int

2224−getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2233+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2225−getPArity _ = 0

2234+getPArity _ = 0

2226

2235

2227-- Return all names, free or globally bound, in the given term.

2236-- Return all names, free or globally bound, in the given term.

2228

2237

@@ -2230,31 +2239,30 @@ allNamesIn :: PTerm -> [Name]

2230allNamesIn tm = nub $ ni 0 [] tm

2239allNamesIn tm = nub $ ni 0 [] tm

2231 where -- TODO THINK added niTacImp, but is it right?

2240 where -- TODO THINK added niTacImp, but is it right?

2232 ni 0 env (PRef _ _ n)

2241 ni 0 env (PRef _ _ n)

2233− | not (n `elem` env) = [n]

2242+ | not (n `elem` env) = [n]

2234− ni 0 env (PPatvar _ n) = [n]

2243+ ni 0 env (PPatvar _ n) = [n]

2235− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2244+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2236− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2245+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2237− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2246+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2238− ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f

2247+ ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f

2239− ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2248+ ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2240− ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2249+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2241− ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc

2250+ ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc

2242− ni 0 env (PHidden tm) = ni 0 env tm

2251+ ni 0 env (PHidden tm) = ni 0 env tm

2243− ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2252+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2244− ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2253+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2245− ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2254+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2246− ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r

2255+ ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r

2247− ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2256+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2248− ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2257+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2249− ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2258+ ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2250− ni 0 env (PUnifyLog tm) = ni 0 env tm

2259+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2251− ni 0 env (PDisamb _ tm) = ni 0 env tm

2260+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2252− ni 0 env (PNoImplicits tm) = ni 0 env tm

2261+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2253−

2254− ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty

2255− ni i env (PUnquote tm) = ni (i - 1) env tm

2256

2262

2263+ ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty

2264+ ni i env (PUnquote tm) = ni (i - 1) env tm

2257− ni i env tm = concatMap (ni i env) (children tm)

2265+ ni i env tm = concatMap (ni i env) (children tm)

2258

2266

2259 niTacImp i env (TacImp _ _ scr) = ni i env scr

2267 niTacImp i env (TacImp _ _ scr) = ni i env scr

2260 niTacImp _ _ _ = []

2268 niTacImp _ _ _ = []

@@ -2265,32 +2273,32 @@ boundNamesIn :: PTerm -> [Name]

2265boundNamesIn tm = S.toList (ni 0 S.empty tm)

2273boundNamesIn tm = S.toList (ni 0 S.empty tm)

2266 where -- TODO THINK Added niTacImp, but is it right?

2274 where -- TODO THINK Added niTacImp, but is it right?

2267 ni :: Int -> S.Set Name -> PTerm -> S.Set Name

2275 ni :: Int -> S.Set Name -> PTerm -> S.Set Name

2268− ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2276+ ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2269− ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2277+ ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2270− ni 0 set (PCase _ c os) = niTms 0 (ni 0 set c) (map snd os)

2278+ ni 0 set (PCase _ c os) = niTms 0 (ni 0 set c) (map snd os)

2271− ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]

2279+ ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]

2272− ni 0 set (PLam fc n _ ty sc) = S.insert n $ ni 0 (ni 0 set ty) sc

2280+ ni 0 set (PLam fc n _ ty sc) = S.insert n $ ni 0 (ni 0 set ty) sc

2273− ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc

2281+ ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc

2274− ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p

2282+ ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p

2275− ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r

2283+ ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r

2276− ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r

2284+ ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r

2277− ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

2285+ ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

2278 ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r

2286 ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r

2279− ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r

2287+ ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r

2280− ni 0 set (PAlternative ns a as) = niTms 0 set as

2288+ ni 0 set (PAlternative ns a as) = niTms 0 set as

2281− ni 0 set (PHidden tm) = ni 0 set tm

2289+ ni 0 set (PHidden tm) = ni 0 set tm

2282− ni 0 set (PUnifyLog tm) = ni 0 set tm

2290+ ni 0 set (PUnifyLog tm) = ni 0 set tm

2283− ni 0 set (PDisamb _ tm) = ni 0 set tm

2291+ ni 0 set (PDisamb _ tm) = ni 0 set tm

2284− ni 0 set (PNoImplicits tm) = ni 0 set tm

2292+ ni 0 set (PNoImplicits tm) = ni 0 set tm

2285

2293

2286− ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty

2294+ ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty

2287− ni i set (PUnquote tm) = ni (i - 1) set tm

2295+ ni i set (PUnquote tm) = ni (i - 1) set tm

2288

2296

2289− ni i set tm = foldr S.union set (map (ni i set) (children tm))

2297+ ni i set tm = foldr (S.union . ni i set) set (children tm)

2290

2298

2291 niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name

2299 niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name

2292− niTms i set [] = set

2300+ niTms i set [] = set

2293− niTms i set (x : xs) = niTms i (ni i set x) xs

2301+ niTms i set (x : xs) = niTms i (ni i set x) xs

2294

2302

2295 niTacImp i set (TacImp _ _ scr) = ni i set scr

2303 niTacImp i set (TacImp _ _ scr) = ni i set scr

2296 niTacImp i set _ = set

2304 niTacImp i set _ = set

@@ -2306,18 +2314,18 @@ implicitNamesIn uvars ist tm

2306 addFn n = do (imps, fns) <- get

2314 addFn n = do (imps, fns) <- get

2307 put (imps, n: fns)

2315 put (imps, n: fns)

2308

2316

2309− notCAF [] = False

2317+ notCAF [] = False

2310 notCAF (PExp _ _ _ _ : _) = True

2318 notCAF (PExp _ _ _ _ : _) = True

2311− notCAF (_ : xs) = notCAF xs

2319+ notCAF (_ : xs) = notCAF xs

2312

2320

2313 notHidden (n, _) = case getAccessibility n of

2321 notHidden (n, _) = case getAccessibility n of

2314− Hidden -> False

2322+ Hidden -> False

2315− _ -> True

2323+ _ -> True

2316

2324

2317 getAccessibility n

2325 getAccessibility n

2318 = case lookupDefAccExact n False (tt_ctxt ist) of

2326 = case lookupDefAccExact n False (tt_ctxt ist) of

2319− Just (n,t) -> t

2327+ Just (n,t) -> t

2320− _ -> Public

2328+ _ -> Public

2321

2329

2322 ni 0 env (PRef _ _ n@(NS _ _))

2330 ni 0 env (PRef _ _ n@(NS _ _))

2323 | not (n `elem` env)

2331 | not (n `elem` env)

@@ -2327,44 +2335,44 @@ implicitNamesIn uvars ist tm

2327 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2335 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2328 ni 0 env (PApp _ f@(PRef _ _ n) as)

2336 ni 0 env (PApp _ f@(PRef _ _ n) as)

2329 | n `elem` uvars = do ni 0 env f

2337 | n `elem` uvars = do ni 0 env f

2330− mapM_ (ni 0 env) (map getTm as)

2338+ mapM_ (ni 0 env . getTm) as

2331 | otherwise = do case lookupTy n (tt_ctxt ist) of

2339 | otherwise = do case lookupTy n (tt_ctxt ist) of

2332− [] -> return ()

2340+ [] -> return ()

2333− _ -> addFn n

2341+ _ -> addFn n

2334− mapM_ (ni 0 env) (map getTm as)

2342+ mapM_ (ni 0 env . getTm) as

2335 ni 0 env (PApp _ f as) = do ni 0 env f

2343 ni 0 env (PApp _ f as) = do ni 0 env f

2336− mapM_ (ni 0 env) (map getTm as)

2344+ mapM_ (ni 0 env . getTm) as

2337 ni 0 env (PAppBind _ f as) = do ni 0 env f

2345 ni 0 env (PAppBind _ f as) = do ni 0 env f

2338− mapM_ (ni 0 env) (map getTm as)

2346+ mapM_ (ni 0 env . getTm) as

2339 ni 0 env (PCase _ c os) = do ni 0 env c

2347 ni 0 env (PCase _ c os) = do ni 0 env c

2340 -- names in 'os', not counting the names bound in the cases

2348 -- names in 'os', not counting the names bound in the cases

2341− mapM_ (ni 0 env) (map snd os)

2349+ mapM_ (ni 0 env . snd) os

2342 (imps, fns) <- get

2350 (imps, fns) <- get

2343 put ([] ,[])

2351 put ([] ,[])

2344− mapM_ (ni 0 env) (map fst os)

2352+ mapM_ (ni 0 env . fst) os

2345 (impsfst, _) <- get

2353 (impsfst, _) <- get

2346 put (nub imps \\ nub impsfst, fns)

2354 put (nub imps \\ nub impsfst, fns)

2347− ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]

2355+ ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]

2348− ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2356+ ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2349− ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2357+ ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2350− ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r

2358+ ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r

2351− ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r

2359+ ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r

2352− ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2360+ ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2353− ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2361+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2354− ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2362+ ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2355− ni 0 env t

2363+ ni 0 env t

2356− ni 0 env r

2364+ ni 0 env r

2357− ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2365+ ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2358− ni 0 env (PHidden tm) = ni 0 env tm

2366+ ni 0 env (PHidden tm) = ni 0 env tm

2359− ni 0 env (PUnifyLog tm) = ni 0 env tm

2367+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2360− ni 0 env (PDisamb _ tm) = ni 0 env tm

2368+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2361− ni 0 env (PNoImplicits tm) = ni 0 env tm

2369+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2362

2370

2363 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

2371 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

2364 maybe (return ()) (ni i env) ty

2372 maybe (return ()) (ni i env) ty

2365 ni i env (PUnquote tm) = ni (i - 1) env tm

2373 ni i env (PUnquote tm) = ni (i - 1) env tm

2366

2374

2367− ni i env tm = mapM_ (ni i env) (children tm)

2375+ ni i env tm = mapM_ (ni i env) (children tm)

2368

2376

2369-- Return names which are free in the given term.

2377-- Return names which are free in the given term.

2370namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

2378namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

@@ -2373,32 +2381,32 @@ namesIn uvars ist tm = nub $ ni 0 [] tm

2373 ni 0 env (PRef _ _ n)

2381 ni 0 env (PRef _ _ n)

2374 | not (n `elem` env)

2382 | not (n `elem` env)

2375 = case lookupTy n (tt_ctxt ist) of

2383 = case lookupTy n (tt_ctxt ist) of

2376− [] -> [n]

2384+ [] -> [n]

2377− _ -> if n `elem` (map fst uvars) then [n] else []

2385+ _ -> [n | n `elem` (map fst uvars)]

2378− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2386+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2379− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2387+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2380− ni 0 env (PCase _ c os) = ni 0 env c ++

2388+ ni 0 env (PCase _ c os) = ni 0 env c ++

2381 -- names in 'os', not counting the names bound in the cases

2389 -- names in 'os', not counting the names bound in the cases

2382− (nub (concatMap (ni 0 env) (map snd os))

2390+ (nub (concatMap (ni 0 env . snd) os)

2383− \\ nub (concatMap (ni 0 env) (map fst os)))

2391+ \\ nub (concatMap (ni 0 env . fst) os))

2384− ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2392+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2385 ni 0 env (PLam fc n nfc ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2393 ni 0 env (PLam fc n nfc ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2386− ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2394+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2387− ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2395+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2388− ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2396+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2389− ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2397+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2390 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2398 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2391− ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2399+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2392 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2400 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2393− ni 0 env (PHidden tm) = ni 0 env tm

2401+ ni 0 env (PHidden tm) = ni 0 env tm

2394− ni 0 env (PUnifyLog tm) = ni 0 env tm

2402+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2395− ni 0 env (PDisamb _ tm) = ni 0 env tm

2403+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2396− ni 0 env (PNoImplicits tm) = ni 0 env tm

2404+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2397

2405

2398− ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2406+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2399− ni i env (PUnquote tm) = ni (i - 1) env tm

2407+ ni i env (PUnquote tm) = ni (i - 1) env tm

2400

2408

2401− ni i env tm = concatMap (ni i env) (children tm)

2409+ ni i env tm = concatMap (ni i env) (children tm)

2402

2410

2403 niTacImp i env (TacImp _ _ scr) = ni i env scr

2411 niTacImp i env (TacImp _ _ scr) = ni i env scr

2404 niTacImp _ _ _ = []

2412 niTacImp _ _ _ = []

@@ -2413,27 +2421,27 @@ usedNamesIn vars ist tm = nub $ ni 0 [] tm

2413 = case lookupDefExact n (tt_ctxt ist) of

2421 = case lookupDefExact n (tt_ctxt ist) of

2414 Nothing -> [n]

2422 Nothing -> [n]

2415 _ -> []

2423 _ -> []

2416− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2424+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2417− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2425+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2418− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2426+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2419− ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2427+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2420− ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2428+ ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2421− ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2429+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2422− ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2430+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2423− ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2431+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2424− ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2432+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2425 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2433 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2426− ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2434+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2427 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2435 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2428− ni 0 env (PHidden tm) = ni 0 env tm

2436+ ni 0 env (PHidden tm) = ni 0 env tm

2429− ni 0 env (PUnifyLog tm) = ni 0 env tm

2437+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2430− ni 0 env (PDisamb _ tm) = ni 0 env tm

2438+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2431− ni 0 env (PNoImplicits tm) = ni 0 env tm

2439+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2432

2440

2433− ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2441+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2434− ni i env (PUnquote tm) = ni (i - 1) env tm

2442+ ni i env (PUnquote tm) = ni (i - 1) env tm

2435

2443

2436− ni i env tm = concatMap (ni i env) (children tm)

2444+ ni i env tm = concatMap (ni i env) (children tm)

2437

2445

2438 niTacImp i env (TacImp _ _ scr) = ni i env scr

2446 niTacImp i env (TacImp _ _ scr) = ni i env scr

2439 niTacImp _ _ _ = []

2447 niTacImp _ _ _ = []

src/Idris/CaseSplit.hs+3−2

@@ -77,7 +77,7 @@ split n t'

77 logElab 1 ("New patterns " ++ showSep ", "

78 (map showTmImpls splits))

79 let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)

80− logElab 4 ("Working from " ++ show t)

80+ logElab 4 ("Working from " ++ showTmImpls t)

81 logElab 4 ("Trying " ++ showSep "\n"

82 (map (showTmImpls) newPats_in))

83 newPats_in <- mapM elabNewPat newPats_in

@@ -227,7 +227,8 @@ elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t

227 i <- getIState

228 return (True, delab i tm))

229 (\e -> do i <- getIState

230− logElab 5 $ "Not a valid split:\n" ++ pshow i e

230+ logElab 5 $ "Not a valid split:\n" ++ showTmImpls t ++ "\n"

231+ ++ pshow i e

231 return (False, t))

232 return (False, t))

232

233

233findPats :: IState -> Type -> [PTerm]

234findPats :: IState -> Type -> [PTerm]

src/Idris/Colours.hs+6−6

@@ -47,9 +47,9 @@ defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True

47mkSGR :: IdrisColour -> [SGR]

48mkSGR (IdrisColour c v u b i) =

49 fg c ++

50− (if u then [SetUnderlining SingleUnderline] else []) ++

50+ [SetUnderlining SingleUnderline | u] ++

51− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

51+ [SetConsoleIntensity BoldIntensity | b] ++

52− (if i then [SetItalicized True] else [])

52+ [SetItalicized True | i]

53 where

54 fg Nothing = []

55 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

@@ -71,9 +71,9 @@ hEndColourise h _ = hSetSGR h [Reset]

71colouriseWithSTX :: IdrisColour -> String -> String

72colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"

73 where sgr = fg c ++

74− (if u then [SetUnderlining SingleUnderline] else []) ++

74+ [SetUnderlining SingleUnderline | u] ++

75− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

75+ [SetConsoleIntensity BoldIntensity | b] ++

76− (if i then [SetItalicized True] else [])

76+ [SetItalicized True | i]

77 fg Nothing = []

78 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

79

src/Idris/Completion.hs+6−6

@@ -9,10 +9,10 @@ import Idris.AbsSyntaxTree

9import Idris.Help

10import Idris.Imports (installedPackages)

11import Idris.Colours

12−import Idris.ParseHelpers(opChars)

12+import Idris.Parser.Helpers(opChars)

13−import qualified Idris.ParseExpr (constants, tactics)

13+import qualified Idris.Parser.Expr (constants, tactics)

14−import Idris.ParseExpr (TacticArg (..))

14+import Idris.Parser.Expr (TacticArg (..))

15−import Idris.REPLParser (allHelp, setOptions)

15+import Idris.REPL.Parser (allHelp, setOptions)

16import Control.Monad.State.Strict

17

18import Data.List

@@ -26,7 +26,7 @@ import System.Console.ANSI (Color)

26commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ]

27

28tacticArgs :: [(String, Maybe TacticArg)]

29−tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics

29+tacticArgs = [ (name, args) | (names, args, _) <- Idris.Parser.Expr.tactics

30 , name <- names ]

31tactics = map fst tacticArgs

32

@@ -48,7 +48,7 @@ names = do i <- get

48 let ctxt = tt_ctxt i

49 return . nub $

50 mapMaybe (nameString . fst) (ctxtAlist ctxt) ++

51− "Type" : map fst Idris.ParseExpr.constants

51+ "Type" : map fst Idris.Parser.Expr.constants

52

53metavars :: Idris [String]

54metavars = do i <- get

src/Idris/Core/CaseTree.hs+2−2

@@ -152,10 +152,10 @@ findCalls sc topargs = nub $ nu' topargs sc where

152 nua ps (SucCase _ sc) = nu' ps sc

153 nua ps (DefaultCase sc) = nu' ps sc

154

155− nut ps (P Ref n _) | n `elem` ps = []

155+ nut ps (P _ n _) | n `elem` ps = []

156 | otherwise = [(n, [])] -- tmp

157 nut ps fn@(App _ f a)

158− | (P Ref n _, args) <- unApply fn

158+ | (P _ n _, args) <- unApply fn

159 = if n `elem` ps then nut ps f ++ nut ps a

160 else [(n, map argNames args)] ++ concatMap (nut ps) args

161 | (P (TCon _ _) n _, _) <- unApply fn = []

src/Idris/Core/Evaluate.hs+13−10

@@ -12,7 +12,7 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,

12 addDatatype, addCasedef, simplifyCasedef, addOperator,

13 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,

14 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,

15− mapDefCtxt,

15+ mapDefCtxt,

16 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

17 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,

18 isUniverse) where

@@ -247,18 +247,16 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

247 | otherwise

248 = do (u, ntimes) <- usable spec n ntimes_in

249 if u then

250− do let val = lookupDefAcc n (spec || atRepl) ctxt

250+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

251 case val of

252 [(Function _ tm, _)] | sUN "assert_total" `elem` stk ->

253 ev ntimes (n:stk) True env tm

254 [(Function _ tm, Public)] ->

255 ev ntimes (n:stk) True env tm

256− [(Function _ tm, Hidden)] ->

257− ev ntimes (n:stk) True env tm

258 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

256 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

259 return $ VP nt n vty

257 return $ VP nt n vty

260 [(CaseOp ci _ _ _ _ cd, acc)]

258 [(CaseOp ci _ _ _ _ cd, acc)]

261− | (acc /= Frozen || sUN "assert_total" `elem` stk) &&

259+ | (acc == Public || sUN "assert_total" `elem` stk) &&

262 null (fst (cases_totcheck cd)) -> -- unoptimised version

260 null (fst (cases_totcheck cd)) -> -- unoptimised version

263 let (ns, tree) = getCases cd in

261 let (ns, tree) = getCases cd in

264 if blockSimplify ci n stk

262 if blockSimplify ci n stk

@@ -319,7 +317,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

319 evApply ntimes' stk top env [l',t',arg'] d'

317 evApply ntimes' stk top env [l',t',arg'] d'

320 -- Treat "assert_total" specially, as long as it's defined!

318 -- Treat "assert_total" specially, as long as it's defined!

321 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)

319 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)

322− | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

320+ | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl || runtime) ctxt,

323 at == txt "assert_total" && not simpl

321 at == txt "assert_total" && not simpl

324 = ev ntimes (n : stk) top env arg

322 = ev ntimes (n : stk) top env arg

325 ev ntimes stk top env (App _ f a)

323 ev ntimes stk top env (App _ f a)

@@ -347,7 +345,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

347 = apply ntimes stk top env f args

345 = apply ntimes stk top env f args

348

346

349 reapply ntimes stk top env f@(VP Ref n ty) args

347 reapply ntimes stk top env f@(VP Ref n ty) args

350− = let val = lookupDefAcc n (spec || atRepl) ctxt in

348+ = let val = lookupDefAcc n (spec || atRepl || runtime) ctxt in

351 case val of

349 case val of

352 [(CaseOp ci _ _ _ _ cd, acc)] ->

350 [(CaseOp ci _ _ _ _ cd, acc)] ->

353 let (ns, tree) = getCases cd in

351 let (ns, tree) = getCases cd in

@@ -373,10 +371,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

373 | otherwise

371 | otherwise

374 = do (u, ntimes) <- usable spec n ntimes_in

372 = do (u, ntimes) <- usable spec n ntimes_in

375 if u then

373 if u then

376− do let val = lookupDefAcc n (spec || atRepl) ctxt

374+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

377 case val of

375 case val of

378 [(CaseOp ci _ _ _ _ cd, acc)]

376 [(CaseOp ci _ _ _ _ cd, acc)]

379− | acc /= Frozen || sUN "assert_total" `elem` stk ->

377+ | acc == Public || sUN "assert_total" `elem` stk ->

380 -- unoptimised version

378 -- unoptimised version

381 let (ns, tree) = getCases cd in

379 let (ns, tree) = getCases cd in

382 if blockSimplify ci n stk

380 if blockSimplify ci n stk

@@ -746,11 +744,16 @@ instance Show Def where

746-- Hidden => doesn't reduce and invisible to type checker

744-- Hidden => doesn't reduce and invisible to type checker

747

745

748data Accessibility = Public | Frozen | Hidden

746data Accessibility = Public | Frozen | Hidden

749− deriving (Show, Eq)

747+ deriving (Eq, Ord)

750{-!

748{-!

751deriving instance NFData Accessibility

749deriving instance NFData Accessibility

752!-}

750!-}

753

751

752+instance Show Accessibility where

753+ show Public = "public export"

754+ show Frozen = "export"

755+ show Hidden = "private"

756+

754-- | The result of totality checking

757-- | The result of totality checking

755data Totality = Total [Int] -- ^ well-founded arguments

758data Totality = Total [Int] -- ^ well-founded arguments

756 | Productive -- ^ productive

759 | Productive -- ^ productive

src/Idris/Core/ProofState.hs+10−1

@@ -206,6 +206,14 @@ mergeSolutions env ns = merge [] ns

206 merge acc ns

207 | otherwise = merge ((n, t): acc) ns

208

209+dropSwaps :: [(Name, TT Name)] -> [(Name, TT Name)]

210+dropSwaps [] = []

211+dropSwaps (p@(x, P _ y _) : xs) | solvedIn y x xs = dropSwaps xs

212+ where solvedIn _ _ [] = False

213+ solvedIn y x ((y', P _ x' _) : xs) | y == y' && x == x' = True

214+ solvedIn y x (_ : xs) = solvedIn y x xs

215+dropSwaps (p : xs) = p : dropSwaps xs

216+

209unify' :: Context -> Env ->

217unify' :: Context -> Env ->

210 (TT Name, Maybe Provenance) ->

218 (TT Name, Maybe Provenance) ->

211 (TT Name, Maybe Provenance) ->

219 (TT Name, Maybe Provenance) ->

@@ -242,7 +250,8 @@ unify' ctxt env (topx, xfrom) (topy, yfrom) =

242 -- problem for each.

250 -- problem for each.

243 uns <- mergeSolutions env (u' ++ ns)

251 uns <- mergeSolutions env (u' ++ ns)

244 ps <- get

252 ps <- get

245− let (ns', probs') = updateProblems ps uns (fails ++ problems ps)

253+ let (ns_p, probs') = updateProblems ps uns (fails ++ problems ps)

254+ let ns' = dropSwaps ns_p

246 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

255 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

247 traceWhen (unifylog ps)

256 traceWhen (unifylog ps)

248 ("Now solved: " ++ show ns' ++

257 ("Now solved: " ++ show ns' ++

src/Idris/Core/TT.hs+1−1

@@ -588,7 +588,7 @@ tcname (SN (MethodN _)) = True

588tcname (SN (ParentN _ _)) = True

589tcname _ = False

590

591−implicitable (NS n _) = implicitable n

591+implicitable (NS n _) = False

592implicitable (UN xs) | T.null xs = False

593 | otherwise = isLower (T.head xs) || T.head xs == '_'

594implicitable (MN _ x) = not (tnull x) && thead x /= '_'

src/Idris/Coverage.hs+3−1

@@ -135,6 +135,7 @@ validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

135 = case (unApply topx, unApply topy) of

136 ((P _ x _, _), (P _ y _, _)) -> x == y

137 _ -> False

138+validCoverageCase ctxt (InfiniteUnify _ _ _) = False

138validCoverageCase ctxt (CantConvert _ _ _) = False

139validCoverageCase ctxt (CantConvert _ _ _) = False

139validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

141validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

@@ -313,7 +314,7 @@ checkAllCovering fc done top n | not (n `elem` done)

313 [Partial _] ->

314 [Partial _] ->

314 case lookupCtxt n (idris_callgraph i) of

315 case lookupCtxt n (idris_callgraph i) of

315 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

316 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

316− (map fst (calls cg))

317+ (calls cg)

317 _ -> return ()

318 _ -> return ()

318 x -> return () -- stop if total

319 x -> return () -- stop if total

319checkAllCovering _ _ _ _ = return ()

320checkAllCovering _ _ _ _ = return ()

@@ -474,6 +475,7 @@ buildSCG (_, n) = do

474 let newscg = buildSCG' ist (rights pats) args

475 let newscg = buildSCG' ist (rights pats) args

475 logCoverage 5 $ "SCG is: " ++ show newscg

476 logCoverage 5 $ "SCG is: " ++ show newscg

476 addToCG n ( cg { scg = newscg } )

477 addToCG n ( cg { scg = newscg } )

478+ _ -> return () -- CG comes from a type declaration only

477 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

479 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

478 x -> error $ "buildSCG: " ++ show (n, x)

480 x -> error $ "buildSCG: " ++ show (n, x)

479

481

src/Idris/DeepSeq.hs+9−7

@@ -199,7 +199,8 @@ instance NFData IOption where

199 opt_optimise

200 opt_printdepth

201 opt_evaltypes

202− opt_desugarnats) =

202+ opt_desugarnats

203+ opt_autoimpls) =

203 rnf opt_logLevel

204 rnf opt_logLevel

204 `seq` rnf opt_typecase

205 `seq` rnf opt_typecase

205 `seq` rnf opt_typeintype

206 `seq` rnf opt_typeintype

@@ -224,6 +225,7 @@ instance NFData IOption where

224 `seq` rnf opt_printdepth

225 `seq` rnf opt_printdepth

225 `seq` rnf opt_evaltypes

226 `seq` rnf opt_evaltypes

226 `seq` rnf opt_desugarnats

227 `seq` rnf opt_desugarnats

228+ `seq` rnf opt_autoimpls

227 `seq` ()

229 `seq` ()

228

230

229instance NFData LanguageExt where

231instance NFData LanguageExt where

@@ -365,9 +367,9 @@ instance NFData LogCat where

365 rnf _ = ()

367 rnf _ = ()

366

368

367instance NFData CGInfo where

369instance NFData CGInfo where

368− rnf (CGInfo x1 x2 x3 x4 x5)

370+ rnf (CGInfo x1 x2 x3)

369 = rnf x1 `seq`

371 = rnf x1 `seq`

370− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

372+ rnf x2 `seq` rnf x3 `seq` ()

371

373

372instance NFData Fixity where

374instance NFData Fixity where

373 rnf (Infixl x1) = rnf x1 `seq` ()

375 rnf (Infixl x1) = rnf x1 `seq` ()

@@ -466,7 +468,7 @@ instance (NFData t) => NFData (PDecl' t) where

466 rnf x9 `seq`

468 rnf x9 `seq`

467 rnf x10 `seq`

469 rnf x10 `seq`

468 rnf x11 `seq` rnf x12 `seq` ()

470 rnf x11 `seq` rnf x12 `seq` ()

469− rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

471+ rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

470 = rnf x1 `seq`

472 = rnf x1 `seq`

471 rnf x2 `seq`

473 rnf x2 `seq`

472 rnf x3 `seq`

474 rnf x3 `seq`

@@ -475,7 +477,7 @@ instance (NFData t) => NFData (PDecl' t) where

475 rnf x6 `seq`

477 rnf x6 `seq`

476 rnf x7 `seq`

478 rnf x7 `seq`

477 rnf x8 `seq`

479 rnf x8 `seq`

478− rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

480+ rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` ()

479 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

481 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

480 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

482 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

481 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

483 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -696,8 +698,8 @@ instance NFData IState where

696 rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

698 rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

697 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

699 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

698 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

700 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

699− x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74)

701+ x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75)

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`

702 = 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`

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`

703 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`

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`

704 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`

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` ()

705+ 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` rnf x75 `seq` ()

src/Idris/Delaborate.hs+1−1

@@ -317,7 +317,7 @@ pprintErr' i (CantConvert x_in y_in env) =

317 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)

318 flagUnique t = t

319pprintErr' i (CantSolveGoal x env) =

320− text "Can't solve goal " <>

320+ text "Can't find a value of type " <>

321 indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delabSugared i x))) <>

322 if (opt_errContext (idris_options i)) then line <> showSc i env else empty

323pprintErr' i (UnifyScope n out tm env) =

src/Idris/Directives.hs+6−2

@@ -21,8 +21,10 @@ directiveAction (DLink cgn obj) = do dirs <- allImportDirs

21 addIBC (IBCObj cgn obj) -- just name, search on loading ibc

22 addObjectFile cgn o

23

24−directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)

24+directiveAction (DFlag cgn flag) = do

25+ let flags = words flag

26+ mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags

25− addFlag cgn flag

27+ mapM_ (addFlag cgn) flags

26

28

27directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

29directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

28 addIBC (IBCHeader cgn hdr)

30 addIBC (IBCHeader cgn hdr)

@@ -68,6 +70,8 @@ directiveAction (DDeprecate n reason)

68 = do n' <- disambiguate n

70 = do n' <- disambiguate n

69 addDeprecated n' reason

71 addDeprecated n' reason

70 addIBC (IBCDeprecate n' reason)

72 addIBC (IBCDeprecate n' reason)

73+directiveAction (DAutoImplicits b)

74+ = setAutoImpls b

71directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

75directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

72

76

73disambiguate :: Name -> Idris Name

77disambiguate :: Name -> Idris Name

src/Idris/Docs.hs+3−3

@@ -19,7 +19,7 @@ import Data.Maybe

19import Data.List

20import qualified Data.Text as T

21

22−-- TODO: Only include names with public/abstract accessibility

22+-- TODO: Only include names with public/export accessibility

23--

24-- Issue #1573 on the Issue tracker.

25-- https://github.com/idris-lang/Idris-dev/issues/1573

@@ -319,8 +319,8 @@ docClass n ci

319 namedInst n@(UN _) = Just n

320 namedInst _ = Nothing

321

322− getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t

322+ getDInst (PInstance _ _ _ _ _ _ _ _ _ t _ _) = Just t

323− getDInst _ = Nothing

323+ getDInst _ = Nothing

324

325 isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))

326 = nm == n && map getTm args == map getTm args'

src/Idris/Elab/Class.hs+2−2

@@ -138,7 +138,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

138

139 -- TODO: probably should normalise

140 checkDefaultSuperclassInstance :: PDecl -> Idris ()

141− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

141+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ n _ ps _ _ _)

142 = do when (not $ null cs) . tclift

143 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

144 i <- getIState

@@ -184,7 +184,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

184

185 tydecl (PTy _ _ _ _ _ _ _ _) = True

186 tydecl _ = False

187− instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

187+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = True

188 instdecl _ = False

189 clause (PClauses _ _ _ _) = True

190 clause _ = False

src/Idris/Elab/Clause.hs+32−18

@@ -80,10 +80,11 @@ elabClauses info' fc opts n_in cs =

80 let atys = map snd (getArgTys fty)

81 cs_elab <- mapM (elabClause info opts)

82 (zip [0..] cs)

83+ ctxt <- getContext

83 -- pats_raw is the version we'll work with at compile time:

84 -- pats_raw is the version we'll work with at compile time:

84 -- no simplification or PE

85 -- no simplification or PE

85 let (pats_in, cs_full) = unzip cs_elab

86 let (pats_in, cs_full) = unzip cs_elab

86− let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in

87+ let pats_raw = map (simple_lhs ctxt) pats_in

87 logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

88 logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

88

89

89 solveDeferred n

90 solveDeferred n

@@ -93,6 +94,7 @@ elabClauses info' fc opts n_in cs =

93 addIBC (IBCOpt n)

94 addIBC (IBCOpt n)

94

95

95 ist <- getIState

96 ist <- getIState

97+ ctxt <- getContext

96 -- Don't apply rules if this is a partial evaluation definition,

98 -- Don't apply rules if this is a partial evaluation definition,

97 -- or we'll make something that just runs itself!

99 -- or we'll make something that just runs itself!

98 let tpats = case specNames opts of

100 let tpats = case specNames opts of

@@ -103,7 +105,7 @@ elabClauses info' fc opts n_in cs =

103 -- RHS

105 -- RHS

104 pe_tm <- doPartialEval ist tpats

106 pe_tm <- doPartialEval ist tpats

105 let pats_pe = if petrans

107 let pats_pe = if petrans

106− then map (simple_lhs (tt_ctxt ist)) pe_tm

108+ then map (simple_lhs ctxt) pe_tm

107 else pats_raw

109 else pats_raw

108

110

109 let tcase = opt_typecase (idris_options ist)

111 let tcase = opt_typecase (idris_options ist)

@@ -183,7 +185,8 @@ elabClauses info' fc opts n_in cs =

183 -- pdef' is the version that gets compiled for run-time,

185 -- pdef' is the version that gets compiled for run-time,

184 -- so we start from the partially evaluated version

186 -- so we start from the partially evaluated version

185 pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe

187 pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe

188+ ctxt <- getContext

186− let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

189+ let pdef' = map (simple_rt ctxt) pdef_in'

187

190

188 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

191 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

189

192

@@ -241,24 +244,28 @@ elabClauses info' fc opts n_in cs =

241 ctxt

244 ctxt

242 setContext ctxt'

245 setContext ctxt'

243 addIBC (IBCDef n)

246 addIBC (IBCDef n)

247+ addDefinedName n

244 setTotality n tot

248 setTotality n tot

245 when (not reflect && PEGenerated `notElem` opts) $

249 when (not reflect && PEGenerated `notElem` opts) $

246 do totcheck (fc, n)

250 do totcheck (fc, n)

247 defer_totcheck (fc, n)

251 defer_totcheck (fc, n)

248 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

252 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

249 i <- getIState

253 i <- getIState

254+ ctxt <- getContext

250− case lookupDef n (tt_ctxt i) of

255+ case lookupDef n ctxt of

251 (CaseOp _ _ _ _ _ cd : _) ->

256 (CaseOp _ _ _ _ _ cd : _) ->

252− let (scargs, sc) = cases_compiletime cd

257+ let (scargs, sc) = cases_compiletime cd in

253− (scargs', sc') = cases_runtime cd in

254− do let calls = findCalls sc' scargs'

258+ do let calls = map fst $ findCalls sc scargs

255− let used = findUsedArgs sc' scargs'

256 -- let scg = buildSCG i sc scargs

259 -- let scg = buildSCG i sc scargs

257 -- add SCG later, when checking totality

260 -- add SCG later, when checking totality

258− let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

259− logElab 2 $ "Called names: " ++ show cg

261+ logElab 2 $ "Called names: " ++ show calls

260− addToCG n cg

262+ -- if the definition is public, make sure

261− addToCalledG n (nub (map fst calls)) -- plus names in type!

263+ -- it only uses public names

264+ nvis <- getFromHideList n

265+ case nvis of

266+ Just Public -> mapM_ (checkVisibility fc n Public Public) calls

267+ _ -> return ()

268+ addCalls n calls

262 addIBC (IBCCG n)

269 addIBC (IBCCG n)

263 _ -> return ()

270 _ -> return ()

264 return ()

271 return ()

@@ -353,11 +360,12 @@ elabPE info fc caller r =

353 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

360 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

354 mkSpecialised specapp_in = do

361 mkSpecialised specapp_in = do

355 ist <- getIState

362 ist <- getIState

363+ ctxt <- getContext

356 let (specTy, specapp) = getSpecTy ist specapp_in

364 let (specTy, specapp) = getSpecTy ist specapp_in

357 let (n, newnm, specdecl) = getSpecClause ist specapp

365 let (n, newnm, specdecl) = getSpecClause ist specapp

358 let lhs = pe_app specdecl

366 let lhs = pe_app specdecl

359 let rhs = pe_def specdecl

367 let rhs = pe_def specdecl

360− let undef = case lookupDefExact newnm (tt_ctxt ist) of

368+ let undef = case lookupDefExact newnm ctxt of

361 Nothing -> True

369 Nothing -> True

362 _ -> False

370 _ -> False

363 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

371 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

@@ -370,7 +378,7 @@ elabPE info fc caller r =

370 let cgns' = filter (\x -> x /= n &&

378 let cgns' = filter (\x -> x /= n &&

371 notStatic ist x) cgns

379 notStatic ist x) cgns

372 -- set small reduction limit on partial/productive things

380 -- set small reduction limit on partial/productive things

373− let maxred = case lookupTotal n (tt_ctxt ist) of

381+ let maxred = case lookupTotal n ctxt of

374 [Total _] -> 65536

382 [Total _] -> 65536

375 [Productive] -> 16

383 [Productive] -> 16

376 _ -> 1

384 _ -> 1

@@ -485,7 +493,7 @@ checkPossible info fc tcgen fname lhs_in

485 processTacticDecls info newDecls

493 processTacticDecls info newDecls

486 sendHighlighting highlights

494 sendHighlighting highlights

487 let lhs_tm = orderPats (getInferTerm lhs')

495 let lhs_tm = orderPats (getInferTerm lhs')

488− case recheck ctxt [] (forget lhs_tm) lhs_tm of

496+ case recheck ctxt' [] (forget lhs_tm) lhs_tm of

489 OK _ -> return True

497 OK _ -> return True

490 err -> return False

498 err -> return False

491 -- if it's a recoverable error, the case may become possible

499 -- if it's a recoverable error, the case may become possible

@@ -558,7 +566,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

558 (Msg "unexpected patterns outside of \"with\" block")))

566 (Msg "unexpected patterns outside of \"with\" block")))

559

567

560 -- get the parameters first, to pass through to any where block

568 -- get the parameters first, to pass through to any where block

561− let fn_ty = case lookupTy fname (tt_ctxt i) of

569+ let fn_ty = case lookupTy fname ctxt of

562 [t] -> t

570 [t] -> t

563 _ -> error "Can't happen (elabClause function type)"

571 _ -> error "Can't happen (elabClause function type)"

564 let fn_is = case lookupCtxt fname (idris_implicits i) of

572 let fn_is = case lookupCtxt fname (idris_implicits i) of

@@ -602,6 +610,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

602

610

603 -- If we're inferring metavariables in the type, don't recheck,

611 -- If we're inferring metavariables in the type, don't recheck,

604 -- because we're only doing this to try to work out those metavariables

612 -- because we're only doing this to try to work out those metavariables

613+ ctxt <- getContext

605 (clhs_c, clhsty) <- if not inf

614 (clhs_c, clhsty) <- if not inf

606 then recheckC_borrowing False (PEGenerated `notElem` opts)

615 then recheckC_borrowing False (PEGenerated `notElem` opts)

607 [] fc id [] lhs_tm

616 [] fc id [] lhs_tm

@@ -627,6 +636,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

627 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

636 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

628 -- Elaborate where block

637 -- Elaborate where block

629 ist <- getIState

638 ist <- getIState

639+ ctxt <- getContext

640+

630 windex <- getName

641 windex <- getName

631 let decls = nub (concatMap declared whereblock)

642 let decls = nub (concatMap declared whereblock)

632 let defs = nub (decls ++ concatMap defined whereblock)

643 let defs = nub (decls ++ concatMap defined whereblock)

@@ -635,7 +646,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

635 -- Unique arguments must be passed to the where block explicitly

646 -- Unique arguments must be passed to the where block explicitly

636 -- (since we can't control "usage" easlily otherwise). Remove them

647 -- (since we can't control "usage" easlily otherwise). Remove them

637 -- from newargs here

648 -- from newargs here

638− let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm

649+ let uniqargs = findUnique ctxt [] lhs_tm

639 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

650 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

640

651

641 let winfo = (pinfo info newargs defs windex) { elabFC = Just fc }

652 let winfo = (pinfo info newargs defs windex) { elabFC = Just fc }

@@ -798,7 +809,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

798 -- pattern bindings

809 -- pattern bindings

799 i <- getIState

810 i <- getIState

800 -- get the parameters first, to pass through to any where block

811 -- get the parameters first, to pass through to any where block

801− let fn_ty = case lookupTy fname (tt_ctxt i) of

812+ let fn_ty = case lookupTy fname ctxt of

802 [t] -> t

813 [t] -> t

803 _ -> error "Can't happen (elabClause function type)"

814 _ -> error "Can't happen (elabClause function type)"

804 let fn_is = case lookupCtxt fname (idris_implicits i) of

815 let fn_is = case lookupCtxt fname (idris_implicits i) of

@@ -819,6 +830,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

819 processTacticDecls info newDecls

830 processTacticDecls info newDecls

820 sendHighlighting highlights

831 sendHighlighting highlights

821

832

833+ ctxt <- getContext

822 let lhs_tm = orderPats (getInferTerm lhs')

834 let lhs_tm = orderPats (getInferTerm lhs')

823 let lhs_ty = getInferType lhs'

835 let lhs_ty = getInferType lhs'

824 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

836 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

@@ -852,6 +864,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

852 addDeferred def''

864 addDeferred def''

853 mapM_ (elabCaseBlock info opts) is

865 mapM_ (elabCaseBlock info opts) is

854 logElab 5 ("Checked wval " ++ show wval')

866 logElab 5 ("Checked wval " ++ show wval')

867+

868+ ctxt <- getContext

855 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

869 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

856 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

870 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

857 let cwvalN = explicitNames (normalise ctxt [] cwval)

871 let cwvalN = explicitNames (normalise ctxt [] cwval)

src/Idris/Elab/Instance.hs+8−4

@@ -55,13 +55,14 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

55 [(Name, Docstring (Either Err PTerm))] ->

56 ElabWhat -> -- phase

57 FC -> [(Name, PTerm)] -> -- constraints

58+ Accessibility ->

58 Name -> -- the class

59 Name -> -- the class

59 FC -> -- precise location of class name

60 FC -> -- precise location of class name

60 [PTerm] -> -- class parameters (i.e. instance)

61 [PTerm] -> -- class parameters (i.e. instance)

61 PTerm -> -- full instance type

62 PTerm -> -- full instance type

62 Maybe Name -> -- explicit name

63 Maybe Name -> -- explicit name

63 [PDecl] -> Idris ()

64 [PDecl] -> Idris ()

64−elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

65+elabInstance info syn doc argDocs what fc cs acc n nfc ps t expn ds = do

65 i <- getIState

66 i <- getIState

66 (n, ci) <- case lookupCtxtName n (idris_classes i) of

67 (n, ci) <- case lookupCtxtName n (idris_classes i) of

67 [c] -> return c

68 [c] -> return c

@@ -70,6 +71,9 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

70 (CantResolveAlts (map fst cs))

71 (CantResolveAlts (map fst cs))

71 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

72 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

72 let iname = mkiname n (namespace info) ps expn

73 let iname = mkiname n (namespace info) ps expn

74+ putIState (i { hide_list = addDef iname acc (hide_list i) })

75+ i <- getIState

76+

73 let emptyclass = null (class_methods ci)

77 let emptyclass = null (class_methods ci)

74 when (what /= EDefns) $ do

78 when (what /= EDefns) $ do

75 nty <- elabType' True info syn doc argDocs fc [] iname NoFC t

79 nty <- elabType' True info syn doc argDocs fc [] iname NoFC t

@@ -159,10 +163,10 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

159 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

163 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

160 Just nm -> nm

164 Just nm -> nm

161

165

162− substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)

166+ substInstance ips pnames (PInstance doc argDocs syn _ cs acc n nfc ps t expn ds)

163− = PInstance doc argDocs syn fc cs n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

167+ = PInstance doc argDocs syn fc cs acc n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

164

168

165− isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

169+ isOverlapping i (PInstance doc argDocs syn _ _ _ n nfc ps t expn _)

166 = case lookupCtxtName n (idris_classes i) of

170 = case lookupCtxtName n (idris_classes i) of

167 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

171 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

168 case lookupTy iname (tt_ctxt i) of

172 case lookupTy iname (tt_ctxt i) of

src/Idris/ElabQuasiquote.hs → src/Idris/Elab/Quasiquote.hsrenamed+1−3

@@ -1,4 +1,4 @@

1−module Idris.ElabQuasiquote (extractUnquotes) where

1+module Idris.Elab.Quasiquote (extractUnquotes) where

2

3import Idris.Core.Elaborate hiding (Tactic(..))

4import Idris.Core.TT

@@ -171,5 +171,3 @@ extractUnquotes n (PRunElab fc tm ns)

171extractUnquotes n (PConstSugar fc tm)

172 = extractUnquotes n tm

173extractUnquotes n x = return (x, []) -- no subterms!

174−

175−

src/Idris/Elab/Record.hs+1−1

@@ -17,7 +17,7 @@ import Idris.DeepSeq

17import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

18import IRTS.Lang

19

20−import Idris.ParseExpr (tryFullExpr)

20+import Idris.Parser.Expr (tryFullExpr)

21

22import Idris.Elab.Type

23import Idris.Elab.Data

src/Idris/Elab/Term.hs+10−10

@@ -20,7 +20,7 @@ import Idris.Core.Typecheck (check, recheck, converts, isType)

20import Idris.Core.WHNF (whnf)

21import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)

22import Idris.ErrReverse (errReverse)

23−import Idris.ElabQuasiquote (extractUnquotes)

23+import Idris.Elab.Quasiquote (extractUnquotes)

24import Idris.Elab.Utils

25import Idris.Reflection

26import qualified Util.Pretty as U

@@ -236,6 +236,7 @@ elab ist info emode opts fn tm

236 pattern = emode == ELHS

237 intransform = emode == ETransLHS

238 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS

239+ autoimpls = opt_autoimpls (idris_options ist)

239

240

240 get_delayed_elab est =

241 get_delayed_elab est =

241 let ds = delayed_elab est in

242 let ds = delayed_elab est in

@@ -614,7 +615,8 @@ elab ist info emode opts fn tm

614 [] -> False

615 [] -> False

615 _ -> True

616 _ -> True

616 bindable (NS _ _) = False

617 bindable (NS _ _) = False

618+ bindable (MN _ _) = True

617− bindable n = implicitable n

619+ bindable n = implicitable n && autoimpls

618 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

620 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

619 elab' ina fc' tm@(PRef fc hls n)

621 elab' ina fc' tm@(PRef fc hls n)

620 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

622 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

@@ -2476,8 +2478,10 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2476 OK hs -> return hs

2478 OK hs -> return hs

2477

2479

2478 -- Normalize error handler terms to produce the new messages

2480 -- Normalize error handler terms to produce the new messages

2481+ -- Need to use 'normaliseAll' since we have to reduce private

2482+ -- names in error handlers too

2479 ctxt <- getContext

2483 ctxt <- getContext

2480− let results = map (normalise ctxt []) (map fst handlers)

2484+ let results = map (normaliseAll ctxt []) (map fst handlers)

2481 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2485 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2482

2486

2483 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

2487 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

@@ -2549,13 +2553,9 @@ processTacticDecls info steps =

2549 -- we refer to, so that if they aren't total, the whole

2553 -- we refer to, so that if they aren't total, the whole

2550 -- thing won't be.

2554 -- thing won't be.

2551 let (scargs, sc) = cases_compiletime cd

2555 let (scargs, sc) = cases_compiletime cd

2552− (scargs', sc') = cases_runtime cd

2553− calls = findCalls sc' scargs

2556+ calls = map fst $ findCalls sc scargs

2554− used = findUsedArgs sc' scargs'

2555− cg = CGInfo scargs' calls [] used []

2556− in do logElab 2 $ "Called names in reflected elab: " ++ show cg

2557+ in do logElab 2 $ "Called names in reflected elab: " ++ show calls

2557− addToCG n cg

2558+ addCalls n calls

2558− addToCalledG n (nub (map fst calls))

2559 addIBC $ IBCCG n

2560 Just _ -> return () -- TODO throw internal error

2561 Nothing -> return ()

src/Idris/Elab/Type.hs+13

@@ -102,6 +102,18 @@ buildType info syn fc opts n ty' = do

102 logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103 addIBC (IBCImp n)

104

105+ -- Add the names referenced to the call graph, and check we're not

106+ -- referring to anything less visible

107+ -- In particular, a public/export type can not refer to anything

108+ -- private, but can refer to any public/export

109+ let refs = freeNames cty

110+ nvis <- getFromHideList n

111+ case nvis of

112+ Nothing -> return ()

113+ Just acc -> mapM_ (checkVisibility fc n (max Frozen acc) acc) refs

114+ addCalls n refs

115+ addIBC (IBCCG n)

116+

105 when (Constructor `notElem` opts) $ do

117 when (Constructor `notElem` opts) $ do

106 let pnames = getParamsInType i [] impls cty

118 let pnames = getParamsInType i [] impls cty

107 let fninfo = FnInfo (param_pos 0 pnames cty)

119 let fninfo = FnInfo (param_pos 0 pnames cty)

@@ -163,6 +175,7 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

163 let usety = if norm then nty' else nty

175 let usety = if norm then nty' else nty

164 ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

176 ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

165 addIBC (IBCDef n)

177 addIBC (IBCDef n)

178+ addDefinedName n

166 let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True))) ds

179 let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True))) ds

167 addDeferred ds'

180 addDeferred ds'

168 setFlags n opts'

181 setFlags n opts'

src/Idris/Elab/Utils.hs+16

@@ -314,3 +314,19 @@ mkStaticTy ns (PPi p n fc ty sc)

314 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

315 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

316mkStaticTy ns t = t

317+

318+-- Check that a name has the minimum required accessibility

319+checkVisibility :: FC -> Name -> Accessibility -> Accessibility -> Name -> Idris ()

320+checkVisibility fc n minAcc acc ref

321+ = do nvis <- getFromHideList ref

322+ case nvis of

323+ Nothing -> return ()

324+ Just acc' -> if acc' > minAcc

325+ then tclift $ tfail (At fc

326+ (Msg $ show acc ++ " " ++ show n ++

327+ " can't refer to " ++

328+ show acc' ++ " " ++ show ref))

329+ else return ()

330+

331+

332+

src/Idris/ElabDecls.hs+2−2

@@ -242,9 +242,9 @@ elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)

242 | what /= EDefns

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

245−elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)

245+elabDecl' what info (PInstance doc argDocs s f cs acc n nfc ps t expn ds)

246 = do logElab 1 $ "Elaborating instance " ++ show n

247− elabInstance info s doc argDocs what f cs n nfc ps t expn ds

247+ elabInstance info s doc argDocs what f cs acc n nfc ps t expn ds

248elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)

249 = do logElab 1 $ "Elaborating record " ++ show name

250 elabRecord info what doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn

src/Idris/IBC.hs+88−62

@@ -3,7 +3,7 @@

3

4module Idris.IBC (loadIBC, loadPkgIndex,

5 writeIBC, writePkgIndex,

6− hasValidIBCVersion) where

6+ hasValidIBCVersion, IBCPhase(..)) where

7

8import Idris.Core.Evaluate

9import Idris.Core.TT

@@ -40,10 +40,18 @@ import System.Directory

40import Codec.Archive.Zip

41

42ibcVersion :: Word16

43−ibcVersion = 128

43+ibcVersion = 132

44+

45+-- When IBC is being loaded - we'll load different things (and omit different

46+-- structures/definitions) depending on which phase we're in

47+data IBCPhase = IBC_Building -- ^ when building the module tree

48+ | IBC_REPL Bool -- ^ when loading modules for the REPL

49+ -- Bool = True for top level module

50+ deriving (Show, Eq)

44

51

45data IBCFile = IBCFile { ver :: Word16,

52data IBCFile = IBCFile { ver :: Word16,

46 sourcefile :: FilePath,

53 sourcefile :: FilePath,

54+ ibc_reachablenames :: ![Name],

47 ibc_imports :: ![(Bool, FilePath)],

55 ibc_imports :: ![(Bool, FilePath)],

48 ibc_importdirs :: ![FilePath],

56 ibc_importdirs :: ![FilePath],

49 ibc_implicits :: ![(Name, [PArg])],

57 ibc_implicits :: ![(Name, [PArg])],

@@ -62,13 +70,10 @@ data IBCFile = IBCFile { ver :: Word16,

62 ibc_cgflags :: ![(Codegen, String)],

70 ibc_cgflags :: ![(Codegen, String)],

63 ibc_dynamic_libs :: ![String],

71 ibc_dynamic_libs :: ![String],

64 ibc_hdrs :: ![(Codegen, String)],

72 ibc_hdrs :: ![(Codegen, String)],

65− ibc_access :: ![(Name, Accessibility)],

66− ibc_total :: ![(Name, Totality)],

67 ibc_totcheckfail :: ![(FC, String)],

73 ibc_totcheckfail :: ![(FC, String)],

68 ibc_flags :: ![(Name, [FnOpt])],

74 ibc_flags :: ![(Name, [FnOpt])],

69 ibc_fninfo :: ![(Name, FnInfo)],

75 ibc_fninfo :: ![(Name, FnInfo)],

70 ibc_cg :: ![(Name, CGInfo)],

76 ibc_cg :: ![(Name, CGInfo)],

71− ibc_defs :: ![(Name, Def)],

72 ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],

77 ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],

73 ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],

78 ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],

74 ibc_transforms :: ![(Name, (Term, Term))],

79 ibc_transforms :: ![(Name, (Term, Term))],

@@ -87,7 +92,10 @@ data IBCFile = IBCFile { ver :: Word16,

87 ibc_usage :: ![(Name, Int)],

92 ibc_usage :: ![(Name, Int)],

88 ibc_exports :: ![Name],

93 ibc_exports :: ![Name],

89 ibc_autohints :: ![(Name, Name)],

94 ibc_autohints :: ![(Name, Name)],

90− ibc_deprecated :: ![(Name, String)]

95+ ibc_deprecated :: ![(Name, String)],

96+ ibc_defs :: ![(Name, Def)],

97+ ibc_total :: ![(Name, Totality)],

98+ ibc_access :: ![(Name, Accessibility)]

91 }

99 }

92 deriving Show

100 deriving Show

93{-!

101{-!

@@ -95,7 +103,7 @@ deriving instance Binary IBCFile

95!-}

103!-}

96

104

97initIBC :: IBCFile

105initIBC :: IBCFile

98−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] []

106+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] []

99

107

100hasValidIBCVersion :: FilePath -> Idris Bool

108hasValidIBCVersion :: FilePath -> Idris Bool

101hasValidIBCVersion fp = do

109hasValidIBCVersion fp = do

@@ -106,8 +114,9 @@ hasValidIBCVersion fp = do

106 return (ver == ibcVersion)

114 return (ver == ibcVersion)

107

115

108loadIBC :: Bool -- ^ True = reexport, False = make everything private

116loadIBC :: Bool -- ^ True = reexport, False = make everything private

117+ -> IBCPhase

109 -> FilePath -> Idris ()

118 -> FilePath -> Idris ()

110−loadIBC reexport fp

119+loadIBC reexport phase fp

111 = do imps <- getImported

120 = do imps <- getImported

112 let redo = case lookup fp imps of

121 let redo = case lookup fp imps of

113 Nothing -> True

122 Nothing -> True

@@ -118,15 +127,16 @@ loadIBC reexport fp

118 case toArchiveOrFail archiveFile of

127 case toArchiveOrFail archiveFile of

119 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

128 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

120 ++ "Please clean and rebuild it."

129 ++ "Please clean and rebuild it."

121− Right archive -> do process reexport archive fp

130+ Right archive -> do process reexport phase archive fp

122 addImported reexport fp

131 addImported reexport fp

132+-- dumpTT

123

133

124-- | Load an entire package from its index file

134-- | Load an entire package from its index file

125loadPkgIndex :: String -> Idris ()

135loadPkgIndex :: String -> Idris ()

126loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

136loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

127 addImportDir (ddir </> pkg)

137 addImportDir (ddir </> pkg)

128 fp <- findPkgIndex pkg

138 fp <- findPkgIndex pkg

129− loadIBC True fp

139+ loadIBC True IBC_Building fp

130

140

131

141

132makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

142makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

@@ -156,13 +166,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

156 makeEntry "ibc_cgflags" (ibc_cgflags i),

166 makeEntry "ibc_cgflags" (ibc_cgflags i),

157 makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

167 makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

158 makeEntry "ibc_hdrs" (ibc_hdrs i),

168 makeEntry "ibc_hdrs" (ibc_hdrs i),

159− makeEntry "ibc_access" (ibc_access i),

160− makeEntry "ibc_total" (ibc_total i),

161 makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

169 makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

162 makeEntry "ibc_flags" (ibc_flags i),

170 makeEntry "ibc_flags" (ibc_flags i),

163 makeEntry "ibc_fninfo" (ibc_fninfo i),

171 makeEntry "ibc_fninfo" (ibc_fninfo i),

164 makeEntry "ibc_cg" (ibc_cg i),

172 makeEntry "ibc_cg" (ibc_cg i),

165− makeEntry "ibc_defs" (ibc_defs i),

166 makeEntry "ibc_docstrings" (ibc_docstrings i),

173 makeEntry "ibc_docstrings" (ibc_docstrings i),

167 makeEntry "ibc_moduledocs" (ibc_moduledocs i),

174 makeEntry "ibc_moduledocs" (ibc_moduledocs i),

168 makeEntry "ibc_transforms" (ibc_transforms i),

175 makeEntry "ibc_transforms" (ibc_transforms i),

@@ -181,7 +188,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

181 makeEntry "ibc_usage" (ibc_usage i),

188 makeEntry "ibc_usage" (ibc_usage i),

182 makeEntry "ibc_exports" (ibc_exports i),

189 makeEntry "ibc_exports" (ibc_exports i),

183 makeEntry "ibc_autohints" (ibc_autohints i),

190 makeEntry "ibc_autohints" (ibc_autohints i),

184− makeEntry "ibc_deprecated" (ibc_deprecated i)]

191+ makeEntry "ibc_deprecated" (ibc_deprecated i),

192+ makeEntry "ibc_defs" (ibc_defs i),

193+ makeEntry "ibc_total" (ibc_total i),

194+ makeEntry "ibc_access" (ibc_access i)]

185

195

186writeArchive :: FilePath -> IBCFile -> Idris ()

196writeArchive :: FilePath -> IBCFile -> Idris ()

187writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

197writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

@@ -315,8 +325,9 @@ getEntry alt f a = case findEntryByPath f a of

315 Just e -> return $! (force . decode . fromEntry) e

325 Just e -> return $! (force . decode . fromEntry) e

316

326

317process :: Bool -- ^ Reexporting

327process :: Bool -- ^ Reexporting

328+ -> IBCPhase

318 -> Archive -> FilePath -> Idris ()

329 -> Archive -> FilePath -> Idris ()

319−process reexp i fn = do

330+process reexp phase i fn = do

320 ver <- getEntry 0 "ver" i

331 ver <- getEntry 0 "ver" i

321 when (ver /= ibcVersion) $ do

332 when (ver /= ibcVersion) $ do

322 logIBC 1 "ibc out of date"

333 logIBC 1 "ibc out of date"

@@ -328,7 +339,7 @@ process reexp i fn = do

328 srcok <- runIO $ doesFileExist source

339 srcok <- runIO $ doesFileExist source

329 when srcok $ timestampOlder source fn

340 when srcok $ timestampOlder source fn

330 pImportDirs =<< getEntry [] "ibc_importdirs" i

341 pImportDirs =<< getEntry [] "ibc_importdirs" i

331− pImports reexp =<< getEntry [] "ibc_imports" i

342+ pImports reexp phase =<< getEntry [] "ibc_imports" i

332 pImps =<< getEntry [] "ibc_implicits" i

343 pImps =<< getEntry [] "ibc_implicits" i

333 pFixes =<< getEntry [] "ibc_fixes" i

344 pFixes =<< getEntry [] "ibc_fixes" i

334 pStatics =<< getEntry [] "ibc_statics" i

345 pStatics =<< getEntry [] "ibc_statics" i

@@ -345,12 +356,9 @@ process reexp i fn = do

345 pCGFlags =<< getEntry [] "ibc_cgflags" i

356 pCGFlags =<< getEntry [] "ibc_cgflags" i

346 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

357 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

347 pHdrs =<< getEntry [] "ibc_hdrs" i

358 pHdrs =<< getEntry [] "ibc_hdrs" i

348− pDefs reexp =<< getEntry [] "ibc_defs" i

349 pPatdefs =<< getEntry [] "ibc_patdefs" i

359 pPatdefs =<< getEntry [] "ibc_patdefs" i

350− pAccess reexp =<< getEntry [] "ibc_access" i

351 pFlags =<< getEntry [] "ibc_flags" i

360 pFlags =<< getEntry [] "ibc_flags" i

352 pFnInfo =<< getEntry [] "ibc_fninfo" i

361 pFnInfo =<< getEntry [] "ibc_fninfo" i

353− pTotal =<< getEntry [] "ibc_total" i

354 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

362 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

355 pCG =<< getEntry [] "ibc_cg" i

363 pCG =<< getEntry [] "ibc_cg" i

356 pDocs =<< getEntry [] "ibc_docstrings" i

364 pDocs =<< getEntry [] "ibc_docstrings" i

@@ -371,6 +379,9 @@ process reexp i fn = do

371 pExports =<< getEntry [] "ibc_exports" i

379 pExports =<< getEntry [] "ibc_exports" i

372 pAutoHints =<< getEntry [] "ibc_autohints" i

380 pAutoHints =<< getEntry [] "ibc_autohints" i

373 pDeprecate =<< getEntry [] "ibc_deprecated" i

381 pDeprecate =<< getEntry [] "ibc_deprecated" i

382+ pDefs reexp =<< getEntry [] "ibc_defs" i

383+ pTotal =<< getEntry [] "ibc_total" i

384+ pAccess reexp phase =<< getEntry [] "ibc_access" i

374

385

375timestampOlder :: FilePath -> FilePath -> Idris ()

386timestampOlder :: FilePath -> FilePath -> Idris ()

376timestampOlder src ibc = do srct <- runIO $ getModificationTime src

387timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -404,8 +415,8 @@ pDeprecate ns = mapM_ (\(n,reason) -> addDeprecated n reason) ns

404pImportDirs :: [FilePath] -> Idris ()

415pImportDirs :: [FilePath] -> Idris ()

405pImportDirs fs = mapM_ addImportDir fs

416pImportDirs fs = mapM_ addImportDir fs

406

417

407−pImports :: Bool -> [(Bool, FilePath)] -> Idris ()

418+pImports :: Bool -> IBCPhase -> [(Bool, FilePath)] -> Idris ()

408−pImports reexp fs

419+pImports reexp phase fs

409 = do mapM_ (\(re, f) ->

420 = do mapM_ (\(re, f) ->

410 do i <- getIState

421 do i <- getIState

411 ibcsd <- valIBCSubDir i

422 ibcsd <- valIBCSubDir i

@@ -414,6 +425,9 @@ pImports reexp fs

414-- if (f `elem` imported i)

425-- if (f `elem` imported i)

415-- then logLvl 1 $ "Already read " ++ f

426-- then logLvl 1 $ "Already read " ++ f

416 putIState (i { imported = f : imported i })

427 putIState (i { imported = f : imported i })

428+ let phase' = case phase of

429+ IBC_REPL _ -> IBC_REPL False

430+ p -> p

417 case fp of

431 case fp of

418 LIDR fn -> do

432 LIDR fn -> do

419 logIBC 1 $ "Failed at " ++ fn

433 logIBC 1 $ "Failed at " ++ fn

@@ -421,7 +435,7 @@ pImports reexp fs

421 IDR fn -> do

435 IDR fn -> do

422 logIBC 1 $ "Failed at " ++ fn

436 logIBC 1 $ "Failed at " ++ fn

423 ifail "Must be an ibc"

437 ifail "Must be an ibc"

424− IBC fn src -> loadIBC (reexp && re) fn)

438+ IBC fn src -> loadIBC (reexp && re) phase' fn)

425 fs

439 fs

426

440

427pImps :: [(Name, [PArg])] -> Idris ()

441pImps :: [(Name, [PArg])] -> Idris ()

@@ -520,10 +534,7 @@ pDefs reexp ds

520 _ -> do logIBC 1 $ "SOLVING " ++ show n

534 _ -> do logIBC 1 $ "SOLVING " ++ show n

521 solveDeferred n

535 solveDeferred n

522 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

536 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

523−-- logLvl 1 $ "Added " ++ show (n, d')

537+ ) ds

524− if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

525− setAccessibility n Hidden

526− else logIBC 1 $ "Exporting " ++ show n) ds

527 where

538 where

528 updateDef (CaseOp c t args o s cd)

539 updateDef (CaseOp c t args o s cd)

529 = do o' <- mapM updateOrig o

540 = do o' <- mapM updateOrig o

@@ -537,11 +548,9 @@ pDefs reexp ds

537 return $ Right (l', r')

548 return $ Right (l', r')

538

549

539 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

550 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

540− = do t' <- updateSC t

541− c' <- updateSC c

551+ = do c' <- updateSC c

542− i' <- updateSC i

543 r' <- updateSC r

552 r' <- updateSC r

544− return $ CaseDefs (ts, t') (cs, c') (is, i') (rs, r')

553+ return $ CaseDefs (cs, c') (cs, c') (cs, c') (rs, r')

545

554

546 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

555 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

547 return (Case t n alts')

556 return (Case t n alts')

@@ -562,19 +571,28 @@ pDefs reexp ds

562 updateAlt (DefaultCase t) = do t' <- updateSC t

571 updateAlt (DefaultCase t) = do t' <- updateSC t

563 return (DefaultCase t')

572 return (DefaultCase t')

564

573

574+ -- We get a lot of repetition in sub terms and can save a fair chunk

575+ -- of memory if we make sure they're shared. addTT looks for a term

576+ -- and returns it if it exists already, while also keeping stats of

577+ -- how many times a subterm is repeated.

578+ update t = do tm <- addTT t

579+ case tm of

580+ Nothing -> update' t

581+ Just t' -> return t'

582+

565− update (P t n ty) = do n' <- getSymbol n

583+ update' (P t n ty) = do n' <- getSymbol n

566− return $ P t n' ty

584+ return $ P t n' ty

567− update (App s f a) = liftM2 (App s) (update f) (update a)

585+ update' (App s f a) = liftM2 (App s) (update' f) (update' a)

568− update (Bind n b sc) = do b' <- updateB b

586+ update' (Bind n b sc) = do b' <- updateB b

569− sc' <- update sc

587+ sc' <- update sc

570− return $ Bind n b' sc'

588+ return $ Bind n b' sc'

571 where

589 where

572− updateB (Let t v) = liftM2 Let (update t) (update v)

590+ updateB (Let t v) = liftM2 Let (update' t) (update' v)

573− updateB b = do ty' <- update (binderTy b)

591+ updateB b = do ty' <- update' (binderTy b)

574 return (b { binderTy = ty' })

592 return (b { binderTy = ty' })

575− update (Proj t i) = do t' <- update t

593+ update' (Proj t i) = do t' <- update' t

576− return $ Proj t' i

594+ return $ Proj t' i

577− update t = return t

595+ update' t = return t

578

596

579pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

597pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

580pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

598pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

@@ -584,12 +602,22 @@ pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

584 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

602 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

585

603

586pAccess :: Bool -- ^ Reexporting?

604pAccess :: Bool -- ^ Reexporting?

605+ -> IBCPhase

587 -> [(Name, Accessibility)] -> Idris ()

606 -> [(Name, Accessibility)] -> Idris ()

588−pAccess reexp ds

607+pAccess reexp phase ds

589 = mapM_ (\ (n, a_in) ->

608 = mapM_ (\ (n, a_in) ->

590 do let a = if reexp then a_in else Hidden

609 do let a = if reexp then a_in else Hidden

591 logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

610 logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

592− updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

611+ updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })

612+

613+ if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

614+ setAccessibility n Hidden

615+ else logIBC 1 $ "Exporting " ++ show n

616+ -- Everything should be available at the REPL from

617+ -- things imported publicly

618+ when (phase == IBC_REPL True) $

619+ setAccessibility n Public

620+ ) ds

593

621

594pFlags :: [(Name, [FnOpt])] -> Idris ()

622pFlags :: [(Name, [FnOpt])] -> Idris ()

595pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

623pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -753,18 +781,14 @@ instance Binary SizeChange where

753 _ -> error "Corrupted binary data for SizeChange"

781 _ -> error "Corrupted binary data for SizeChange"

754

782

755instance Binary CGInfo where

783instance Binary CGInfo where

756− put (CGInfo x1 x2 x3 x4 x5)

784+ put (CGInfo x1 x2 x3)

757 = do put x1

785 = do put x1

758− put x2

759-- put x3 -- Already used SCG info for totality check

786-- put x3 -- Already used SCG info for totality check

760− put x4

787+ put x3

761− put x5

762 get

788 get

763 = do x1 <- get

789 = do x1 <- get

764− x2 <- get

765− x4 <- get

766− x5 <- get

790+ x3 <- get

767− return (CGInfo x1 x2 [] x4 x5)

791+ return (CGInfo x1 [] x3)

768

792

769instance Binary CaseType where

793instance Binary CaseType where

770 put x = case x of

794 put x = case x of

@@ -883,13 +907,13 @@ instance Binary Def where

883 put x2

907 put x2

884 -- all primitives just get added at the start, don't write

908 -- all primitives just get added at the start, don't write

885 Operator x1 x2 x3 -> do return ()

909 Operator x1 x2 x3 -> do return ()

910+ -- no need to add/load original patterns, because they're not

911+ -- used again after totality checking

886− CaseOp x1 x2 x2a x3 x3a x4 -> do putWord8 3

912+ CaseOp x1 x2 x3 _ _ x4 -> do putWord8 3

887− put x1

913+ put x1

888− put x2

914+ put x2

889− put x2a

890− put x3

915+ put x3

891− -- no x3a

892− put x4

916+ put x4

893 get

917 get

894 = do i <- getWord8

918 = do i <- getWord8

895 case i of

919 case i of

@@ -903,10 +927,10 @@ instance Binary Def where

903 3 -> do x1 <- get

927 3 -> do x1 <- get

904 x2 <- get

928 x2 <- get

905 x3 <- get

929 x3 <- get

906− x4 <- get

930+-- x4 <- get

907 -- x3 <- get always []

931 -- x3 <- get always []

908 x5 <- get

932 x5 <- get

909− return (CaseOp x1 x2 x3 x4 [] x5)

933+ return (CaseOp x1 x2 x3 [] [] x5)

910 _ -> error "Corrupted binary data for Def"

934 _ -> error "Corrupted binary data for Def"

911

935

912instance Binary Accessibility where

936instance Binary Accessibility where

@@ -1235,7 +1259,7 @@ instance (Binary t) => Binary (PDecl' t) where

1235 put x10

1259 put x10

1236 put x11

1260 put x11

1237 put x12

1261 put x12

1238− PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->

1262+ PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 ->

1239 do putWord8 8

1263 do putWord8 8

1240 put x1

1264 put x1

1241 put x2

1265 put x2

@@ -1248,6 +1272,7 @@ instance (Binary t) => Binary (PDecl' t) where

1248 put x9

1272 put x9

1249 put x10

1273 put x10

1250 put x11

1274 put x11

1275+ put x12

1251 PDSL x1 x2 -> do putWord8 9

1276 PDSL x1 x2 -> do putWord8 9

1252 put x1

1277 put x1

1253 put x2

1278 put x2

@@ -1362,7 +1387,8 @@ instance (Binary t) => Binary (PDecl' t) where

1362 x9 <- get

1387 x9 <- get

1363 x10 <- get

1388 x10 <- get

1364 x11 <- get

1389 x11 <- get

1390+ x12 <- get

1365− return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1391+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

1366 9 -> do x1 <- get

1392 9 -> do x1 <- get

1367 x2 <- get

1393 x2 <- get

1368 return (PDSL x1 x2)

1394 return (PDSL x1 x2)

src/Idris/IdrisDoc.hs+1−1

@@ -10,7 +10,7 @@ import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),

10import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,

11 Accessibility (..), isDConName, isFnName,

12 isTConName)

13−import Idris.ParseHelpers (opChars)

13+import Idris.Parser.Helpers (opChars)

14import Idris.AbsSyntax

15import Idris.Docs

16import Idris.Docstrings (nullDocstring)

src/Idris/Interactive.hs+74−42

@@ -76,7 +76,7 @@ addClauseFrom fn updatefile l n = do

76 getIndent i n xs | take 9 xs == "instance " = i

77 getIndent i n xs | take (length n) xs == n = i

78 getIndent i n (x : xs) = getIndent (i + 1) n xs

79−

79+

80 getAppName (PApp _ r _) = getAppName r

81 getAppName (PRef _ _ r) = r

82 getAppName (PTyped n _) = getAppName n

@@ -120,7 +120,7 @@ addMissing fn updatefile l n

120 if updatefile

121 then do let fb = fn ++ "~"

122 runIO $ writeSource fb (unlines (before ++ nonblank)

123− ++ extras ++

123+ ++ extras ++

124 (if null extras then ""

125 else "\n" ++ unlines rest))

126 runIO $ copyFile fb fn

@@ -193,7 +193,7 @@ makeCase fn updatefile l n

193 case findSubstr ('?':n) line of

194 Just (before, pos, after) ->

195 [before ++ (if b then "(" else "") ++ "case _ of",

196− take (pos + (if b then 6 else 5)) (repeat ' ') ++

196+ take (pos + (if b then 6 else 5)) (repeat ' ') ++

197 "case_val => ?" ++ n ++ (if b then ")" else "")

198 ++ after]

199 Nothing -> fail "No such metavariable"

@@ -208,7 +208,7 @@ makeCase fn updatefile l n

208

209 findSubstr n xs = findSubstr' [] 0 n xs

210

211− findSubstr' acc i n xs | take (length n) xs == n

211+ findSubstr' acc i n xs | take (length n) xs == n

212 = Just (reverse acc, i, drop (length n) xs)

213 findSubstr' acc i n [] = Nothing

214 findSubstr' acc i n (x : xs) = findSubstr' (x : acc) (i + 1) n xs

@@ -217,7 +217,7 @@ makeCase fn updatefile l n

217

218

219

220−doProofSearch :: FilePath -> Bool -> Bool ->

220+doProofSearch :: FilePath -> Bool -> Bool ->

221 Int -> Name -> [Name] -> Maybe Int -> Idris ()

222doProofSearch fn updatefile rec l n hints Nothing

223 = doProofSearch fn updatefile rec l n hints (Just 20)

@@ -230,7 +230,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

230 [] -> return n

231 ns -> ierror (CantResolveAlts ns)

232 i <- getIState

233− let (top, envlen, psnames, _)

233+ let (top, envlen, psnames, _)

234 = case lookup mn (idris_metavars i) of

235 Just (t, e, ns, False) -> (t, e, ns, False)

236 _ -> (Nothing, 0, [], True)

@@ -238,7 +238,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

238 let body t = PProof [Try (TSeq Intros (ProofSearch rec False depth t psnames hints))

239 (ProofSearch rec False depth t psnames hints)]

240 let def = PClause fc mn (PRef fc [] mn) [] (body top) []

241− newmv <- idrisCatch

241+ newmv_pre <- idrisCatch

242 (do elabDecl' EAll recinfo (PClauses fc [] mn [def])

243 (tm, ty) <- elabVal recinfo ERHS (PRef fc [] mn)

244 ctxt <- getContext

@@ -249,10 +249,11 @@ doProofSearch fn updatefile rec l n hints (Just depth)

249 (dropCtxt envlen

250 (delab i (fst (specialise ctxt [] [(mn, 1)] tm))))))

251 (\e -> return ("?" ++ show n))

252+ let newmv = guessBrackets False tyline (show n) newmv_pre

252 if updatefile then

253 if updatefile then

253 do let fb = fn ++ "~"

254 do let fb = fn ++ "~"

254 runIO $ writeSource fb (unlines before ++

255 runIO $ writeSource fb (unlines before ++

255− updateMeta False tyline (show n) newmv ++ "\n"

256+ updateMeta tyline (show n) newmv ++ "\n"

256 ++ unlines later)

257 ++ unlines later)

257 runIO $ copyFile fb fn

258 runIO $ copyFile fb fn

258 else iPrintResult newmv

259 else iPrintResult newmv

@@ -270,18 +271,34 @@ doProofSearch fn updatefile rec l n hints (Just depth)

270 nsroot (SN (WhereN _ _ n)) = nsroot n

271 nsroot (SN (WhereN _ _ n)) = nsroot n

271 nsroot n = n

272 nsroot n = n

272

273

273−updateMeta brack ('?':cs) n new

274+updateMeta ('?':cs) n new

275+ | length cs >= length n

276+ = case splitAt (length n) cs of

277+ (mv, c:cs) ->

278+ if ((isSpace c || c == ')' || c == '}') && mv == n)

279+ then new ++ (c : cs)

280+ else '?' : mv ++ c : updateMeta cs n new

281+ (mv, []) -> if (mv == n) then new else '?' : mv

282+updateMeta ('=':'>':cs) n new = '=':'>':updateMeta cs n new

283+updateMeta ('=':cs) n new = '=':updateMeta cs n new

284+updateMeta (c:cs) n new

285+ = c : updateMeta cs n new

286+updateMeta [] n new = ""

287+

288+guessBrackets brack ('?':cs) n new

274 | length cs >= length n

289 | length cs >= length n

275 = case splitAt (length n) cs of

290 = case splitAt (length n) cs of

276 (mv, c:cs) ->

291 (mv, c:cs) ->

277 if ((isSpace c || c == ')' || c == '}') && mv == n)

292 if ((isSpace c || c == ')' || c == '}') && mv == n)

278− then addBracket brack new ++ (c : cs)

293+ then addBracket brack new

279− else '?' : mv ++ c : updateMeta True cs n new

294+ else guessBrackets True cs n new

280 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

295 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

281−updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new

296+guessBrackets brack ('=':'>':cs) n new = guessBrackets False cs n new

297+guessBrackets brack ('-':'>':cs) n new = guessBrackets False cs n new

298+guessBrackets brack ('=':cs) n new = guessBrackets False cs n new

282−updateMeta brack (c:cs) n new

299+guessBrackets brack (c:cs) n new

283− = c : updateMeta (brack || not (isSpace c)) cs n new

300+ = guessBrackets (brack || not (isSpace c)) cs n new

284−updateMeta brack [] n new = ""

301+guessBrackets brack [] n new = ""

285

302

286checkProv line n = isProv' False line n

303checkProv line n = isProv' False line n

287 where

304 where

@@ -291,7 +308,7 @@ checkProv line n = isProv' False line n

291 isProv' _ ('}':cs) n = isProv' True cs n

308 isProv' _ ('}':cs) n = isProv' True cs n

292 isProv' p (_:cs) n = isProv' p cs n

309 isProv' p (_:cs) n = isProv' p cs n

293 isProv' _ [] n = False

310 isProv' _ [] n = False

294−

311+

295addBracket False new = new

312addBracket False new = new

296addBracket True new@('(':xs) | last xs == ')' = new

313addBracket True new@('(':xs) | last xs == ')' = new

297addBracket True new | any isSpace new = '(' : new ++ ")"

314addBracket True new | any isSpace new = '(' : new ++ ")"

@@ -305,7 +322,7 @@ makeLemma fn updatefile l n

305

322

306 -- if the name is in braces, rather than preceded by a ?, treat it

323 -- if the name is in braces, rather than preceded by a ?, treat it

307 -- as a lemma in a provisional definition

324 -- as a lemma in a provisional definition

308−

325+

309 let isProv = checkProv tyline (show n)

326 let isProv = checkProv tyline (show n)

310

327

311 ctxt <- getContext

328 ctxt <- getContext

@@ -320,13 +337,14 @@ makeLemma fn updatefile l n

320

337

321 if (not isProv) then do

338 if (not isProv) then do

322 let skip = guessImps i (tt_ctxt i) mty

339 let skip = guessImps i (tt_ctxt i) mty

340+ let impty = stripMNBind skip margs (delab i mty)

323− let classes = guessClasses i (tt_ctxt i) mty

341+ let classes = guessClasses i (tt_ctxt i) [] (allNamesIn impty) mty

324

342

325− let lem = show n ++ " : " ++

343+ let lem = show n ++ " : " ++

326 constraints i classes mty ++

344 constraints i classes mty ++

327 showTmOpts (defaultPPOption { ppopt_pinames = True })

345 showTmOpts (defaultPPOption { ppopt_pinames = True })

328− (stripMNBind skip margs (delab i mty))

346+ impty

329− let lem_app = show n ++ appArgs skip margs mty

347+ let lem_app = guessBrackets False tyline (show n) (show n ++ appArgs skip margs mty)

330

348

331 if updatefile then

349 if updatefile then

332 do let fb = fn ++ "~"

350 do let fb = fn ++ "~"

@@ -362,19 +380,26 @@ makeLemma fn updatefile l n

362 where getIndent s = length (takeWhile isSpace s)

380 where getIndent s = length (takeWhile isSpace s)

363

381

364 appArgs skip 0 _ = ""

382 appArgs skip 0 _ = ""

365− appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

383+ appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

366 | (thead c /= '_' && n `notElem` skip)

384 | (thead c /= '_' && n `notElem` skip)

367 = " " ++ show n ++ appArgs skip (i - 1) sc

385 = " " ++ show n ++ appArgs skip (i - 1) sc

368 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

386 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

369 appArgs skip i _ = ""

387 appArgs skip i _ = ""

370

388

371− stripMNBind _ args t | args <= 0 = t

389+ stripMNBind _ args t | args <= 0 = stripImp t

372− stripMNBind skip args (PPi b n@(UN c) _ ty sc)

390+ stripMNBind skip args (PPi b n@(UN c) _ ty sc)

373 | n `notElem` skip ||

391 | n `notElem` skip ||

374 take 4 (str c) == "__pi" -- keep in type, but not in app

392 take 4 (str c) == "__pi" -- keep in type, but not in app

375− = PPi b n NoFC ty (stripMNBind skip (args - 1) sc)

393+ = PPi b n NoFC (stripImp ty) (stripMNBind skip (args - 1) sc)

376 stripMNBind skip args (PPi b _ _ ty sc) = stripMNBind skip (args - 1) sc

394 stripMNBind skip args (PPi b _ _ ty sc) = stripMNBind skip (args - 1) sc

377− stripMNBind skip args t = t

395+ stripMNBind skip args t = stripImp t

396+

397+ stripImp (PApp fc f as) = PApp fc (stripImp f) (map placeholderImp as)

398+ where

399+ placeholderImp tm@(PImp _ _ _ _ _) = tm { getTm = Placeholder }

400+ placeholderImp tm = tm { getTm = stripImp (getTm tm) }

401+ stripImp (PPi b n f ty sc) = PPi b n f (stripImp ty) (stripImp sc)

402+ stripImp t = t

378

403

379 constraints :: IState -> [Name] -> Type -> String

404 constraints :: IState -> [Name] -> Type -> String

380 constraints i [] ty = ""

405 constraints i [] ty = ""

@@ -382,7 +407,7 @@ makeLemma fn updatefile l n

382 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "

407 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "

383

408

384 showConstraints i ns (Bind n (Pi _ ty _) sc)

409 showConstraints i ns (Bind n (Pi _ ty _) sc)

385− | n `elem` ns = show (delab i ty) :

410+ | n `elem` ns = show (delab i ty) :

386 showConstraints i ns (substV (P Bound n Erased) sc)

411 showConstraints i ns (substV (P Bound n Erased) sc)

387 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)

412 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)

388 showConstraints _ _ _ = []

413 showConstraints _ _ _ = []

@@ -393,10 +418,10 @@ makeLemma fn updatefile l n

393 -- Also, make type class instances implicit

418 -- Also, make type class instances implicit

394 guessImps :: IState -> Context -> Term -> [Name]

419 guessImps :: IState -> Context -> Term -> [Name]

395 -- machine names aren't lifted

420 -- machine names aren't lifted

396− guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)

421+ guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)

397 = n : guessImps ist ctxt sc

422 = n : guessImps ist ctxt sc

398 guessImps ist ctxt (Bind n (Pi _ ty _) sc)

423 guessImps ist ctxt (Bind n (Pi _ ty _) sc)

399− | guarded ctxt n (substV (P Bound n Erased) sc)

424+ | guarded ctxt n (substV (P Bound n Erased) sc)

400 = n : guessImps ist ctxt sc

425 = n : guessImps ist ctxt sc

401 | isClass ist ty

426 | isClass ist ty

402 = n : guessImps ist ctxt sc

427 = n : guessImps ist ctxt sc

@@ -404,22 +429,29 @@ makeLemma fn updatefile l n

404 | ignoreName n = n : guessImps ist ctxt sc

429 | ignoreName n = n : guessImps ist ctxt sc

405 | otherwise = guessImps ist ctxt sc

430 | otherwise = guessImps ist ctxt sc

406 guessImps ist ctxt _ = []

431 guessImps ist ctxt _ = []

407−

432+

408 paramty (TType _) = True

433 paramty (TType _) = True

409 paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc

434 paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc

410 paramty _ = False

435 paramty _ = False

411−

436+

412 -- TMP HACK unusable name so don't lift

437 -- TMP HACK unusable name so don't lift

413 ignoreName n = case show n of

438 ignoreName n = case show n of

414 "_aX" -> True

439 "_aX" -> True

415 _ -> False

440 _ -> False

416

441

417− guessClasses :: IState -> Context -> Term -> [Name]

442+ guessClasses :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]

418− guessClasses ist ctxt (Bind n (Pi _ ty _) sc)

443+ guessClasses ist ctxt binders usednames (Bind n (Pi _ ty _) sc)

419− | isParamClass ist ty

444+ | isParamClass ist ty && any (\x -> elem x usednames)

445+ (paramNames binders ty)

420− = n : guessClasses ist ctxt sc

446+ = n : guessClasses ist ctxt (n : binders) usednames sc

421− | otherwise = guessClasses ist ctxt sc

447+ | otherwise = guessClasses ist ctxt (n : binders) usednames sc

422− guessClasses ist ctxt _ = []

448+ guessClasses ist ctxt _ _ _ = []

449+

450+ paramNames bs ty | (P _ _ _, args) <- unApply ty

451+ = vnames args

452+ where vnames [] = []

453+ vnames (V i : xs) | i < length bs = bs !! i : vnames xs

454+ vnames (_ : xs) = vnames xs

423

455

424 isClass ist t

456 isClass ist t

425 | (P _ n _, args) <- unApply t

457 | (P _ n _, args) <- unApply t

@@ -427,7 +459,7 @@ makeLemma fn updatefile l n

427 Just _ -> True

459 Just _ -> True

428 _ -> False

460 _ -> False

429 | otherwise = False

461 | otherwise = False

430−

462+

431 isParamClass ist t

463 isParamClass ist t

432 | (P _ n _, args) <- unApply t

464 | (P _ n _, args) <- unApply t

433 = case lookupCtxtExact n (idris_classes ist) of

465 = case lookupCtxtExact n (idris_classes ist) of

@@ -443,18 +475,18 @@ makeLemma fn updatefile l n

443 isConName f ctxt = any (guarded ctxt n) args

475 isConName f ctxt = any (guarded ctxt n) args

444-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

476-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

445-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc

477-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc

446− guarded ctxt n (Bind _ (Pi _ t _) sc)

478+ guarded ctxt n (Bind _ (Pi _ t _) sc)

447 = guarded ctxt n t || guarded ctxt n sc

479 = guarded ctxt n t || guarded ctxt n sc

448 guarded ctxt n _ = False

480 guarded ctxt n _ = False

449

481

450 blank = all isSpace

482 blank = all isSpace

451

483

452 addLem before tyline lem lem_app later

484 addLem before tyline lem lem_app later

453− = let (bef_end, blankline : bef_start)

485+ = let (bef_end, blankline : bef_start)

454 = case span (not . blank) (reverse before) of

486 = case span (not . blank) (reverse before) of

455 (bef, []) -> (bef, "" : [])

487 (bef, []) -> (bef, "" : [])

456 x -> x

488 x -> x

457− mvline = updateMeta False tyline (show n) lem_app in

489+ mvline = updateMeta tyline (show n) lem_app in

458 unlines $ reverse bef_start ++

490 unlines $ reverse bef_start ++

459 [blankline, lem, blankline] ++

491 [blankline, lem, blankline] ++

460 reverse bef_end ++ mvline : later

492 reverse bef_end ++ mvline : later

@@ -464,6 +496,6 @@ makeLemma fn updatefile l n

464 = case span (not . blank) later of

496 = case span (not . blank) later of

465 (bef, []) -> (bef, "" : [])

497 (bef, []) -> (bef, "" : [])

466 x -> x in

498 x -> x in

467− unlines $ before ++ tyline :

499+ unlines $ before ++ tyline :

468 (later_bef ++ [blankline, lem_app, blankline] ++

500 (later_bef ++ [blankline, lem_app, blankline] ++

469 later_end)

501 later_end)

src/Idris/Parser.hs+63−53

@@ -1,10 +1,10 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2{-# OPTIONS_GHC -O0 #-}

3module Idris.Parser(module Idris.Parser,

4− module Idris.ParseExpr,

4+ module Idris.Parser.Expr,

5− module Idris.ParseData,

5+ module Idris.Parser.Data,

6− module Idris.ParseHelpers,

6+ module Idris.Parser.Helpers,

7− module Idris.ParseOps) where

7+ module Idris.Parser.Ops) where

8

9import Prelude hiding (pi)

10

@@ -35,10 +35,10 @@ import Idris.Unlit

35import Idris.Providers

36import Idris.Output

37

38−import Idris.ParseHelpers

38+import Idris.Parser.Helpers

39−import Idris.ParseOps

39+import Idris.Parser.Ops

40−import Idris.ParseExpr

40+import Idris.Parser.Expr

41−import Idris.ParseData

41+import Idris.Parser.Data

42

43import Idris.Docstrings hiding (Unchecked)

44

@@ -211,7 +211,7 @@ internalDecl syn

211 declBody continue)

212 <|> fail "End of readable input"

213 where declBody :: Bool -> IdrisParser [PDecl]

214− declBody b =

214+ declBody b =

215 try (instance_ True syn)

216 <|> declBody' b

217 <|> using_ syn

@@ -337,8 +337,8 @@ declExtension syn ns rules =

337 (map (updateNs ns) ds)

338 (updateRecCon ns cname)

339 cdocs

340− updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)

340+ updateNs ns (PInstance docs pdocs s fc cs acc cn fc' ps ity ni ds)

341− = PInstance docs pdocs s fc cs (updateB ns cn) fc'

341+ = PInstance docs pdocs s fc cs acc (updateB ns cn) fc'

342 ps ity (fmap (updateB ns) ni)

343 (map (updateNs ns) ds)

344 updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)

@@ -502,7 +502,9 @@ syntaxRule syn

502 body' <- fixBind ((n,n'):rens) body

503 return $ PLam fc n' nfc ty' body'

504 fixBind rens (PPi plic n nfc argTy body)

505− | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)

505+ | n `elem` userNames = liftM2 (PPi plic n nfc)

506+ (fixBind rens argTy)

507+ (fixBind rens body)

506 | otherwise =

508 | otherwise =

507 do ty' <- fixBind rens argTy

509 do ty' <- fixBind rens argTy

508 n' <- gensym n

510 n' <- gensym n

@@ -521,6 +523,10 @@ syntaxRule syn

521 return $ PLet fc n' nfc ty' val' body'

523 return $ PLet fc n' nfc ty' val' body'

522 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

524 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

523 return $ PMatchApp fc n'

525 return $ PMatchApp fc n'

526+ -- Also rename resolved quotations, to allow syntax rules to

527+ -- have quoted references to their own bindings.

528+ fixBind rens (PQuoteName n True fc) | Just n' <- lookup n rens =

529+ return $ PQuoteName n' True fc

524 fixBind rens x = descendM (fixBind rens) x

530 fixBind rens x = descendM (fixBind rens) x

525

531

526 gensym :: Name -> IdrisParser Name

532 gensym :: Name -> IdrisParser Name

@@ -584,7 +590,7 @@ fnDecl' syn = checkFixity $

584 then [TotalFn]

590 then [TotalFn]

585 else []

591 else []

586 opts <- fnOpts initOpts

592 opts <- fnOpts initOpts

587− acc <- optional accessibility

593+ acc <- accessibility

588 opts' <- fnOpts opts

594 opts' <- fnOpts opts

589 (n_in, nfc) <- fnName

595 (n_in, nfc) <- fnName

590 let n = expandNS syn n_in

596 let n = expandNS syn n_in

@@ -698,7 +704,7 @@ postulate syn = do (doc, ext)

698 then [TotalFn]

704 then [TotalFn]

699 else []

705 else []

700 opts <- fnOpts initOpts

706 opts <- fnOpts initOpts

701− acc <- optional accessibility

707+ acc <- accessibility

702 opts' <- fnOpts opts

708 opts' <- fnOpts opts

703 (n_in, nfc) <- fnName

709 (n_in, nfc) <- fnName

704 let n = expandNS syn n_in

710 let n = expandNS syn n_in

@@ -856,7 +862,7 @@ Class ::=

856class_ :: SyntaxInfo -> IdrisParser [PDecl]

862class_ :: SyntaxInfo -> IdrisParser [PDecl]

857class_ syn = do (doc, argDocs, acc)

863class_ syn = do (doc, argDocs, acc)

858 <- try (do (doc, argDocs) <- docstring syn

864 <- try (do (doc, argDocs) <- docstring syn

859− acc <- optional accessibility

865+ acc <- accessibility

860 classKeyword

866 classKeyword

861 return (doc, argDocs, acc))

867 return (doc, argDocs, acc))

862 fc <- getFC

868 fc <- getFC

@@ -873,15 +879,12 @@ class_ syn = do (doc, argDocs, acc)

873 where

879 where

874 fundeps :: IdrisParser [(Name, FC)]

880 fundeps :: IdrisParser [(Name, FC)]

875 fundeps = do lchar '|'; sepBy name (lchar ',')

881 fundeps = do lchar '|'; sepBy name (lchar ',')

876−

882+

877 classKeyword :: IdrisParser ()

883 classKeyword :: IdrisParser ()

878 classKeyword = reservedHL "interface"

884 classKeyword = reservedHL "interface"

879 <|> do reservedHL "class"

885 <|> do reservedHL "class"

880 fc <- getFC

886 fc <- getFC

881− ist <- get

882− put ist { parserWarnings =

883− (fc, Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

887+ parserWarning fc Nothing (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

884− : parserWarnings ist }

885

888

886 carg :: IdrisParser (Name, FC, PTerm)

889 carg :: IdrisParser (Name, FC, PTerm)

887 carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

890 carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

@@ -903,8 +906,9 @@ InstanceName ::= '[' Name ']';

903@

906@

904-}

907-}

905instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

908instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

906−instance_ kwopt syn

909+instance_ kwopt syn

910+ = do acc <- accessibility

907− = do (doc, argDocs)

911+ (doc, argDocs)

908 <- try (docstring syn <* if kwopt then optional instanceKeyword

912 <- try (docstring syn <* if kwopt then optional instanceKeyword

909 else do instanceKeyword

913 else do instanceKeyword

910 return (Just ()))

914 return (Just ()))

@@ -917,7 +921,7 @@ instance_ kwopt syn

917 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

921 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

918 let t = bindList (PPi constraint) cs sc

922 let t = bindList (PPi constraint) cs sc

919 ds <- instanceBlock syn

923 ds <- instanceBlock syn

920− return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]

924+ return [PInstance doc argDocs syn fc cs' acc cn cnfc args t en ds]

921 <?> "implementation declaration"

925 <?> "implementation declaration"

922 where instanceName :: IdrisParser Name

926 where instanceName :: IdrisParser Name

923 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

927 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

@@ -928,11 +932,7 @@ instance_ kwopt syn

928 instanceKeyword = reservedHL "implementation"

932 instanceKeyword = reservedHL "implementation"

929 <|> do reservedHL "instance"

933 <|> do reservedHL "instance"

930 fc <- getFC

934 fc <- getFC

931− ist <- get

932− put ist { parserWarnings =

933− (fc, Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

935+ parserWarning fc Nothing (Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

934− : parserWarnings ist }

935−

936

937-- | Parse a docstring

938docstring :: SyntaxInfo

@@ -1321,7 +1321,10 @@ directive syn = do try (lchar '%' *> reserved "lib")

1321 return [PDirective (DHide n)]

1322 <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

1323 return [PDirective (DFreeze n)]

1324− <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1324+ <|> do try (lchar '%' *> reserved "access")

1325+ acc <- accessibility

1326+ ist <- get

1327+ put ist { default_access = acc }

1325 return [PDirective (DAccess acc)]

1328 return [PDirective (DAccess acc)]

1326 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1329 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1327 i <- get

1330 i <- get

@@ -1353,7 +1356,12 @@ directive syn = do try (lchar '%' *> reserved "lib")

1353 fn <- fst <$> fnName

1356 fn <- fst <$> fnName

1354 arg <- fst <$> iName []

1357 arg <- fst <$> iName []

1355 return [PDirective (DUsed fc fn arg)]

1358 return [PDirective (DUsed fc fn arg)]

1359+ <|> do try (lchar '%' *> reserved "auto_implicits")

1360+ b <- on_off

1361+ return [PDirective (DAutoImplicits b)]

1356 <?> "directive"

1362 <?> "directive"

1363+ where on_off = do reserved "on"; return True

1364+ <|> do reserved "off"; return False

1357

1365

1358pLangExt :: IdrisParser LanguageExt

1366pLangExt :: IdrisParser LanguageExt

1359pLangExt = (reserved "TypeProviders" >> return TypeProviders)

1367pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1491,14 +1499,23 @@ parseImports fname input

1491 [(FC, OutputAnnotation)], IState)

1499 [(FC, OutputAnnotation)], IState)

1492 imports = do whiteSpace

1500 imports = do whiteSpace

1493 (mdoc, mname, annots) <- moduleHeader

1501 (mdoc, mname, annots) <- moduleHeader

1494− ps <- many import_

1502+ ps_exp <- many import_

1495 mrk <- mark

1503 mrk <- mark

1496 isEof <- lookAheadMatches eof

1504 isEof <- lookAheadMatches eof

1497 let mrk' = if isEof

1505 let mrk' = if isEof

1498 then Nothing

1506 then Nothing

1499 else Just mrk

1507 else Just mrk

1500 i <- get

1508 i <- get

1509+ -- add Builtins and Prelude, unless options say

1510+ -- not to

1511+ let ps = ps_exp -- imp "Builtins" : imp "Prelude" : ps_exp

1501 return ((mdoc, mname, ps, mrk'), annots, i)

1512 return ((mdoc, mname, ps, mrk'), annots, i)

1513+

1514+ imp m = ImportInfo False (toPath m)

1515+ Nothing [] NoFC NoFC

1516+ ns = Spl.splitOn "."

1517+ toPath = foldl1' (</>) . ns

1518+

1502 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

1519 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

1503 addPath [] _ = []

1520 addPath [] _ = []

1504 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

1521 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

@@ -1556,17 +1573,17 @@ parseProg syn fname input mrk

1556 return (ds, i')

1573 return (ds, i')

1557

1574

1558{- | Load idris module and show error if something wrong happens -}

1575{- | Load idris module and show error if something wrong happens -}

1559−loadModule :: FilePath -> Idris (Maybe String)

1576+loadModule :: FilePath -> IBCPhase -> Idris (Maybe String)

1560−loadModule f

1577+loadModule f phase

1561− = idrisCatch (loadModule' f)

1578+ = idrisCatch (loadModule' f phase)

1562 (\e -> do setErrSpan (getErrSpan e)

1579 (\e -> do setErrSpan (getErrSpan e)

1563 ist <- getIState

1580 ist <- getIState

1564 iWarn (getErrSpan e) $ pprintErr ist e

1581 iWarn (getErrSpan e) $ pprintErr ist e

1565 return Nothing)

1582 return Nothing)

1566

1583

1567{- | Load idris module -}

1584{- | Load idris module -}

1568−loadModule' :: FilePath -> Idris (Maybe String)

1585+loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String)

1569−loadModule' f

1586+loadModule' f phase

1570 = do i <- getIState

1587 = do i <- getIState

1571 let file = takeWhile (/= ' ') f

1588 let file = takeWhile (/= ' ') f

1572 ibcsd <- valIBCSubDir i

1589 ibcsd <- valIBCSubDir i

@@ -1580,7 +1597,7 @@ loadModule' f

1580 IDR fn -> loadSource False fn Nothing

1597 IDR fn -> loadSource False fn Nothing

1581 LIDR fn -> loadSource True fn Nothing

1598 LIDR fn -> loadSource True fn Nothing

1582 IBC fn src ->

1599 IBC fn src ->

1583− idrisCatch (loadIBC True fn)

1600+ idrisCatch (loadIBC True phase fn)

1584 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

1601 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

1585 case src of

1602 case src of

1586 IDR sfn -> loadSource False sfn Nothing

1603 IDR sfn -> loadSource False sfn Nothing

@@ -1588,18 +1605,18 @@ loadModule' f

1588 return $ Just file

1605 return $ Just file

1589

1606

1590{- | Load idris code from file -}

1607{- | Load idris code from file -}

1591−loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1608+loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris ()

1592−loadFromIFile reexp i@(IBC fn src) maxline

1609+loadFromIFile reexp phase i@(IBC fn src) maxline

1593 = do logParser 1 $ "Skipping " ++ getSrcFile i

1610 = do logParser 1 $ "Skipping " ++ getSrcFile i

1594− idrisCatch (loadIBC reexp fn)

1611+ idrisCatch (loadIBC reexp phase fn)

1595 (\err -> ierror $ LoadingFailed fn err)

1612 (\err -> ierror $ LoadingFailed fn err)

1596 where

1613 where

1597 getSrcFile (IDR fn) = fn

1614 getSrcFile (IDR fn) = fn

1598 getSrcFile (LIDR fn) = fn

1615 getSrcFile (LIDR fn) = fn

1599 getSrcFile (IBC f src) = getSrcFile src

1616 getSrcFile (IBC f src) = getSrcFile src

1600

1617

1601−loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline

1618+loadFromIFile _ _ (IDR fn) maxline = loadSource' False fn maxline

1602−loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline

1619+loadFromIFile _ _ (LIDR fn) maxline = loadSource' True fn maxline

1603

1620

1604{-| Load idris source code and show error if something wrong happens -}

1621{-| Load idris source code and show error if something wrong happens -}

1605loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

1622loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

@@ -1630,7 +1647,7 @@ loadSource lidr f toline

1630 LIDR fn -> ifail $ "No ibc for " ++ f

1647 LIDR fn -> ifail $ "No ibc for " ++ f

1631 IDR fn -> ifail $ "No ibc for " ++ f

1648 IDR fn -> ifail $ "No ibc for " ++ f

1632 IBC fn src ->

1649 IBC fn src ->

1633− do loadIBC True fn

1650+ do loadIBC True IBC_Building fn

1634 let srcFn = case src of

1651 let srcFn = case src of

1635 IDR fn -> Just fn

1652 IDR fn -> Just fn

1636 LIDR fn -> Just fn

1653 LIDR fn -> Just fn

@@ -1760,7 +1777,7 @@ loadSource lidr f toline

1760 clearHighlights

1777 clearHighlights

1761 i <- getIState

1778 i <- getIState

1762 putIState (i { default_total = def_total,

1779 putIState (i { default_total = def_total,

1763− hide_list = [] })

1780+ hide_list = emptyContext })

1764 return ()

1781 return ()

1765 where

1782 where

1766 namespaces :: [String] -> [PDecl] -> [PDecl]

1783 namespaces :: [String] -> [PDecl] -> [PDecl]

@@ -1790,16 +1807,9 @@ loadSource lidr f toline

1790 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

1807 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

1791

1808

1792{- | Adds names to hide list -}

1809{- | Adds names to hide list -}

1793−addHides :: [(Name, Maybe Accessibility)] -> Idris ()

1810+addHides :: Ctxt Accessibility -> Idris ()

1794addHides xs = do i <- getIState

1811addHides xs = do i <- getIState

1795 let defh = default_access i

1812 let defh = default_access i

1796− let (hs, as) = partition isNothing xs

1797− unless (null as) $

1798− mapM_ doHide

1813+ mapM_ doHide (toAlist xs)

1799− (map (\ (n, _) -> (n, defh)) hs ++

1800− map (\ (n, Just a) -> (n, a)) as)

1801− where isNothing (_, Nothing) = True

1802− isNothing _ = False

1803−

1804− doHide (n, a) = do setAccessibility n a

1814+ where doHide (n, a) = do setAccessibility n a

1805 addIBC (IBCAccess n a)

1815 addIBC (IBCAccess n a)

src/Idris/ParseData.hs → src/Idris/Parser/Data.hsrenamed+12−12

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

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseData where

2+module Idris.Parser.Data where

3

4import Prelude hiding (pi)

5

@@ -12,9 +12,9 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16−import Idris.ParseOps

16+import Idris.Parser.Ops

17−import Idris.ParseExpr

17+import Idris.Parser.Expr

18import Idris.DSL

19

20import Idris.Core.TT

@@ -48,7 +48,7 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

48 let doc' = annotCode (tryFullExpr syn ist) doc

49 paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

50 | (n, d) <- paramDocs ]

51− acc <- optional accessibility

51+ acc <- accessibility

52 opts <- dataOpts []

53 co <- recordI

54 return (doc', paramDocs', acc, opts ++ co))

@@ -59,8 +59,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

59 syn_namespace syn }

60 params <- manyTill (recordParameter rsyn) (reservedHL "where")

61 (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn

62+ let fnames = map (expandNS rsyn) (mapMaybe getName fields)

62 case cname of

63 case cname of

63− Just cn' -> accData acc tyn [fst cn']

64+ Just cn' -> accData acc tyn (fst cn' : fnames)

64 Nothing -> return ()

65 Nothing -> return ()

65 return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

66 return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

66 <?> "record type declaration"

67 <?> "record type declaration"

@@ -70,6 +71,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

70 ++ getRecNames syn sc

71 ++ getRecNames syn sc

71 getRecNames _ _ = []

72 getRecNames _ _ = []

72

73

74+ getName (Just (n, _), _, _, _) = Just n

75+ getName _ = Nothing

76+

73 toFreeze :: Maybe Accessibility -> Maybe Accessibility

77 toFreeze :: Maybe Accessibility -> Maybe Accessibility

74 toFreeze (Just Frozen) = Just Hidden

78 toFreeze (Just Frozen) = Just Hidden

75 toFreeze x = x

79 toFreeze x = x

@@ -167,11 +171,7 @@ dataOpts opts

167 <|> return opts

171 <|> return opts

168 <?> "data options"

172 <?> "data options"

169 where warnElim fc =

173 where warnElim fc =

170− do ist <- get

174+ parserWarning fc (Just NoElimDeprecationWarnings) (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

171− let cmdline = opt_cmdline (idris_options ist)

172− unless (NoElimDeprecationWarnings `elem` cmdline) $

173− put ist { parserWarnings =

174− (fc, Msg "Eliminator generation is deprecated. Use an eliminator generator in a library instead.") : parserWarnings ist }

175

176{- | Parses a data type declaration

177Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?

@@ -192,7 +192,7 @@ data_ :: SyntaxInfo -> IdrisParser PDecl

192data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

193 (doc, argDocs) <- option noDocs docComment

194 pushIndent

195− acc <- optional accessibility

195+ acc <- accessibility

196 elim <- dataOpts []

197 co <- dataI

198 ist <- get

src/Idris/ParseExpr.hs → src/Idris/Parser/Expr.hsrenamed+19−20

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

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}

2−module Idris.ParseExpr where

2+module Idris.Parser.Expr where

3

4import Prelude hiding (pi)

5

@@ -12,8 +12,8 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16−import Idris.ParseOps

16+import Idris.Parser.Ops

17import Idris.DSL

18

19import Idris.Core.TT

@@ -161,7 +161,7 @@ extension syn ns rules =

161 extensionSymbol (Symbol s) = do fc <- symbolFC s

162 highlightP fc AnnKeyword

163 return Nothing

164−

164+

165 flatten :: PTerm -> PTerm -- flatten application

166 flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))

167 flatten t = t

@@ -252,7 +252,7 @@ updateSynMatch = update

252

253 updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)

254 updTacImp _ x = x

255−

255+

256 dropn :: Name -> [(Name, a)] -> [(Name, a)]

257 dropn n [] = []

258 dropn n ((x,t) : xs) | n == x = xs

@@ -333,11 +333,7 @@ caseOption syn = do lhs <- expr (syn { inPattern = True })

333

334warnTacticDeprecation :: FC -> IdrisParser ()

335warnTacticDeprecation fc =

336− do ist <- get

337− let cmdline = opt_cmdline (idris_options ist)

338− unless (NoOldTacticDeprecationWarnings `elem` cmdline) $

339− put ist { parserWarnings =

340− (fc, Msg "This style of tactic proof is deprecated. See %runElab for the replacement.") : parserWarnings ist }

336+ parserWarning fc (Just NoOldTacticDeprecationWarnings) (Msg "This style of tactic proof is deprecated. See %runElab for the replacement.")

341

337

342{- | Parses a proof block

338{- | Parses a proof block

343@

339@

@@ -480,7 +476,7 @@ bracketed' open syn =

480 <|> try (do l <- simpleExpr syn

476 <|> try (do l <- simpleExpr syn

481 op <- option Nothing (do o <- operator

477 op <- option Nothing (do o <- operator

482 lchar ')'

478 lchar ')'

483− return (Just o))

479+ return (Just o))

484 fc0 <- getFC

480 fc0 <- getFC

485 case op of

481 case op of

486 Nothing -> bracketedExpr syn open l

482 Nothing -> bracketedExpr syn open l

@@ -588,7 +584,7 @@ runElab syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "runElab

588 return $ PRunElab fc tm (syn_namespace syn)

584 return $ PRunElab fc tm (syn_namespace syn)

589 <?> "new-style tactics expression"

585 <?> "new-style tactics expression"

590

586

591−{- | Parses a disambiguation expression

587+{- | Parses a disambiguation expression

592Disamb ::=

588Disamb ::=

593 '%' 'disamb' NameList Expr

589 '%' 'disamb' NameList Expr

594 ;

590 ;

@@ -1010,7 +1006,7 @@ Pi' ::=

1010@

1006@

1011 -}

1007 -}

1012

1008

1013−bindsymbol opts st syn

1009+bindsymbol opts st syn

1014 = do symbol "->"

1010 = do symbol "->"

1015 return (Exp opts st False)

1011 return (Exp opts st False)

1016

1012

@@ -1019,7 +1015,7 @@ explicitPi opts st syn

1019 binder <- bindsymbol opts st syn

1015 binder <- bindsymbol opts st syn

1020 sc <- expr syn

1016 sc <- expr syn

1021 return (bindList (PPi binder) xt sc)

1017 return (bindList (PPi binder) xt sc)

1022−

1018+

1023autoImplicit opts st syn

1019autoImplicit opts st syn

1024 = do kw <- reservedFC "auto"

1020 = do kw <- reservedFC "auto"

1025 when (st == Static) $ fail "auto implicits can not be static"

1021 when (st == Static) $ fail "auto implicits can not be static"

@@ -1029,7 +1025,7 @@ autoImplicit opts st syn

1029 sc <- expr syn

1025 sc <- expr syn

1030 highlightP kw AnnKeyword

1026 highlightP kw AnnKeyword

1031 return (bindList (PPi

1027 return (bindList (PPi

1032− (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)

1028+ (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)

1033

1029

1034defaultImplicit opts st syn = do

1030defaultImplicit opts st syn = do

1035 kw <- reservedFC "default"

1031 kw <- reservedFC "default"

@@ -1055,7 +1051,7 @@ normalImplicit opts st syn = do

1055 constraint)

1051 constraint)

1056 else (Imp opts st False (Just (Impl False False)),

1052 else (Imp opts st False (Just (Impl False False)),

1057 Imp opts st False (Just (Impl True False)))

1053 Imp opts st False (Just (Impl True False)))

1058− return (bindList (PPi im) xt

1054+ return (bindList (PPi im) xt

1059 (bindList (PPi cl) cs sc))

1055 (bindList (PPi cl) cs sc))

1060

1056

1061implicitPi opts st syn =

1057implicitPi opts st syn =

@@ -1389,7 +1385,11 @@ Static ::=

1389@

1385@

1390-}

1386-}

1391static :: IdrisParser Static

1387static :: IdrisParser Static

1392−static = do reserved "[static]"; return Static

1388+static = do reserved "%static"; return Static

1389+ <|> do reserved "[static]"

1390+ fc <- getFC

1391+ parserWarning fc Nothing (Msg "The use of [static] is deprecated, use %static instead.")

1392+ return Static

1393 <|> return Dynamic

1394 <?> "static modifier"

1395

@@ -1443,7 +1443,7 @@ data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n

1443-- https://github.com/idris-lang/Idris-dev/issues/1766

1444-- | A list of available tactics and their argument requirements

1445tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

1446−tactics =

1446+tactics =

1447 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1448 do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)

1449 , noArgs ["intros"] Intros

@@ -1527,7 +1527,7 @@ tactics =

1527 imp :: IdrisParser Bool

1528 imp = do lchar '?'; return False

1529 <|> do lchar '_'; return True

1530−

1530+

1531

1532tactic :: SyntaxInfo -> IdrisParser PTactic

1533tactic syn = choice [ do choice (map reserved names); parser syn

@@ -1550,4 +1550,3 @@ fullTactic :: SyntaxInfo -> IdrisParser PTactic

1550fullTactic syn = do t <- tactic syn

1551 eof

1552 return t

1553−

src/Idris/ParseHelpers.hs → src/Idris/Parser/Helpers.hsrenamed+47−14

@@ -2,12 +2,12 @@

2#if !(MIN_VERSION_base(4,8,0))

3{-# LANGUAGE OverlappingInstances #-}

4#endif

5−module Idris.ParseHelpers where

5+module Idris.Parser.Helpers where

6

7import Prelude hiding (pi)

8

9import Text.Trifecta.Delta

10−import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)

10+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace, Err)

11import Text.Parser.LookAhead

12import Text.Parser.Expression

13import qualified Text.Parser.Token as Tok

@@ -105,6 +105,14 @@ reportParserWarnings = do ist <- getIState

105 parserWarnings ist)

106 clearParserWarnings

107

108+

109+parserWarning :: FC -> Maybe Opt -> Err -> IdrisParser ()

110+parserWarning fc warnOpt warnErr = do

111+ ist <- get

112+ let cmdline = opt_cmdline (idris_options ist)

113+ unless (maybe False (`elem` cmdline) warnOpt) $

114+ put ist { parserWarnings = (fc, warnErr) : parserWarnings ist }

115+

108{- * Space, comments and literals (token/lexing like parsers) -}

116{- * Space, comments and literals (token/lexing like parsers) -}

109

117

110-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)

118-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)

@@ -246,9 +254,9 @@ idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved

246 "case", "of", "total", "partial", "mutual",

254 "case", "of", "total", "partial", "mutual",

247 "infix", "infixl", "infixr", "rewrite",

255 "infix", "infixl", "infixr", "rewrite",

248 "where", "with", "syntax", "proof", "postulate",

256 "where", "with", "syntax", "proof", "postulate",

249− "using", "namespace", "class", "instance",

257+ "using", "namespace", "class", "instance",

250 "interface", "implementation", "parameters",

258 "interface", "implementation", "parameters",

251− "public", "private", "abstract", "implicit",

259+ "public", "private", "export", "abstract", "implicit",

252 "quoteGoal", "constructor",

260 "quoteGoal", "constructor",

253 "if", "then", "else"]

261 "if", "then", "else"]

254

262

@@ -612,22 +620,47 @@ notOpenBraces = do ist <- get

612 hasNothing = any isNothing

620 hasNothing = any isNothing

613

621

614{- | Parses an accessibilty modifier (e.g. public, private) -}

622{- | Parses an accessibilty modifier (e.g. public, private) -}

615−accessibility :: IdrisParser Accessibility

623+accessibility' :: IdrisParser Accessibility

624+accessibility'

616−accessibility = do reserved "public"; return Public

625+ = do reserved "public";

626+ gotexp <- optional (reserved "export")

627+ case gotexp of

628+ Just _ -> return ()

629+ Nothing -> do

630+ ist <- get

631+ fc <- getFC

632+ put ist { parserWarnings =

633+ (fc, Msg "'public' is deprecated. Use 'public export' instead.")

634+ : parserWarnings ist }

635+ return Public

617− <|> do reserved "abstract"; return Frozen

636+ <|> do reserved "abstract";

637+ ist <- get

638+ fc <- getFC

639+ put ist { parserWarnings =

640+ (fc, Msg "The 'abstract' keyword is deprecated. Use 'export' instead.")

641+ : parserWarnings ist }

642+ return Frozen

643+ <|> do reserved "export"; return Frozen

618 <|> do reserved "private"; return Hidden

644 <|> do reserved "private"; return Hidden

619 <?> "accessibility modifier"

645 <?> "accessibility modifier"

620

646

647+accessibility :: IdrisParser Accessibility

648+accessibility = do acc <- optional accessibility'

649+ case acc of

650+ Just a -> return a

651+ Nothing -> do ist <- get

652+ return (default_access ist)

653+

621-- | Adds accessibility option for function

654-- | Adds accessibility option for function

622−addAcc :: Name -> Maybe Accessibility -> IdrisParser ()

655+addAcc :: Name -> Accessibility -> IdrisParser ()

623addAcc n a = do i <- get

656addAcc n a = do i <- get

624− put (i { hide_list = (n, a) : hide_list i })

657+ put (i { hide_list = addDef n a (hide_list i) })

625

658

626{- | Add accessbility option for data declarations

659{- | Add accessbility option for data declarations

627 (works for classes too - 'abstract' means the data/class is visible but members not) -}

660 (works for classes too - 'abstract' means the data/class is visible but members not) -}

628−accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()

661+accData :: Accessibility -> Name -> [Name] -> IdrisParser ()

629−accData (Just Frozen) n ns = do addAcc n (Just Frozen)

662+accData Frozen n ns = do addAcc n Public -- so that it can be used in public definitions

630− mapM_ (\n -> addAcc n (Just Hidden)) ns

663+ mapM_ (\n -> addAcc n Hidden) ns -- so that they are invisible

631accData a n ns = do addAcc n a

664accData a n ns = do addAcc n a

632 mapM_ (`addAcc` a) ns

665 mapM_ (`addAcc` a) ns

633

666

@@ -662,7 +695,7 @@ collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

662collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

695collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

663collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

696collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

664 = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'

697 = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'

665−collect (PInstance doc argDocs f s cs n nfc ps t en ds : ds')

698+collect (PInstance doc argDocs f s cs acc n nfc ps t en ds : ds')

666− = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'

699+ = PInstance doc argDocs f s cs acc n nfc ps t en (collect ds) : collect ds'

667collect (d : ds) = d : collect ds

700collect (d : ds) = d : collect ds

668collect [] = []

701collect [] = []

src/Idris/ParseOps.hs → src/Idris/Parser/Ops.hsrenamed+2−3

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

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseOps where

2+module Idris.Parser.Ops where

3

4import Prelude hiding (pi)

5

@@ -12,7 +12,7 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16

17import Idris.Core.TT

18

@@ -170,4 +170,3 @@ fixityType = do reserved "infixl"; return Infixl

170 <|> do reserved "infix"; return InfixN

171 <|> do reserved "prefix"; return PrefixN

172 <?> "fixity type"

173−

src/Idris/ProofSearch.hs+31−33

@@ -48,13 +48,13 @@ trivialHoles psnames ok elab ist

48 then try' (elab (PRef (fileFC "prf") [] x))

49 (tryAll xs) True

50 else tryAll xs

51−

51+

52 holesOK hs ap@(App _ _ _)

53 | (P _ n _, args) <- unApply ap

54 = holeArgsOK hs n 0 args

55 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

56 holesOK hs (P _ n _) = not (n `elem` hs)

57− holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

57+ holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

58 holesOK hs sc

59 holesOK hs _ = True

60

@@ -85,8 +85,8 @@ trivialTCs ok elab ist

85 then try' (elab (PRef (fileFC "prf") [] x))

86 (tryAll xs) True

87 else tryAll xs

88−

88+

89− tcArg env ty

89+ tcArg env ty

90 | (P _ n _, args) <- unApply (getRetTy (normalise (tt_ctxt ist) env ty))

91 = case lookupCtxtExact n (idris_classes ist) of

92 Just _ -> True

@@ -98,7 +98,7 @@ trivialTCs ok elab ist

98 = holeArgsOK hs n 0 args

99 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

100 holesOK hs (P _ n _) = not (n `elem` hs)

101− holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

101+ holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

102 holesOK hs sc

103 holesOK hs _ = True

104

@@ -111,16 +111,16 @@ cantSolveGoal :: ElabD a

111cantSolveGoal = do g <- goal

112 env <- get_env

113 lift $ tfail $

114− CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

114+ CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

115

116−proofSearch :: Bool -> -- recursive search (False for 'refine')

116+proofSearch :: Bool -> -- recursive search (False for 'refine')

117 Bool -> -- invoked from a tactic proof. If so, making

118 -- new metavariables is meaningless, and there shoudl

119 -- be an error reported instead.

120 Bool -> -- ambiguity ok

121 Bool -> -- defer on failure

122 Int -> -- maximum depth

123− (PTerm -> ElabD ()) -> Maybe Name -> Name ->

123+ (PTerm -> ElabD ()) -> Maybe Name -> Name ->

124 [Name] ->

125 [Name] ->

126 IState -> ElabD ()

@@ -131,7 +131,7 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

131 tryAllFns all_imps

132 where

133 -- if nothing worked, make a new metavariable

134− tryAllFns [] | fromProver = cantSolveGoal

134+ tryAllFns [] | fromProver = cantSolveGoal

135 tryAllFns [] = do attack; defer [] nroot; solve

136 tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True

137

@@ -142,20 +142,20 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

142 (match_apply (Var f) imps) True

143 ps' <- get_probs

144-- when (length ps < length ps') $ fail "Can't apply constructor"

145− -- Make metavariables for new holes

145+ -- Make metavariables for new holes

146 hs' <- get_holes

147 ptm <- get_term

148 if fromProver then cantSolveGoal

149 else do

150 mapM_ (\ h -> do focus h

151− attack; defer [] nroot; solve)

151+ attack; defer [] nroot; solve)

152 (hs' \\ hs)

153-- (filter (\ (x, y) -> not x) (zip (map fst imps) args))

154 solve

155

156 isImp (PImp p _ _ _ _) = (True, p)

157 isImp arg = (True, priority arg) -- try to get all of them by unification

158−proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist

158+proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist

159 = do compute

160 ty <- goal

161 hs <- get_holes

@@ -172,7 +172,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

172 (autoArg (sUN "auto"))

173 else autoArg (sUN "auto") -- not enough info in the type yet

174 where

175− findInferredTy (t : _) = elab (delab ist (toUN t))

175+ findInferredTy (t : _) = elab (delab ist (toUN t))

176

177 cantsolve (InternalMsg _) = True

178 cantsolve (CantSolveGoal _ _) = True

@@ -185,12 +185,12 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

185 conArgsOK ty

186 = let (f, as) = unApply ty in

187 case f of

188− P _ n _ ->

188+ P _ n _ ->

189 let autohints = case lookupCtxtExact n (idris_autohints ist) of

190 Nothing -> []

191 Just hs -> hs in

192 case lookupCtxtExact n (idris_datatypes ist) of

193− Just t -> do rs <- mapM (conReady as)

193+ Just t -> do rs <- mapM (conReady as)

194 (autohints ++ con_names t)

195 return (and rs)

196 Nothing -> -- local variable, go for it

@@ -199,7 +199,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

199 _ -> typeNotSearchable ty

200

201 conReady :: [Term] -> Name -> ElabD Bool

202− conReady as n

202+ conReady as n

203 = case lookupTyExact n (tt_ctxt ist) of

204 Just ty -> do let (_, cs) = unApply (getRetTy ty)

205 -- if any metavariables in 'as' correspond to

@@ -223,7 +223,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

223 inHS hs (P _ n _) = n `elem` hs

224 isHS _ _ = False

225

226− toUN t@(P nt (MN i n) ty)

226+ toUN t@(P nt (MN i n) ty)

227 | ('_':xs) <- str n = t

228 | otherwise = P nt (UN n) ty

229 toUN (App s f a) = App s (toUN f) (toUN a)

@@ -239,7 +239,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

239 psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()

240 psRec _ 0 locs tys | fromProver = cantSolveGoal

241 psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"

242− psRec False d locs tys = tryCons d locs tys hints

242+ psRec False d locs tys = tryCons d locs tys hints

243 psRec True d locs tys

244 = do compute

245 ty <- goal

@@ -248,11 +248,11 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

248 try' (try' (trivialHoles psnames [] elab ist)

249 (resolveTC False False 20 ty nroot elab ist)

250 True)

251− (try' (try' (resolveByCon (d - 1) locs tys')

251+ (try' (try' (resolveByCon (d - 1) locs tys')

252 (resolveByLocals (d - 1) locs tys')

253 True)

254 -- if all else fails, make a new metavariable

255− (if fromProver

255+ (if fromProver

256 then fail "cantSolveGoal"

257 else do attack; defer [] nroot; solve) True) True

258

@@ -269,7 +269,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

269 = do t <- goal

270 let (f, _) = unApply t

271 case f of

272− P _ n _ ->

272+ P _ n _ ->

273 do let autohints = case lookupCtxtExact n (idris_autohints ist) of

274 Nothing -> []

275 Just hs -> hs

@@ -292,26 +292,26 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

292 tryLocals d locs tys env

293

294 tryLocals d locs tys [] = fail "Locals failed"

295− tryLocals d locs tys ((x, t) : xs)

295+ tryLocals d locs tys ((x, t) : xs)

296 | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs

297− | otherwise = try' (tryLocal d (x : locs) tys x t)

297+ | otherwise = try' (tryLocal d (x : locs) tys x t)

298 (tryLocals d locs tys xs) True

299

300 tryCons d locs tys [] = fail "Constructors failed"

301− tryCons d locs tys (c : cs)

301+ tryCons d locs tys (c : cs)

302 = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

303

304− tryLocal d locs tys n t

304+ tryLocal d locs tys n t

305 = do let a = getPArity (delab ist (binderTy t))

306 tryLocalArg d locs tys n a

307

308 tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") [] n)

309− tryLocalArg d locs tys n i

309+ tryLocalArg d locs tys n i

310 = simple_app False (tryLocalArg d locs tys n (i - 1))

311 (psRec True d locs tys) "proof search local apply"

312

313 -- Like type class resolution, but searching with constructors

314− tryCon d locs tys n =

314+ tryCon d locs tys n =

315 do ty <- goal

316 let imps = case lookupCtxtExact n (idris_implicits ist) of

317 Nothing -> []

@@ -341,7 +341,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

341 (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

342 _ -> []

343

344−-- In interactive mode, only search for things if there is some

344+-- In interactive mode, only search for things if there is some

345-- index to help pick a relevant constructor

346checkConstructor :: IState -> [Name] -> ElabD ()

347checkConstructor ist [] = return ()

@@ -397,7 +397,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

397 _ -> []

398

399 traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $

400− try' (trivialTCs okholes elab ist)

400+ try' (trivialTCs okholes elab ist)

401 (do addDefault t tc ttypes

402 let stk = map fst (filter snd $ elab_stack ist)

403 let insts = findInstances ist t

@@ -432,7 +432,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

432 tcDetArgsOK _ _ _ [] = Just []

433

434 isMeta :: [Name] -> Term -> Bool

435− isMeta ns (P _ n _) = n `elem` ns

435+ isMeta ns (P _ n _) = n `elem` ns

436 isMeta _ _ = False

437

438 notHole hs (P _ n _, c)

@@ -449,7 +449,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

449 chaser (NS n _) = chaser n

450 chaser _ = False

451

452− numclass = sNS (sUN "Num") ["Classes","Prelude"]

452+ numclass = sNS (sUN "Num") ["Interfaces","Prelude"]

453

454 addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn

455 = do focus a

@@ -530,5 +530,3 @@ findInstances ist t

530 where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of

531 Just (_, Hidden) -> False

532 _ -> True

533−

534−

src/Idris/REPL.hs+25−21

@@ -8,10 +8,10 @@ module Idris.REPL(getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc,

8import Idris.AbsSyntax

9import Idris.ASTUtils

10import Idris.Apropos (apropos, aproposModules)

11−import Idris.REPLParser

11+import Idris.REPL.Parser

12−import Idris.ElabDecls

13import Idris.Erasure

12import Idris.Erasure

14import Idris.Error

13import Idris.Error

14+import Idris.IBC

15import Idris.ErrReverse

16import Idris.Delaborate

17import Idris.Docstrings (Docstring, overview, renderDocstring, renderDocTerm)

@@ -38,6 +38,7 @@ import Idris.IBC (loadPkgIndex, writePkgIndex)

38

39import Idris.REPL.Browse (namesInNS, namespacesInNS)

40

41+import Idris.ElabDecls

41import Idris.Elab.Type

42import Idris.Elab.Type

42import Idris.Elab.Clause

43import Idris.Elab.Clause

43import Idris.Elab.Data

44import Idris.Elab.Data

@@ -690,9 +691,9 @@ reload orig inputs = do

690

691

691watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])

692watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])

692watch orig inputs = do

693watch orig inputs = do

693− let inputSet = S.fromList inputs

694− let dirs = nub $ map takeDirectory inputs

695 resp <- runIO $ do

694 resp <- runIO $ do

695+ let dirs = nub $ map takeDirectory inputs

696+ inputSet <- fmap S.fromList $ mapM canonicalizePath inputs

696 signal <- newEmptyMVar

697 signal <- newEmptyMVar

697 withManager $ \mgr -> do

698 withManager $ \mgr -> do

698 forM_ dirs $ \dir ->

699 forM_ dirs $ \dir ->

@@ -735,7 +736,7 @@ processInput cmd orig inputs efile

735 return (Just mod)

736 return (Just mod)

736 Success (Right (ModImport f)) ->

737 Success (Right (ModImport f)) ->

737 do clearErr

738 do clearErr

738− fmod <- loadModule f

739+ fmod <- loadModule f (IBC_REPL True)

739 return (Just (inputs ++ maybe [] (:[]) fmod))

740 return (Just (inputs ++ maybe [] (:[]) fmod))

740 Success (Right Edit) -> do -- takeMVar stvar

741 Success (Right Edit) -> do -- takeMVar stvar

741 edit efile orig

742 edit efile orig

@@ -817,7 +818,7 @@ process fn Warranty = iPrintResult warranty

817process fn (ChangeDirectory f)

818process fn (ChangeDirectory f)

818 = do runIO $ setCurrentDirectory f

819 = do runIO $ setCurrentDirectory f

819 return ()

820 return ()

820−process fn (ModImport f) = do fmod <- loadModule f

821+process fn (ModImport f) = do fmod <- loadModule f (IBC_REPL True)

821 case fmod of

822 case fmod of

822 Just pr -> isetPrompt pr

823 Just pr -> isetPrompt pr

823 Nothing -> iPrintError $ "Can't find import " ++ f

824 Nothing -> iPrintError $ "Can't find import " ++ f

@@ -901,8 +902,8 @@ process fn (NewDefn decls) = do

901 fixClauses :: PDecl' t -> PDecl' t

902 fixClauses :: PDecl' t -> PDecl' t

902 fixClauses (PClauses fc opts _ css@(clause:cs)) =

903 fixClauses (PClauses fc opts _ css@(clause:cs)) =

903 PClauses fc opts (getClauseName clause) css

904 PClauses fc opts (getClauseName clause) css

904− fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =

905+ fixClauses (PInstance doc argDocs syn fc constraints acc cls nfc parms ty instName decls) =

905− PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)

906+ PInstance doc argDocs syn fc constraints acc cls nfc parms ty instName (map fixClauses decls)

906 fixClauses decl = decl

907 fixClauses decl = decl

907

908

908process fn (Undefine names) = undefine names

909process fn (Undefine names) = undefine names

@@ -1089,7 +1090,7 @@ process fn (DebugInfo n)

1089 when (not (null di)) $ iputStrLn (show di)

1090 when (not (null di)) $ iputStrLn (show di)

1090 let imps = lookupCtxt n (idris_implicits i)

1091 let imps = lookupCtxt n (idris_implicits i)

1091 when (not (null imps)) $ iputStrLn (show imps)

1092 when (not (null imps)) $ iputStrLn (show imps)

1092− let d = lookupDef n (tt_ctxt i)

1093+ let d = lookupDefAcc n False (tt_ctxt i)

1093 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1094 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1094 let cg = lookupCtxtName n (idris_callgraph i)

1095 let cg = lookupCtxtName n (idris_callgraph i)

1095 i <- getIState

1096 i <- getIState

@@ -1238,12 +1239,15 @@ process fn (Compile codegen f)

1238 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

1239 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

1239 | otherwise = do opts <- getCmdLine

1240 | otherwise = do opts <- getCmdLine

1240 let iface = Interface `elem` opts

1241 let iface = Interface `elem` opts

1242+ let mainname = sNS (sUN "main") ["Main"]

1243+

1241 m <- if iface then return Nothing else

1244 m <- if iface then return Nothing else

1242 do (m', _) <- elabVal recinfo ERHS

1245 do (m', _) <- elabVal recinfo ERHS

1243 (PApp fc (PRef fc [] (sUN "run__IO"))

1246 (PApp fc (PRef fc [] (sUN "run__IO"))

1244− [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])])

1247+ [pexp $ PRef fc [] mainname])

1245 return (Just m')

1248 return (Just m')

1246 ir <- compile codegen f m

1249 ir <- compile codegen f m

1250+

1247 i <- getIState

1251 i <- getIState

1248 runIO $ generate codegen (fst (head (idris_imported i))) ir

1252 runIO $ generate codegen (fst (head (idris_imported i))) ir

1249 where fc = fileFC "main"

1253 where fc = fileFC "main"

@@ -1559,7 +1563,7 @@ loadInputs inputs toline -- furthest line to read in input source files

1559 logParser 1 ("MODULE TREE : " ++ show modTree)

1563 logParser 1 ("MODULE TREE : " ++ show modTree)

1560 logParser 1 ("RELOAD: " ++ show ifiles)

1564 logParser 1 ("RELOAD: " ++ show ifiles)

1561 when (not (all ibc ifiles) || loadCode) $

1565 when (not (all ibc ifiles) || loadCode) $

1562− tryLoad False (filter (not . ibc) ifiles)

1566+ tryLoad False IBC_Building (filter (not . ibc) ifiles)

1563 -- return the files that need rechecking

1567 -- return the files that need rechecking

1564 return (input, ifiles))

1568 return (input, ifiles))

1565 ninputs

1569 ninputs

@@ -1570,7 +1574,8 @@ loadInputs inputs toline -- furthest line to read in input source files

1570 Nothing ->

1574 Nothing ->

1571 do putIState $!! ist { idris_tyinfodata = tidata }

1575 do putIState $!! ist { idris_tyinfodata = tidata }

1572 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1576 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1577+-- logLvl 0 $ "Loading from " ++ show ibcfiles

1573− tryLoad True (mapMaybe id ibcfiles)

1578+ tryLoad True (IBC_REPL True) (mapMaybe id ibcfiles)

1574 _ -> return ()

1579 _ -> return ()

1575 exports <- findExports

1580 exports <- findExports

1576

1581

@@ -1590,9 +1595,9 @@ loadInputs inputs toline -- furthest line to read in input source files

1590 iWarn emptyFC $ pprintErr i e

1595 iWarn emptyFC $ pprintErr i e

1591 return [])

1596 return [])

1592 where -- load all files, stop if any fail

1597 where -- load all files, stop if any fail

1593− tryLoad :: Bool -> [IFileType] -> Idris ()

1598+ tryLoad :: Bool -> IBCPhase -> [IFileType] -> Idris ()

1594− tryLoad keepstate [] = warnTotality >> return ()

1599+ tryLoad keepstate phase [] = warnTotality >> return ()

1595− tryLoad keepstate (f : fs)

1600+ tryLoad keepstate phase (f : fs)

1596 = do ist <- getIState

1601 = do ist <- getIState

1597 let maxline

1602 let maxline

1598 = case toline of

1603 = case toline of

@@ -1605,7 +1610,7 @@ loadInputs inputs toline -- furthest line to read in input source files

1605 then Just l

1610 then Just l

1606 else Nothing

1611 else Nothing

1607 _ -> Nothing

1612 _ -> Nothing

1608− loadFromIFile True f maxline

1613+ loadFromIFile True phase f maxline

1609 inew <- getIState

1614 inew <- getIState

1610 -- FIXME: Save these in IBC to avoid this hack! Need to

1615 -- FIXME: Save these in IBC to avoid this hack! Need to

1611 -- preserve it all from source inputs

1616 -- preserve it all from source inputs

@@ -1623,7 +1628,7 @@ loadInputs inputs toline -- furthest line to read in input source files

1623 ist <- getIState

1628 ist <- getIState

1624 putIState $!! ist { idris_tyinfodata = tidata,

1629 putIState $!! ist { idris_tyinfodata = tidata,

1625 idris_patdefs = patdefs }

1630 idris_patdefs = patdefs }

1626− tryLoad keepstate fs

1631+ tryLoad keepstate phase fs

1627

1632

1628 ibc (IBC _ _) = True

1633 ibc (IBC _ _) = True

1629 ibc _ = False

1634 ibc _ = False

@@ -1727,13 +1732,12 @@ idrisMain opts =

1727 addPkgDir "base"

1732 addPkgDir "base"

1728 mapM_ addPkgDir pkgdirs

1733 mapM_ addPkgDir pkgdirs

1729 elabPrims

1734 elabPrims

1730− when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"

1735+ when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins" (IBC_REPL True)

1731 addAutoImport "Builtins"

1736 addAutoImport "Builtins"

1732 return ()

1737 return ()

1733− when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

1738+ when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" (IBC_REPL True)

1734 addAutoImport "Prelude"

1739 addAutoImport "Prelude"

1735 return ()

1740 return ()

1736−

1737 when (runrepl && not idesl) initScript

1741 when (runrepl && not idesl) initScript

1738

1742

1739 nobanner <- getNoBanner

1743 nobanner <- getNoBanner

@@ -1794,7 +1798,7 @@ idrisMain opts =

1794 when (runrepl && not idesl) $ do

1798 when (runrepl && not idesl) $ do

1795-- clearOrigPats

1799-- clearOrigPats

1796 startServer port orig mods

1800 startServer port orig mods

1797− runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1801+ runInputT (replSettings (Just historyFile)) $ repl (force orig) mods efile

1798 let idesock = IdemodeSocket `elem` opts

1802 let idesock = IdemodeSocket `elem` opts

1799 when (idesl) $ idemodeStart idesock orig inputs

1803 when (idesl) $ idemodeStart idesock orig inputs

1800 ok <- noErrors

1804 ok <- noErrors

src/Idris/REPLParser.hs → src/Idris/REPL/Parser.hsrenamed+1−1

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

1

2−module Idris.REPLParser (parseCmd, help, allHelp, setOptions) where

2+module Idris.REPL.Parser (parseCmd, help, allHelp, setOptions) where

3

4import System.FilePath ((</>))

5import System.Console.ANSI (Color(..))

src/Idris/Reflection.hs+4−4

@@ -364,10 +364,10 @@ reifyArithTy (P _ n _) | n == reflm "ATDouble" = return ATFloat

364reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

365

366reifyNativeTy :: Term -> ElabD NativeTy

367−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

367+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

368−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

368+reifyNativeTy (P _ n _) | n == reflm "IT16" = return IT16

369−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

369+reifyNativeTy (P _ n _) | n == reflm "IT32" = return IT32

370−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

370+reifyNativeTy (P _ n _) | n == reflm "IT64" = return IT64

371reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

372

373reifyIntTy :: Term -> ElabD IntTy

src/Pkg/PParser.hs+3−3

@@ -5,11 +5,11 @@

5module Pkg.PParser where

6

7import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)

8−

8+import qualified Text.PrettyPrint.ANSI.Leijen as PP

9import Idris.Core.TT

10import Idris.REPL

11import Idris.AbsSyntaxTree

12−import Idris.ParseHelpers hiding (stringLiteral)

12+import Idris.Parser.Helpers hiding (stringLiteral)

13import Idris.CmdOptions

14

15import Control.Monad.State.Strict

@@ -51,7 +51,7 @@ parseDesc :: FilePath -> IO PkgDesc

51parseDesc fp = do

52 p <- readFile fp

53 case runparser pPkg defaultPkg fp p of

54− Failure err -> fail (show err)

54+ Failure err -> fail (show $ PP.plain err)

55 Success x -> return x

56

57pPkg :: PParser PkgDesc

src/Pkg/Package.hs+1−1

@@ -142,7 +142,7 @@ documentPkg fp =

142 setCurrentDirectory pkgDir

143 let run l = runExceptT . execStateT l

144 load [] = return ()

145− load (f:fs) = do loadModule f; load fs

145+ load (f:fs) = do loadModule f IBC_Building; load fs

146 loader = do idrisMain opts; addImportDir (sourcedir pkgdesc); load fs

147 idrisInstance <- run loader idrisInit

148 setCurrentDirectory cd

src/Util/System.hs−4

@@ -2,7 +2,6 @@

2module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,

3 writeSource, writeSourceText, readSource,

4 setupBundledCC, isATTY) where

5−

6-- System helper functions.

5-- System helper functions.

7

6

8import Control.Exception as CE

7import Control.Exception as CE

@@ -32,9 +31,6 @@ import System.Environment (getEnv, setEnv, getExecutablePath)

32catchIO :: IO a -> (IOError -> IO a) -> IO a

31catchIO :: IO a -> (IOError -> IO a) -> IO a

33catchIO = CE.catch

32catchIO = CE.catch

34

33

35−throwIO :: IOError -> IO a

36−throwIO = CE.throw

37−

38isWindows :: Bool

34isWindows :: Bool

39isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

35isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

40

36

stack-shell.nixnew file+28

@@ -0,0 +1,28 @@

1+with (import <nixpkgs> {});

2+

3+let

4+ # MUST match resolver in stack.yaml

5+ resolver = haskell.packages.lts-4_2.ghc;

6+

7+ native_libs = [

8+ libffi

9+ zlib

10+ ncurses

11+ gmp

12+ pkgconfig

13+ ] ++ lib.optionals stdenv.isDarwin (with darwin.apple_sdk.frameworks; [

14+ Cocoa

15+ CoreServices

16+ ]);

17+

18+in stdenv.mkDerivation {

19+

20+ name = "idrisBuildEnv";

21+

22+ buildInputs = [ resolver ] ++ native_libs;

23+

24+ STACK_IN_NIX_EXTRA_ARGS = builtins.foldl'

25+ (acc: lib:

26+ " --extra-lib-dirs=${lib}/lib --extra-include-dirs=${lib}/include" + acc)

27+ "" native_libs;

28+}

stack.yaml+4−1

@@ -1,4 +1,4 @@

1−resolver: lts-3.16

1+resolver: lts-4.2

2packages:

3- '.'

4flags:

@@ -11,3 +11,6 @@ extra-deps:

11- cheapskate-0.1.0.4

12- hscurses-1.4.2.0

13- libffi-0.1

14+nix:

15+ enable: false

16+ shell-file: stack-shell.nix

test/Makefile+23−13

@@ -1,24 +1,34 @@

1−.PHONY: test test_java test_js time update diff distclean $(TESTS)

1+.PHONY: test test_js time update diff distclean $(TESTS)

2

3TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

4

5test: $(TESTS)

6

7−%.test:

8− @perl ./runtest.pl $(patsubst %.test,%,$@)

9

7

10−test_js:

8+info: runtest

11− @perl ./runtest.pl without primitives005 sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 --codegen node

9+ @./runtest all

12

10

13−update:

11+%.test: runtest

14− /usr/bin/env perl ./runtest.pl all -u

12+ @./runtest $(patsubst %.test,%,$@) -q

15

13

16−diff:

14+test_js: runtest

17− /usr/bin/env perl ./runtest.pl all -d

15+ @./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 primitives005 opts --codegen node

18

16

17+update: runtest

18+ @./runtest all -u

19+

20+diff: runtest

21+ @./runtest all -d

22+

19−time:

23+time: runtest

20− /usr/bin/env perl ./runtest.pl all -t

24+ @./runtest all -t

21

25

22distclean:

26distclean:

27+ @rm runtest

23− rm -f *~

28+ @rm -f *~

24− rm -f */output

29+ @rm -f */output

30+

31+

32+runtest:

33+ @ghc --make runtest.hs

34+ @rm runtest.o runtest.hi

test/basic001/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ reg005.idr -o reg005

2+${IDRIS:-idris} $@ reg005.idr -o reg005

3−idris $@ basic001a.idr -o basic001a

3+${IDRIS:-idris} $@ basic001a.idr -o basic001a

4./reg005

5./basic001a

6rm -f reg005 basic001a *.ibc

test/basic002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 test006.idr -o test006

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 test006.idr -o test006

3./test006

4rm -f test006 test006.ibc

test/basic003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test027.idr -o test027

2+${IDRIS:-idris} $@ test027.idr -o test027

3./test027

4rm -f test027 *.ibc

test/basic004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test016.idr -o test016

2+${IDRIS:-idris} $@ test016.idr -o test016

3./test016

4rm -f test016 *.ibc

test/basic005/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test019.lidr -o test019

2+${IDRIS:-idris} $@ test019.lidr -o test019

3./test019

4rm -f test019 *.ibc

test/basic006/run+2−2

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

1#!/usr/bin/env bash

2

3−idris --consolewidth 80 $@ test020.idr -o test020

3+${IDRIS:-idris} --consolewidth 80 $@ test020.idr -o test020

4−idris --consolewidth 80 $@ test020a.idr --check --nocolor

4+${IDRIS:-idris} --consolewidth 80 $@ test020a.idr --check --nocolor

5./test020

6rm -f test020 *.ibc

test/basic007/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o test033 test033.idr

2+${IDRIS:-idris} $@ -o test033 test033.idr

3./test033

4rm -f *.ibc test033

test/basic008/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test036.idr -o test036

2+${IDRIS:-idris} $@ test036.idr -o test036

3./test036

4rm -f test036 *.ibc

test/basic009/A.idr+1

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

1module A

2

3+public export

3num : Nat

4num : Nat

4num = 0

5num = 0

test/basic009/B/C.idr+1

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

1module B.C

2

3+public export

3num : Nat

4num : Nat

4num = 1

5num = 1

test/basic009/run+3−3

@@ -1,8 +1,8 @@

1#!/usr/bin/env bash

2

3−idris --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS

3+${IDRIS:-idris} --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS

4−idris --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

4+${IDRIS:-idris} --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

5−idris --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

5+${IDRIS:-idris} --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

6

7

8rm -f *.ibc B/*.ibc

test/basic011/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic011.idr -p contrib -o basic011

2+${IDRIS:-idris} $@ basic011.idr -p contrib -o basic011

3./basic011

4rm -f basic011 *.ibc

test/basic012/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic012.idr -o basic012

2+${IDRIS:-idris} $@ basic012.idr -o basic012

3./basic012

4rm -f basic012 *.ibc

test/basic013/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic013.idr -o basic013

2+${IDRIS:-idris} $@ basic013.idr -o basic013

3./basic013

4rm -f basic013 *.ibc

test/basic014/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ basic014.idr --check

2+${IDRIS:-idris} $@ basic014.idr --check

3rm -f *.ibc

test/basic015/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic015.idr -o basic015

2+${IDRIS:-idris} $@ basic015.idr -o basic015

3./basic015

4rm -f basic015 *.ibc

test/basic016/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ CycleA.idr --consolewidth 80 --nocolour --check

2+${IDRIS:-idris} $@ CycleA.idr --consolewidth 80 --nocolour --check

3rm -f *.ibc

test/basic017/basic017.idrnew file+25

@@ -0,0 +1,25 @@

1+%auto_implicits off

2+

3+data Vect : Nat -> Type -> Type where

4+ Nil : {a : _} -> Vect Z a

5+ (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a

6+

7+data Elem : {a, n : _} -> a -> Vect n a -> Type where

8+ Here : {x, xs : _} -> Elem x (x :: xs)

9+ There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)

10+

11+using (xs : Vect _ _)

12+ data Elem2 : {a, n : _} -> a -> Vect n a -> Type where

13+ Here2 : {x : _} -> Elem2 x (x :: xs)

14+ There2 : {x, y : _} -> Elem2 x xs -> Elem2 x (y :: xs)

15+

16+append : {n, m, a : _} -> Vect n a -> Vect m a -> Vect (n + m) a

17+append [] ys = ys

18+append (x :: xs) ys = x :: append xs ys

19+

20+%auto_implicits on

21+

22+append2 : Vect n a -> Vect m a -> Vect (n + m) a

23+append2 [] ys = ys

24+append2 (x :: xs) ys = x :: append2 xs ys

25+

test/basic017/basic017a.idrnew file+15

@@ -0,0 +1,15 @@

1+%auto_implicits off

2+

3+data Vect : Nat -> Type -> Type where

4+ Nil : {a : _} -> Vect Z a

5+ (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a

6+

7+data Elem : {a, n : _} -> a -> Vect n a -> Type where

8+ Here : {x, xs : _} -> Elem x (x :: xs)

9+ There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)

10+

11+append : Vect n a -> Vect m a -> Vect (n + m) a

12+append [] ys = ys

13+append (x :: xs) ys = x :: append xs ys

14+

15+

test/basic017/expectednew file+3

@@ -0,0 +1,3 @@

1+basic017a.idr:11:8:When checking type of Main.append:

2+When checking an application of Main.Vect:

3+ No such variable n

test/basic017/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ basic017.idr --check --nocolor

3+${IDRIS:-idris} $@ basic017a.idr --check --nocolor

4+rm -f *.ibc

test/bignum001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bignum001.idr -o bignum001

2+${IDRIS:-idris} $@ bignum001.idr -o bignum001

3./bignum001

4rm -f bignum001 *.ibc

test/bignum002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bignum002.idr -o bignum002

2+${IDRIS:-idris} $@ bignum002.idr -o bignum002

3./bignum002

4rm -f bignum002 *.ibc

test/bounded001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bounded001.idr -o bounded001

2+${IDRIS:-idris} $@ bounded001.idr -o bounded001

3./bounded001

4rm -f bounded001 *.ibc

test/classes001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

3rm -f bounded001 *.ibc

test/corecords001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ corecords001.idr -o corecords001

2+${IDRIS:-idris} $@ corecords001.idr -o corecords001

3./corecords001

4rm -f corecords001 corecords001.ibc

test/corecords002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ corecords002.idr -o corecords002

2+${IDRIS:-idris} $@ corecords002.idr -o corecords002

3./corecords002

4rm -f corecords002 corecords002.ibc

test/delab001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --quiet --nocolor delab001.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolor delab001.idr < input

3rm -f *.ibc

test/disambig002/disambig002.idr+10−12

@@ -6,7 +6,7 @@ Dec0 : Type -> Type

6Dec0 = Dec

7

8Dec1 : {A : Type} -> (P : A -> Type) -> Type

9−Dec1 {A} P = (a : A) -> Dec0 (P a)

9+Dec1 {A} P = (a : A) -> Dec0 (P a)

10

11Unique : Type -> Type

12Unique t = (p : t) -> (q : t) -> p = q

@@ -53,8 +53,8 @@ namespace Finite

53filterTag : {A : Type} ->

54 {P : A -> Type} ->

55 Dec1 P ->

56− Vect n A ->

56+ Vect n A ->

57− Sigma Nat (\ m => Vect m (Sigma A P))

57+ DPair Nat (\ m => Vect m (DPair A P))

58filterTag d1P Nil = (_ ** Nil)

59filterTag d1P (a :: as) with (filterTag d1P as)

60 | (_ ** tail) with (d1P a)

@@ -66,7 +66,7 @@ toVect : {A : Type} ->

66 {P : A -> Type} ->

67 Finite A ->

68 Dec1 P ->

69− (n : Nat ** Vect n (Sigma A P))

69+ (n : Nat ** Vect n (DPair A P))

70toVect fA d1P = filterTag d1P (toVect fA)

71

72sigmaUniqueLemma1 : {A : Type} ->

@@ -74,16 +74,14 @@ sigmaUniqueLemma1 : {A : Type} ->

74 Unique1 {t0 = A} P ->

75 (a : A) ->

76 (p : P a) ->

77− (ss : Vect n (Sigma A P)) ->

77+ (ss : Vect n (DPair A P)) ->

78− Elem a (map getWitness ss) ->

78+ Elem a (map fst ss) ->

79 Elem (a ** p) ss

80

81toVectComplete : {A : Type} ->

82 {P : A -> Type} ->

83− (fA : Finite A) ->

83+ (fA : Finite A) ->

84− (d1P : Dec1 P) ->

84+ (d1P : Dec1 P) ->

85 Unique1 {t0 = A} P ->

86− (s : Sigma A P) ->

86+ (s : DPair A P) ->

87− Elem s (getProof (toVect fA d1P))

87+ Elem s (snd (toVect fA d1P))

88−

89−

test/disambig002/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ disambig002.idr --check

2+${IDRIS:-idris} $@ disambig002.idr --check

3rm -f *.ibc

test/docs001/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs001.idr < input

2+${IDRIS:-idris} --quiet --nocolor --consolewidth 80 docs001.idr < input

3rm *.ibc

test/docs002/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input

2+${IDRIS:-idris} --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input

3rm *.ibc

test/docs003/expected+1−1

@@ -5,7 +5,7 @@ Parameters:

5 f -- a parameterised type

6

7Methods:

8− map : Functor f => (m : a -> b) -> f a -> f b

8+ map : Functor f => (func : a -> b) -> f a -> f b

9 Apply a function across everything of type 'a' in a

10 parameterised type

11

test/docs003/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet --nocolor docs003.idr < input

2+${IDRIS:-idris} --consolewidth 80 --quiet --nocolor docs003.idr < input

3rm *.ibc

test/docs004/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs004.idr < input

2+${IDRIS:-idris} --quiet --nocolor --consolewidth 80 docs004.idr < input

3rm *.ibc

test/dsl001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test001.idr -o test001

2+${IDRIS:-idris} $@ test001.idr -o test001

3./test001

4rm -f test001 test001.ibc

test/dsl001/test001.idr+1−1

@@ -45,7 +45,7 @@ using (G : Vect n Ty)

45 index_next = Pop

46

47 total

48− interp : Env G -> [static] (e : Expr G t) -> interpTy t

48+ interp : Env G -> %static (e : Expr G t) -> interpTy t

49 interp env (Var i) = lookup i env

50 interp env (Val x) = x

51 interp env (Lam sc) = \x => interp (x :: env) sc

test/dsl002/Resimp.idr+3−1

@@ -3,6 +3,8 @@ module Resimp

3import public Data.Vect

4import public Data.Fin

5

6+%access public export

7+

6-- IO operations which read a resource

8-- IO operations which read a resource

7data Reader : Type -> Type where

9data Reader : Type -> Type where

8 MkReader : IO a -> Reader a

10 MkReader : IO a -> Reader a

@@ -122,7 +124,7 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

122 ioret : a -> IO a

124 ioret : a -> IO a

123 ioret = return

125 ioret = return

124

126

125− interp : Env gam -> [static] (e : Res gam gam' t) ->

127+ interp : Env gam -> %static (e : Res gam gam' t) ->

126 (Env gam' -> interpTy t -> IO u) -> IO u

128 (Env gam' -> interpTy t -> IO u) -> IO u

127

129

128 interp env (Let val scope) k

130 interp env (Let val scope) k

test/dsl002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test014.idr -o test014

2+${IDRIS:-idris} $@ test014.idr -o test014

3./test014

4rm -f test014 Resimp.ibc test014.ibc

test/dsl003/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --nocolour --check DSLPi.idr -e test1 -e test2

2+${IDRIS:-idris} $@ --nocolour --check DSLPi.idr -e test1 -e test2

3rm -f *.ibc

test/dsl004/run+3−3

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

1#!/usr/bin/env bash

2−idris $@ Door0.idr --check

2+${IDRIS:-idris} $@ Door0.idr --check

3−idris $@ Door1.idr --check

3+${IDRIS:-idris} $@ Door1.idr --check

4−idris $@ Door2.idr --check

4+${IDRIS:-idris} $@ Door2.idr --check

5rm -f *.ibc

test/effects001/run+2−2

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

1#!/usr/bin/env bash

2−idris -p effects $@ test021.idr -o test021

2+${IDRIS:-idris} -p effects $@ test021.idr -o test021

3−idris -p effects $@ test021a.idr -o test021a

3+${IDRIS:-idris} -p effects $@ test021a.idr -o test021a

4./test021

5./test021a

6rm -f test021 test021a *.ibc

test/effects002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris -p effects $@ test025.idr -o test025

2+${IDRIS:-idris} -p effects $@ test025.idr -o test025

3./test025

4rm -f test025 *.ibc

test/effects003/VectMissing.idr+1−3

@@ -3,9 +3,7 @@ module VectMissing

3import Data.Fin

4import Data.Vect

5

6−implementation Uninhabited (Elem x []) where

6+export

7− uninhabited Here impossible

8−

9shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a

7shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a

10shrink (x :: ys) Here = ys

8shrink (x :: ys) Here = ys

11shrink (y :: []) (There p) = absurd p

9shrink (y :: []) (There p) = absurd p

test/effects003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ hangman.idr --consolewidth 80 --nocolour -p effects -o hangman

2+${IDRIS:-idris} $@ hangman.idr --consolewidth 80 --nocolour -p effects -o hangman

3./hangman < input

4rm -f hangman *.ibc

test/effects004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ effects004.idr -o effects004 -p effects

2+${IDRIS:-idris} $@ effects004.idr -o effects004 -p effects

3./effects004 < input

4rm -f effects004 *.ibc

test/effects005/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ defaultLogger.idr -o default -p effects

2+${IDRIS:-idris} $@ defaultLogger.idr -o default -p effects

3./default

4−idris $@ categoryLogger.idr -o category -p effects

4+${IDRIS:-idris} $@ categoryLogger.idr -o category -p effects

5./category

6rm -f default category *.ibc

test/error001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ test002.idr --check --noprelude --consolewidth 70

2+${IDRIS:-idris} $@ test002.idr --check --noprelude --consolewidth 70

3rm -f *.ibc

test/error002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test031.idr -o test031

2+${IDRIS:-idris} $@ test031.idr -o test031

3./test031

4rm -f test031 *.ibc

test/error003/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ ErrorReflection.idr --nocolour --check

2+${IDRIS:-idris} --consolewidth 80 $@ ErrorReflection.idr --nocolour --check

3rm -f *.ibc

test/error004/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ FunErrTest.idr --nocolour --check

2+${IDRIS:-idris} --consolewidth 80 $@ FunErrTest.idr --nocolour --check

3rm -f *.ibc

test/error005/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour error005.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour error005.idr

3rm -f *.ibc

test/error006/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour WithPatsNoWith.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour WithPatsNoWith.idr

3rm -f *.ibc

test/ffi001/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --nocolour test022.idr --exec main

2+${IDRIS:-idris} --quiet --nocolour test022.idr --exec main

3rm -f *.ibc

test/ffi002/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet test023.idr -o test023

2+${IDRIS:-idris} --consolewidth 80 --quiet test023.idr -o test023

3rm -f test023 *.ibc

test/ffi003/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --nocolour test024.idr --exec main < input

2+${IDRIS:-idris} --quiet --nocolour test024.idr --exec main < input

3rm -f *.ibc

test/ffi004/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --nocolour --check test026.idr

2+${IDRIS:-idris} --quiet --nocolour --check test026.idr

3rm -f *.ibc

test/ffi005/run+1−1

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

1#!/usr/bin/env bash

2

3−idris $@ Postulate.idr -o postulate

3+${IDRIS:-idris} $@ Postulate.idr -o postulate

4./postulate

5rm -f postulate *.ibc

test/ffi006/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ ffi006.idr --interface -o ffi006.o

2+${IDRIS:-idris} $@ ffi006.idr --interface -o ffi006.o

3${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006

4./ffi006

5rm -f ffi006 *.ibc *.o *.h

test/ffi007/expectednew file+8

@@ -0,0 +1,8 @@

1+8

2+5

3+Before calling callback

4+In an Idris callback

5+After calling callback

6+00000377

7+I'm dynamic 3

8+6

test/ffi007/ffi007.cnew file+30

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

1+#include <stdio.h>

2+

3+typedef int (*callback)(int);

4+typedef int (*cb2)(char *);

5+

6+void test_ffi(callback cb)

7+{

8+ printf("%d\n", cb(3));

9+}

10+

11+void test_ffi2(cb2 cb)

12+{

13+ printf("%d\n", cb("hello"));

14+}

15+

16+void test_ffi3(void (*cb)(void))

17+{

18+ printf("Before calling callback\n");

19+ cb();

20+ printf("After calling callback\n");

21+}

22+

23+int dynamic_fn(int i) {

24+ printf("I'm dynamic %d\n", i);

25+ return i*2;

26+}

27+

28+callback test_ffi6(void) {

29+ return &dynamic_fn;

30+}

test/ffi007/ffi007.hnew file+11

@@ -0,0 +1,11 @@

1+#include <stdint.h>

2+typedef int (*callback)(int);

3+

4+int32_t testvar = 887;

5+

6+void test_ffi(int (*cb)(int));

7+

8+void test_ffi2(int (*cb)(char*));

9+void test_ffi3(void (*cb)(void));

10+

11+callback test_ffi6(void);

test/ffi007/ffi007.idrnew file+49

@@ -0,0 +1,49 @@

1+module Main

2+

3+%include c "ffi007.h"

4+

5+getInt : Int -> Int

6+getInt _ = 8

7+

8+test : IO ()

9+test = foreign FFI_C "test_ffi" (CFnPtr (Int -> Int) -> IO ()) (MkCFnPtr getInt)

10+

11+strLen : String -> Int

12+strLen s = cast $ length s

13+

14+test2 : IO ()

15+test2 = foreign FFI_C "test_ffi2" (CFnPtr (String -> Int) -> IO ()) (MkCFnPtr strLen)

16+

17+-- Do IO

18+printIt : () -> ()

19+printIt _ = unsafePerformIO $ do

20+ putStrLn "In an Idris callback"

21+

22+test3 : IO ()

23+test3 = foreign FFI_C "test_ffi3" (CFnPtr (() -> ()) -> IO ()) (MkCFnPtr printIt)

24+

25+test4 : IO Ptr

26+test4 = foreign FFI_C "%wrapper" (CFnPtr (() -> ()) -> IO Ptr) (MkCFnPtr printIt)

27+

28+test5 : IO Ptr

29+test5 = foreign FFI_C "&testvar" (IO Ptr)

30+

31+test6 : IO Ptr

32+test6 = foreign FFI_C "test_ffi6" (IO Ptr)

33+

34+test7 : Ptr -> Int -> IO Int

35+test7 fnptr i = foreign FFI_C "%dynamic" (Ptr -> Int -> IO Int) fnptr i

36+

37+main : IO ()

38+main = do

39+ test

40+ test2

41+ test3

42+ ptr <- test4

43+ tv <- test5

44+ val <- prim_peek32 tv 0

45+ printLn val

46+ fptr <- test6

47+ i <- test7 fptr 3

48+ printLn i

49+ return ()

test/ffi007/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ ffi007.idr -o ffi007 --cg-opt "ffi007.c"

3+./ffi007

4+rm -f ffi007 *.ibc

test/folding001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ folding001.idr -o folding001

2+${IDRIS:-idris} $@ folding001.idr -o folding001

3./folding001

4rm -f folding001 *.ibc

test/idrisdoc001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2# Tests that no documentation is built for empty and/or private-only namespaces

3−idris --mkdoc test_empty.ipkg

3+${IDRIS:-idris} --mkdoc test_empty.ipkg

4rm -rf *.ibc *_doc

test/idrisdoc002/TestFunctions.idr+2−1

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

1module TestFunctions

2

3||| Test function

4+public export

4test : ()

5test : ()

5−test = ()

6+test = ()

test/idrisdoc002/run+1−1

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

1#!/usr/bin/env bash

2# Tests that documentation is generated for functions

3−idris --mkdoc test_functions.ipkg

3+${IDRIS:-idris} --mkdoc test_functions.ipkg

4[ -d test_functions_doc ] && echo "Functions are documented"

5rm -rf *.ibc *_doc

test/idrisdoc003/TestDatatypes.idr+2−1

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

1module TestDatatypes

2

3||| This is another test

4+public export

4data Test : Type where

5data Test : Type where

5 ||| Test constructor

6 ||| Test constructor

6− ATest : Test

7+ ATest : Test

test/idrisdoc003/run+1−1

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

1#!/usr/bin/env bash

2# Tests that documentation is generated for data types

3−idris --mkdoc test_datatypes.ipkg

3+${IDRIS:-idris} --mkdoc test_datatypes.ipkg

4[ -d test_datatypes_doc ] && echo "Data types are documented"

5rm -rf *.ibc *_doc

test/idrisdoc004/TestTypeclasses.idr+1

@@ -3,6 +3,7 @@ module TestTypeclasses

3||| This is a test

4|||

5||| @ a Test arg

6+public export

6interface Test a where

7interface Test a where

7 ||| Test function

8 ||| Test function

8 test : a -> Int

9 test : a -> Int

test/idrisdoc004/run+1−1

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

1#!/usr/bin/env bash

2# Tests that documentation is generated for typeclasses

3−idris --mkdoc test_typeclasses.ipkg

3+${IDRIS:-idris} --mkdoc test_typeclasses.ipkg

4[ -d test_typeclasses_doc ] && echo "Typeclasses are documented"

5rm -rf *.ibc *_doc

test/idrisdoc005/TestTracing.idr+2−1

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

1module TestTracing

2

3+public export

3test : Bool

4test : Bool

4−test = True

5+test = True

test/idrisdoc005/run+1−1

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

1#!/usr/bin/env bash

2# Tests that references to other namespaces are traced

3−idris --mkdoc test_tracing.ipkg

3+${IDRIS:-idris} --mkdoc test_tracing.ipkg

4[ -f test_tracing_doc/docs/TestTracing.html ] && echo "TestTracing: Check"

5[ -f test_tracing_doc/docs/Prelude.Bool.html ] && echo "Prelude.Bool: Check"

6rm -rf *.ibc *_doc

test/idrisdoc006/A/fully/Qualified/NAME.idr+2−2

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

1module A.fully.Qualified.NAME

2

3||| This is another test

4−data Test : Type where

4+public export data Test : Type where

5 ||| Test constructor

6− ATest : Test

6+ ATest : Test

test/idrisdoc006/B.idr+2−1

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

1module B

2

3||| Test function

4+public export

4test : ()

5test : ()

5−test = ()

6+test = ()

test/idrisdoc006/run+2−2

@@ -1,8 +1,8 @@

1#!/usr/bin/env bash

2# Tests that documentation properly is merged with existent.

3−idris --mkdoc package_a.ipkg

3+${IDRIS:-idris} --mkdoc package_a.ipkg

4[ -f test_merge_doc/IdrisDoc ] && echo "IdrisDoc file written"

5−idris --mkdoc package_b.ipkg

5+${IDRIS:-idris} --mkdoc package_b.ipkg

6ls -1p test_merge_doc/docs

7if grep -q "href\\=\"docs/A.fully.Qualified.NAME\\.html\"" test_merge_doc/index.html; then

8 echo A.fully.Qualified.NAME is in the index

test/idrisdoc007/run+1−1

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

1#!/usr/bin/env bash

2# Tests that documentation only is written when safe

3mkdir do_not_delete_doc

4−idris --mkdoc package.ipkg > nowhere

4+${IDRIS:-idris} --mkdoc package.ipkg > nowhere

5echo Exit status $expects 1$: $?

6rm -rf do_not_delete_doc *.ibc nowhere

test/idrisdoc008/Abstract.idr+2−2

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

1module Abstract

2

3−abstract

3+export

4frozen : ()

5−frozen = ()

5+frozen = ()

test/idrisdoc008/Visible.idr+2−2

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

1module Visible

2

3−public

3+public export

4visible : ()

5−visible = ()

5+visible = ()

test/idrisdoc008/run+1−1

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

1#!/usr/bin/env bash

2# Tests that documentation is generated for both public and abstract members.

3−idris --mkdoc visibility.ipkg

3+${IDRIS:-idris} --mkdoc visibility.ipkg

4[ -f visibility_doc/docs/Abstract.html ] && echo "Abstract members are documented"

5[ -f visibility_doc/docs/Visible.html ] && echo "Public members are documented"

6rm -rf *.ibc *_doc

test/idrisdoc009/Test.idr+2

@@ -23,6 +23,8 @@

23module Test

24import Data.Complex

25

26+%access public export

27+

26myplus : Nat -> Nat -> Nat

28myplus : Nat -> Nat -> Nat

27myplus Z j = j

29myplus Z j = j

28myplus (S k) j = S (myplus k j)

30myplus (S k) j = S (myplus k j)

test/idrisdoc009/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --nocolour --quiet Test.idr < input

2+${IDRIS:-idris} $@ --nocolour --quiet Test.idr < input

3rm -f *.ibc

test/interactive001/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet test032.idr < input

2+${IDRIS:-idris} --quiet test032.idr < input

3rm -f *.ibc

test/interactive002/expected+1−1

@@ -5,6 +5,6 @@ Nat

5Vect (n + m) a

6Nat

7Nat

8−S n

8+(S n)

9String

10()

test/interactive002/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet interactive002.idr < input

2+${IDRIS:-idris} --quiet interactive002.idr < input

3rm -f *.ibc

test/interactive003/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet interactive003.idr < input

2+${IDRIS:-idris} --quiet interactive003.idr < input

3rm -f *.ibc

test/interactive004/expected+1−1

@@ -1,2 +1,2 @@

1plus ?foo_rhs2 ?foo_rhs3

2−append k m ?append_rhs2 ?append_rhs3

2+(append k m ?append_rhs2 ?append_rhs3)

test/interactive004/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet interactive004.idr < input

2+${IDRIS:-idris} --quiet interactive004.idr < input

3rm -f *.ibc

test/interactive005/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --quiet interactive005.idr --consolewidth 70 < input

2+${IDRIS:-idris} --nocolour --quiet interactive005.idr --consolewidth 70 < input

3rm -f *.ibc

4rm -f hello.bytecode

5rm -f hello

test/interactive006/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet --port 5000 interactive006.idr < input

2+${IDRIS:-idris} --quiet --port 5000 interactive006.idr < input

3rm -f *.ibc

test/interactive007/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris -p contrib --nobanner --nocolor < input

2+${IDRIS:-idris} -p contrib --nobanner --nocolor < input

test/interactive008/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --nobanner --nocolor < input

2+${IDRIS:-idris} --nobanner --nocolor < input

test/interactive009/expected+1−1

@@ -1 +1 @@

1−IsSetCons pf prfRec

1+(IsSetCons pf prfRec)

test/interactive009/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet interactive009.idr < input

2+${IDRIS:-idris} --quiet interactive009.idr < input

3rm -f *.ibc

test/interactive010/expected+3−3

@@ -1,12 +1,12 @@

1Prelude.List.(++) : List a -> List a -> List a

2Prelude.Strings.(++) : String -> String -> String

3−a is not an implicit argument of Prelude.Classes./

3+a is not an implicit argument of Prelude.Interfaces./

4Usage is :doc <functionname>

5Usage is :wc <functionname>

6Usage is :printdef <functionname>

7−pat {ty504} : Type u. pat {__class505} : Prelude.Classes.Fractional {ty504}. Prelude.Classes./ {ty504} {__class505}

7+pat {ty504} : Type u. pat {__class505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__class505}

8

9− : pty {ty504} : Type u. pty {__class505} : Prelude.Classes.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}

9+ : pty {ty504} : Type u. pty {__class505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}

10(input):1:1: error: expected: ":",

11 dependent type signature,

12 end of input

test/interactive010/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --quiet --nobanner --nocolor --consolewidth 80 < input

2+${IDRIS:-idris} --quiet --nobanner --nocolor --consolewidth 80 < input

test/interactive011/run+1−1

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

1#!/usr/bin/env bash

2−idris --quiet interactive011.idr < input

2+${IDRIS:-idris} --quiet interactive011.idr < input

3rm -f *.ibc

test/interactive012/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 70 --quiet interactive012.idr < input

2+${IDRIS:-idris} --nocolour --consolewidth 70 --quiet interactive012.idr < input

3rm -f *.ibc

test/io001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test004.idr -o test004

2+${IDRIS:-idris} $@ test004.idr -o test004

3./test004

4rm -f test004 test004.ibc testfile

test/io001/test004.idr+1−1

@@ -17,7 +17,7 @@ dumpFile fn = do { Right h <- openFile fn Read

17 closeFile h }

18

19main : IO ()

20−main = do { Right h <- openFile "testfile" Write

20+main = do { Right h <- openFile "testfile" WriteTruncate

21 fPutStr h "Hello!\nWorld!\n...\n3\n4\nLast line\n"

22 closeFile h

23 putStrLn "Reading testfile"

test/io002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test008.idr -o test008

2+${IDRIS:-idris} $@ test008.idr -o test008

3./test008

4rm -f test008 test008.ibc

test/io003/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ test018.idr -p contrib -o test018

2+${IDRIS:-idris} $@ test018.idr -p contrib -o test018

3−idris $@ test018a.idr -p contrib -o test018a

3+${IDRIS:-idris} $@ test018a.idr -p contrib -o test018a

4./test018

5#./test018a

6rm -f test018 test018a *.ibc

test/literate001/Lit.lidr+2−2

@@ -2,12 +2,12 @@

2

3Test some string primitives while we're at it

4

5−> st : String

5+> export st : String

6> st = "abcdefg"

7

8Literate main program

9

10−> main : IO ()

10+> export main : IO ()

11> main = do { putStrLn (show (strHead st))

12> putStrLn (show (strIndex st 3))

13> putStrLn (strCons 'z' st)

test/literate001/run+2−2

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test003a.lidr --check

2+${IDRIS:-idris} --consolewidth 80 $@ test003a.lidr --check

3−idris --consolewidth 80 $@ test003.lidr -o test003

3+${IDRIS:-idris} --consolewidth 80 $@ test003.lidr -o test003

4./test003

5rm -f test003 test003.ibc Lit.ibc

test/meta001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check --nocolour --consolewidth 70 Finite.idr

2+${IDRIS:-idris} $@ --check --nocolour --consolewidth 70 Finite.idr

3rm -f *.ibc

test/meta002/AgdaStyleReflection.idr+94−9

@@ -2,6 +2,10 @@

2||| Idris's reflected elaboration. Requires handling type class

3||| resolution and implicit arguments - some of the same features as

4||| the Idris elaborator itself.

5+|||

6+||| Since this test was put together, Agda has adopted an Idris-style

7+||| elaborator reflection mechanism. The module name is preserved for

8+||| historical interest.

5module AgdaStyleReflection

9module AgdaStyleReflection

6

10

7

11

@@ -11,6 +15,7 @@ import Pruviloj

11%default total

15%default total

12

16

13

17

18+

14||| Function arguments as provided at the application site

19||| Function arguments as provided at the application site

15record Arg a where

20record Arg a where

16 constructor MkArg

21 constructor MkArg

@@ -20,6 +25,10 @@ record Arg a where

20implementation Functor Arg where

25implementation Functor Arg where

21 map f (MkArg plic x) = MkArg plic (f x)

26 map f (MkArg plic x) = MkArg plic (f x)

22

27

28+implementation Show a => Show (Arg a) where

29+ showPrec d (MkArg plic x) = showCon d "MkArg" $ showArg plic ++ showArg x

30+

31+

23||| Reflected terms, in the tradition of Agda's reflection library

32||| Reflected terms, in the tradition of Agda's reflection library

24data Term

33data Term

25 = Var Nat (List (Arg Term))

34 = Var Nat (List (Arg Term))

@@ -37,6 +46,41 @@ unApply tm = unApply' tm []

37 unApply' (RApp f x) xs = unApply' f (x::xs)

46 unApply' (RApp f x) xs = unApply' f (x::xs)

38 unApply' notApp xs = (notApp, xs)

47 unApply' notApp xs = (notApp, xs)

39

48

49+

50+implementation Quotable Plicity Raw where

51+ quotedTy = `(Plicity)

52+ quote Explicit = `(Explicit)

53+ quote Implicit = `(Implicit)

54+ quote Constraint = `(Constraint)

55+

56+implementation (Quotable a Raw) => Quotable (Arg a) Raw where

57+ quotedTy = `(Arg ~(quotedTy {a=a}))

58+ quote (MkArg plicity argValue) =

59+ `(MkArg {a=~(quotedTy {a=a})} ~(quote plicity) ~(quote argValue))

60+

61+

62+implementation Quotable Term Raw where

63+ quotedTy = `(Term)

64+ quote (Var k xs) = `(AgdaStyleReflection.Var ~(quote k) ~(assert_total $ quote xs))

65+ quote (Ctor n xs) = `(AgdaStyleReflection.Ctor ~(quote n) ~(assert_total $ quote xs))

66+ quote (TyCtor n xs) = `(AgdaStyleReflection.TyCtor ~(quote n) ~(assert_total $ quote xs))

67+ quote (Def n xs) = `(Def ~(quote n) ~(assert_total $ quote xs))

68+ quote (Lam x) = `(AgdaStyleReflection.Lam ~(quote x))

69+ quote (Pi x y) = `(AgdaStyleReflection.Pi ~(quote x) ~(quote y))

70+ quote (Constant c) = `(Constant ~(quote c))

71+ quote Ty = `(Ty)

72+

73+

74+implementation Show Term where

75+ showPrec d (Var k xs) = showCon d "Var" $ showArg k ++ showArg xs

76+ showPrec d (Ctor n xs) = showCon d "Ctor" $ showArg n ++ showArg xs

77+ showPrec d (TyCtor n xs) = showCon d "TyCtor" $ showArg n ++ showArg xs

78+ showPrec d (Def n xs) = showCon d "Def" $ showArg n ++ showArg xs

79+ showPrec d (Lam x) = showCon d "Lam" $ showArg x

80+ showPrec d (Pi x y) = showCon d "Pi" $ showArg x ++ showArg y

81+ showPrec d (Constant c) = showCon d "Constant" $ showArg c

82+ showPrec d Ty = "Ty"

83+

40||| Quote a reflected Idris term to a Term in some induced local context

84||| Quote a reflected Idris term to a Term in some induced local context

41covering

85covering

42quoteTerm' : List TTName -> Raw -> Elab Term

86quoteTerm' : List TTName -> Raw -> Elab Term

@@ -183,16 +227,39 @@ covering

183spliceTerm : Term -> Elab ()

227spliceTerm : Term -> Elab ()

184spliceTerm = spliceTerm' []

228spliceTerm = spliceTerm' []

185

229

186−||| Lift an Agda-style tactic into an Idris-style tactic

230+syntax "splice" [tm] = %runElab (spliceTerm tm)

231+

187covering

232covering

188−quoteGoalImpl : (Term -> Term) -> Elab ()

233+quoteGoalImpl : TTName -> Elab ()

189−quoteGoalImpl f = do compute

234+quoteGoalImpl f =

235+ do g <- goalType >>= quoteTerm

236+ fill (RApp (Var f) (quote g))

237+ solve

238+

239+syntax "quoteGoal" {g} "in" [e] =

240+ let f = \g : Term => e in %runElab (quoteGoalImpl `{f})

241+

242+

243+-- Note: this definition would seem to be the right thing, but it's not:

244+-- syntax "tactic" [tac] = quoteGoal g in splice tac g

245+-- This is because it would make

246+-- tactic foo

247+-- expand to

248+-- let f = \g : Term => %runElab (spliceTerm (tac g))

249+-- in %runElab (quoteGoalImpl `{f})

250+-- which confuses the meta-level at which the body of the lambda should be

251+-- run. It must be sequenced into the same monadic action as quoting the goal,

252+-- yielding the following implementation:

253+

254+covering

255+tacticImpl : (tac : Term -> Term) -> Elab ()

190− g <- goalType >>= quoteTerm

256+tacticImpl tac = do g <- goalType >>= quoteTerm

191− spliceTerm (f g)

257+ AgdaStyleReflection.spliceTerm (tac g)

258+

259+syntax "tactic" [tacticCode] =

260+ %runElab (tacticImpl tacticCode)

192

261

193−syntax "quoteGoal" {x} "in" [expr] = %runElab (quoteGoalImpl (\x => expr))

194

262

195−syntax "tactic" [expr] = %runElab (quoteGoalImpl expr)

196

263

197

264

198

265

@@ -231,12 +298,30 @@ covering

231trivial : (goal : Term) -> Term

298trivial : (goal : Term) -> Term

232trivial = perhaps . trivial'

299trivial = perhaps . trivial'

233

300

301+-- DOESN'T WORK because reflection operations are not pure - they have

302+-- side effects in the elaborator! Also due to metalevel confusion in

303+-- underlying syntax

234−foo : (Nat, (), Nat, Either (() -> ()) Void)

304+--foo : (Nat, (), Either Void Nat, Nat -> ())

235−foo = quoteGoal x in trivial x

305+--foo = quoteGoal g in splice (trivial g)

236

306

307+

308+-- WORKS because "tactic" takes care of the sequencing of operations

237bar : (Nat, (), Either Void Nat, Nat -> ())

309bar : (Nat, (), Either Void Nat, Nat -> ())

238bar = tactic trivial

310bar = tactic trivial

239

311

312+someTerm : Term

313+someTerm = quoteGoal g in g

314+

315+ok : AgdaStyleReflection.someTerm = TyCtor (NS (UN "Term") ["AgdaStyleReflection"]) []

316+ok = Refl

317+

318+-- assert_total needed due to partial Show implementations

319+stringly : String -> String

320+stringly = quoteGoal g in \x => assert_total $ show g

321+

322+ok2 : stringly "fnord" = "Pi (Constant StrType) (Constant StrType)"

323+ok2 = Refl

324+

240-- When checking right hand side of baz:

325-- When checking right hand side of baz:

241-- PROOF SEARCH FAILURE is not defined.

326-- PROOF SEARCH FAILURE is not defined.

242baz : (Nat, Void)

327baz : (Nat, Void)

test/meta002/Tacs.idr+4−5

@@ -208,7 +208,7 @@ namespace STLC

208

209 -- Now we put this hole variable into our sigma constructor

210 -- prior to elaboration, so it doesn't disappear too soon

211− fill `(MkSigma ~(Var tH) ~(Var tmH) : Sigma Ty (Tm []))

211+ fill `(MkDPair ~(Var tH) ~(Var tmH) : DPair Ty (Tm []))

212 solve

213 focus tmH

214 mkTerm [] tm

@@ -287,18 +287,17 @@ namespace STLC

287 apply `(UnitCon {env=~(Var envH)})

288 []

289 solve

290− testElab : Sigma Ty (Tm [])

290+ testElab : DPair Ty (Tm [])

291 testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon))

292

293− testElab2 : Sigma Ty (Tm [])

293+ testElab2 : DPair Ty (Tm [])

294 testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))

295

296 -- Doesn't work! :-)

297− testElab3 : Sigma Ty (Tm [])

297+ testElab3 : DPair Ty (Tm [])

298 testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))

299 (Lam "x" (App (Var 0) (Var 0)))))

300 -- Error is:

301 -- Tacs.idr line 247 col 14:

302 -- When elaborating right hand side of testElab3:

303 -- Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value

304−

test/meta002/expected+2−2

@@ -1,9 +1,9 @@

1Tacs.idr:298:15:

2When checking right hand side of testElab3 with expected type

3− Sigma Ty (Tm [])

3+ DPair Ty (Tm [])

4

5Unifying ty and ARR ty t would lead to infinite value

6−AgdaStyleReflection.idr:243:5:

6+AgdaStyleReflection.idr:328:5:

7When checking right hand side of baz with expected type

8 (Nat, Void)

9

test/meta002/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

2+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

3−idris $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

3+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

4# Disabled due to excess memory consumption

5# idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr

6rm -f *.ibc

test/meta003/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --nocolour --check --consolewidth 70 BadDef.idr

2+${IDRIS:-idris} $@ --nocolour --check --consolewidth 70 BadDef.idr

3rm -f *.ibc

test/meta004/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr

2+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr

3rm -f *.ibc

test/mktest.pl+1−1

@@ -13,7 +13,7 @@ chdir($test);

13open(FOO,">run");

14

15print FOO "#!/usr/bin/env bash\n";

16−print FOO "idris \$@ $test.idr -o $test\n";

16+print FOO "${IDRIS:-idris} \$@ $test.idr -o $test\n";

17print FOO "./$test\n";print FOO "rm -f $test *.ibc\n";

18

19close(FOO);

test/pkg001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --build test.ipkg

2+${IDRIS:-idris} $@ --build test.ipkg

3rm -f *.ibc

test/pkg002/run+1−1

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

1#!/usr/bin/env bash

2### Test: IPKG executable names can be any namespaced identifier.

3−idris $@ --build test.ipkg

3+${IDRIS:-idris} $@ --build test.ipkg

4rm -f *.ibc

5rm -f some.namespaced.identifier

test/pkg003/run+1−1

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

1#!/usr/bin/env bash

2### Test: IPKG executable names can be a quoted string

3### containing a valid filename.

4−idris $@ --build test.ipkg

4+${IDRIS:-idris} $@ --build test.ipkg

5rm -f *.ibc

6rm -f 'quoting-allows-hyphens and spaces and fun stuff!'

test/pkg004/expected+3−3

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

1−Uncaught error: user error ([1mtest.ipkg[0m:[1m10[0m:[1m1[0m: [91merror[0m: filename

1+Uncaught error: user error (test.ipkg:9:1: error: filename

2 must contain no directory

3 component, expected: space

4−[1m[94m<EOF>[0;1m[0m

4+<EOF>

5−[92m^[0m )

5+^ )

test/pkg004/run+1−1

@@ -2,5 +2,5 @@

2### Test: IPKG executable names CANNOT include a directory separator.

3# TODO: Verify that a name like "a/b\c" is rejected by both *NIX and Windows

4# (assuming these tests get run on Windows).

5−idris $@ --consolewidth 80 --nobanner --nocolor --build test.ipkg

5+${IDRIS:-idris} $@ --build test.ipkg

6rm -f *.ibc

test/pkg004/test.ipkg−1

@@ -2,7 +2,6 @@ package test

2

3modules = Main

4

5−

6opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"

5opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"

7

6

8main = Main

7main = Main

test/primitives001/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ test005.idr -o test005

2+${IDRIS:-idris} $@ test005.idr -o test005

3./test005

4−idris $@ substring.idr -o substring

4+${IDRIS:-idris} $@ substring.idr -o substring

5./substring < input

6rm -f test005 substring *.ibc

test/primitives003/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ -o test038 test038.idr --nocolour

2+${IDRIS:-idris} $@ -o test038 test038.idr --nocolour

3./test038

4rm -f test038 *.ibc

5

test/primitives004-disabled/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o primitives004 primitives004.idr --nocolour

2+${IDRIS:-idris} $@ -o primitives004 primitives004.idr --nocolour

3./primitives004

4rm -f primitives004 *.ibc

test/primitives005/expectednew file+2

@@ -0,0 +1,2 @@

1+04030201

2+000000000000FFFF

test/primitives005/primitives005.idrnew file+24

@@ -0,0 +1,24 @@

1+module Main

2+

3+%include C "memory.h"

4+

5+-- use calloc to ensure zeroed out memory

6+malloc : Int -> IO Ptr

7+malloc size = foreign FFI_C "calloc" (Int -> Int -> IO Ptr) size 1

8+

9+free : Ptr -> IO ()

10+free ptr = foreign FFI_C "free" (Ptr -> IO ()) ptr

11+

12+main : IO ()

13+main = do

14+ p <- malloc 1000

15+ prim_poke16 p 0 0xffff

16+ prim_poke8 p 8 1

17+ prim_poke8 p 9 2

18+ prim_poke8 p 10 3

19+ prim_poke8 p 11 4

20+ a <- prim_peek32 p 8

21+ b <- prim_peek64 p 0

22+ printLn a

23+ printLn b

24+ free p

test/primitives005/runnew file+5

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

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ -o p005 primitives005.idr --nocolour

3+./p005

4+rm -f p005 *.ibc

5+

test/proof001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ test029.idr --consolewidth 80 --nocolour --check test029

2+${IDRIS:-idris} $@ test029.idr --consolewidth 80 --nocolour --check test029

3rm -f *.ibc

test/proof002/Reflect.idr+3−4

@@ -2,6 +2,7 @@ module Reflect

2

3import Decidable.Equality

4

5+%access public export

5%default total

6%default total

6

7

7using (xs : List a, ys : List a, G : List (List a))

8using (xs : List a, ys : List a, G : List (List a))

@@ -43,7 +44,7 @@ using (xs : List a, ys : List a, G : List (List a))

43 let (yl ** (yr, yprf)) = expr_r ey in

44 let (yl ** (yr, yprf)) = expr_r ey in

44 appRExpr _ _ xr yr xprf yprf

45 appRExpr _ _ xr yr xprf yprf

45 where

46 where

46− appRExpr : (xs', ys' : List a) ->

47+ appRExpr : (xs', ys' : List a) ->

47 {G : List (List a)} -> {xs, ys : List a} ->

48 {G : List (List a)} -> {xs, ys : List a} ->

48 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

49 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

49 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

50 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

@@ -205,6 +206,4 @@ Reflect.bp1 = proof {

205-- prover.

206-- prover.

206

207

207syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in

208syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in

208− getJust (prove (getProof x)) ItIsJust

209+ getJust (prove (snd x)) ItIsJust

209−

210−

test/proof002/expected+4−4

@@ -1,8 +1,8 @@

1−Reflect.idr:173:21-26:

1+Reflect.idr:174:21-26:

2This style of tactic proof is deprecated. See %runElab for the replacement.

3−Reflect.idr:182:21-26:

3+Reflect.idr:183:21-26:

4This style of tactic proof is deprecated. See %runElab for the replacement.

5−Reflect.idr:190:15-20:

5+Reflect.idr:191:15-20:

6This style of tactic proof is deprecated. See %runElab for the replacement.

7test030a.idr:12:26-14:1:

8When checking right hand side of testReflect1 with expected type

@@ -12,7 +12,7 @@ When checking an application of function Reflect.getJust:

12 Type mismatch between

13 IsJust (Just x1) (Type of ItIsJust)

14 and

15− IsJust (prove (getProof x)) (Expected type)

15+ IsJust (prove (snd x)) (Expected type)

16

17 Specifically:

18 Type mismatch between

test/proof002/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test030.idr --check --nocolour

2+${IDRIS:-idris} --consolewidth 80 $@ test030.idr --check --nocolour

3−idris --consolewidth 80 $@ test030a.idr --check --nocolour

3+${IDRIS:-idris} --consolewidth 80 $@ test030a.idr --check --nocolour

4rm -f *.ibc

test/proof002/test030.idr−1

@@ -10,4 +10,3 @@ total

10testReflect1 : (xs, ys : List a) ->

11 ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12testReflect1 {a} xs ys = AssocProof a

13−

test/proof003/Parity.idr+2

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

1module Parity

2

3+%access public export

4+

3data Parity : Nat -> Type where

5data Parity : Nat -> Type where

4 Even : {n : Nat} -> Parity (n + n)

6 Even : {n : Nat} -> Parity (n + n)

5 Odd : {n : Nat} -> Parity (S (n + n))

7 Odd : {n : Nat} -> Parity (S (n + n))

test/proof003/expected+2−2

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

1−Parity.idr:15:18-23:

1+Parity.idr:17:18-23:

2This style of tactic proof is deprecated. See %runElab for the replacement.

3−Parity.idr:22:18-23:

3+Parity.idr:24:18-23:

4This style of tactic proof is deprecated. See %runElab for the replacement.

5test015.idr:88:15-20:

6This style of tactic proof is deprecated. See %runElab for the replacement.

test/proof003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test015.idr --nocolour --consolewidth 80 -o test015

2+${IDRIS:-idris} $@ test015.idr --nocolour --consolewidth 80 -o test015

3./test015

4rm -f test015 Parity.ibc test015.ibc

test/proof004/run+1−1

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

1#!/usr/bin/env bash

2−idris --check $@ test035.idr

2+${IDRIS:-idris} --check $@ test035.idr

3rm -f *.ibc

test/proof005/run+1−1

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

1#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSuccess.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSuccess.idr

3rm -f *.ibc

test/proof006/run+1−1

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

1#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSyntax.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSyntax.idr

3rm -f *.ibc

test/proof007/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

3rm -f *.ibc

test/proof008/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr

3rm -f *.ibc

test/proof009/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --consolewidth 70 --quiet proof009.idr < input

2+${IDRIS:-idris} $@ --consolewidth 70 --quiet proof009.idr < input

3rm -f *.ibc

test/proof010/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ proof010.idr -o proof010

2+${IDRIS:-idris} $@ proof010.idr -o proof010

3./proof010

4rm -f proof010 *.ibc

test/proofsearch001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check proofsearch001.idr

2+${IDRIS:-idris} $@ --check proofsearch001.idr

3rm -f *.ibc

test/proofsearch002/Process.idr+1−1

@@ -3,7 +3,7 @@ module Process

3import System.Concurrency.Raw

4import public Data.List -- public, to get proof search machinery

5

6−%access public

6+%access public export

7

8-- Process IDs are parameterised by their interface. A request of type

9-- 'iface t' will get a response of type 't'

test/proofsearch002/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check proofsearch002.idr

2+${IDRIS:-idris} $@ --check proofsearch002.idr

3rm -f *.ibc

test/proofsearch003/run+1−1

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

1#!/usr/bin/env bash

2−idris --check proofsearch003.idr

2+${IDRIS:-idris} --check proofsearch003.idr

3rm -f *.ibc

test/pruviloj001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr

2+${IDRIS:-idris} $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr

3rm -f *.ibc

test/quasiquote001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ QuasiquoteBasics.idr -o quasiquote001

2+${IDRIS:-idris} $@ QuasiquoteBasics.idr -o quasiquote001

3./quasiquote001

4rm -f quasiquote001 *.ibc

test/quasiquote002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ GoalQQuote.idr -o quasiquote002

2+${IDRIS:-idris} $@ GoalQQuote.idr -o quasiquote002

3./quasiquote002

4rm -f quasiquote002 *.ibc

test/quasiquote003/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check NoInfer.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check NoInfer.idr

3rm -f *.ibc

test/quasiquote004/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour Quasiquote004.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour Quasiquote004.idr

3rm -f *.ibc

test/quasiquote005/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check --nocolour Quasiquote005.idr

2+${IDRIS:-idris} $@ --check --nocolour Quasiquote005.idr

3rm -f *.ibc

test/quasiquote006/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

2+${IDRIS:-idris} $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

3rm -f *.ibc

test/records001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test011.idr -o test011

2+${IDRIS:-idris} $@ test011.idr -o test011

3./test011

4rm -f test011 test011.ibc

test/records002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ record002.idr -o record002

2+${IDRIS:-idris} $@ record002.idr -o record002

3./record002

4rm -f record002 *.ibc

test/records003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ records003.idr -o records003

2+${IDRIS:-idris} $@ records003.idr -o records003

3./records003

4rm -f records003 *.ibc

test/records004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ records004.idr -o records004

2+${IDRIS:-idris} $@ records004.idr -o records004

3./records004

4rm -f records004 *.ibc

test/reg001/reg001.idr+13−14

@@ -37,7 +37,7 @@ filterTagP {n = S m} p (a :: as) q with (p a)

37 **

38 ((a ** believe_me Oh)

39 ::

40− (fst (getProof (filterTagP p as (believe_me Oh)))),

40+ (fst (snd (filterTagP p as (believe_me Oh)))),

41 Oh

42 )

43 )

@@ -95,7 +95,7 @@ mytranspose (x :: y :: xs)

95

96using (A : Type, B : A->Type, C : Type)

97 foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)

98− foo2 f p = f (getWitness p) (getProof p)

98+ foo2 f p = f (fst p) (snd p)

99

100

101m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

@@ -144,7 +144,7 @@ X : Nat -> Type

144X t = (c : Nat ** So (c < 5))

145

146column : X t -> Nat

147−column = getWitness

147+column = fst

148

149data Action = Left | Ahead | Right

150

@@ -161,31 +161,31 @@ isSubsetOf : Set univ => univ -> univ -> Type

161isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

162

163interface Set univ => HasPower univ where

164− Powerset : (a : univ) ->

164+ Powerset : (a : univ) ->

165− Sigma univ (\Pa => (c : univ) ->

165+ DPair univ (\Pa => (c : univ) ->

166 (isSubsetOf c a) -> member c Pa)

167

168powerset : HasPower univ => univ -> univ

169−powerset {univ} a = getWitness (Powerset a)

169+powerset {univ} a = fst (Powerset a)

170

171mapFilter : (alpha -> beta) ->

172− (alpha -> Bool) ->

172+ (alpha -> Bool) ->

173− Vect n alpha ->

173+ Vect n alpha ->

174 (n : Nat ** Vect n beta)

175mapFilter f p Nil = (_ ** Nil)

176mapFilter f p (a :: as) with (p a)

177− | True = (_ ** (f a) :: (getProof (mapFilter f p as)))

177+ | True = (_ ** (f a) :: (snd (mapFilter f p as)))

178 | False = mapFilter f p as

179

180hVectEx1 : HVect [String, List Nat, Nat, (Nat, Nat)]

181hVectEx1 = ["Hello",[1,2,3],42,(0,10)]

182−

182+

183vecfoo : HVect [String, List Nat, Nat, (Nat, Nat)]

184vecfoo = put (S (S Z)) hVectEx1

185

186foom : Monad m => Int -> m Int

187−foom = pure

187+foom = pure

188−

188+

189bar : IO ()

190bar = case foom 5 of

191 Nothing => print 42

@@ -193,7 +193,7 @@ bar = case foom 5 of

193

194Max : (Nat -> Type) -> Type

195Max p = (Nat , (k : Nat) -> p k -> Nat)

196−

196+

197maxEquiv : Max p -> (n1 : Nat) -> p n1 -> Nat

198maxEquiv a n1 pr1 = snd a n1 pr1

199

@@ -207,4 +207,3 @@ data Kappa : (r : Rho) -> Type where K : Kappa r

207kappa : Kappa (rho r) -> Kappa (rho r)

208kappa {r} k = k' where -- k' : Kappa (rho r)

209 k' = k

210−

test/reg001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris reg001.idr --check

2+${IDRIS:-idris} reg001.idr --check

3rm -rf reg001.ibc

4

test/reg002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris reg012.idr -o reg012

2+${IDRIS:-idris} reg012.idr -o reg012

3./reg012

4rm -f reg012 *.ibc

test/reg003/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg003.idr

2+${IDRIS:-idris} --consolewidth 80 --check reg003.idr

3−idris --consolewidth 80 --check reg003a.idr

3+${IDRIS:-idris} --consolewidth 80 --check reg003a.idr

4rm -f *.ibc

test/reg004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg004.idr -o reg004

2+${IDRIS:-idris} $@ reg004.idr -o reg004

3./reg004

4rm -f reg004 *.ibc

test/reg005/expectednew file+3

@@ -0,0 +1,3 @@

1+hey

2+you

3+[(), ()]

test/reg005/reg005.idrnew file+9

@@ -0,0 +1,9 @@

1+module UPIO

2+

3+foo : List (IO ())

4+foo = [putStrLn "hey", putStrLn "you"]

5+

6+namespace Main

7+ main : IO ()

8+ main = let stuff = map unsafePerformIO foo in putStrLn (show stuff)

9+

test/reg005/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ reg005.idr -o reg005

3+./reg005

4+rm -f reg005 *.ibc

test/reg006/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg006.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg006.idr --check

3rm -f *.ibc

test/reg007/A.lidr+1−1

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

1> module A

2

3−> n : Nat

3+> public export n : Nat

4> n = ?lala

5

test/reg007/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg007.lidr

2+${IDRIS:-idris} --consolewidth 80 --nocolour --check $@ reg007.lidr

3rm -f *.ibc

test/reg010/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg010.idr --check --nocolour

2+${IDRIS:-idris} --consolewidth 80 $@ reg010.idr --check --nocolour

test/reg013/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg013.idr -o reg013

2+${IDRIS:-idris} $@ reg013.idr -o reg013

3./reg013

4rm -f reg013 *.ibc

test/reg016/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg016.idr -o reg016

2+${IDRIS:-idris} $@ reg016.idr -o reg016

3./reg016

4rm -f reg016 *.ibc

test/reg017/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 reg017.idr -o reg017

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 reg017.idr -o reg017

3./reg017

4rm -f reg017 *.ibc

test/reg018/run+4−4

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg018a.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg018a.idr --check

3−idris --consolewidth 80 $@ reg018b.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ reg018b.idr --check

4−idris --consolewidth 80 $@ reg018c.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ reg018c.idr --check

5−idris --consolewidth 80 $@ reg018d.idr --check

5+${IDRIS:-idris} --consolewidth 80 $@ reg018d.idr --check

6rm *.ibc

test/reg020/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg020.idr -o reg020

2+${IDRIS:-idris} $@ reg020.idr -o reg020

3./reg020

4rm -f reg020 *.ibc

test/reg023/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg023.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg023.idr --check

3rm -f *.ibc

test/reg024/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg024.idr -o reg024

2+${IDRIS:-idris} $@ reg024.idr -o reg024

3./reg024

4rm -f reg024 *.ibc

test/reg025/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg025.idr -o reg025

2+${IDRIS:-idris} $@ reg025.idr -o reg025

3./reg025

4rm -f reg025 *.ibc

test/reg027/run+2−2

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg027.idr -o reg027

2+${IDRIS:-idris} --consolewidth 80 $@ reg027.idr -o reg027

3./reg027

4−idris --consolewidth 80 $@ reg027a.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ reg027a.idr --check

5rm -f reg027 *.ibc

test/reg028/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg028.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg028.idr --check

3−idris --consolewidth 80 $@ reg028a.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ reg028a.idr --check

4rm -f *.ibc

test/reg029/run+2−2

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

1#!/usr/bin/env bash

2

3−idris $@ reg029.idr -o reg029

3+${IDRIS:-idris} $@ reg029.idr -o reg029

4unset IDRIS_REG029_NONEXISTENT_VAR

5export IDRIS_REG029_EXISTENT_VAR='exists!'

6

@@ -12,6 +12,6 @@ else

12 javac -cp reg029:. Reg029Wrapper.java

13 java -cp reg029:. Reg029Wrapper

14fi

15−idris $@ reg029.idr --execute

15+${IDRIS:-idris} $@ reg029.idr --execute

16rm -f reg029 *.ibc *.class

17

test/reg031/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg031.idr -o reg031

2+${IDRIS:-idris} $@ reg031.idr -o reg031

3./reg031

4rm -f *.ibc reg031

test/reg032/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test028.idr -o test028

2+${IDRIS:-idris} $@ test028.idr -o test028

3./test028

4rm -f test028 test028.ibc

test/reg034/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg034.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg034.idr

3rm -f reg034 *.ibc

test/reg035/run+3−3

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg035.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035.idr

3−idris --nocolour --consolewidth 80 --check reg035a.lidr

3+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035a.lidr

4−idris --nocolour --consolewidth 80 --check reg035b.idr

4+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035b.idr

5rm -f *.ibc

test/reg036/run+1−1

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

1#!/usr/bin/env bash

2−idris --check reg036.idr

2+${IDRIS:-idris} --check reg036.idr

3rm -f reg036 *.ibc

test/reg037/run+1−1

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

1#!/usr/bin/env bash

2−idris --check reg037.idr

2+${IDRIS:-idris} --check reg037.idr

3rm -f reg037 *.ibc

test/reg038/run+1−1

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

1#!/usr/bin/env bash

2−idris --check reg038.idr

2+${IDRIS:-idris} --check reg038.idr

3rm -f *.ibc

test/reg040/run+1−1

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

1#!/usr/bin/env bash

2

3−idris --warnreach reg040.idr -o reg040

3+${IDRIS:-idris} --warnreach reg040.idr -o reg040

4./reg040

5

6rm -f reg040 *.ibc

test/reg041/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ --quiet ott.idr -e example

2+${IDRIS:-idris} $@ --quiet ott.idr -e example

3−idris $@ showu.idr -o reg040

3+${IDRIS:-idris} $@ showu.idr -o reg040

4./reg040

5rm -f reg040 *.ibc

test/reg042/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg042 -o reg042 --warnreach

2+${IDRIS:-idris} $@ reg042 -o reg042 --warnreach

3./reg042

4rm -f reg042 *.ibc

test/reg044/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 reg044.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 reg044.idr --check

3rm -f *.ibc

test/reg045/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg045.idr -o reg045

2+${IDRIS:-idris} $@ reg045.idr -o reg045

3./reg045

4rm -f reg045 *.ibc

test/reg046/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg046.idr --check

2+${IDRIS:-idris} $@ reg046.idr --check

3rm -f reg046 *.ibc

test/reg047/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg047.idr --check --nobuiltins

2+${IDRIS:-idris} $@ reg047.idr --check --nobuiltins

3−idris $@ reg047a.idr --check

3+${IDRIS:-idris} $@ reg047a.idr --check

4rm -f *.ibc

test/reg048/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg048.idr -p contrib -o reg048

2+${IDRIS:-idris} $@ reg048.idr -p contrib -o reg048

3./reg048

4rm -f reg048 *.ibc

test/reg049/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg049.idr

2+${IDRIS:-idris} --consolewidth 80 --nocolour --check $@ reg049.idr

3rm -f *.ibc

test/reg050/run+3−3

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

1#!/usr/bin/env bash

2−idris --nocolour --check $@ working.idr

2+${IDRIS:-idris} --nocolour --check $@ working.idr

3−idris --nocolour --check $@ badbangop.idr

3+${IDRIS:-idris} --nocolour --check $@ badbangop.idr

4−idris --nocolour --check $@ baddoublebang.idr

4+${IDRIS:-idris} --nocolour --check $@ baddoublebang.idr

5rm -f *.ibc

test/reg051-disabled/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg051.idr --check

2+${IDRIS:-idris} $@ reg051.idr --check

3rm -f *.ibc

test/reg052/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o reg052 reg052.idr

2+${IDRIS:-idris} $@ -o reg052 reg052.idr

3./reg052

4rm -f reg052 *.ibc

test/reg053/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check four.idr

2+${IDRIS:-idris} $@ --check four.idr

3rm -f *.ibc

test/reg054/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg054.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg054.idr --check

test/reg055/run+2−2

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg055.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg055.idr --check

3−idris --nocolour --consolewidth 80 $@ reg055a.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg055a.idr --check

4rm -f *.ibc

5

test/reg056/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg056.idr -o reg056

2+${IDRIS:-idris} --consolewidth 80 $@ reg056.idr -o reg056

3rm -f *.ibc

test/reg057/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg057.idr --check

2+${IDRIS:-idris} $@ reg057.idr --check

3rm -f *.ibc

test/reg058/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ implicits.idr --check

2+${IDRIS:-idris} $@ implicits.idr --check

3−idris $@ implicits2.idr --check

3+${IDRIS:-idris} $@ implicits2.idr --check

4

5rm -f *.ibc

test/reg059/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg059.idr --check

2+${IDRIS:-idris} $@ reg059.idr --check

3rm -f *.ibc

test/reg060/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg060.idr --check

2+${IDRIS:-idris} $@ reg060.idr --check

3rm -f *.ibc

test/reg061/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ Capture.idr --check

2+${IDRIS:-idris} $@ Capture.idr --check

3rm -f *.ibc

test/reg062/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg062.idr --check --nocolour

2+${IDRIS:-idris} $@ reg062.idr --check --nocolour

3−idris $@ reg062.lidr --check --nocolour

3+${IDRIS:-idris} $@ reg062.lidr --check --nocolour

4rm -f *.ibc

test/reg063/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ Cmp.idr --check --nocolour --quiet

2+${IDRIS:-idris} $@ Cmp.idr --check --nocolour --quiet

3rm *.ibc

test/reg064/reg064.idr+6−7

@@ -1,9 +1,8 @@

1−sigmaEq2 : {A : Type} ->

1+sigmaEq2 : {A : Type} ->

2− {P : A -> Type} ->

2+ {P : A -> Type} ->

3− {s1: Sigma A P} ->

3+ {s1: DPair A P} ->

4− {s2: Sigma A P} ->

4+ {s2: DPair A P} ->

5− getWitness s1 = getWitness s2 ->

5+ fst s1 = fst s2 ->

6− getProof s1 = getProof s2 ->

6+ snd s1 = snd s2 ->

7 s1 = s2

8sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl

9−

test/reg064/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg064.idr --check

2+${IDRIS:-idris} $@ reg064.idr --check

3rm -f *.ibc

test/reg065/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg065.idr --check

2+${IDRIS:-idris} $@ reg065.idr --check

3rm -f *.ibc

test/reg066/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ reg066.idr --check --nocolor

2+${IDRIS:-idris} $@ reg066.idr --check --nocolor

3rm -f *.ibc

test/reg067/run+1−1

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

1#!/usr/bin/env bash

2rm -f *.ibc reg067

3−idris $@ reg067.idr -o reg067 --warnreach

3+${IDRIS:-idris} $@ reg067.idr -o reg067 --warnreach

4./reg067

5rm -f *.ibc reg067

test/runtest.hsnew file+229

@@ -0,0 +1,229 @@

1+{-# LANGUAGE CPP #-}

2+module Main where

3+

4+import Control.Monad

5+import Data.Char

6+import Data.List

7+import Data.Maybe

8+import qualified Data.Set as S

9+import Data.Time.Clock

10+import System.Directory

11+import System.Environment

12+import System.FilePath

13+import System.Exit

14+import System.Info

15+import System.IO

16+import System.Process

17+

18+-- Because GHC earlier than 7.8 lacks setEnv

19+-- Install the setenv package on Windows.

20+#if __GLASGOW_HASKELL__ < 708

21+#ifndef mingw32_HOST_OS

22+import qualified System.Posix.Env as PE(setEnv)

23+

24+setEnv k v = PE.setEnv k v True

25+#else

26+import System.SetEnv(setEnv)

27+#endif

28+#endif

29+

30+data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)

31+

32+type Flags = S.Set Flag

33+

34+data Status = Success | Failure | Updated deriving (Eq, Show)

35+

36+data Config = Config {

37+ flags :: Flags,

38+ idrOpts :: [String],

39+ tests :: [String]

40+} deriving (Show, Eq)

41+

42+isQuiet conf = Quiet `S.member` (flags conf)

43+showOutput conf = ShowOutput `S.member` (flags conf)

44+showTime conf = Time `S.member` (flags conf)

45+showDiff conf = Diff `S.member` (flags conf)

46+doUpdate conf = Update `S.member` (flags conf)

47+

48+checkTestName :: String -> Bool

49+checkTestName d = (all isDigit $ take 3 $ reverse d)

50+ && (not $ isInfixOf "disabled" d)

51+

52+enumTests :: IO [String]

53+enumTests = do

54+ cwd <- getCurrentDirectory

55+ dirs <- getDirectoryContents cwd

56+ return $ sort $ filter checkTestName dirs

57+

58+parseFlag :: String -> Maybe Flag

59+parseFlag s = case s of

60+ "-u" -> Just Update

61+ "-d" -> Just Diff

62+ "-s" -> Just ShowOutput

63+ "-t" -> Just Time

64+ "-q" -> Just Quiet

65+ _ -> Nothing

66+

67+parseFlags :: [String] -> (S.Set Flag, [String])

68+parseFlags xs = (S.fromList f, i)

69+ where

70+ f = catMaybes $ map parseFlag fl

71+ (fl, i) = partition (\s -> parseFlag s /= Nothing) xs

72+

73+parseArgs :: [String] -> IO Config

74+parseArgs args = do

75+ (tests, rest) <- case args of

76+ ("all":xs) -> do

77+ et <- enumTests

78+ return (et, xs)

79+ ("without":xs) -> do

80+ t <- enumTests

81+ (blacklist, ys) <- return $ break (== "opts") xs

82+ return (t \\ blacklist, ys \\ ["opts"])

83+ (x:xs) -> do

84+ exists <- doesDirectoryExist x

85+ return (if checkTestName x && exists then [x] else [], xs)

86+ [] -> do

87+ et <- enumTests

88+ return (et, [])

89+ let (testOpts, idOpts) = parseFlags rest

90+ return $ Config testOpts idOpts tests

91+

92+-- "bash" needed because Haskell has cmd as the default shell on windows, and

93+-- we also want to run the process with another current directory, so we get

94+-- this thing.

95+runInShell :: String -> [String] -> IO (ExitCode, String)

96+runInShell test opts = do

97+ (ec, output, _) <- readCreateProcessWithExitCode

98+ ((proc "bash" ("run":opts)) { cwd = Just test,

99+ std_out = CreatePipe })

100+ ""

101+ return (ec, output)

102+

103+runTest :: Config -> String -> IO Status

104+runTest conf test = do

105+ -- don't touch the current directory as we want to run these things

106+ -- in parallel in the future

107+ let inTest s = test ++ "/" ++ s

108+ t1 <- getCurrentTime

109+ (exitCode, output) <- runInShell test (idrOpts conf)

110+ t2 <- getCurrentTime

111+ expected <- readFile $ inTest "expected"

112+ writeFile (inTest "output") output

113+ res <- if (norm output == norm expected)

114+ then do putStrLn $ test ++ " finished...success"

115+ return Success

116+ else if doUpdate conf

117+ then do putStrLn $ test ++ " finished...UPDATE"

118+ writeFile (inTest "expected") output

119+ return Updated

120+ else do putStrLn $ test ++ " finished...FAILURE"

121+ _ <- rawSystem "diff" [inTest "output", inTest "expected"]

122+ return Failure

123+ when (showTime conf) $ do

124+ let dt = diffUTCTime t2 t1

125+ putStrLn $ "Duration of " ++ test ++ " was " ++ show dt

126+ return res

127+ where

128+ -- just pretend that backslashes are slashes for comparison

129+ -- purposes to avoid path problems, so don't write any tests

130+ -- that depend on that distinction in other contexts.

131+ -- Also rewrite newlines for consistency.

132+ norm ('\r':'\n':xs) = '\n' : norm xs

133+ norm ('\\':xs) = '/' : norm xs

134+ norm (x : xs) = x : norm xs

135+ norm [] = []

136+

137+printStats :: Config -> [Status] -> IO ()

138+printStats conf stats = do

139+ let total = length stats

140+ let successful = length $ filter (== Success) stats

141+ let failures = length $ filter (== Failure) stats

142+ let updates = length $ filter (== Updated) stats

143+ putStrLn "\n----"

144+ putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "

145+ ++ show failures ++ " failed, " ++ show updates ++ " updated."

146+ let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats

147+ when (failed /= []) $ do

148+ putStrLn "\nFailed tests:"

149+ mapM_ putStrLn failed

150+ putStrLn ""

151+

152+runTests :: Config -> IO Bool

153+runTests conf = do

154+ stats <- mapM (runTest conf) (tests conf)

155+ unless (isQuiet conf) $ printStats conf stats

156+ return $ all (== Success) stats

157+

158+runShow :: Config -> IO Bool

159+runShow conf = do

160+ mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)

161+ return True

162+

163+runDiff :: Config -> IO Bool

164+runDiff conf = do

165+ mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"

166+ ec <- rawSystem "diff" [t++"/output", t++"/expected"]

167+ when (ec == ExitSuccess) $ putStrLn "No differences found.")

168+ (tests conf)

169+ return True

170+

171+whisper :: Config -> String -> IO ()

172+whisper conf s = do unless (isQuiet conf) $ putStrLn s

173+

174+isWindows :: Bool

175+isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

176+

177+setPath :: Config -> IO ()

178+setPath conf = do

179+ maybeEnv <- lookupEnv "IDRIS"

180+ idrisExists <- case maybeEnv of

181+ Just idrisExe -> do

182+ let exeExtension = if isWindows then ".exe" else ""

183+ doesFileExist (idrisExe ++ exeExtension)

184+ Nothing -> return False

185+ if (idrisExists)

186+ then do

187+ idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv

188+ setEnv "IDRIS" idrisAbs

189+ whisper conf $ "Using " ++ idrisAbs

190+ else do

191+ path <- getEnv "PATH"

192+ setEnv "IDRIS" ""

193+ let sandbox = "../.cabal-sandbox/bin"

194+ hasBox <- doesDirectoryExist sandbox

195+ bindir <- if hasBox

196+ then do

197+ whisper conf $ "Using Cabal sandbox at " ++ sandbox

198+ makeAbsolute sandbox

199+ else do

200+ stackExe <- findExecutable "stack"

201+ case stackExe of

202+ Just stack -> do

203+ out <- readProcess stack ["path", "--dist-dir"] []

204+ stackDistDir <- return $ takeWhile (/= '\n') out

205+ let stackDir = "../" ++ stackDistDir ++ "/build/idris"

206+ whisper conf $ "Using stack work dir at " ++ stackDir

207+ makeAbsolute stackDir

208+ Nothing -> return ""

209+ when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)

210+

211+main = do

212+ hSetBuffering stdout LineBuffering

213+ withCabal <- doesDirectoryExist "test"

214+ when withCabal $ do

215+ setCurrentDirectory "test"

216+ args <- getArgs

217+ conf <- parseArgs args

218+ setPath conf

219+ t1 <- getCurrentTime

220+ res <- case tests conf of

221+ [] -> return True

222+ xs | showOutput conf -> runShow conf

223+ xs | showDiff conf -> runDiff conf

224+ xs -> runTests conf

225+ t2 <- getCurrentTime

226+ when (showTime conf) $ do

227+ let dt = diffUTCTime t2 t1

228+ putStrLn $ "Duration of Entire Test Suite was " ++ show dt

229+ unless res exitFailure

test/runtest.pldeleted−214

@@ -1,214 +0,0 @@

1−#!/usr/bin/env perl

2−

3−use strict;

4−use Cwd;

5−use Cwd 'abs_path';

6−use Env;

7−

8−my $exitstatus = 0;

9−my @idrOpts = ();

10−

11−

12−# Determines how idris was built locally, returning a PATH modifier.

13−#

14−# Order of checking is:

15−#

16−# 1. Cabal Sandboxing

17−# 2. Stack

18−# 3. Pure cabal.

19−#

20−sub sandbox_path {

21− my ($test_dir,) = @_;

22− my $sandbox = "$test_dir/../../.cabal-sandbox/bin";

23−

24− my $stack_bin_path = `stack path --dist-dir`;

25− $stack_bin_path =~ s/\n//g;

26− my $stack_work_dir = "$test_dir/../../$stack_bin_path/build/idris";

27−

28− if ( -d $sandbox ) {

29−

30− my $sandbox_abs = abs_path($sandbox);

31− print "Using Cabal Sandbox\n";

32− printf("Sandbox located at: %s\n", $sandbox_abs);

33− return "PATH=\"$sandbox_abs:$PATH\"";

34−

35− } elsif ( -d $stack_work_dir ) {

36−

37− my $stack_work_abs = abs_path($stack_work_dir);

38− print "Using Stack Work\n";

39− printf("Stack work located at: %s\n", $stack_work_abs);

40− return "PATH=\"$stack_work_abs:$PATH\"";

41−

42− } else {

43− print "Using Default Cabal.\n";

44− return "";

45− }

46−}

47−

48−# Run an individual test, and compare expected output with given

49−# output and report results.

50−#

51−sub runtest {

52− my ($test, $update, $showTime) = @_;

53−

54− my $sandbox = sandbox_path($test);

55−

56− chdir($test);

57−

58− my $startTime = time();

59− print "Running $test...\n";

60− my $got = `$sandbox ./run @idrOpts`;

61− my $exp = `cat expected`;

62−

63− my $endTime = time();

64− my $elapsedTime = $endTime - $startTime;

65−

66− if ($showTime == 1 ){

67− printf("Duration of $test was %d\n", $elapsedTime);

68− }

69−

70− # Allow for variant expected output for tests by overriding expected

71− # when there is an expected.<os> file in the test.

72− # This should be the exception but there are sometimes valid reasons

73− # for os-dependent output.

74− # The endings are msys for windows, darwin for osx and linux for linux

75− if ( -e "expected.$^O") {

76− $exp = `cat expected.$^O`;

77− }

78− open my $out, '>', 'output';

79− print $out $got;

80− close $out;

81−

82− # $ok = system("diff output expected &> /dev/null");

83− # Mangle newlines in $got and $exp

84− $got =~ s/\r\n/\n/g;

85− $exp =~ s/\r\n/\n/g;

86−

87− # Normalize paths in $got and $exp, so the expected outcomes don't

88− # change between platforms

89− while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) {

90− $got = "$1$2/$3:$4:$5";

91− }

92− while($exp =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) {

93− $exp = "$1$2/$3:$4:$5";

94− }

95−

96− if ($got eq $exp) {

97− print "Ran $test...success\n";

98− }

99− else {

100− if ($update == 0) {

101− $exitstatus = 1;

102− print "Ran $test...FAILURE\n";

103− system "diff output expected";

104− } else {

105− system("cp output expected");

106− print "Ran $test...UPDATED\n";

107− }

108− }

109− chdir "..";

110−}

111−

112−# Main test running program to sort test input, and execute individual

113−# tests.

114−#

115−

116−my ( @without, @args, @tests, @opts );

117−

118−# Deal with the Args.

119−if ($#ARGV>=0) {

120− my $test = shift @ARGV;

121− if ($test eq "all") {

122− opendir my $dir, ".";

123− my @list = readdir $dir;

124− foreach my $file (@list) {

125− if ($file =~ /[0-9][0-9][0-9]$/) {

126− push @tests, $file;

127− }

128− }

129− @tests = sort @tests;

130−

131− } elsif ($test eq "without") {

132− @args = @ARGV;

133− foreach my $file (@args) {

134− last if ($file =~ /--/);

135− push @without, shift @ARGV;

136− }

137−

138− opendir my $dir, ".";

139− my @list = readdir $dir;

140− foreach my $file (@list) {

141− if ($file =~ /[0-9][0-9][0-9]$/) {

142− if (!(grep ($_ eq $file, @without))) {

143− push @tests, $file;

144− }

145− else {

146− print "Omitting $file\n";

147− }

148− }

149− }

150− @tests = sort @tests;

151− }

152− else {

153− if ($test =~ /[0-9][0-9][0-9]$/) {

154− push @tests, $test;

155− }

156− }

157− @opts = @ARGV;

158−}

159−else {

160− print "Give a test name, or 'all' to run all.\n";

161− exit;

162−}

163−

164−# Run the tests.

165−

166−my $update = 0;

167−my $diff = 0;

168−my $show = 0;

169−my $usejava = 0;

170−my $showTime = 0;

171−

172−while (my $opt = shift @opts) {

173− if ($opt eq "-u") { $update = 1; }

174− elsif ($opt eq "-d") { $diff = 1; }

175− elsif ($opt eq "-s") { $show = 1; }

176− elsif ($opt eq "-t") { $showTime = 1; }

177− else { push(@idrOpts, $opt); }

178−}

179−

180−my $idris = $ENV{IDRIS};

181−my $path = $ENV{PATH};

182−$ENV{PATH} = cwd() . "/" . $idris . ":" . $path;

183−

184−my $startTime = time();

185−

186−foreach my $test (@tests) {

187− if ($diff == 0 && $show == 0) {

188− runtest($test,$update,$showTime);

189− }

190− else {

191− chdir $test;

192−

193− if ($show == 1) {

194− system "cat output";

195− }

196− if ($diff == 1) {

197− print "Differences in $test:\n";

198− my $ok = system "diff output expected";

199− if ($ok == 0) {

200− print "No differences found.\n";

201− }

202− }

203− chdir "..";

204− }

205−}

206−

207−my $endTime = time();

208−my $elapsedTime = $endTime - $startTime;

209−

210−if ($showTime == 1) {

211− printf("Duration of Entire Test Suite was %d\n", $elapsedTime);

212−}

213−

214−exit $exitstatus;

test/sourceLocation001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 SourceLoc.idr -o sourceLocation001

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 SourceLoc.idr -o sourceLocation001

3./sourceLocation001

4rm -f sourceLocation001 *.ibc

test/sugar001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test007.idr -o test007

2+${IDRIS:-idris} $@ test007.idr -o test007

3./test007

4rm -f test007 test007.ibc

test/sugar002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test009.idr -o test009

2+${IDRIS:-idris} $@ test009.idr -o test009

3./test009

4rm -f test009 test009.ibc

test/sugar003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test013.idr -o test013

2+${IDRIS:-idris} $@ test013.idr -o test013

3./test013

4rm -f test013 test013.ibc

test/sugar004/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ sugar004.idr -o sugar004

2+${IDRIS:-idris} $@ sugar004.idr -o sugar004

3./sugar004

4./sugar004 42

5./sugar004 42 100

test/sugar005/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ As.idr -o sugar005

2+${IDRIS:-idris} $@ As.idr -o sugar005

3./sugar005

4rm -f sugar005 *.ibc

test/syntax001/expected+2−2

@@ -2,7 +2,7 @@ Syntax.idr:6:7-9:1:

2When checking right hand side of foo with expected type

3 Nat

4

5−When checking an application of function Prelude.Classes.+:

5+When checking an application of function Prelude.Interfaces.+:

6 Type mismatch between

7 String (Type of "argh")

8 and

@@ -11,7 +11,7 @@ SyntaxTest.idr:5:7-6:1:

11When checking right hand side of foo with expected type

12 Nat

13

14−When checking an application of function Prelude.Classes.+:

14+When checking an application of function Prelude.Interfaces.+:

15 Type mismatch between

16 String (Type of "argh")

17 and

test/syntax001/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ Syntax.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ Syntax.idr --nocolour --consolewidth 80 --check

3−idris $@ SyntaxTest.idr --nocolour --consolewidth 80 --check

3+${IDRIS:-idris} $@ SyntaxTest.idr --nocolour --consolewidth 80 --check

4rm -f *.ibc

test/syntax002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ syntax002.idr -o syntax002

2+${IDRIS:-idris} $@ syntax002.idr -o syntax002

3./syntax002

4rm -f syntax002 *.ibc

test/tactics001/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --check Tactics.idr

2+${IDRIS:-idris} $@ --check Tactics.idr

3rm -f *.ibc

test/totality001/run+3−3

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test010.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check test010.idr

3−idris --consolewidth 80 $@ --check test010a.idr

3+${IDRIS:-idris} --consolewidth 80 $@ --check test010a.idr

4−idris --consolewidth 80 $@ --check test010b.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check test010b.idr

5

6rm -f *.ibc

test/totality002/run+3−3

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test017.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check test017.idr

3−idris --consolewidth 80 $@ --check test017a.idr

3+${IDRIS:-idris} --consolewidth 80 $@ --check test017a.idr

4−idris --consolewidth 80 $@ --check test017b.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check test017b.idr

5rm -f *.ibc

test/totality003/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ totality003.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ totality003.idr --check

3−idris --nocolour --consolewidth 80 $@ totality003a.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ totality003a.idr --check

4rm -f *.ibc

test/totality004/run+2−2

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality004.idr -o totality004

2+${IDRIS:-idris} --consolewidth 80 $@ totality004.idr -o totality004

3./totality004

4−idris --consolewidth 80 $@ --check totality004a.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check totality004a.idr

5rm -f totality004 *.ibc

test/totality005/run+2−2

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

1#!/usr/bin/env bash

2−idris $@ totality005.idr --total --check

2+${IDRIS:-idris} $@ totality005.idr --total --check

3−idris $@ totality005.idr -o totality005

3+${IDRIS:-idris} $@ totality005.idr -o totality005

4./totality005

5rm -f totality005 *.ibc

test/totality006/run+3−3

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality006.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ totality006.idr --check

3−idris --consolewidth 80 $@ totality006a.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ totality006a.idr --check

4−idris --consolewidth 80 $@ totality006b.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ totality006b.idr --check

5rm -f *.ibc

test/totality007/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --build totality.ipkg

2+${IDRIS:-idris} $@ --build totality.ipkg

3rm -f src/*.ibc

test/totality008/run+1−1

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

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality008.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ totality008.idr --check

3rm -f *.ibc

test/totality009/run+2−2

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

1#!/usr/bin/env bash

2OPTS="--consolewidth infinite --nocolour"

3−idris "$@" $OPTS --check TestLambdaImpossible

3+${IDRIS:-idris} "$@" $OPTS --check TestLambdaImpossible

4−idris "$@" $OPTS --check --warnpartial TestLambdaPossible

4+${IDRIS:-idris} "$@" $OPTS --check --warnpartial TestLambdaPossible

5rm -f *.ibc

test/totality010/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ totality010.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ totality010.idr --nocolour --consolewidth 80 --check

3rm -f *.ibc

test/tutorial001/run+1−1

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

1#!/usr/bin/env bash

2−idris --check tutorial001.idr

2+${IDRIS:-idris} --check tutorial001.idr

3rm -f *.ibc

test/tutorial002/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 tutorial002.idr --check

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 tutorial002.idr --check

3rm -f *.ibc

test/tutorial003/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ tutorial003.idr --check

2+${IDRIS:-idris} $@ tutorial003.idr --check

3rm -f *.ibc

test/tutorial004/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ tutorial004.idr --check --nocolour --consolewidth 80

2+${IDRIS:-idris} $@ tutorial004.idr --check --nocolour --consolewidth 80

3rm -f *.ibc

test/tutorial005/run+1−1

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

1#!/usr/bin/env bash

2−idris $@ tutorial005.idr --check

2+${IDRIS:-idris} $@ tutorial005.idr --check

3rm -f *.ibc

test/tutorial006/run+3−3

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006a.idr --check

3−idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006b.idr --check

4−idris --nocolour --consolewidth 80 $@ tutorial006c.idr -p effects --check

4+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006c.idr -p effects --check

5rm -f *.ibc

test/unique001/run+6−6

@@ -1,9 +1,9 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001.idr -o unique001

3./unique001

4−idris --nocolour --consolewidth 80 $@ unique001a.idr --check

4+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001a.idr --check

5−idris --nocolour --consolewidth 80 $@ unique001b.idr --check

5+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001b.idr --check

6−idris --nocolour --consolewidth 80 $@ unique001c.idr --check

6+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001c.idr --check

7−idris --nocolour --consolewidth 80 $@ unique001d.idr --check

7+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001d.idr --check

8−idris --nocolour --consolewidth 80 $@ unique001e.idr --check

8+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001e.idr --check

9rm -f unique001 *.ibc

test/unique001/unique001c.idr−4

@@ -44,7 +44,3 @@ data MPair : AnyType -> AnyType -> AnyType where

44

45ndup : {a : UniqueType} -> a -> UPair a a

46ndup {a} x = (\f : Int -> a => MkUPair (f 0) (f 1)) (uconst x)

47−

48−

49−

50−

test/unique002/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique002.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique002.idr --check

3−idris --nocolour --consolewidth 80 $@ unique002a.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique002a.idr --check

4rm -f *.ibc

test/unique003/run+1−1

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

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique003.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique003.idr --check

3rm -f *.ibc